home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / misc / volume8 / pcmail / part04 < prev    next >
Lisp/Scheme  |  1989-11-03  |  38KB  |  967 lines
  1. Newsgroups: comp.sources.misc
  2. subject: v08i112: pcmail part 04 of 08
  3. From: allbery@uunet.UU.NET (Brandon S. Allbery - comp.sources.misc)
  4. Reply-To: markl@oracle.com (Croaker the Physician)
  5.  
  6. Posting-number: Volume 8, Issue 112
  7. Submitted-by: markl@oracle.com (Croaker the Physician)
  8. Archive-name: pcmail/part04
  9.  
  10. #--------------------------------CUT HERE-------------------------------------
  11. #! /bin/sh
  12. #
  13. # This is a shell archive.  Save this into a file, edit it
  14. # and delete all lines above this comment.  Then give this
  15. # file to sh by executing the command "sh file".  The files
  16. # will be extracted into the current directory owned by
  17. # you with default permissions.
  18. #
  19. # The files contained herein are:
  20. #
  21. # -rw-rw-r--  1 markl       24644 Nov  1 13:33 pcmailattr.el
  22. # -rw-rw-r--  1 markl       10900 Oct 31 11:50 pcmailmove.el
  23. #
  24. echo 'x - pcmailattr.el'
  25. if test -f pcmailattr.el; then echo 'shar: not overwriting pcmailattr.el'; else
  26. sed 's/^X//' << '________This_Is_The_END________' > pcmailattr.el
  27. X;;;; GNU-EMACS PCMAIL mail reader
  28. X
  29. X;;  Written by Mark L. Lambert
  30. X;;  Architecture Group, Network Products Division
  31. X;;  Oracle Corporation
  32. X;;  20 Davis Dr,
  33. X;;  Belmont CA, 94002
  34. X;;
  35. X;;  internet: markl@oracle.com or markl%oracle.com@apple.com
  36. X;;  UUCP:     {hplabs,uunet,apple}!oracle!markl
  37. X
  38. X;; Copyright (C) 1989 Mark L. Lambert
  39. X
  40. X;; This file is not officially part of GNU Emacs, but is being
  41. X;; donated to the Free Software Foundation.  As such, it is
  42. X;; subject to the standard GNU-Emacs General Public License,
  43. X;; referred to below.
  44. X
  45. X;; GNU Emacs is distributed in the hope that it will be useful,
  46. X;; but WITHOUT ANY WARRANTY.  No author or distributor
  47. X;; accepts responsibility to anyone for the consequences of using it
  48. X;; or for whether it serves any particular purpose or works at all,
  49. X;; unless he says so in writing.  Refer to the GNU Emacs General Public
  50. X;; License for full details.
  51. X
  52. X;; Everyone is granted permission to copy, modify and redistribute
  53. X;; GNU Emacs, but only under the conditions described in the
  54. X;; GNU Emacs General Public License.   A copy of this license is
  55. X;; supposed to have been given to you along with GNU Emacs so you
  56. X;; can know your rights and responsibilities.  It should be in a
  57. X;; file named COPYING.  Among other things, the copyright notice
  58. X;; and this notice must be preserved on all copies.
  59. X
  60. X;;;; global variables
  61. X
  62. X(defvar pcmail-attribute-obarray (make-vector 47 0)
  63. X  "An attribute obarray used for completion in attribute-manipulation
  64. Xcommands.")
  65. X
  66. X;; note the inclusion of pcmail-defined attributes here.  In order to
  67. X;; conform to Babyl, these attributes must also be present in the user-defined
  68. X;; labels section of a babyl mail file header.  Normally this would 
  69. X;; automatically load them into the obarray at folder-open time.  
  70. X;; Unfortunately some older pcmail mail files won't have them, so we provide 
  71. X;; them here for backward compatibility
  72. X
  73. X(mapcar '(lambda (a) (intern a pcmail-attribute-obarray))
  74. X    (append pcmail-babyl-defined-attributes
  75. X        '("printed" "copied" "edited" "timely" "expired" 
  76. X          "undigestified" "archived" "precious")))
  77. X
  78. X;;; sticky defaults
  79. X
  80. X(defvar pcmail-last-attr nil
  81. X  "The name of the last attribute given to an attribute command.")
  82. X
  83. X(defvar pcmail-last-priority nil
  84. X  "The last priority assigned a message.")
  85. X
  86. X;;;; priority setting commands
  87. X
  88. X(defun pcmail-change-message-priority (priority)
  89. X  "Change the current message's priority.
  90. XArgs: (priority)
  91. X  Change the current message's priority.  A priority is represented by a 
  92. Xnon-zero number, the lower the number the higher the priority; messages can 
  93. Xbe sorted by priority using the \\[pcmail-sort-folder\\] command.
  94. XInput defaults to last priority given a message."
  95. X  (interactive 
  96. X   (if current-prefix-arg
  97. X       '(nil)
  98. X     (let ((p (pcmail-read-string-default "Message priority: " 
  99. X                      pcmail-last-priority t)))
  100. X       (or (> (string-to-int p) 0)
  101. X       (error "Priority must be a number greater than zero."))
  102. X       (list (string-to-int (setq pcmail-last-priority p))))))
  103. X  (pcmail-change-message-priority-1 priority pcmail-current-subset-message 1)
  104. X  (pcmail-update-folder-mode-line pcmail-current-subset-message))
  105. X
  106. X(defun pcmail-change-priority-subset (priority)
  107. X  "Change the current message subset's priority.
  108. XArgs: (priority)
  109. X  Change the current subset's priority.  A priority is represented by a 
  110. Xnon-zero number, the lower the number the higher the priority; messages can 
  111. Xbe sorted by priority using the \\[pcmail-sort-folder\\] command.
  112. XInput defaults to last priority given a message."
  113. X  (interactive 
  114. X   (if current-prefix-arg
  115. X       '(nil)
  116. X     (let ((p (pcmail-read-string-default "Message priority: " 
  117. X                      pcmail-last-priority t)))
  118. X       (or (> (string-to-int p) 0)
  119. X       (error "Priority must be a number greater than zero."))
  120. X       (list (string-to-int (setq pcmail-last-priority p))))))
  121. X  (pcmail-barf-if-empty-folder)
  122. X  (pcmail-change-message-priority-1 priority 1 (pcmail-current-subset-length))
  123. X  (pcmail-update-folder-mode-line pcmail-current-subset-message))
  124. X
  125. X(defun pcmail-change-message-priority-1 (p start len)
  126. X  "Change message priorities to P starting with START for LEN subset messages.
  127. XArgs: (p start len)"
  128. X  (pcmail-barf-if-empty-folder)
  129. X  (let ((i start))
  130. X    (unwind-protect
  131. X    (while (< i (+ start len))
  132. X      (pcmail-set-priority (pcmail-make-absolute i) p)
  133. X      (and (zerop (% (- (setq i (1+ i)) start) pcmail-progress-interval))
  134. X           (message "Setting priorities...%d" (- i start))))
  135. X      (pcmail-update-folder-mode-line pcmail-current-subset-message))
  136. X    (and (>= (- i start) pcmail-progress-interval)
  137. X     (message "Setting priorities...done (%d message%s)"
  138. X          (- i start) (pcmail-s-ending (- i start))))))
  139. X
  140. X;;;; attribute-changing operations: deletion, undeletion, general attribute 
  141. X;;;; setting and clearing.
  142. X
  143. X(defun pcmail-change-message-attr (attr mode)
  144. X  "Toggle a named attribute of the current message.  
  145. XArgs: (attr mode)
  146. X  Toggle a named attribute of the current message.  Completion on input is
  147. Xpermitted; input defaults to last attribute given to an attribute command.
  148. XWith a prefix arg, don't toggle.  If the arg is positive, set the attribute;
  149. Xif negative, clear the attribute."
  150. X  (interactive (list (pcmail-read-attr 
  151. X              (concat 
  152. X               (cond ((null current-prefix-arg) "Toggle")
  153. X                 ((>= current-prefix-arg 0) "Set")
  154. X                 (t "Clear"))
  155. X               " attribute: "))
  156. X             current-prefix-arg))
  157. X  (pcmail-barf-if-empty-folder)
  158. X  (pcmail-change-message-attr-1 attr
  159. X                (cond ((null mode) 'toggle)
  160. X                      ((>= mode 0) t))
  161. X                pcmail-current-subset-message 1))
  162. X
  163. X(defun pcmail-change-attr-subset (attr mode)
  164. X  "Toggle a named attribute in each message of the current message subset.
  165. XArgs: (attr mode)
  166. X  Toggle a named attribute in each message of the current message subset.
  167. XCompletion on input is permitted; input defaults to last attribute given to
  168. Xan attribute command.  With a prefix arg, don't toggle.  If the arg is
  169. Xpositive, set the attribute; if negative, clear the attribute."
  170. X  (interactive (list (pcmail-read-attr
  171. X              (concat 
  172. X               (cond ((null current-prefix-arg) "Toggle")
  173. X                 ((>= current-prefix-arg 0) "Set")
  174. X                 (t "Clear"))
  175. X               " message subset attribute: "))
  176. X             current-prefix-arg))
  177. X  (pcmail-barf-if-empty-folder)
  178. X  (pcmail-change-message-attr-1 attr 
  179. X                (cond ((null mode) 'toggle)
  180. X                      ((>= mode 0) t))
  181. X                1 (pcmail-current-subset-length)))
  182. X
  183. X(defun pcmail-change-message-attr-1 (attr state start len)
  184. X  "Munge message attributes in the current message subset.
  185. XArgs: (attr state start len)
  186. X  Set attribute ATTR to STATE for all messages in the current subset from START
  187. Xfor LEN messages.  If STATE is 'toggle, toggle the current attribute state."
  188. X  (let ((i start))
  189. X    (unwind-protect
  190. X    (while (< i (+ start len))
  191. X      (pcmail-set-attribute (pcmail-make-absolute i) attr state)
  192. X      (and (zerop (% (- (setq i (1+ i)) start) pcmail-progress-interval))
  193. X           (message "%sing %s attribute...%d"
  194. X            (cond ((eq state 'toggle) "Toggl")
  195. X                  (state "Sett")
  196. X                  (t "Clear")) 
  197. X            attr (- i start))))
  198. X      (pcmail-update-folder-mode-line pcmail-current-subset-message))
  199. X    (and (>= (- i start) pcmail-progress-interval)
  200. X     (message "%sing %s attribute...done (%d message%s)"
  201. X          (cond ((eq state 'toggle) "Toggl")
  202. X            (state "Sett")
  203. X            (t "Clear")) 
  204. X          attr (- i start) (pcmail-s-ending (- i start))))))
  205. X
  206. X(defun pcmail-undelete-previous-message ()
  207. X  "Looking backward from the current message, clear the first deleted 
  208. Xmessage's delete attribute.
  209. XArgs: none"
  210. X  (interactive)
  211. X  (pcmail-barf-if-empty-folder)
  212. X  (let ((n (pcmail-next-subset-message-of-type 
  213. X        nil nil 'include-current 'pcmail-has-attribute-p "deleted")))
  214. X    (cond (n
  215. X        (pcmail-set-attribute (pcmail-make-absolute n) "deleted" nil)
  216. X        (pcmail-goto-message n))
  217. X      (t
  218. X        (message "No previous deleted message in the current subset.")))))
  219. X
  220. X(defun pcmail-undelete-subset ()
  221. X  "Undelete all messages in the current message subset.
  222. XArgs: none"
  223. X  (interactive)
  224. X  (pcmail-barf-if-empty-folder)
  225. X  (pcmail-change-message-attr-1 "deleted" nil 1
  226. X                (pcmail-current-subset-length)))
  227. X
  228. X(defun pcmail-delete-message (&optional dont-skip)
  229. X  "Delete this message and move to the next interesting message.
  230. XArgs: (&optional dont-skip)
  231. XDelete this message and move to the next interesting message.  Deleted 
  232. Xmessages remain in the folder until the \\[pcmail-expunge-folder] command 
  233. Xis given.  With a prefix argument, delete and move to the next message in the 
  234. Xcurrent subset whether or not it is interesting."
  235. X  (interactive "P")
  236. X  (pcmail-barf-if-empty-folder)
  237. X  (let ((n pcmail-current-subset-message))
  238. X    (pcmail-set-attribute (pcmail-make-absolute n) "deleted" t)
  239. X    (pcmail-next-message dont-skip)
  240. X    (and (= n pcmail-current-subset-message)
  241. X     (pcmail-update-folder-mode-line n))))
  242. X
  243. X(defun pcmail-delete-message-backward (&optional dont-skip)
  244. X  "Delete this message and move to the previous interesting message.
  245. XArgs: (&optional dont-skip)
  246. X  Delete this message and move to the previous interesting message.  
  247. XDeleted messages remain in the folder until the \\[pcmail-expunge-folder] 
  248. Xcommand is given.  With a prefix argument, delete and move to the previous 
  249. Xmessage in the current subset whether or not it is interesting."
  250. X  (interactive)
  251. X  (pcmail-barf-if-empty-folder)
  252. X  (let ((n pcmail-current-subset-message))
  253. X    (pcmail-set-attribute (pcmail-make-absolute n) "deleted" t)
  254. X    (pcmail-previous-message dont-skip)
  255. X    (and (= n pcmail-current-subset-message)
  256. X     (pcmail-update-folder-mode-line n))))
  257. X
  258. X(defun pcmail-delete-subset ()
  259. X  "Delete all messages in the current message subset.
  260. XArgs: none
  261. X  Delete all messages in the current message subset.  Deleted messages remain
  262. Xin the folder until the \\[pcmail-expunge-folder] command is given."
  263. X  (interactive)
  264. X  (pcmail-barf-if-empty-folder)
  265. X  (pcmail-change-message-attr-1 "deleted" t 1 (pcmail-current-subset-length)))
  266. X
  267. X(defun pcmail-zap-to-message ()
  268. X  "Delete all messages in the current subset from the current message forward.
  269. XArgs: none
  270. X  Delete all messages in the current subset from the current message forward.
  271. XDeleted messages remain in the folder until the \\[pcmail-expunge-folder] 
  272. Xcommand is given."
  273. X  (interactive)
  274. X  (pcmail-barf-if-empty-folder)
  275. X  (pcmail-change-message-attr-1 "deleted" t pcmail-current-subset-message
  276. X                (1+ (- (pcmail-current-subset-length)
  277. X                       pcmail-current-subset-message))))
  278. X
  279. X(defun pcmail-kill-message-later (n date)
  280. X  "Arrange for something to happen to a message some time in the future.
  281. XArgs: (n date)
  282. X  If called interactively, read a date of the form dd-mmm-yy from the 
  283. Xminibuffer.  N is current message.  If called as a function, supply an 
  284. Xabsolute message number and a date string in the form dd-mmm-yy.  Set 
  285. Xmessage N's \"timely\" attribute.  Insert an expires: field in the message 
  286. Xheader.  When the current date is greater than a message's expiration date, 
  287. Xapply the hook pcmail-expiration-hook to the message.  With a prefix argument 
  288. X(called interactively) or a DATE value of NIL (called as a function), remove 
  289. Xthe expired field and clear the message's \"timely\" attribute, effectively 
  290. Xunexpiring the message."
  291. X  (interactive
  292. X   (list (pcmail-make-absolute pcmail-current-subset-message)
  293. X     (if current-prefix-arg
  294. X         nil
  295. X       (let ((expiration))
  296. X         (while 
  297. X                 ; string-to-date triple validates date format
  298. X           (not (pcmail-string-to-date-triple
  299. X               (setq expiration 
  300. X                 (pcmail-read-string-default 
  301. X                  "Expiration date (dd-mmm-yy): " nil t))))
  302. X           (message "Date not dd-mmm-yy.") (ding) (sit-for 2))
  303. X         expiration))))
  304. X  (pcmail-set-message-expiration n date)
  305. X  (pcmail-set-attribute n "timely" (and date t))
  306. X  (pcmail-update-folder-mode-line pcmail-current-subset-message))
  307. X                 
  308. X;;;; attribute-hacking utilities
  309. X
  310. X;;; two functions that work on messages with relative numbers.  A relative 
  311. X;;; message number is that message's index within the current subset.  Its
  312. X;;; absolute number is its index within the entire folder.
  313. X
  314. X(defun pcmail-update-folder-mode-line (n)
  315. X  "Display message information in the mode line.
  316. XArgs: (n)
  317. X  Set pcmail-display-info to string describing message with relative number N.
  318. XThe string is formatted by the directives in pcmail-folder-mode-line-format.
  319. XSee description of that variable for details.  The formatted string will be
  320. Xdisplayed in the mode line."
  321. X  (setq pcmail-display-info
  322. X    (pcmail-format-string
  323. X     pcmail-folder-mode-line-format
  324. X     (list (list "s" '(lambda (n) n) n)
  325. X           (list "S" '(lambda () (pcmail-current-subset-length)))
  326. X           (list "e" '(lambda () 
  327. X                (if (eq major-mode 'pcmail-edit-mode)
  328. X                "Editing "
  329. X                  "")))
  330. X           (list "E" '(lambda (n)
  331. X                (let ((abs (pcmail-make-absolute n)) (exp))
  332. X                  (if (and (pcmail-has-attribute-p abs "timely")
  333. X                       (setq exp 
  334. X                         (pcmail-message-expiration abs)))
  335. X                  (concat "Expires: " exp)
  336. X                "")))
  337. X             n)
  338. X           (list "n" 
  339. X             '(lambda (n)
  340. X            (cond ((or (/= (pcmail-current-subset-length)
  341. X                       pcmail-total-messages)
  342. X                   (/= n (pcmail-make-absolute n)))
  343. X                   (format "[%d/%d]" (pcmail-make-absolute n)
  344. X                       pcmail-total-messages))
  345. X                  (t
  346. X                   ""))) n)
  347. X           (list "f" '(lambda () pcmail-folder-name))
  348. X           (list "a" 
  349. X             '(lambda (n)
  350. X            (let ((attrs (aref pcmail-attr-vector 
  351. X                       (pcmail-make-absolute n))))
  352. X              (if attrs
  353. X                  (mapconcat 'identity attrs ", ")
  354. X                "[no attributes]"))) n)
  355. X           (list "l" 
  356. X             '(lambda (n) 
  357. X            (pcmail-message-line-count (pcmail-make-absolute n)))
  358. X             n)
  359. X           (list "c"
  360. X             '(lambda (n) 
  361. X            (pcmail-message-char-count (pcmail-make-absolute n)))
  362. X             n)
  363. X           (list "p"
  364. X             '(lambda (n) 
  365. X            (let ((p (pcmail-message-priority
  366. X                  (pcmail-make-absolute n))))
  367. X              (if (= p 1) ""
  368. X                (format "Priority: %d" p))))
  369. X             n))))
  370. X  (and (= n pcmail-current-subset-message)
  371. X       (pcmail-force-mode-line-update)))
  372. X
  373. X(defun pcmail-next-subset-message-of-type (forward-p invert-p include-current-p
  374. X                       pred &rest args)
  375. X  "Return the number of the next message that satisfies a predicate.
  376. XArgs: (forward-p invert-p include-current-p pred &rest args)
  377. X  Starting with the current subset message if INCLUDE-CURRENT-P is non-nil,
  378. Xthe first message after/before current otherwise, return the number of the
  379. Xfirst subset message that satisfies PRED applied to ARGS, or if INVERT-P is
  380. Xnon-NIL, does not satisfy PRED applied to ARGS.  Search forward
  381. Xif FORWARD-P is non-nil, backward else.  If no such message is found,
  382. Xreturn NIL."
  383. X  (let ((found) (current pcmail-current-subset-message))
  384. X    (or include-current-p
  385. X    (setq current (funcall (if forward-p '1+ '1-) current)))
  386. X    (while (and (not found) 
  387. X        (funcall (if forward-p '<= '>=) current 
  388. X             (if forward-p (pcmail-current-subset-length) 1)))
  389. X      (and (if invert-p
  390. X           (not (apply pred (pcmail-make-absolute current) args))
  391. X         (apply pred (pcmail-make-absolute current) args))
  392. X       (setq found current))
  393. X      (setq current (funcall (if forward-p '1+ '1-) current)))
  394. X    found))
  395. X
  396. X;;; all following routines deal with absolute-numbered messages
  397. X
  398. X(defun pcmail-hack-timely-messages (tl)
  399. X  "Given a list of timely messages, figure out what to do with them.
  400. XArgs: (tl)
  401. X  TL is a list of message numbers, corresponding to messages with the 
  402. X\"timely\" attribute set.  If any of these messages has an expired: header
  403. Xfield earlier than the current date, apply pcmail-expiration-hook to
  404. Xthe message number."
  405. X  (let ((now-days (pcmail-date-triple-to-ndays 
  406. X           (pcmail-string-to-date-triple))))
  407. X    (mapcar 
  408. X     '(lambda (n)
  409. X    (let ((expiration (pcmail-message-expiration n)))
  410. X      (cond ((and expiration
  411. X              pcmail-expiration-hook
  412. X              (not (pcmail-has-attribute-p n "expired"))
  413. X              (setq expiration 
  414. X                (pcmail-string-to-date-triple expiration))
  415. X              (setq expiration
  416. X                (pcmail-date-triple-to-ndays expiration))
  417. X              (<= expiration now-days))
  418. X         (funcall pcmail-expiration-hook n)
  419. X         (pcmail-set-attribute n "expired" t)
  420. X         (pcmail-set-attribute n "timely" nil)))))
  421. X     tl)))
  422. X
  423. X(defun pcmail-set-message-expiration (n date)
  424. X  "Set message absolute-numbered N's expiration to DATE.
  425. XArgs: (n date)
  426. X N is an absolute message number, DATE is a date string dd-mmm-yy.
  427. XRemove N's expires: field if it has one.  If DATE is non-nil, place its
  428. Xentries in a new expires: field."
  429. X  (save-excursion
  430. X    (save-restriction
  431. X      (pcmail-narrow-to-unpruned-header n)
  432. X      (goto-char (point-min))
  433. X      (let ((buffer-read-only nil)
  434. X        (case-fold-search t))
  435. X    (and (re-search-forward "^expires:.*\n\\([ \t]+.*\n\\)*" nil t)
  436. X         (replace-match ""))
  437. X    (and date (insert "Expires: " date "\n"))))))
  438. X
  439. X(defun pcmail-message-expiration (n)
  440. X  "Return message absolute-numbered N's expiration date as a date string
  441. XArgs: (n)
  442. X  If N has a a valid expired: field in the form \"dd mm yy\", return it, 
  443. Xelse return NIL."
  444. X  (save-excursion
  445. X    (save-restriction
  446. X      (pcmail-narrow-to-unpruned-header n)
  447. X      (goto-char (point-min))
  448. X      (mail-fetch-field "expires"))))
  449. X
  450. X(defun pcmail-interesting-p (n)
  451. X  "Return non-NIL if message absolute-numbered N is interesting, NIL else.
  452. XArgs: (n)
  453. X  Return non-NIL if message absolute-numbered N is interesting, NIL else.  
  454. XMessage N is interesting if pcmail-interesting-hook returns non-NIL 
  455. Xwhen applied to N.  If pcmail-interesting-hook is NIL, all messages 
  456. Xare interesting."
  457. X  (if pcmail-interesting-hook
  458. X      (funcall pcmail-interesting-hook n)
  459. X    t))
  460. X
  461. X(defun pcmail-has-attribute-p (n attr)
  462. X  "Check an attribute's membership in a message attribute list.
  463. XArgs: (n attr)
  464. X  Return T if ATTR is a member of message absolute-numbered N's attribute 
  465. Xlist, NIL else."
  466. X  (pcmail-in-sequence-p attr (aref pcmail-attr-vector n)))
  467. X
  468. X(defun pcmail-set-attribute (n attr state)
  469. X  "Set, clear, or toggle a message attribute.
  470. XArgs: (n attr state)
  471. X  Set message absolute-numbered N's attribute ATTR to STATE.  If STATE is 
  472. X'toggle, toggle the attribute's state.  If ATTR is \"deleted\", do not
  473. Xset state to non-NIL if N already has the \"precious\" attribute"
  474. X  (pcmail-barf-if-empty-folder)
  475. X  (or (pcmail-attribute-p attr)
  476. X      (error "No attribute named %s." attr))
  477. X  (let ((curstate (pcmail-babyl-attr-present-p n attr)))
  478. X    (cond ((and curstate (or (eq state 'toggle) (not state)))
  479. X       (pcmail-remove-from-message-attribute-list n attr)
  480. X       (pcmail-remove-babyl-attr n attr))
  481. X      ((and (not curstate) state
  482. X        (if (and (pcmail-has-attribute-p n "precious")
  483. X             (string= attr "deleted"))
  484. X            nil
  485. X          t))
  486. X       (pcmail-add-to-message-attribute-list n attr)
  487. X       (pcmail-add-babyl-attr n attr))))
  488. X  
  489. X  ; this may have screwed up the region around the current message.  Fix it.
  490. X  (pcmail-narrow-to-message 
  491. X   (pcmail-make-absolute pcmail-current-subset-message))
  492. X  state)
  493. X
  494. X(defun pcmail-priority-less-than-p (a b)
  495. X  "Args: (a b)
  496. XReturn T is message A's priority is higher (less than) B's, NIL else."
  497. X  (< (pcmail-message-priority a) (pcmail-message-priority b)))
  498. X
  499. X(defun pcmail-message-priority (n)
  500. X  "Return specified message's Priority: field contents as a number.
  501. XArgs: (n)
  502. X  First search the pcmail-priority-vector cache for a priority number.  If 
  503. Xnone is found, get message N's Priority: field and turn it into a number.  
  504. XIf no priority exists, return the highest priority, 1."
  505. X  (or (aref pcmail-priority-vector n)
  506. X      (aset pcmail-priority-vector n
  507. X        (cond ((zerop n)
  508. X           1)
  509. X          (t
  510. X            (save-excursion
  511. X              (save-restriction
  512. X            (let ((case-fold-search t))
  513. X              (pcmail-narrow-to-unpruned-header n)
  514. X              (let ((p (mail-fetch-field "priority")))
  515. X                (if p (string-to-int p) 1))))))))))
  516. X
  517. X(defun pcmail-set-priority (n p)
  518. X  "Set message absolute-numbered N's priority to P.  Kill priority if P is NIL.
  519. XArgs: (n p)"
  520. X  (save-excursion
  521. X    (save-restriction
  522. X      (pcmail-narrow-to-unpruned-header n)
  523. X      (goto-char (point-min))
  524. X      (let ((buffer-read-only nil)
  525. X        (case-fold-search t))
  526. X    (and (re-search-forward "^priority:.*\n\\([ \t]+.*\n\\)*" nil t)
  527. X         (replace-match ""))
  528. X    (and p
  529. X         (insert "Priority: " (int-to-string p) "\n"))
  530. X    (aset pcmail-priority-vector n (or p 1))))))
  531. X
  532. X;; sort routines for sort by from or to fields.  Shouldn't be here, but I
  533. X;; can't think of a better place to put them
  534. X
  535. X(defun pcmail-from-field-less-than-p (a b)
  536. X  "Return t if message A's from field is lexicographically less than B's
  537. XArgs: (a b)"
  538. X  (let ((afrom) (bfrom))
  539. X    (save-excursion
  540. X      (save-restriction
  541. X    (pcmail-narrow-to-unpruned-header a)
  542. X    (setq afrom (mail-strip-quoted-names
  543. X             (or (mail-fetch-field "resent-from")
  544. X             (mail-fetch-field "resent-sender")
  545. X             (mail-fetch-field "from")
  546. X             (mail-fetch-field "sender")
  547. X             "")))))
  548. X    (save-excursion
  549. X      (save-restriction
  550. X    (pcmail-narrow-to-unpruned-header b)
  551. X    (setq bfrom (mail-strip-quoted-names
  552. X             (or (mail-fetch-field "resent-from")
  553. X             (mail-fetch-field "resent-sender")
  554. X             (mail-fetch-field "from")
  555. X             (mail-fetch-field "sender")
  556. X             "")))))
  557. X    (string< afrom bfrom)))
  558. X
  559. X(defun pcmail-to-field-less-than-p (a b)
  560. X  "Return t if message A's to field is lexicographically less than B's
  561. XArgs: (a b)"
  562. X  (let ((ato) (bto))
  563. X    (save-excursion
  564. X      (save-restriction
  565. X    (pcmail-narrow-to-unpruned-header a)
  566. X    (setq ato (mail-strip-quoted-names
  567. X           (or (mail-fetch-field "resent-to")
  568. X               (mail-fetch-field "resent-apparently-to")
  569. X               (mail-fetch-field "to")
  570. X               (mail-fetch-field "apparently-to") ;uck
  571. X               "")))))
  572. X    (save-excursion
  573. X      (save-restriction
  574. X    (pcmail-narrow-to-unpruned-header b)
  575. X    (setq bto (mail-strip-quoted-names
  576. X           (or (mail-fetch-field "resent-to")
  577. X               (mail-fetch-field "resent-apparently-to")
  578. X               (mail-fetch-field "to")
  579. X               (mail-fetch-field "apparently-to") ;uck
  580. X               "")))))
  581. X    (string< ato bto)))
  582. X             
  583. X;;; utilities which know how folder attribute names are stored.  All
  584. X;;; the following are internal to pcmailattr.el
  585. X;;;
  586. X;;; system-defined attributes are interned in a completion obarray at load 
  587. X;;; time.  New user-defined attributes are interned into the obarray as 
  588. X;;; needed, as well as installed in the current folder's babyl header 
  589. X;;; labels: field.  Old user-defined attributes are read from labels: fields 
  590. X;;; and interned into the obarray as folders are opened for the first time
  591. X
  592. X(defun pcmail-add-to-message-attribute-list (n attr)
  593. X  "Add an attribute to a message's attribute list.
  594. XArgs (n attr)
  595. X  Add attribute string ATTR to message absolute-numbered N's attribute list."
  596. X  (aset pcmail-attr-vector n 
  597. X    (cons attr (aref pcmail-attr-vector n))))
  598. X
  599. X(defun pcmail-remove-from-message-attribute-list (n attr)
  600. X  "Remove an attribute from a message's attribute list.
  601. XArgs: (n attr)
  602. X  Remove attribute string ATTR from message absolute-numbered N's attribute 
  603. Xlist."
  604. X  (let ((attrs (aref pcmail-attr-vector n))
  605. X    (temp))
  606. X    (while attrs
  607. X      (or (string= attr (car attrs))
  608. X      (setq temp (cons (car attrs) temp)))
  609. X      (setq attrs (cdr attrs)))
  610. X    (aset pcmail-attr-vector n temp)))
  611. X
  612. X(defun pcmail-read-attr (prompt)
  613. X  "Read an attribute from the minibuffer.
  614. XArgs: (prompt)
  615. X  Read an attribute from the minibuffer, prompting with PROMPT.  Blank input
  616. Xcauses the value of pcmail-last-attr to be used.  Non-blank input completes
  617. Xoff pcmail-attribute-obarray, setting pcmail-last-attr to be the input just
  618. Xreceived.  If the attribute is not in the obarray ask if it should be put
  619. Xthere as well as in the current folder's Babyl header labels: field."
  620. X  (or (pcmail-attribute-p pcmail-last-attr)
  621. X      (setq pcmail-last-attr nil))
  622. X  (let ((a (pcmail-completing-read prompt pcmail-attribute-obarray 
  623. X                   pcmail-last-attr)))
  624. X    (or (pcmail-attribute-p a)
  625. X    (if (y-or-n-p "Undefined attribute; install? ")
  626. X        (pcmail-install-attribute a)
  627. X      (error "Aborted.")))
  628. X    (setq pcmail-last-attr a)))
  629. X
  630. X(defun pcmail-attribute-p (a)
  631. X  "Return non-NIL if A is a valid attribute, NIL else.
  632. XArgs: (a)"
  633. X  (and (stringp a) (intern-soft a pcmail-attribute-obarray)))
  634. X
  635. X(defun pcmail-legal-attribute-name-p (a)
  636. X  "Return non-NIL if A is a legal attribute string, NIL else.
  637. XArgs: (a)"
  638. X  (not (string-match "," a)))
  639. X
  640. X(defun pcmail-load-user-defined-attributes ()
  641. X  "Intern user-defined labels.
  642. XArgs: none"
  643. X  (mapcar '(lambda (x) (intern x pcmail-attribute-obarray))
  644. X      (pcmail-user-defined-babyl-attr-list)))
  645. X
  646. X(defun pcmail-install-attribute (attr)
  647. X  "Install a user-defined message attribute.
  648. XArgs: (attr)
  649. X  Place attribute ATTR in the completion obarray pcmail-attribute-obarray."
  650. X  (or (pcmail-legal-attribute-name-p attr)
  651. X      (error "%s is not a legal attribute name."))
  652. X  (pcmail-insert-user-defined-babyl-attr attr)
  653. X  (intern attr pcmail-attribute-obarray))
  654. X    
  655. X(provide 'pcmailattr)
  656. X
  657. ________This_Is_The_END________
  658. if test `wc -c < pcmailattr.el` -ne 24644; then
  659.     echo 'shar: pcmailattr.el was damaged during transit (should have been 24644 bytes)'
  660. fi
  661. fi        ; : end of overwriting check
  662. echo 'x - pcmailmove.el'
  663. if test -f pcmailmove.el; then echo 'shar: not overwriting pcmailmove.el'; else
  664. sed 's/^X//' << '________This_Is_The_END________' > pcmailmove.el
  665. X;;;; GNU-EMACS PCMAIL mail reader
  666. X
  667. X;;  Written by Mark L. Lambert
  668. X;;  Architecture Group, Network Products Division
  669. X;;  Oracle Corporation
  670. X;;  20 Davis Dr,
  671. X;;  Belmont CA, 94002
  672. X;;
  673. X;;  internet: markl@oracle.com or markl%oracle.com@apple.com
  674. X;;  UUCP:     {hplabs,uunet,apple}!oracle!markl
  675. X
  676. X;; Copyright (C) 1989 Mark L. Lambert
  677. X
  678. X;; This file is not officially part of GNU Emacs, but is being
  679. X;; donated to the Free Software Foundation.  As such, it is
  680. X;; subject to the standard GNU-Emacs General Public License,
  681. X;; referred to below.
  682. X
  683. X;; GNU Emacs is distributed in the hope that it will be useful,
  684. X;; but WITHOUT ANY WARRANTY.  No author or distributor
  685. X;; accepts responsibility to anyone for the consequences of using it
  686. X;; or for whether it serves any particular purpose or works at all,
  687. X;; unless he says so in writing.  Refer to the GNU Emacs General Public
  688. X;; License for full details.
  689. X
  690. X;; Everyone is granted permission to copy, modify and redistribute
  691. X;; GNU Emacs, but only under the conditions described in the
  692. X;; GNU Emacs General Public License.   A copy of this license is
  693. X;; supposed to have been given to you along with GNU Emacs so you
  694. X;; can know your rights and responsibilities.  It should be in a
  695. X;; file named COPYING.  Among other things, the copyright notice
  696. X;; and this notice must be preserved on all copies.
  697. X
  698. X;;;; movement and display commands within a single folder
  699. X
  700. X;;; movement commands
  701. X
  702. X(defun pcmail-beginning-of-message ()
  703. X  "Move to the beginning of the current message.
  704. XArgs: none"
  705. X  (interactive)
  706. X  (pcmail-barf-if-empty-folder)
  707. X  (pcmail-goto-message pcmail-current-subset-message))
  708. X
  709. X(defun pcmail-goto-message (&optional n)
  710. X  "Move to message number N of the current subset and display it.
  711. XArgs: (&optional n)
  712. XDisplay message N in the current folder's curent subset.  If called
  713. Xinteractively, N is specified by a numeric prefix argument.  If not 
  714. Xspecified, N defaults to the first message in the subset."
  715. X  (interactive "p")
  716. X  (pcmail-display-subset-message (or n (setq n 1))))
  717. X
  718. X(defun pcmail-last-message (&optional dont-skip)
  719. X  "Move to the last interesting message in the current subset and display it.
  720. XArgs: (&optional dont-skip)
  721. X  Display the last interesting message in the current folder's current subset.
  722. Xpcmail-interesting-p returns non-NIL when applied to an interesting message.  
  723. XIf called interactively, a prefix argument means move to the last message in 
  724. Xthe subset whether interesting or not."
  725. X  (interactive "P")
  726. X  (pcmail-barf-if-empty-folder)
  727. X  (let ((n))
  728. X    (cond (dont-skip
  729. X        (setq n (pcmail-current-subset-length)))
  730. X      (t
  731. X        (let ((pcmail-current-subset-message
  732. X            (pcmail-current-subset-length)))
  733. X          (setq n (pcmail-next-subset-message-of-type 
  734. X            nil nil 'include-current 'pcmail-interesting-p)))))
  735. X    (cond (n
  736. X       (pcmail-goto-message n))
  737. X      (t
  738. X       (pcmail-goto-message 1)
  739. X       (message "No interesting messages in this folder")))))
  740. X
  741. X(defun pcmail-next-message (&optional dont-skip)
  742. X  "Move to the next interesting message in the current subset and display it.
  743. XArgs: (&optional dont-skip)
  744. X  Display the next interesting message in the current folder's current subset.
  745. Xpcmail-interesting-p returns non-NIL when applied to an interesting message.  
  746. XIf called interactively, a prefix argument means move to the next message in 
  747. Xthe subset whether interesting or not."
  748. X  (interactive "P")
  749. X  (pcmail-barf-if-empty-folder)
  750. X  (let ((n))
  751. X    (cond (dont-skip
  752. X        (setq n (1+ pcmail-current-subset-message)))
  753. X      (t
  754. X        (setq n (pcmail-next-subset-message-of-type
  755. X              'forward nil nil 'pcmail-interesting-p))))
  756. X    (cond (n
  757. X        (pcmail-goto-message n))
  758. X      (t
  759. X        (message "No further interesting messages.")))))
  760. X
  761. X(defun pcmail-next-message-of-type (filter-name)
  762. X  "Move to the next message in the current subset that satisfies a predicate.
  763. XArgs: (filter)
  764. X  If called interactively, read a filter name from the minibuffer, use
  765. Xit to read that filter's arguments and get the filter predicate.  If called 
  766. Xas a function, supply a valid filter name.  Move to and display the next 
  767. Xsuch message."
  768. X  (interactive
  769. X   (list (pcmail-read-filter-name "Show next message in filter: ")))
  770. X  (pcmail-barf-if-empty-folder)
  771. X  (let ((i (1+ pcmail-current-subset-message))
  772. X    (found)
  773. X    (pred (pcmail-get-filter filter-name))
  774. X    (pcmail-current-tested-message)) ;inherited by predicates
  775. X    (while (and (not found) (<= i (pcmail-current-subset-length)))
  776. X      (setq pcmail-current-tested-message (pcmail-make-absolute i))
  777. X      (and (eval pred)
  778. X       (setq found i))
  779. X      (setq i (1+ i)))
  780. X    (cond (found
  781. X       (pcmail-goto-message found))
  782. X      (t
  783. X       (error "No more such messages in the current subset.")))))
  784. X
  785. X(defun pcmail-previous-message (&optional dont-skip)
  786. X  "Move to the previous interesting message in the current subset and display.
  787. XArgs: (&optional dont-skip)
  788. X  Display the previous interesting message in the current folder's current 
  789. Xsubset.  pcmail-interesting-p returns non-NIL when applied to an interesting 
  790. Xmessage.  If called interactively, a prefix argument means move to the 
  791. Xprevious message in the subset whether interesting or not."
  792. X  (interactive "P")
  793. X  (pcmail-barf-if-empty-folder)
  794. X  (let ((n))
  795. X    (cond (dont-skip
  796. X        (setq n (1- pcmail-current-subset-message)))
  797. X      (t
  798. X        (setq n (pcmail-next-subset-message-of-type
  799. X              nil nil nil 'pcmail-interesting-p))))
  800. X    (cond (n
  801. X        (pcmail-goto-message n))
  802. X      (t
  803. X        (message "No previous interesting messages.")))))
  804. X
  805. X
  806. X(defun pcmail-previous-message-of-type (filter-name)
  807. X  "Move to the previous message in the current subset satisfying a predicate.
  808. XArgs: (filter)
  809. X  If called interactively, read a filter name from the minibuffer, use
  810. Xit to read that filter's arguments and get the filter predicate.  If called 
  811. Xas a function, supply a valid filter name.  Move to and display the first
  812. Xprevious such message."
  813. X  (interactive
  814. X   (list (pcmail-read-filter-name "Show previous message in filter: ")))
  815. X  (pcmail-barf-if-empty-folder)
  816. X  (let ((i (1- pcmail-current-subset-message))
  817. X    (found)
  818. X    (pred (pcmail-get-filter filter-name))
  819. X    (pcmail-current-tested-message)) ;inherited by predicates
  820. X    (while (and (not found) (>= i 1))
  821. X      (setq pcmail-current-tested-message (pcmail-make-absolute i))
  822. X      (and (eval pred)
  823. X       (setq found i))
  824. X      (setq i (1- i)))
  825. X    (cond (found
  826. X       (pcmail-goto-message found))
  827. X      (t
  828. X       (error "No previous such messages in the current subset.")))))
  829. X
  830. X;;; movement utility routines
  831. X
  832. X(defun pcmail-display-subset-message (n)
  833. X  "Display the Nth message in the current subset.
  834. XArgs: (n)"
  835. X  (let ((msg)
  836. X    (absolute))
  837. X    (cond ((< n 1)
  838. X       (setq n (min 1 (pcmail-current-subset-length))
  839. X         msg "Beginning of folder")
  840. X       (setq pcmail-current-subset-message 1))
  841. X      ((> n (pcmail-current-subset-length))
  842. X       (setq n (pcmail-current-subset-length)
  843. X         msg "End of folder")
  844. X       (setq pcmail-current-subset-message 
  845. X         (pcmail-current-subset-length)))
  846. X      (t
  847. X        (setq pcmail-current-subset-message n)))
  848. X    (setq absolute (pcmail-make-absolute n))
  849. X    (or (pcmail-header-pruned-p absolute)
  850. X    (pcmail-prune-header absolute))
  851. X    (and (pcmail-has-attribute-p absolute "unseen")
  852. X     (pcmail-set-attribute absolute "unseen" nil))    
  853. X    (pcmail-narrow-to-message absolute)
  854. X    (pcmail-update-folder-mode-line n)
  855. X    (and msg (message msg))))
  856. X
  857. X(defun pcmail-message-char-count (n)
  858. X  "Return number of characters in message absolute-numbered N.
  859. XArgs: (n)"
  860. X  (save-excursion
  861. X    (save-restriction
  862. X      (pcmail-narrow-to-message n)
  863. X      (- (point-max) (point-min)))))
  864. X
  865. X(defun pcmail-message-line-count (n)
  866. X  "Return number of lines in message absolute-numbered N.
  867. XArgs: (n)"
  868. X  (save-excursion
  869. X    (save-restriction
  870. X      (pcmail-narrow-to-message n)
  871. X      (count-lines (point-min) (point-max)))))
  872. X
  873. X(defun pcmail-message-contents (n)
  874. X  "Return message N's contents
  875. XArgs: (n)
  876. X  Returns contents of message absolute-numbered N, including all Babyl header 
  877. Xand trailer information, as a string."
  878. X  (save-restriction
  879. X    (widen)
  880. X    (buffer-substring (pcmail-msgbeg n) (pcmail-msgend n))))
  881. X
  882. X(defun pcmail-maybe-set-message-vectors ()
  883. X  "Reset message vectors if any are NIL.
  884. XArgs: none"
  885. X  (or (and pcmail-total-messages
  886. X       pcmail-current-subset-message
  887. X       pcmail-attr-vector
  888. X       pcmail-message-vector)
  889. X      (pcmail-set-message-vectors)))
  890. X
  891. X(defun pcmail-set-message-vectors (&optional start)
  892. X  "Scan folder, setting up message information vectors.
  893. XArgs: (&optional start)
  894. X  Set up current buffer's message information vectors.  Build current
  895. Xsubset using default filter name.  Deal with expired messages.  Message
  896. Xscan begins at buffer position START, if present.  If start is not present,
  897. Xflush old message counters before scan, otherwise append new information
  898. Xto old counters.  See also pcmail-scan-babyl-messages."
  899. X  (let ((total-messages 0)
  900. X    (i 0)
  901. X    (case-fold-search)
  902. X    (timely-list)
  903. X    (messages-list)
  904. X    (filter)
  905. X    (filter-start)
  906. X    (attr-list))
  907. X    (unwind-protect
  908. X    (progn
  909. X      (cond ((null start)        ;new?
  910. X         (and (vectorp pcmail-message-vector)
  911. X              (while (< i (length pcmail-message-vector))
  912. X            (move-marker (aref pcmail-message-vector i) nil)
  913. X            (setq i (1+ i))))
  914. X         (setq pcmail-message-vector 
  915. X               (make-vector 1
  916. X                    (save-restriction
  917. X                      (widen)
  918. X                      (point-min-marker)))
  919. X               pcmail-current-subset-message 1
  920. X               pcmail-attr-vector nil
  921. X               pcmail-total-messages -1
  922. X               pcmail-date-vector (make-vector 1 nil)
  923. X               pcmail-priority-vector (make-vector 1 nil)
  924. X               pcmail-summary-vector (make-vector 1 nil)
  925. X               filter (pcmail-filter-description
  926. X                   pcmail-default-filter-name)))
  927. X        (t            ;or append?
  928. X         (setq filter-start (1+ pcmail-total-messages)
  929. X               filter pcmail-current-filter-description)))
  930. X      (pcmail-scan-babyl-messages start))
  931. X      (setq pcmail-message-vector 
  932. X        (vconcat pcmail-message-vector (apply 'vector messages-list))
  933. X        pcmail-attr-vector
  934. X        (vconcat pcmail-attr-vector (apply 'vector attr-list))
  935. X        pcmail-date-vector
  936. X        (vconcat pcmail-date-vector (make-vector total-messages nil))
  937. X        pcmail-priority-vector
  938. X        (vconcat pcmail-priority-vector (make-vector total-messages nil))
  939. X        pcmail-summary-vector
  940. X        (vconcat pcmail-summary-vector (make-vector total-messages nil))
  941. X        pcmail-total-messages (+ pcmail-total-messages total-messages))
  942. X      (pcmail-build-subset-membership filter filter-start)
  943. X      (pcmail-hack-timely-messages timely-list)
  944. X      (and (>= total-messages pcmail-progress-interval)
  945. X       (message "Counting messages in %s...done (%d message%s)" 
  946. X            pcmail-folder-name total-messages 
  947. X            (pcmail-s-ending total-messages))))))
  948. X    
  949. X(defun pcmail-msgbeg (n)
  950. X  "Return marker position of beginning of message absolute-numbered N.
  951. XArgs: none"
  952. X  (aref pcmail-message-vector n))
  953. X
  954. X(defun pcmail-msgend (n)
  955. X  "Return marker position of end of message absolute-numbered N.
  956. XArgs: none"
  957. X  (aref pcmail-message-vector (1+ n)))
  958. X
  959. X(provide 'pcmailmove)
  960. ________This_Is_The_END________
  961. if test `wc -c < pcmailmove.el` -ne 10900; then
  962.     echo 'shar: pcmailmove.el was damaged during transit (should have been 10900 bytes)'
  963. fi
  964. fi        ; : end of overwriting check
  965. exit 0
  966.  
  967.