mh-alias.el 27 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683
  1. ;;; mh-alias.el --- MH-E mail alias completion and expansion
  2. ;; Copyright (C) 1994-1997, 2001-2012 Free Software Foundation, Inc.
  3. ;; Author: Peter S. Galbraith <psg@debian.org>
  4. ;; Maintainer: Bill Wohler <wohler@newt.com>
  5. ;; Keywords: mail
  6. ;; See: mh-e.el
  7. ;; This file is part of GNU Emacs.
  8. ;; GNU Emacs is free software: you can redistribute it and/or modify
  9. ;; it under the terms of the GNU General Public License as published by
  10. ;; the Free Software Foundation, either version 3 of the License, or
  11. ;; (at your option) any later version.
  12. ;; GNU Emacs is distributed in the hope that it will be useful,
  13. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  15. ;; GNU General Public License for more details.
  16. ;; You should have received a copy of the GNU General Public License
  17. ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
  18. ;;; Commentary:
  19. ;;; Change Log:
  20. ;;; Code:
  21. (require 'mh-e)
  22. (mh-require-cl)
  23. (require 'goto-addr)
  24. (defvar mh-alias-alist 'not-read
  25. "Alist of MH aliases.")
  26. (defvar mh-alias-blind-alist nil
  27. "Alist of MH aliases that are blind lists.")
  28. (defvar mh-alias-passwd-alist nil
  29. "Alist of aliases extracted from passwd file and their expansions.")
  30. (defvar mh-alias-tstamp nil
  31. "Time aliases were last loaded.")
  32. (defvar mh-alias-read-address-map
  33. (let ((map (copy-keymap minibuffer-local-completion-map)))
  34. (define-key map "," 'mh-alias-minibuffer-confirm-address)
  35. (define-key map " " 'self-insert-command)
  36. map))
  37. (defvar mh-alias-system-aliases
  38. '("/etc/nmh/MailAliases" "/etc/mh/MailAliases"
  39. "/usr/lib/mh/MailAliases" "/usr/share/mailutils/mh/MailAliases"
  40. "/etc/passwd")
  41. "*A list of system files which are a source of aliases.
  42. If these files are modified, they are automatically reread. This list
  43. need include only system aliases and the passwd file, since personal
  44. alias files listed in your \"Aliasfile:\" MH profile component are
  45. automatically included. You can update the alias list manually using
  46. \\[mh-alias-reload].")
  47. ;;; Alias Loading
  48. (defun mh-alias-tstamp (arg)
  49. "Check whether alias files have been modified.
  50. Return t if any file listed in the Aliasfile MH profile component has
  51. been modified since the timestamp.
  52. If ARG is non-nil, set timestamp with the current time."
  53. (if arg
  54. (let ((time (current-time)))
  55. (setq mh-alias-tstamp (list (nth 0 time) (nth 1 time))))
  56. (let ((stamp))
  57. (car (memq t (mapcar
  58. (function
  59. (lambda (file)
  60. (when (and file (file-exists-p file))
  61. (setq stamp (nth 5 (file-attributes file)))
  62. (or (> (car stamp) (car mh-alias-tstamp))
  63. (and (= (car stamp) (car mh-alias-tstamp))
  64. (> (cadr stamp) (cadr mh-alias-tstamp)))))))
  65. (mh-alias-filenames t)))))))
  66. (defun mh-alias-filenames (arg)
  67. "Return list of filenames that contain aliases.
  68. The filenames come from the Aliasfile profile component and are
  69. expanded.
  70. If ARG is non-nil, filenames listed in `mh-alias-system-aliases' are
  71. appended."
  72. (or mh-progs (mh-find-path))
  73. (save-excursion
  74. (let* ((filename (mh-profile-component "Aliasfile"))
  75. (filelist (and filename (split-string filename "[ \t]+")))
  76. (userlist
  77. (mapcar
  78. (function
  79. (lambda (file)
  80. (if (and mh-user-path file
  81. (file-exists-p (expand-file-name file mh-user-path)))
  82. (expand-file-name file mh-user-path))))
  83. filelist)))
  84. (if arg
  85. (if (stringp mh-alias-system-aliases)
  86. (append userlist (list mh-alias-system-aliases))
  87. (append userlist mh-alias-system-aliases))
  88. userlist))))
  89. (defun mh-alias-gecos-name (gecos-name username comma-separator)
  90. "Return a usable address string from a GECOS-NAME and USERNAME.
  91. Use only part of the GECOS-NAME up to the first comma if
  92. COMMA-SEPARATOR is non-nil."
  93. (let ((res gecos-name))
  94. ;; Keep only string until first comma if COMMA-SEPARATOR is t.
  95. (if (and comma-separator
  96. (string-match "^\\([^,]+\\)," res))
  97. (setq res (match-string 1 res)))
  98. ;; Replace "&" with capitalized username
  99. (if (string-match "&" res)
  100. (setq res (mh-replace-regexp-in-string "&" (capitalize username) res)))
  101. ;; Remove " character
  102. (if (string-match "\"" res)
  103. (setq res (mh-replace-regexp-in-string "\"" "" res)))
  104. ;; If empty string, use username instead
  105. (if (string-equal "" res)
  106. (setq res username))
  107. ;; Surround by quotes if doesn't consist of simple characters
  108. (if (not (string-match "^[ a-zA-Z0-9-]+$" res))
  109. (setq res (concat "\"" res "\"")))
  110. res))
  111. (defun mh-alias-local-users ()
  112. "Return an alist of local users from /etc/passwd.
  113. Exclude all aliases already in `mh-alias-alist' from \"ali\""
  114. (let (passwd-alist)
  115. (with-current-buffer (get-buffer-create mh-temp-buffer)
  116. (erase-buffer)
  117. (cond
  118. ((eq mh-alias-local-users t)
  119. (if (file-readable-p "/etc/passwd")
  120. (insert-file-contents "/etc/passwd")))
  121. ((stringp mh-alias-local-users)
  122. (insert mh-alias-local-users "\n")
  123. (shell-command-on-region (point-min) (point-max) mh-alias-local-users t)
  124. (goto-char (point-min))))
  125. (while (< (point) (point-max))
  126. (cond
  127. ((looking-at "\\([^:]*\\):[^:]*:\\([^:]*\\):[^:]*:\\([^:]*\\):")
  128. (when (> (string-to-number (match-string 2)) 200)
  129. (let* ((username (match-string 1))
  130. (gecos-name (match-string 3))
  131. (realname (mh-alias-gecos-name
  132. gecos-name username
  133. mh-alias-passwd-gecos-comma-separator-flag))
  134. (alias-name (if mh-alias-local-users-prefix
  135. (concat mh-alias-local-users-prefix
  136. (mh-alias-suggest-alias realname t))
  137. username))
  138. (alias-translation
  139. (if (string-equal username realname)
  140. (concat "<" username ">")
  141. (concat realname " <" username ">"))))
  142. (when (not (mh-assoc-string alias-name mh-alias-alist t))
  143. (setq passwd-alist (cons (list alias-name alias-translation)
  144. passwd-alist)))))))
  145. (forward-line 1)))
  146. passwd-alist))
  147. (defun mh-alias-reload ()
  148. "Reload MH aliases.
  149. Since aliases are updated frequently, MH-E reloads aliases
  150. automatically whenever an alias lookup occurs if an alias source has
  151. changed. Sources include files listed in your \"Aliasfile:\" profile
  152. component and your password file if option `mh-alias-local-users' is
  153. turned on. However, you can reload your aliases manually by calling
  154. this command directly.
  155. This function runs `mh-alias-reloaded-hook' after the aliases have
  156. been loaded."
  157. (interactive)
  158. (save-excursion
  159. (message "Loading MH aliases...")
  160. (mh-alias-tstamp t)
  161. (mh-exec-cmd-quiet t "ali" "-nolist" "-nouser")
  162. (setq mh-alias-alist nil)
  163. (setq mh-alias-blind-alist nil)
  164. (while (< (point) (point-max))
  165. (cond
  166. ((looking-at "^[ \t]")) ;Continuation line
  167. ((looking-at "\\(.+\\): .+: .*$") ; A new -blind- MH alias
  168. (when (not (mh-assoc-string (match-string 1) mh-alias-blind-alist t))
  169. (setq mh-alias-blind-alist
  170. (cons (list (match-string 1)) mh-alias-blind-alist))
  171. (setq mh-alias-alist (cons (list (match-string 1)) mh-alias-alist))))
  172. ((looking-at "\\(.+\\): .*$") ; A new MH alias
  173. (when (not (mh-assoc-string (match-string 1) mh-alias-alist t))
  174. (setq mh-alias-alist
  175. (cons (list (match-string 1)) mh-alias-alist)))))
  176. (forward-line 1)))
  177. (when mh-alias-local-users
  178. (setq mh-alias-passwd-alist (mh-alias-local-users))
  179. ;; Update aliases with local users, but leave existing aliases alone.
  180. (let ((local-users mh-alias-passwd-alist)
  181. user)
  182. (while local-users
  183. (setq user (car local-users))
  184. (if (not (mh-assoc-string (car user) mh-alias-alist t))
  185. (setq mh-alias-alist (append mh-alias-alist (list user))))
  186. (setq local-users (cdr local-users)))))
  187. (run-hooks 'mh-alias-reloaded-hook)
  188. (message "Loading MH aliases...done"))
  189. ;;;###mh-autoload
  190. (defun mh-alias-reload-maybe ()
  191. "Load new MH aliases."
  192. (if (or (eq mh-alias-alist 'not-read) ; Doesn't exist?
  193. (mh-alias-tstamp nil)) ; Out of date?
  194. (mh-alias-reload)))
  195. ;;; Alias Expansion
  196. (defun mh-alias-ali (alias &optional user)
  197. "Return ali expansion for ALIAS.
  198. ALIAS must be a string for a single alias.
  199. If USER is t, then assume ALIAS is an address and call ali -user. ali
  200. returns the string unchanged if not defined. The same is done here."
  201. (condition-case err
  202. (save-excursion
  203. (let ((user-arg (if user "-user" "-nouser")))
  204. (mh-exec-cmd-quiet t "ali" user-arg "-nolist" alias))
  205. (goto-char (point-max))
  206. (if (looking-at "^$") (delete-char -1))
  207. (buffer-substring (point-min)(point-max)))
  208. (error (progn
  209. (message "%s" (error-message-string err))
  210. alias))))
  211. ;;;###mh-autoload
  212. (defun mh-alias-expand (alias)
  213. "Return expansion for ALIAS.
  214. Blind aliases or users from /etc/passwd are not expanded."
  215. (cond
  216. ((mh-assoc-string alias mh-alias-blind-alist t)
  217. alias) ; Don't expand a blind alias
  218. ((mh-assoc-string alias mh-alias-passwd-alist t)
  219. (cadr (mh-assoc-string alias mh-alias-passwd-alist t)))
  220. (t
  221. (mh-alias-ali alias))))
  222. (mh-require 'crm nil t) ; completing-read-multiple
  223. (mh-require 'multi-prompt nil t)
  224. ;;;###mh-autoload
  225. (defun mh-read-address (prompt)
  226. "Read an address from the minibuffer with PROMPT."
  227. (mh-alias-reload-maybe)
  228. (if (not mh-alias-alist) ; If still no aliases, just prompt
  229. (read-string prompt)
  230. (let* ((minibuffer-local-completion-map mh-alias-read-address-map)
  231. (completion-ignore-case mh-alias-completion-ignore-case-flag)
  232. (the-answer
  233. (cond ((fboundp 'completing-read-multiple)
  234. (mh-funcall-if-exists
  235. completing-read-multiple prompt mh-alias-alist nil nil))
  236. ((featurep 'multi-prompt)
  237. (mh-funcall-if-exists
  238. multi-prompt "," nil prompt mh-alias-alist nil nil))
  239. (t (split-string
  240. (completing-read prompt mh-alias-alist nil nil) ",")))))
  241. (if (not mh-alias-expand-aliases-flag)
  242. (mapconcat 'identity the-answer ", ")
  243. ;; Loop over all elements, checking if in passwd alias or blind first
  244. (mapconcat 'mh-alias-expand the-answer ",\n ")))))
  245. ;;;###mh-autoload
  246. (defun mh-alias-minibuffer-confirm-address ()
  247. "Display the alias expansion if `mh-alias-flash-on-comma' is non-nil."
  248. (interactive)
  249. (when mh-alias-flash-on-comma
  250. (save-excursion
  251. (let* ((case-fold-search t)
  252. (beg (mh-beginning-of-word))
  253. (the-name (buffer-substring-no-properties beg (point))))
  254. (if (mh-assoc-string the-name mh-alias-alist t)
  255. (message "%s -> %s" the-name (mh-alias-expand the-name))
  256. ;; Check if it was a single word likely to be an alias
  257. (if (and (equal mh-alias-flash-on-comma 1)
  258. (not (string-match " " the-name)))
  259. (message "No alias for %s" the-name))))))
  260. (self-insert-command 1))
  261. ;;;###mh-autoload
  262. (defun mh-alias-letter-expand-alias ()
  263. "Expand mail alias before point."
  264. (mh-alias-reload-maybe)
  265. (let* ((begin (mh-beginning-of-word))
  266. (end (save-excursion
  267. (goto-char begin)
  268. (mh-beginning-of-word -1))))
  269. (when (>= end (point))
  270. (list
  271. begin (if (fboundp 'completion-at-point) end (point))
  272. (if (not mh-alias-expand-aliases-flag)
  273. mh-alias-alist
  274. (lambda (string pred action)
  275. (case action
  276. ((nil)
  277. (let ((res (try-completion string mh-alias-alist pred)))
  278. (if (or (eq res t)
  279. (and (stringp res)
  280. (eq t (try-completion res mh-alias-alist pred))))
  281. (or (mh-alias-expand (if (stringp res) res string))
  282. res)
  283. res)))
  284. ((t) (all-completions string mh-alias-alist pred))
  285. ((lambda) (mh-test-completion string mh-alias-alist pred)))))))))
  286. ;;; Alias File Updating
  287. (defun mh-alias-suggest-alias (string &optional no-comma-swap)
  288. "Suggest an alias for STRING.
  289. Don't reverse the order of strings separated by a comma if
  290. NO-COMMA-SWAP is non-nil."
  291. (cond
  292. ((string-match "^<\\(.*\\)>$" string)
  293. ;; <somename@foo.bar> -> recurse, stripping brackets.
  294. (mh-alias-suggest-alias (match-string 1 string) no-comma-swap))
  295. ((string-match "^\\sw+$" string)
  296. ;; One word -> downcase it.
  297. (downcase string))
  298. ((string-match "^\\(\\sw+\\)\\s-+\\(\\sw+\\)$" string)
  299. ;; Two words -> first.last
  300. (downcase
  301. (format "%s.%s" (match-string 1 string) (match-string 2 string))))
  302. ((string-match "^\\([-a-zA-Z0-9._]+\\)@[-a-zA-z0-9_]+\\.+[a-zA-Z0-9]+$"
  303. string)
  304. ;; email only -> downcase username
  305. (downcase (match-string 1 string)))
  306. ((string-match "^\"\\(.*\\)\".*" string)
  307. ;; "Some name" <somename@foo.bar> -> recurse -> "Some name"
  308. (mh-alias-suggest-alias (match-string 1 string) no-comma-swap))
  309. ((string-match "^\\(.*\\) +<.*>$" string)
  310. ;; Some name <somename@foo.bar> -> recurse -> Some name
  311. (mh-alias-suggest-alias (match-string 1 string) no-comma-swap))
  312. ((string-match (concat goto-address-mail-regexp " +(\\(.*\\))$") string)
  313. ;; somename@foo.bar (Some name) -> recurse -> Some name
  314. (mh-alias-suggest-alias (match-string 1 string) no-comma-swap))
  315. ((string-match "^\\(Dr\\|Prof\\)\\.? +\\(.*\\)" string)
  316. ;; Strip out title
  317. (mh-alias-suggest-alias (match-string 2 string) no-comma-swap))
  318. ((string-match "^\\(.*\\), +\\(Jr\\.?\\|II+\\)$" string)
  319. ;; Strip out tails with comma
  320. (mh-alias-suggest-alias (match-string 1 string) no-comma-swap))
  321. ((string-match "^\\(.*\\) +\\(Jr\\.?\\|II+\\)$" string)
  322. ;; Strip out tails
  323. (mh-alias-suggest-alias (match-string 1 string) no-comma-swap))
  324. ((string-match "^\\(\\sw+\\) +[A-Z]\\.? +\\(.*\\)$" string)
  325. ;; Strip out initials
  326. (mh-alias-suggest-alias
  327. (format "%s %s" (match-string 1 string) (match-string 2 string))
  328. no-comma-swap))
  329. ((and (not no-comma-swap)
  330. (string-match "^\\([^,]+\\), +\\(.*\\)$" string))
  331. ;; Reverse order of comma-separated fields to handle:
  332. ;; From: "Galbraith, Peter" <psg@debian.org>
  333. ;; but don't this for a name string extracted from the passwd file
  334. ;; with mh-alias-passwd-gecos-comma-separator-flag set to nil.
  335. (mh-alias-suggest-alias
  336. (format "%s %s" (match-string 2 string) (match-string 1 string))
  337. no-comma-swap))
  338. (t
  339. ;; Output string, with spaces replaced by dots.
  340. (mh-alias-canonicalize-suggestion string))))
  341. (defun mh-alias-canonicalize-suggestion (string)
  342. "Process STRING to replace spaces by periods.
  343. First all spaces and commas are replaced by periods. Then every run of
  344. consecutive periods are replaced with a single period. Finally the
  345. string is converted to lower case."
  346. (with-temp-buffer
  347. (insert string)
  348. ;; Replace spaces with periods
  349. (goto-char (point-min))
  350. (while (re-search-forward " +" nil t)
  351. (replace-match "." nil nil))
  352. ;; Replace commas with periods
  353. (goto-char (point-min))
  354. (while (re-search-forward ",+" nil t)
  355. (replace-match "." nil nil))
  356. ;; Replace consecutive periods with a single period
  357. (goto-char (point-min))
  358. (while (re-search-forward "\\.\\.+" nil t)
  359. (replace-match "." nil nil))
  360. ;; Convert to lower case
  361. (downcase-region (point-min) (point-max))
  362. ;; Whew! all done...
  363. (buffer-string)))
  364. (defun mh-alias-which-file-has-alias (alias file-list)
  365. "Return the name of writable file which defines ALIAS from list FILE-LIST."
  366. (with-current-buffer (get-buffer-create mh-temp-buffer)
  367. (let ((the-list file-list)
  368. (found))
  369. (while the-list
  370. (erase-buffer)
  371. (when (file-writable-p (car file-list))
  372. (insert-file-contents (car file-list))
  373. (if (re-search-forward (concat "^" (regexp-quote alias) ":") nil t)
  374. (setq found (car file-list)
  375. the-list nil)
  376. (setq the-list (cdr the-list)))))
  377. found)))
  378. (defun mh-alias-insert-file (&optional alias)
  379. "Return filename which should be used to add ALIAS.
  380. The value of the option `mh-alias-insert-file' is used if non-nil\;
  381. otherwise the value of the \"Aliasfile:\" profile component is used.
  382. If the alias already exists, try to return the name of the file that
  383. contains it."
  384. (cond
  385. ((and mh-alias-insert-file (listp mh-alias-insert-file))
  386. (if (not (elt mh-alias-insert-file 1)) ; Only one entry, use it
  387. (car mh-alias-insert-file)
  388. (if (or (not alias)
  389. (string-equal alias (mh-alias-ali alias))) ;alias doesn't exist
  390. (completing-read "Alias file: "
  391. (mapcar 'list mh-alias-insert-file) nil t)
  392. (or (mh-alias-which-file-has-alias alias mh-alias-insert-file)
  393. (completing-read "Alias file: "
  394. (mapcar 'list mh-alias-insert-file) nil t)))))
  395. ((and mh-alias-insert-file (stringp mh-alias-insert-file))
  396. mh-alias-insert-file)
  397. (t
  398. ;; writable ones returned from (mh-alias-filenames):
  399. (let ((autolist (delq nil (mapcar (lambda (file)
  400. (if (and (file-writable-p file)
  401. (not (string-equal
  402. file "/etc/passwd")))
  403. file))
  404. (mh-alias-filenames t)))))
  405. (cond
  406. ((not autolist)
  407. (error "No writable alias file;
  408. set `mh-alias-insert-file' or the \"Aliasfile:\" profile component"))
  409. ((not (elt autolist 1)) ; Only one entry, use it
  410. (car autolist))
  411. ((or (not alias)
  412. (string-equal alias (mh-alias-ali alias))) ;alias doesn't exist
  413. (completing-read "Alias file: " (mapcar 'list autolist) nil t))
  414. (t
  415. (or (mh-alias-which-file-has-alias alias autolist)
  416. (completing-read "Alias file: "
  417. (mapcar 'list autolist) nil t))))))))
  418. ;;;###mh-autoload
  419. (defun mh-alias-address-to-alias (address)
  420. "Return the ADDRESS alias if defined, or nil."
  421. (let* ((aliases (mh-alias-ali address t)))
  422. (if (string-equal aliases address)
  423. nil ; ali returned same string -> no.
  424. ;; Double-check that we have an individual alias. This means that the
  425. ;; alias doesn't expand into a list (of which this address is part).
  426. (car (delq nil (mapcar
  427. (function
  428. (lambda (alias)
  429. (let ((recurse (mh-alias-ali alias nil)))
  430. (if (string-match ".*,.*" recurse)
  431. nil
  432. alias))))
  433. (split-string aliases ", +")))))))
  434. ;;;###mh-autoload
  435. (defun mh-alias-for-from-p ()
  436. "Return t if sender's address has a corresponding alias."
  437. (mh-alias-reload-maybe)
  438. (save-excursion
  439. (if (not (mh-folder-line-matches-show-buffer-p))
  440. nil ;No corresponding show buffer
  441. (if (eq major-mode 'mh-folder-mode)
  442. (set-buffer mh-show-buffer))
  443. (let ((from-header (mh-extract-from-header-value)))
  444. (and from-header
  445. (mh-alias-address-to-alias from-header))))))
  446. (defun mh-alias-add-alias-to-file (alias address &optional file)
  447. "Add ALIAS for ADDRESS in alias FILE without alias check or prompts.
  448. Prompt for alias file if not provided and there is more than one
  449. candidate.
  450. If the alias exists already, you will have the choice of
  451. inserting the new alias before or after the old alias. In the
  452. former case, this alias will be used when sending mail to this
  453. alias. In the latter case, the alias serves as an additional
  454. folder name hint when filing messages."
  455. (if (not file)
  456. (setq file (mh-alias-insert-file alias)))
  457. (with-current-buffer (find-file-noselect file)
  458. (goto-char (point-min))
  459. (let ((alias-search (concat alias ":"))
  460. (letter)
  461. (case-fold-search t))
  462. (cond
  463. ;; Search for exact match (if we had the same alias before)
  464. ((re-search-forward
  465. (concat "^" (regexp-quote alias-search) " *\\(.*\\)") nil t)
  466. (let ((answer (read-string
  467. (format (concat "Alias %s exists; insert new address "
  468. "[b]efore or [a]fter: ")
  469. (match-string 1))))
  470. (case-fold-search t))
  471. (cond ((string-match "^b" answer))
  472. ((string-match "^a" answer)
  473. (forward-line 1))
  474. (t
  475. (error "Unrecognized response")))))
  476. ;; No, so sort-in at the right place
  477. ;; search for "^alias", then "^alia", etc.
  478. ((eq mh-alias-insertion-location 'sorted)
  479. (setq letter (substring alias-search -1)
  480. alias-search (substring alias-search 0 -1))
  481. (while (and (not (equal alias-search ""))
  482. (not (re-search-forward
  483. (concat "^" (regexp-quote alias-search)) nil t)))
  484. (setq letter (substring alias-search -1)
  485. alias-search (substring alias-search 0 -1)))
  486. ;; Next, move forward to sort alphabetically for following letters
  487. (beginning-of-line)
  488. (while (re-search-forward
  489. (concat "^" (regexp-quote alias-search) "[a-" letter "]")
  490. nil t)
  491. (forward-line 1)))
  492. ((eq mh-alias-insertion-location 'bottom)
  493. (goto-char (point-max)))
  494. ((eq mh-alias-insertion-location 'top)
  495. (goto-char (point-min)))))
  496. (beginning-of-line)
  497. (insert (format "%s: %s\n" alias address))
  498. (save-buffer)))
  499. (defun mh-alias-add-alias (alias address)
  500. "Add ALIAS for ADDRESS in personal alias file.
  501. This function prompts you for an alias and address. If the alias
  502. exists already, you will have the choice of inserting the new
  503. alias before or after the old alias. In the former case, this
  504. alias will be used when sending mail to this alias. In the latter
  505. case, the alias serves as an additional folder name hint when
  506. filing messages."
  507. (interactive "P\nP")
  508. (mh-alias-reload-maybe)
  509. (setq alias (completing-read "Alias: " mh-alias-alist nil nil alias))
  510. (if (and address (string-match "^<\\(.*\\)>$" address))
  511. (setq address (match-string 1 address)))
  512. (setq address (read-string "Address: " address))
  513. (if (string-match "^<\\(.*\\)>$" address)
  514. (setq address (match-string 1 address)))
  515. (let ((address-alias (mh-alias-address-to-alias address))
  516. (alias-address (mh-alias-expand alias)))
  517. (if (string-equal alias-address alias)
  518. (setq alias-address nil))
  519. (cond
  520. ((and (equal alias address-alias)
  521. (equal address alias-address))
  522. (message "Already defined as %s" alias-address))
  523. (address-alias
  524. (if (y-or-n-p (format "Address has alias %s; set new one? "
  525. address-alias))
  526. (mh-alias-add-alias-to-file alias address)))
  527. (t
  528. (mh-alias-add-alias-to-file alias address)))))
  529. ;;;###mh-autoload
  530. (defun mh-alias-grab-from-field ()
  531. "Add alias for the sender of the current message."
  532. (interactive)
  533. (mh-alias-reload-maybe)
  534. (save-excursion
  535. (cond
  536. ((mh-folder-line-matches-show-buffer-p)
  537. (set-buffer mh-show-buffer))
  538. ((and (eq major-mode 'mh-folder-mode)
  539. (mh-get-msg-num nil))
  540. (set-buffer (get-buffer-create mh-temp-buffer))
  541. (insert-file-contents (mh-msg-filename (mh-get-msg-num t))))
  542. ((eq major-mode 'mh-folder-mode)
  543. (error "Cursor not pointing to a message")))
  544. (let* ((address (or (mh-extract-from-header-value)
  545. (error "Message has no From: header")))
  546. (alias (mh-alias-suggest-alias address)))
  547. (mh-alias-add-alias alias address))))
  548. (defun mh-alias-add-address-under-point ()
  549. "Insert an alias for address under point."
  550. (interactive)
  551. (let ((address (goto-address-find-address-at-point)))
  552. (if address
  553. (mh-alias-add-alias nil address)
  554. (message "No email address found under point"))))
  555. (defun mh-alias-apropos (regexp)
  556. "Show all aliases or addresses that match a regular expression REGEXP."
  557. (interactive "sAlias regexp: ")
  558. (if mh-alias-local-users
  559. (mh-alias-reload-maybe))
  560. (let ((matches "")
  561. (group-matches "")
  562. (passwd-matches))
  563. (save-excursion
  564. (message "Reading MH aliases...")
  565. (mh-exec-cmd-quiet t "ali" "-nolist" "-nouser")
  566. (message "Parsing MH aliases...")
  567. (while (re-search-forward regexp nil t)
  568. (beginning-of-line)
  569. (cond
  570. ((looking-at "^[ \t]") ;Continuation line
  571. (setq group-matches
  572. (concat group-matches
  573. (buffer-substring
  574. (save-excursion
  575. (or (re-search-backward "^[^ \t]" nil t)
  576. (point)))
  577. (progn
  578. (if (re-search-forward "^[^ \t]" nil t)
  579. (forward-char -1))
  580. (point))))))
  581. (t
  582. (setq matches
  583. (concat matches
  584. (buffer-substring (point)(progn (end-of-line)(point)))
  585. "\n")))))
  586. (message "Parsing MH aliases...done")
  587. (when mh-alias-local-users
  588. (message "Making passwd aliases...")
  589. (setq passwd-matches
  590. (mapconcat
  591. (lambda (elem)
  592. (if (or (string-match regexp (car elem))
  593. (string-match regexp (cadr elem)))
  594. (format "%s: %s\n" (car elem) (cadr elem))))
  595. mh-alias-passwd-alist ""))
  596. (message "Making passwd aliases...done")))
  597. (if (and (string-equal "" matches)
  598. (string-equal "" group-matches)
  599. (string-equal "" passwd-matches))
  600. (message "No matches")
  601. (with-output-to-temp-buffer mh-aliases-buffer
  602. (if (not (string-equal "" matches))
  603. (princ matches))
  604. (when (not (string-equal group-matches ""))
  605. (princ "\nGroup Aliases:\n\n")
  606. (princ group-matches))
  607. (when (not (string-equal passwd-matches ""))
  608. (princ "\nLocal User Aliases:\n\n")
  609. (princ passwd-matches))))))
  610. (defun mh-folder-line-matches-show-buffer-p ()
  611. "Return t if the message under point in folder-mode is in the show buffer.
  612. Return nil in any other circumstance (no message under point, no
  613. show buffer, the message in the show buffer doesn't match."
  614. (and (eq major-mode 'mh-folder-mode)
  615. (mh-get-msg-num nil)
  616. mh-show-buffer
  617. (get-buffer mh-show-buffer)
  618. (buffer-file-name (get-buffer mh-show-buffer))
  619. (string-match ".*/\\([0-9]+\\)$"
  620. (buffer-file-name (get-buffer mh-show-buffer)))
  621. (string-equal
  622. (match-string 1 (buffer-file-name (get-buffer mh-show-buffer)))
  623. (int-to-string (mh-get-msg-num nil)))))
  624. (provide 'mh-alias)
  625. ;; Local Variables:
  626. ;; indent-tabs-mode: nil
  627. ;; sentence-end-double-space: nil
  628. ;; End:
  629. ;;; mh-alias.el ends here