nnspool.el 16 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477
  1. ;;; nnspool.el --- spool access for GNU Emacs
  2. ;; Copyright (C) 1988-1990, 1993-1998, 2000-2012
  3. ;; Free Software Foundation, Inc.
  4. ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
  5. ;; Lars Magne Ingebrigtsen <larsi@gnus.org>
  6. ;; Keywords: news
  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. ;;; Code:
  20. (require 'nnheader)
  21. (require 'nntp)
  22. (require 'nnoo)
  23. (eval-when-compile (require 'cl))
  24. ;; Probably this entire thing should be obsolete.
  25. ;; It's only used to init nnspool-spool-directory, so why not just
  26. ;; set that variable's default directly?
  27. (eval-and-compile
  28. (defvar news-directory (if (file-exists-p "/usr/spool/news/")
  29. "/usr/spool/news/"
  30. "/var/spool/news/")
  31. "The root directory below which all news files are stored.")
  32. (defvaralias 'news-path 'news-directory))
  33. ;; Ditto re obsolescence.
  34. (defvar news-inews-program
  35. (cond ((file-exists-p "/usr/bin/inews") "/usr/bin/inews")
  36. ((file-exists-p "/usr/local/inews") "/usr/local/inews")
  37. ((file-exists-p "/usr/local/bin/inews") "/usr/local/bin/inews")
  38. ((file-exists-p "/usr/contrib/lib/news/inews") "/usr/contrib/lib/news/inews")
  39. ((file-exists-p "/usr/lib/news/inews") "/usr/lib/news/inews")
  40. (t "inews"))
  41. "Program to post news.")
  42. (nnoo-declare nnspool)
  43. (defvoo nnspool-inews-program news-inews-program
  44. "Program to post news.
  45. This is most commonly `inews' or `injnews'.")
  46. (defvoo nnspool-inews-switches '("-h" "-S")
  47. "Switches for nnspool-request-post to pass to `inews' for posting news.
  48. If you are using Cnews, you probably should set this variable to nil.")
  49. (defvoo nnspool-spool-directory
  50. (file-name-as-directory (if (boundp 'news-directory)
  51. (symbol-value 'news-directory)
  52. news-path))
  53. "Local news spool directory.")
  54. (defvoo nnspool-nov-directory (concat nnspool-spool-directory "over.view/")
  55. "Local news nov directory.")
  56. (defvoo nnspool-lib-dir
  57. (if (file-exists-p "/usr/lib/news/active")
  58. "/usr/lib/news/"
  59. "/var/lib/news/")
  60. "Where the local news library files are stored.")
  61. (defvoo nnspool-active-file (concat nnspool-lib-dir "active")
  62. "Local news active file.")
  63. (defvoo nnspool-newsgroups-file (concat nnspool-lib-dir "newsgroups")
  64. "Local news newsgroups file.")
  65. (defvoo nnspool-distributions-file (concat nnspool-lib-dir "distribs.pat")
  66. "Local news distributions file.")
  67. (defvoo nnspool-history-file (concat nnspool-lib-dir "history")
  68. "Local news history file.")
  69. (defvoo nnspool-active-times-file (concat nnspool-lib-dir "active.times")
  70. "Local news active date file.")
  71. (defvoo nnspool-large-newsgroup 50
  72. "The number of articles which indicates a large newsgroup.
  73. If the number of articles is greater than the value, verbose
  74. messages will be shown to indicate the current status.")
  75. (defvoo nnspool-nov-is-evil nil
  76. "Non-nil means that nnspool will never return NOV lines instead of headers.")
  77. (defconst nnspool-sift-nov-with-sed nil
  78. "If non-nil, use sed to get the relevant portion from the overview file.
  79. If nil, nnspool will load the entire file into a buffer and process it
  80. there.")
  81. (defvoo nnspool-rejected-article-hook nil
  82. "*A hook that will be run when an article has been rejected by the server.")
  83. (defvoo nnspool-file-coding-system nnheader-file-coding-system
  84. "Coding system for nnspool.")
  85. (defconst nnspool-version "nnspool 2.0"
  86. "Version numbers of this version of NNSPOOL.")
  87. (defvoo nnspool-current-directory nil
  88. "Current news group directory.")
  89. (defvoo nnspool-current-group nil)
  90. (defvoo nnspool-status-string "")
  91. ;;; Interface functions.
  92. (nnoo-define-basics nnspool)
  93. (deffoo nnspool-retrieve-headers (articles &optional group server fetch-old)
  94. "Retrieve the headers of ARTICLES."
  95. (with-current-buffer nntp-server-buffer
  96. (erase-buffer)
  97. (when (nnspool-possibly-change-directory group)
  98. (let* ((number (length articles))
  99. (count 0)
  100. (default-directory nnspool-current-directory)
  101. (do-message (and (numberp nnspool-large-newsgroup)
  102. (> number nnspool-large-newsgroup)))
  103. (nnheader-file-coding-system nnspool-file-coding-system)
  104. file beg article ag)
  105. (if (and (numberp (car articles))
  106. (nnspool-retrieve-headers-with-nov articles fetch-old))
  107. ;; We successfully retrieved the NOV headers.
  108. 'nov
  109. ;; No NOV headers here, so we do it the hard way.
  110. (while (setq article (pop articles))
  111. (if (stringp article)
  112. ;; This is a Message-ID.
  113. (setq ag (nnspool-find-id article)
  114. file (and ag (nnspool-article-pathname
  115. (car ag) (cdr ag)))
  116. article (cdr ag))
  117. ;; This is an article in the current group.
  118. (setq file (int-to-string article)))
  119. ;; Insert the head of the article.
  120. (when (and file
  121. (file-exists-p file))
  122. (insert "221 ")
  123. (princ article (current-buffer))
  124. (insert " Article retrieved.\n")
  125. (setq beg (point))
  126. (inline (nnheader-insert-head file))
  127. (goto-char beg)
  128. (if (search-forward "\n\n" nil t)
  129. (progn
  130. (forward-char -1)
  131. (insert ".\n"))
  132. (goto-char (point-max))
  133. (if (bolp)
  134. (insert ".\n")
  135. (insert "\n.\n")))
  136. (delete-region (point) (point-max)))
  137. (and do-message
  138. (zerop (% (incf count) 20))
  139. (nnheader-message 5 "nnspool: Receiving headers... %d%%"
  140. (/ (* count 100) number))))
  141. (when do-message
  142. (nnheader-message 5 "nnspool: Receiving headers...done"))
  143. ;; Fold continuation lines.
  144. (nnheader-fold-continuation-lines)
  145. 'headers)))))
  146. (deffoo nnspool-open-server (server &optional defs)
  147. (nnoo-change-server 'nnspool server defs)
  148. (cond
  149. ((not (file-exists-p nnspool-spool-directory))
  150. (nnspool-close-server)
  151. (nnheader-report 'nnspool "Spool directory doesn't exist: %s"
  152. nnspool-spool-directory))
  153. ((not (file-directory-p
  154. (directory-file-name
  155. (file-truename nnspool-spool-directory))))
  156. (nnspool-close-server)
  157. (nnheader-report 'nnspool "Not a directory: %s" nnspool-spool-directory))
  158. ((not (file-exists-p nnspool-active-file))
  159. (nnheader-report 'nnspool "The active file doesn't exist: %s"
  160. nnspool-active-file))
  161. (t
  162. (nnheader-report 'nnspool "Opened server %s using directory %s"
  163. server nnspool-spool-directory)
  164. t)))
  165. (deffoo nnspool-request-article (id &optional group server buffer)
  166. "Select article by message ID (or number)."
  167. (nnspool-possibly-change-directory group)
  168. (let ((nntp-server-buffer (or buffer nntp-server-buffer))
  169. file ag)
  170. (if (stringp id)
  171. ;; This is a Message-ID.
  172. (when (setq ag (nnspool-find-id id))
  173. (setq file (nnspool-article-pathname (car ag) (cdr ag))))
  174. (setq file (nnspool-article-pathname nnspool-current-group id)))
  175. (and file
  176. (file-exists-p file)
  177. (not (file-directory-p file))
  178. (save-excursion (nnspool-find-file file))
  179. ;; We return the article number and group name.
  180. (if (numberp id)
  181. (cons nnspool-current-group id)
  182. ag))))
  183. (deffoo nnspool-request-body (id &optional group server)
  184. "Select article body by message ID (or number)."
  185. (nnspool-possibly-change-directory group)
  186. (let ((res (nnspool-request-article id)))
  187. (when res
  188. (with-current-buffer nntp-server-buffer
  189. (goto-char (point-min))
  190. (when (search-forward "\n\n" nil t)
  191. (delete-region (point-min) (point)))
  192. res))))
  193. (deffoo nnspool-request-head (id &optional group server)
  194. "Select article head by message ID (or number)."
  195. (nnspool-possibly-change-directory group)
  196. (let ((res (nnspool-request-article id)))
  197. (when res
  198. (with-current-buffer nntp-server-buffer
  199. (goto-char (point-min))
  200. (when (search-forward "\n\n" nil t)
  201. (delete-region (1- (point)) (point-max)))
  202. (nnheader-fold-continuation-lines)))
  203. res))
  204. (deffoo nnspool-request-group (group &optional server dont-check info)
  205. "Select news GROUP."
  206. (let ((pathname (nnspool-article-pathname group))
  207. dir)
  208. (if (not (file-directory-p pathname))
  209. (nnheader-report
  210. 'nnspool "Invalid group name (no such directory): %s" group)
  211. (setq nnspool-current-directory pathname)
  212. (nnheader-report 'nnspool "Selected group %s" group)
  213. (if dont-check
  214. (progn
  215. (nnheader-report 'nnspool "Selected group %s" group)
  216. t)
  217. ;; Yes, completely empty spool directories *are* possible.
  218. ;; Fix by Sudish Joseph <joseph@cis.ohio-state.edu>
  219. (when (setq dir (directory-files pathname nil "^[0-9]+$" t))
  220. (setq dir (sort (mapcar 'string-to-number dir) '<)))
  221. (if dir
  222. (nnheader-insert
  223. "211 %d %d %d %s\n" (length dir) (car dir)
  224. (car (last dir)) group)
  225. (nnheader-report 'nnspool "Empty group %s" group)
  226. (nnheader-insert "211 0 0 0 %s\n" group))))))
  227. (deffoo nnspool-request-type (group &optional article)
  228. 'news)
  229. (deffoo nnspool-close-group (group &optional server)
  230. t)
  231. (deffoo nnspool-request-list (&optional server)
  232. "List active newsgroups."
  233. (save-excursion
  234. (or (nnspool-find-file nnspool-active-file)
  235. (nnheader-report 'nnspool (nnheader-file-error nnspool-active-file)))))
  236. (deffoo nnspool-request-list-newsgroups (&optional server)
  237. "List newsgroups (defined in NNTP2)."
  238. (save-excursion
  239. (or (nnspool-find-file nnspool-newsgroups-file)
  240. (nnheader-report 'nnspool (nnheader-file-error
  241. nnspool-newsgroups-file)))))
  242. (deffoo nnspool-request-list-distributions (&optional server)
  243. "List distributions (defined in NNTP2)."
  244. (save-excursion
  245. (or (nnspool-find-file nnspool-distributions-file)
  246. (nnheader-report 'nnspool (nnheader-file-error
  247. nnspool-distributions-file)))))
  248. ;; Suggested by Hallvard B Furuseth <h.b.furuseth@usit.uio.no>.
  249. (deffoo nnspool-request-newgroups (date &optional server)
  250. "List groups created after DATE."
  251. (if (nnspool-find-file nnspool-active-times-file)
  252. (save-excursion
  253. ;; Find the last valid line.
  254. (goto-char (point-max))
  255. (while (and (not (looking-at
  256. "\\([^ ]+\\) +\\([0-9]+\\)[0-9][0-9][0-9] "))
  257. (zerop (forward-line -1))))
  258. ;; We require nnheader which requires gnus-util.
  259. (let ((seconds (gnus-float-time (date-to-time date)))
  260. groups)
  261. ;; Go through lines and add the latest groups to a list.
  262. (while (and (looking-at "\\([^ ]+\\) +[0-9]+ ")
  263. (progn
  264. ;; We insert a .0 to make the list reader
  265. ;; interpret the number as a float. It is far
  266. ;; too big to be stored in a lisp integer.
  267. (goto-char (1- (match-end 0)))
  268. (insert ".0")
  269. (> (progn
  270. (goto-char (match-end 1))
  271. (read (current-buffer)))
  272. seconds))
  273. (push (buffer-substring
  274. (match-beginning 1) (match-end 1))
  275. groups)
  276. (zerop (forward-line -1))))
  277. (erase-buffer)
  278. (dolist (group groups)
  279. (insert group " 0 0 y\n")))
  280. t)
  281. nil))
  282. (deffoo nnspool-request-post (&optional server)
  283. "Post a new news in current buffer."
  284. (save-excursion
  285. (let* ((process-connection-type nil) ; t bugs out on Solaris
  286. (inews-buffer (generate-new-buffer " *nnspool post*"))
  287. (proc
  288. (condition-case err
  289. (apply 'start-process "*nnspool inews*" inews-buffer
  290. nnspool-inews-program nnspool-inews-switches)
  291. (error
  292. (nnheader-report 'nnspool "inews error: %S" err)))))
  293. (if (not proc)
  294. ;; The inews program failed.
  295. ()
  296. (nnheader-report 'nnspool "")
  297. (set-process-sentinel proc 'nnspool-inews-sentinel)
  298. (mm-with-unibyte-current-buffer
  299. (process-send-region proc (point-min) (point-max)))
  300. ;; We slap a condition-case around this, because the process may
  301. ;; have exited already...
  302. (ignore-errors
  303. (process-send-eof proc))
  304. t))))
  305. ;;; Internal functions.
  306. (defun nnspool-inews-sentinel (proc status)
  307. (with-current-buffer (process-buffer proc)
  308. (goto-char (point-min))
  309. (if (or (zerop (buffer-size))
  310. (search-forward "spooled" nil t))
  311. (kill-buffer (current-buffer))
  312. ;; Make status message by folding lines.
  313. (while (re-search-forward "[ \t\n]+" nil t)
  314. (replace-match " " t t))
  315. (nnheader-report 'nnspool "%s" (buffer-string))
  316. (nnheader-message 5 "nnspool: %s" nnspool-status-string)
  317. (ding)
  318. (run-hooks 'nnspool-rejected-article-hook))))
  319. (defun nnspool-retrieve-headers-with-nov (articles &optional fetch-old)
  320. (if (or gnus-nov-is-evil nnspool-nov-is-evil)
  321. nil
  322. (let ((nov (nnheader-group-pathname
  323. nnspool-current-group nnspool-nov-directory ".overview"))
  324. (arts articles)
  325. (nnheader-file-coding-system nnspool-file-coding-system)
  326. last)
  327. (if (not (file-exists-p nov))
  328. ()
  329. (with-current-buffer nntp-server-buffer
  330. (erase-buffer)
  331. (if nnspool-sift-nov-with-sed
  332. (nnspool-sift-nov-with-sed articles nov)
  333. (nnheader-insert-file-contents nov)
  334. (if (and fetch-old
  335. (not (numberp fetch-old)))
  336. t ; We want all the headers.
  337. (ignore-errors
  338. ;; Delete unwanted NOV lines.
  339. (nnheader-nov-delete-outside-range
  340. (if fetch-old (max 1 (- (car articles) fetch-old))
  341. (car articles))
  342. (car (last articles)))
  343. ;; If the buffer is empty, this wasn't very successful.
  344. (unless (zerop (buffer-size))
  345. ;; We check what the last article number was.
  346. ;; The NOV file may be out of sync with the articles
  347. ;; in the group.
  348. (forward-line -1)
  349. (setq last (read (current-buffer)))
  350. (if (= last (car articles))
  351. ;; Yup, it's all there.
  352. t
  353. ;; Perhaps not. We try to find the missing articles.
  354. (while (and arts
  355. (<= last (car arts)))
  356. (pop arts))
  357. ;; The articles in `arts' are missing from the buffer.
  358. (mapc 'nnspool-insert-nov-head arts)
  359. t))))))))))
  360. (defun nnspool-insert-nov-head (article)
  361. "Read the head of ARTICLE, convert to NOV headers, and insert."
  362. (save-excursion
  363. (let ((cur (current-buffer))
  364. buf)
  365. (setq buf (nnheader-set-temp-buffer " *nnspool head*"))
  366. (when (nnheader-insert-head
  367. (nnspool-article-pathname nnspool-current-group article))
  368. (nnheader-insert-article-line article)
  369. (goto-char (point-min))
  370. (let ((headers (nnheader-parse-head)))
  371. (set-buffer cur)
  372. (goto-char (point-max))
  373. (nnheader-insert-nov headers)))
  374. (kill-buffer buf))))
  375. (defun nnspool-sift-nov-with-sed (articles file)
  376. (let ((first (car articles))
  377. (last (car (last articles))))
  378. (call-process "awk" nil t nil
  379. (format "BEGIN {firstmsg=%d; lastmsg=%d;}\n $1 >= firstmsg && $1 <= lastmsg {print;}"
  380. (1- first) (1+ last))
  381. file)))
  382. ;; Fixed by fdc@cliwe.ping.de (Frank D. Cringle).
  383. ;; Find out what group an article identified by a Message-ID is in.
  384. (defun nnspool-find-id (id)
  385. (with-temp-buffer
  386. (ignore-errors
  387. (call-process "grep" nil t nil (regexp-quote id) nnspool-history-file))
  388. (goto-char (point-min))
  389. (when (looking-at "<[^>]+>[ \t]+[-0-9~]+[ \t]+\\([^ /\t\n]+\\)/\\([0-9]+\\)[ \t\n]")
  390. (cons (match-string 1) (string-to-number (match-string 2))))))
  391. (defun nnspool-find-file (file)
  392. "Insert FILE in server buffer safely."
  393. (set-buffer nntp-server-buffer)
  394. (erase-buffer)
  395. (condition-case ()
  396. (let ((coding-system-for-read nnspool-file-coding-system))
  397. (mm-insert-file-contents file)
  398. t)
  399. (file-error nil)))
  400. (defun nnspool-possibly-change-directory (group)
  401. (if (not group)
  402. t
  403. (let ((pathname (nnspool-article-pathname group)))
  404. (if (file-directory-p pathname)
  405. (setq nnspool-current-directory pathname
  406. nnspool-current-group group)
  407. (nnheader-report 'nnspool "No such newsgroup: %s" group)))))
  408. (defun nnspool-article-pathname (group &optional article)
  409. "Find the file name for GROUP."
  410. (nnheader-group-pathname group nnspool-spool-directory article))
  411. (provide 'nnspool)
  412. ;;; nnspool.el ends here