home *** CD-ROM | disk | FTP | other *** search
/ NetNews Usenet Archive 1992 #31 / NN_1992_31.iso / spool / comp / mail / mime / 50 < prev    next >
Encoding:
Text File  |  1992-12-23  |  11.0 KB  |  326 lines
  1. Xref: sparky comp.mail.mime:50 gnu.emacs.gnus:1427
  2. Newsgroups: comp.mail.mime,gnu.emacs.gnus
  3. Path: sparky!uunet!world!spike
  4. From: spike@world.std.com (Joe Ilacqua)
  5. Subject: MIME support for GNUS.
  6. Message-ID: <BzqJv8.5z9@world.std.com>
  7. Organization: Software Tool & Die
  8. Date: Wed, 23 Dec 1992 23:28:19 GMT
  9. Lines: 315
  10.  
  11.  
  12.     This is more of a proof of concept than a finished product,
  13. but it seems to work.  This package allows you to read MIME format
  14. news articles, use richtext in you postings, and insert (presumably
  15. binary) files into you messages.
  16.  
  17.     You need to have "Metamail" installed and have
  18. "transparent.el" in your load path.
  19. Have fun.
  20.  
  21. ->Spike
  22.  
  23. #!/bin/sh
  24. # This is a shell archive (produced by shar 3.50)
  25. # To extract the files from this archive, save it to a file, remove
  26. # everything above the "!/bin/sh" line above, and type "sh file_name".
  27. #
  28. # made 12/23/1992 23:24 UTC by spike@world
  29. # Source directory /staff/spike
  30. #
  31. # existing files will NOT be overwritten unless -c is specified
  32. #
  33. # This shar contains:
  34. # length  mode       name
  35. # ------ ---------- ------------------------------------------
  36. #   9416 -rw-rw-r-- gnus-mime.el
  37. #
  38. # ============= gnus-mime.el ==============
  39. if test -f 'gnus-mime.el' -a X"$1" != X"-c"; then
  40.     echo 'x - skipping gnus-mime.el (File already exists)'
  41. else
  42. echo 'x - extracting gnus-mime.el (Text)'
  43. sed 's/^X//' << 'SHAR_EOF' > 'gnus-mime.el' &&
  44. ;;;  Support to read/post MIME format USENET articles in GNUS.
  45. X
  46. ;;  Author Spike <Spike@world.std.com>
  47. ;;  with code from Michael Littman's <mlittman@breeze.bellcore.com>
  48. ;;  richtext.el and metamail's MH-E patches.
  49. X
  50. X
  51. ;;  This requires that you have the metamail package installed
  52. ;;  (thumper.bellcore.com:/pub/nsb/mm.tar.Z) and transparent.el
  53. ;;  
  54. ;;  This package provides four basic functions
  55. ;;
  56. ;;  gnus-Subject-run-metamail - invokes metamail on the selected news article.
  57. ;;  gnus-inews-article - replaces the standard gnus-inews-article with one
  58. ;;                       which inserts MIME headers and does Richtext style
  59. ;;                       signatures.
  60. ;;  gnus-richtext-posting - converts the posting buffer to Richtext format,
  61. ;;                          knows how to make text bold, italics, and
  62. ;;                          underlined.
  63. ;;  gnus-insert-file-as-mime - Allows you to insert arbitrary data into
  64. ;;                             a posting in MIME format.  Automatically
  65. ;;                             recognizes some formats (GIF, JPEG, PS),
  66. ;;                             more can be add through "auto-mime-id-list".
  67. X
  68. ;;  As ships this binds gnus-Subject-run-metamail to "@" in the "*Subject*"
  69. ;;  buffer.  gnus-richtext-posting to "C-c r" and "gnus-insert-file-as-mime" to
  70. ;;  "C-c i" in the posting buffer.
  71. ;;
  72. X
  73. ;;  To use put "(load-library "gnus-mime.el")" in your ".emacs" or "default.el"
  74. X
  75. ;;  If you want GNUS to announce MIME postings but something like:
  76. ;;  (setq gnus-Article-prepare-hook
  77. ;;       '(lambda ()
  78. ;;      (gnus-Subject-check-content-type)))
  79. ;;  in your ".emacs" file.
  80. X
  81. ;; CAVEATS: You can only insert one file per posting.  You can not call
  82. ;;          gnus-richtext-posting after calling gnus-insert-file-as-mime.
  83. X
  84. (require 'transparent)
  85. (load-library "rnewspost") ;; sigh...  This could be better.
  86. (require 'gnuspost)
  87. (provide 'gnus-mime)
  88. X
  89. (defvar gnus-invoke-mime-key "@" 
  90. X  "The key that calls gnus-Subject-run-metamail")
  91. X
  92. (define-key gnus-Subject-mode-map gnus-invoke-mime-key
  93. X  'gnus-Subject-run-metamail)
  94. X
  95. (define-key news-reply-mode-map "\C-cr" 'gnus-richtext-posting)
  96. (define-key news-reply-mode-map "\C-ci" 'gnus-insert-file-as-mime)
  97. X
  98. (defvar auto-mime-id-list nil "\
  99. A list of filename patterns vs corresponding MIME type strings
  100. Each element looks like (REGEXP . TYPE).")
  101. (setq auto-mime-id-list (mapcar 'purecopy
  102. X                              '(("\\.gif$" . "image/gif")
  103. X                ("\\.jpg$" . "image/jpeg")
  104. X                ("\\.xwd$" . "image/x-xwd")
  105. X                ("\\.ps$"  . "application/PostScript"))))
  106. X
  107. ;;;;;;
  108. X
  109. (defun gnus-Subject-check-content-type ()
  110. X  (if (gnus-fetch-field "Mime-Version")
  111. X      (let ((content-type (gnus-fetch-field "Content-Type")))
  112. X       (message (concat "You can use '" gnus-invoke-mime-key 
  113. X                "' to view this '" content-type 
  114. X                "' MIME format article.")))))
  115. X
  116. (defun gnus-Subject-run-metamail ()
  117. X  (interactive)
  118. X  "Process Selected Article Through \"metamail\"."
  119. X  (gnus-Subject-select-article)
  120. X  (gnus-eval-in-buffer-window gnus-Article-buffer
  121. X  (let ((metamail-tmpfile (make-temp-name "/tmp/rmailct")))
  122. X    (save-restriction
  123. X      (widen)
  124. X      (write-region (point-min) (point-max) metamail-tmpfile))
  125. X    (if 
  126. X    (and window-system (getenv "DISPLAY"))
  127. X    (let ((buffer-read-only nil))
  128. X      (push-mark (point) t)
  129. X      (erase-buffer)
  130. X      (call-process "metamail" nil t t
  131. X         "-m" "mh-e" "-x" "-d" "-q" "-z" metamail-tmpfile)
  132. X      (exchange-point-and-mark)
  133. X      (set-buffer-modified-p nil)
  134. X      (other-window -1))
  135. X      (progn
  136. X    (other-window -1)
  137. X    (switch-to-buffer "METAMAIL")
  138. X    (erase-buffer)
  139. X    (sit-for 0)
  140. X    (transparent-window
  141. X     "METAMAIL"
  142. X     "metamail"
  143. X     (list "-p" "-d" "-q" metamail-tmpfile)
  144. X     nil
  145. X     (concat
  146. X      "\n\r\n\r*****************************************"
  147. X      "*******************************\n\rPress any key "
  148. X      "to go back to EMACS\n\r\n\r***********************" 
  149. X      "*************************************************\n\r")))
  150. X      )
  151. X    )
  152. X  )
  153. X )
  154. X
  155. X
  156. (defvar rich-substitutions
  157. X      '(
  158. X        ("<"        "<lt>") ; in case some one sends less-thans.
  159. X        ("\\B%\\b" "</italic>") ; needs to be first to not get closing tags.
  160. X        ("\\b%\\B" "<italic>")
  161. X        ("\\B\\*\\b" "<bold>")
  162. X        ("\\b\\*\\B" "</bold>")
  163. X        ("
  164. " "
  165. <nl>")
  166. X        ("\\B_\\b" "<underline>")
  167. X        ("\\b_\\B" "</underline>")
  168. X        )
  169. X      "A table of REGEXP to translate text to MIME's text/richtext format.")
  170. X
  171. (defun gnus-richtext-posting ()
  172. X  "Convert the current buffer to MIME's \"text/richtext\" format.
  173. \"*foo*\" is converted to bold, \"%foo%\" to italics, and \"_foo_\" to
  174. underlined. Note: this does not recognize font markers *after*
  175. punctuation, thus \"*foo!*\" will not work."
  176. X  (interactive)
  177. X  (mail-position-on-field "Subject")
  178. X  (or (gnus-fetch-field "Mime-Version")
  179. X      (insert "\nMime-Version: 1.0"))
  180. X  (or (gnus-fetch-field "Content-Type")
  181. X      (insert "\nContent-Type: text/richtext"))
  182. X  (goto-char (point-min))
  183. X  (search-forward (concat "\n" mail-header-separator "\n") nil t)
  184. X  (perform-rich-sub)
  185. X  )
  186. X
  187. (defun perform-rich-sub ()
  188. X  "Perform the rich substiution."
  189. X  (let ((subs rich-substitutions)
  190. X        pat rep
  191. X        (top (point)))
  192. X    (save-excursion
  193. X      (while subs
  194. X        (setq pat (car (car subs)))
  195. X        (setq rep (car (cdr (car subs))))
  196. X        (setq subs (cdr subs))
  197. X        (goto-char top)
  198. X        (while (re-search-forward pat (point-max) t)
  199. X          (replace-match rep))
  200. X        ))))
  201. X
  202. (defun gnus-insert-file-as-mime (filename)
  203. X  "Encode and insert a file into the posting buffer and setup the correct
  204. MIME headers for that file type."
  205. X  (interactive "FFind file: ")
  206. X  (let ((ctype nil)
  207. X    (boundary
  208. X     (concat "GNUS.BOUNDARY." (system-name) "." (current-time-string))))
  209. X    (let ((mlist auto-mime-id-list)
  210. X      (name filename))
  211. X      (while (and (not ctype) mlist)
  212. X    (if (string-match (car (car mlist)) name)
  213. X        (setq ctype (cdr (car mlist))))
  214. X              (setq mlist (cdr mlist))))
  215. X    (if (not ctype)
  216. X    (setq ctype 
  217. X          (read-string "MIME content type: " "application/octet-stream")))
  218. X    (goto-char (point-min))
  219. X    (re-search-forward
  220. X     (concat "^" (regexp-quote mail-header-separator) "\n"))
  221. X    (insert (concat "--" boundary "\n"))
  222. X    (insert "Content-type: text/richtext\n")
  223. X    (insert "Content-Transfer-Encoding: quoted-printable\n\n")
  224. X    (goto-char (point-max))
  225. X    (insert (concat "\n--" boundary "\n"))
  226. X    (insert (concat "Content-type: " ctype "\n"))
  227. X    (insert "Content-Transfer-Encoding: base64\n\n")
  228. X    (shell-command (concat "mmencode " filename) t)
  229. X    (goto-char (point-max))
  230. X    (insert (concat "\n--" boundary "\n"))
  231. X    (mail-position-on-field "Subject")
  232. X    (or (gnus-fetch-field "Mime-Version")
  233. X    (insert "\nMime-Version: 1.0"))
  234. X    (if (gnus-fetch-field "Content-Type")
  235. X    (progn
  236. X      (mail-position-on-field "Content-Type")
  237. X      (beginning-of-line)
  238. X      (delete-region (point) (progn (forward-line 1) (point)))))
  239. X      (insert (concat "Content-Type: multipart/mixed;\n"
  240. X              "\tboundary=\"" boundary "\"\n"))
  241. X    ))
  242. X
  243. (defun gnus-inews-article ()
  244. X  "NNTP inews interface."
  245. X  (let ((signature
  246. X     (if gnus-signature-file
  247. X         (expand-file-name gnus-signature-file nil)))
  248. X    (distribution nil)
  249. X    (artbuf (current-buffer))
  250. X    (tmpbuf (get-buffer-create " *GNUS-posting*"))
  251. X    (ctype nil))
  252. X    (save-excursion
  253. X      (set-buffer tmpbuf)
  254. X      (buffer-flush-undo (current-buffer))
  255. X      (erase-buffer)
  256. X      (insert-buffer-substring artbuf)
  257. X      ;; Get distribution.
  258. X      (setq distribution (gnus-fetch-field "Distribution"))
  259. X      (if signature
  260. X      (progn
  261. X        ;; Change signature file by distribution.
  262. X        ;; Suggested by hyoko@flab.fujitsu.junet.
  263. X        (if (file-exists-p (concat signature "-" distribution))
  264. X        (setq signature (concat signature "-" distribution)))
  265. X        ;; Insert signature.
  266. X        (if (file-exists-p signature)
  267. X        (progn
  268. X          ;; Mime signature format
  269. X          (setq ctype (gnus-fetch-field "Content-Type"))
  270. X          (if (and ctype (string-match "multipart/mixed" ctype))
  271. X              (progn
  272. X            (string-match "boundary=\"" ctype)
  273. X            (setq boundary (substring ctype  (- (match-end 0) 1)))
  274. X            (string-match "\"" boundary)
  275. X            (setq boundary 
  276. X                  (substring boundary 0 (- (match-end 0) 1)))
  277. X            (goto-char (point-max))
  278. X            (insert (concat "--" boundary "\n"))
  279. X            (insert "Content-type: text/richtext\n")
  280. X            (insert "Content-Transfer-Encoding: quoted-printable\n\n")
  281. X            ))
  282. X          (goto-char (point-max))
  283. X          (insert "<signature>")
  284. X          (insert-file-contents signature)
  285. X          (goto-char (point-max))
  286. X          (insert "</signature>\n")))
  287. X        ))
  288. X      ;; Prepare article headers.
  289. X      (save-restriction
  290. X    (goto-char (point-min))
  291. X    (search-forward "\n\n")
  292. X    (narrow-to-region (point-min) (point))
  293. X    (gnus-inews-insert-headers)
  294. X    ;; insert mime headers if needed.
  295. X    (goto-char (point-max))
  296. X    (forward-line -2)
  297. X    (or (gnus-fetch-field "Mime-Version")
  298. X        (insert "Mime-Version: 1.0"\n))
  299. X    (or (gnus-fetch-field "Content-Type")
  300. X        (insert "Content-Type: text/richtext\n"))
  301. X    ;; Save author copy of posted article. The article must be
  302. X    ;;  copied before being posted because `gnus-request-post'
  303. X    ;;  modifies the buffer.
  304. X    (let ((case-fold-search t))
  305. X      ;; Find and handle any FCC fields.
  306. X      (goto-char (point-min))
  307. X      (if (re-search-forward "^FCC:" nil t)
  308. X          (gnus-inews-do-fcc))))
  309. X      (widen)
  310. X      ;; Run final inews hooks.
  311. X      (run-hooks 'gnus-Inews-article-hook)
  312. X      ;; Post an article to NNTP server.
  313. X      ;; Return NIL if post failed.
  314. X      (prog1
  315. X      (gnus-request-post)
  316. X    (kill-buffer (current-buffer)))
  317. X      )))
  318. SHAR_EOF
  319. chmod 0664 gnus-mime.el ||
  320. echo 'restore of gnus-mime.el failed'
  321. Wc_c="`wc -c < 'gnus-mime.el'`"
  322. test 9416 -eq "$Wc_c" ||
  323.     echo 'gnus-mime.el: original size 9416, current size' "$Wc_c"
  324. fi
  325. exit 0
  326.