home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / misc / gnus-mark.el < prev    next >
Encoding:
Text File  |  1991-08-01  |  16.3 KB  |  447 lines
  1. ;;; -*- Mode:Emacs-Lisp -*-
  2.  
  3. ;;; gnus-mark.el
  4. ;;;
  5. ;;; LCD Archive Entry:
  6. ;;; gnus-mark|Jamie Zawinski|jwz@lucid.com
  7. ;;; |Operate on more than one news article at a time
  8. ;;; |91-06-28||~/misc/gnus-mark.el.Z|
  9. ;;;
  10. ;;; Operating on more than one news article at a time.
  11. ;;; Created: 28-Jun-91 by Jamie Zawinski <jwz@lucid.com>
  12. ;;; Modified: 28-Jun-91 by Sebastian Kremer <sk@thp.Uni-Koeln.DE>
  13. ;;;
  14. ;;; typing `@' in the subject buffer will mark the current article with
  15. ;;; an `@'.  After marking more than one article this way, you can use one
  16. ;;; of the commands in this file on all of them at once.
  17. ;;;
  18. ;;; `M-@' will prompt you for a regular expression, and will mark all f
  19. ;;; articles which match.
  20. ;;;
  21. ;;; `^U@' will prompt you for a mark-character to use other than `@'.
  22. ;;;
  23. ;;; To unmark an article, use `u', `d', or `^U M-@ SPC RET'.
  24. ;;;
  25. ;;; `C-f' (gnus-forward-marked-articles) will put you in a send-mail buffer 
  26. ;;; along with the contents of all of the marked articles in RFC-944 digest
  27. ;;; format, suitable for later explosion with any reasonable mail reader.
  28. ;;; (changed by PM (was F))
  29. ;;;
  30. ;;; `M-x gnus-uudecode-marked-messages' (M-x gnus-uu RET works) will strip the
  31. ;;; junk from the beginning and end of the marked articles, concatenate them
  32. ;;; together, and pipe the result through uudecode.  If the resultant file is
  33. ;;; a tar file and/or is compressed, this command offers to unpack/uncompress
  34. ;;; as well.  See also the variables gnus-uudecode-file-mode, 
  35. ;;; gnus-uudecode-auto-chmod, and gnus-uudecode-auto-touch.  If the first
  36. ;;; marked message is not the first part of the uuencoded file, or if the last
  37. ;;; marked message is not the last part of the uuencoded file, it complains.
  38. ;;; However, it's not possible to tell if the middle parts are out of order,
  39. ;;; so make sure you use ^C^S^S to get the articles in the right order first.
  40. ;;; It also complains about obviously-corrupted files.
  41. ;;;
  42. ;;; `M-x gnus-unshar-marked-articles' (M-x gnus-un RET works) will strip the 
  43. ;;; junk from the beginning and end of the marked articles, and run each of
  44. ;;; them through sh in turn.  This doesn't work on shar files that don't 
  45. ;;; begin with "#!".
  46. ;;;
  47. ;;; Both of the above commands prompt you for a directory in which to do the
  48. ;;; dirty work.  If the directory you specify doesn't exist, you have the
  49. ;;; option of creating it.
  50.  
  51. (require 'gnus)
  52.  
  53. (define-key gnus-Subject-mode-map "@" 'gnus-Subject-mark-article)
  54. (define-key gnus-Subject-mode-map "\C-f" 'gnus-forward-marked-articles)
  55. (define-key gnus-Subject-mode-map "\M-@" 'gnus-Subject-mark-regexp)
  56. ;;; See also gnus-uudecode-marked-messages and gnus-unshar-marked-articles.
  57.  
  58. (defvar gnus-default-mark-char ?@
  59.   "*Character used to mark articles for later commands in GNUS.")
  60.  
  61. (defun gnus-Subject-mark-article (mark)
  62. "Mark the current articel for later commands.
  63. This marker comes from variable `gnus-default-mark-char'.
  64. You can change this variable by giving a prefix argument to this command,
  65. in which case you will be prompted for the character to use."
  66.   (interactive (list (if current-prefix-arg
  67.              (let ((cursor-in-echo-area t))
  68.                (message "Mark message with: ")
  69.                (setq gnus-default-mark-char (read-char)))
  70.              gnus-default-mark-char)))
  71.   (or (eq (current-buffer) (get-buffer gnus-Subject-buffer))
  72.       (error "not in subject buffer"))
  73.   (beginning-of-line)
  74.   (let ((buffer-read-only nil))
  75.     (delete-char 1)
  76.     (insert (make-string 1 mark)))
  77.   (forward-line 1))
  78.  
  79. ;; Actually, gnus-kill should have an interactive spec!
  80. (defun gnus-Subject-mark-regexp (regexp &optional marker)
  81.   "Mark all articles with subjects matching REGEXP.
  82. With a prefix ARG, prompt for the marker.  Type RET immediately to
  83. mark them as unread or enter SPC RET to remove all kinds of marks."
  84.   (interactive
  85.    (list (read-string "Mark (regexp): ")
  86.      (if current-prefix-arg
  87.          (read-string
  88.           "Mark with char (RET to mark as unread, SPC RET to remove existing markers): "))))
  89.   (setq marker (or marker (char-to-string gnus-default-mark-char)))
  90.   (gnus-kill "Subject" regexp
  91.          (if (equal "" marker)
  92.          '(gnus-Subject-mark-as-unread)
  93.            (list 'gnus-Subject-mark-as-read nil marker))
  94.          ;; overwrite existing marks:
  95.          t))
  96.  
  97. (defun gnus-Subject-mark-map-articles (mark function)
  98.   (save-excursion
  99.     (set-buffer gnus-Subject-buffer)
  100.     (let ((str (concat "^" (make-string 1 mark) " +\\([0-9]+\\):"))
  101.       got-one)
  102.       (save-excursion
  103.     (goto-char (point-min))
  104.     (while (not (eobp))
  105.       (if (looking-at str)
  106.           (progn
  107.         (setq got-one t)
  108.         (save-excursion
  109.           (funcall function
  110.             (gnus-find-header-by-number gnus-newsgroup-headers 
  111.               (string-to-int
  112.             (buffer-substring
  113.               (match-beginning 1) (match-end 1))))))))
  114.       (forward-line 1)))
  115.       (cond ((not got-one)
  116.          (let ((article (gnus-Subject-article-number)))
  117.            (if (or (null gnus-current-article)
  118.                (/= article gnus-current-article))
  119.            ;; Selected subject is different from current article's.
  120.            (gnus-Subject-display-article article))
  121.            (funcall function 
  122.             (gnus-find-header-by-number gnus-newsgroup-headers 
  123.                             article)))))
  124.       )))
  125.  
  126.  
  127. ;;; RFC944 forwarding of multiple messages
  128.  
  129. (defun gnus-forward-marked-articles ()
  130.   "Forward the marked messages to another user, RFC944 style."
  131.   (interactive)
  132.   (let (subj p
  133.     (state 'first)
  134.     tmp-buf)
  135.     (unwind-protect
  136.     (progn
  137.       (setq tmp-buf (get-buffer-create "*gnus-forward-tmp*"))
  138.       (save-excursion (set-buffer tmp-buf) (erase-buffer))
  139.       (gnus-Subject-mark-map-articles
  140.        gnus-default-mark-char
  141.        (function (lambda (msg)
  142.          (if (eq state 'first) (setq state t) (setq state nil))
  143.          (message "Snarfing article %s..." (aref msg 0))
  144.          (or (eq gnus-current-article (aref msg 0))
  145.          (gnus-Subject-display-article (aref msg 0)))
  146.          (set-buffer tmp-buf)
  147.          (goto-char (point-max))
  148.          (if subj
  149.          (insert "----------\n")
  150.            (setq subj (aref msg 1)))
  151.          (setq p (point))
  152.          (insert-buffer gnus-Article-buffer)
  153.          (goto-char p)
  154.          (while (re-search-forward "^-" nil t)
  155.            (insert " -"))
  156.          )))
  157.       (mail nil nil (concat "[Fwd: " subj "]"))
  158.       (save-excursion
  159.         (goto-char (point-max))
  160.         (insert (if state
  161.             "---------- Begin forwarded message\n"
  162.               "---------- Begin digest\n"))
  163.         (insert-buffer tmp-buf)
  164.         (goto-char (point-max))
  165.         (insert (if state
  166.             "\n---------- End forwarded message\n"
  167.               "\n---------- End digest\n"))))
  168.       ;; protected
  169.       (and tmp-buf (kill-buffer tmp-buf)))))
  170.  
  171.  
  172. ;;; reading a directory name, and offering to create if it doesn't exist.
  173.  
  174. (defun gnus-mark-read-directory (prompt &optional default-dir)
  175.   (let ((dir
  176.      (read-file-name prompt
  177.              (or default-dir default-directory)
  178.              (or default-dir default-directory)
  179.              nil)))
  180.     (if (string-match "/$" dir)
  181.     (setq dir (substring dir 0 (match-beginning 0))))
  182.     (setq dir
  183.       (cond ((file-directory-p dir) dir)
  184.         ((file-exists-p dir)
  185.          (ding)
  186.          (message "%s exists and is not a directory!" dir)
  187.          (sleep-for 2)
  188.          (gnus-mark-read-directory prompt dir))
  189.         ((y-or-n-p (format "directory %s doesn't exist, create it? " dir))
  190.          (gnus-make-directory dir)
  191.          dir)
  192.         (t (gnus-mark-read-directory prompt dir))))
  193.     (if (string-match "/$" dir)
  194.     dir
  195.       (concat dir "/"))))
  196.  
  197.  
  198. ;;; uudecode
  199.  
  200. (defconst gnus-uudecode-begin-pattern
  201.     "^begin[ \t]+\\([0-9][0-9][0-9]\\)[ \t]+\\([^ \t\n]*\\)$")
  202.  
  203. (defconst gnus-uudecode-body-pattern
  204.     "^M.............................................................?$")
  205.  
  206. (defconst gnus-uudecode-begin-or-body-pattern
  207.     (concat "\\(" gnus-uudecode-begin-pattern "\\|"
  208.         gnus-uudecode-body-pattern "\\)"))
  209.  
  210. (defvar gnus-uudecode-file-mode "644"
  211.   "*If non-nil, this overrides the mode specified in the `begin' line of
  212. a uuencoded file being unpacked by vm-uudecode.  This should be a string,
  213. which is the mode desired in octal.")
  214.  
  215. (defvar gnus-uudecode-auto-chmod "u+w"
  216.   "*If non-nil, then when gnus is untarring a file for you, it will
  217. apply this chmod modifier to each of the unpacked files.  This should be
  218. a string like \"u+w\".")
  219.  
  220. (defvar gnus-uudecode-auto-touch t
  221.   "*If non-nil, then when vm-uudecode is untarring a file for you, it will
  222. cause the write-date of each of the unpacked files to be the current time.
  223. Normally tar unpacks files with the time at which they are packed; this can
  224. cause your `make' commands to fail if you are installing a new version of
  225. a package which you have modified.")
  226.  
  227. (defvar gnus-uudecode-picture-pattern "\\.\\(gif\\|p[bgp]m\\|rast\\|pic\\)$"
  228.   "*If non-nil, this should be a pattern which matches files which are 
  229. images.  When gnus-uudecode-marked-articles creates a file which matches
  230. this pattern, it will ask you if you want to look at it now.  If so, it
  231. invokes gnus-uudecode-picture-viewer with the filename as an argument.
  232. After doing this, it asks you if you want to keep the picture or delete it.")
  233.  
  234. (defvar gnus-uudecode-picture-viewer "xv"
  235.   "*The picture viewer that gnus-uudecode-marked-messages uses.  See doc of
  236. variable gnus-uudecode-picture-pattern.")
  237.  
  238. (defvar gnus-uudecode-default-directory nil "*")
  239.  
  240. (defun gnus-uudecode-marked-articles (directory)
  241.   "Strip the junk from the beginning and end of the marked articles, 
  242. concatenate them together, and pipe the result through uudecode.  If
  243. the resultant file is a tar file and/or is compressed, this command
  244. offers to unpack/uncompress as well.  See also the variables
  245. gnus-uudecode-file-mode, gnus-uudecode-auto-chmod, and
  246.  gnus-uudecode-auto-touch."
  247.   (interactive (list (gnus-mark-read-directory "uudecode in directory: "
  248.                gnus-uudecode-default-directory)))
  249.   (setq gnus-uudecode-default-directory directory)
  250.   (let ((state 'first)
  251.     tmp-buf
  252.     name)
  253.     (unwind-protect
  254.       (progn
  255.        (setq tmp-buf  (get-buffer-create "*gnus-uudecode-tmp*"))
  256.        (save-excursion (set-buffer tmp-buf) (erase-buffer))
  257.        (gnus-Subject-mark-map-articles
  258.     gnus-default-mark-char
  259.     (function (lambda (msg)
  260.       (message "Snarfing article %s..." (aref msg 0))
  261.       (if (eq state 'last)
  262.           (error "articles out of order: articles follow `end' line."))
  263.       (or (eq gnus-current-article (aref msg 0))
  264.           (gnus-Subject-display-article (aref msg 0)))
  265.       (set-buffer tmp-buf)
  266.       (goto-char (point-max))
  267.       (let ((p (point))
  268.         (case-fold-search nil))
  269.         (insert-buffer gnus-Article-buffer)
  270.         (cond
  271.          ((eq state 'first)
  272.           (or (re-search-forward gnus-uudecode-begin-pattern nil t)
  273.           (error "couldn't find `begin' line in first article."))
  274.           ;; I'd like to second-guess the losers who use mixed-case
  275.           ;; and upper-case filenames, but this trashes trailing ".Z"
  276.           ;;(downcase-region (match-beginning 2) (match-end 2))
  277.           (setq name (buffer-substring (match-beginning 2) (match-end 2)))
  278.           ;; don't tolerate bogus umasks.
  279.           (if gnus-uudecode-file-mode
  280.           (progn
  281.             (goto-char (match-beginning 1))
  282.             (delete-region (match-beginning 1) (match-end 1))
  283.             (insert gnus-uudecode-file-mode)))
  284.           (setq state 'middle))
  285.          (t
  286.           (or (re-search-forward gnus-uudecode-begin-or-body-pattern nil t)
  287.           (error "couldn't find beginning of data."))))
  288.         (beginning-of-line)
  289.         (delete-region p (point))
  290.         (let (c len tmp)
  291.           ;; This could be sped up a lot, but then we'd lose the
  292.           ;; error checking it does; maybe that's ok.
  293.           (while (progn
  294.                (forward-line)
  295.                (setq c (- (following-char) ? ))
  296.                (end-of-line)
  297.                (setq tmp (/ (1- (current-column)) 4))
  298.                (beginning-of-line)
  299.                (= (+ tmp (+ tmp tmp)) c))
  300.         )
  301.           ;; Slack.
  302.           (setq p (point))
  303.           (if (or (looking-at "end\n")
  304.               (progn (forward-line 1) (looking-at "end\n"))
  305.               (progn (forward-line 1) (looking-at "end\n"))
  306.               (progn (forward-line 1) (looking-at "end\n")))
  307.           (progn
  308.             (forward-line 1)
  309.             (setq state 'last))
  310.         (goto-char p))
  311.           )
  312.         (delete-region (point) (point-max))))))
  313.        (or (eq state 'last) (error "no `end' line in last article."))
  314.        (set-buffer tmp-buf)
  315.        (let* ((base-file (file-name-nondirectory name))
  316.           (final-file (concat directory base-file))
  317.           (command (concat "cd " directory " ; uudecode"))
  318.           tar-p)
  319.      (cond ((string-match "\\.tar\\.Z$" base-file)
  320.         (if (y-or-n-p "uncompress/untar? ")
  321.             (setq command (concat command " && zcat "
  322.                       base-file " | tar -vxf -")
  323.               final-file nil
  324.               tar-p t)))
  325.            ((string-match "\\.tar$" base-file)
  326.         (if (y-or-n-p "untar? ")
  327.             (setq command (concat command " && tar -vxf " base-file)
  328.               final-file nil
  329.               tar-p t)))
  330.            ((string-match "\\.Z$" base-file)
  331.         (if (y-or-n-p "uncompress? ")
  332.             (setq command (concat command " ; uncompress " base-file)
  333.               final-file (substring base-file 0
  334.                         (match-beginning 0))))))
  335.      (let ((str (concat "executing \"" command "\" ...")))
  336.        (message str)
  337.        (shell-command-on-region (point-min) (point-max) command nil)
  338. ;       (if final-file
  339. ;          (dired-add-entry-all-buffers directory
  340. ;         (file-name-nondirectory final-file)))
  341.        (message (concat str " done.")))
  342.      (cond
  343.       (tar-p
  344.        (set-buffer (get-buffer "*Shell Command Output*"))
  345.        (let ((all (concat command "\n" (buffer-string)))
  346.          files files-str)
  347.          (goto-char (point-min))
  348.          (while (not (eobp))
  349.            (if (looking-at "^x \\([^,\n]+\\), ")
  350.            (setq files (cons (buffer-substring
  351.                       (match-beginning 1) (match-end 1))
  352.                      files)))
  353.            (forward-line 1))
  354.          (setq files (nreverse files)
  355.            files-str (mapconcat 'identity files " "))
  356.          (cond
  357.           (files
  358.            (cond
  359.         (gnus-uudecode-auto-chmod
  360.          (setq command (concat "cd " directory " ; chmod "
  361.                        gnus-uudecode-auto-chmod " " files-str))
  362.          (shell-command command)
  363.          (setq all (concat all "\n" command "\n" (buffer-string)))))
  364.            (cond
  365.         (gnus-uudecode-auto-touch
  366.          (setq command (concat "cd " directory " ; touch " files-str))
  367.          (shell-command command)
  368.          (setq all (concat all "\n" command "\n" (buffer-string)))))
  369.           (goto-char (point-min))
  370.           (insert all "\n")
  371. ;          (mapcar (function (lambda (x)
  372. ;            (dired-add-entry-all-buffers directory x)))
  373. ;              files)
  374.           ))))
  375.       (t
  376.        (message "wrote file %s" final-file)
  377.        (let ((case-fold-search t))
  378.          (cond ((null gnus-uudecode-picture-pattern) nil)
  379.            ((and (string-match gnus-uudecode-picture-pattern
  380.                        final-file)
  381.              (y-or-n-p
  382.                (format "look at the picture in %s? " final-file)))
  383.             (shell-command
  384.               (concat gnus-uudecode-picture-viewer " " final-file))
  385.             (if (y-or-n-p (format "delete file %s? " final-file))
  386.             (progn
  387.               (delete-file final-file)
  388.               (message "%s deleted." final-file))
  389.             )))))
  390.       )))
  391.       ;; protected
  392.       (and tmp-buf (kill-buffer tmp-buf)))))
  393.  
  394.  
  395. ;;; shar (ack pffleughhh barf)
  396.  
  397. (defvar gnus-unshar-program "/bin/sh"
  398.   "*The program to use to unshar files; you might want to use something
  399. that is less of a gaping security hole than /bin/sh.")
  400.  
  401. (defvar gnus-unshar-default-directory nil "*")
  402.  
  403. (defun gnus-unshar-marked-articles (directory)
  404.   "For each of the marked articles, strip the junk from the beginning and end
  405. and then run the result through gnus-unshar-program (typically /bin/sh.)"
  406.   (interactive (list (gnus-mark-read-directory
  407.                "unshar in directory: " gnus-unshar-default-directory)))
  408.   (setq gnus-unshar-default-directory directory)
  409.   (let (tmp-buf tmp-buf2
  410.     (command (concat "cd " directory " ; " gnus-unshar-program)))
  411.     (unwind-protect
  412.       (progn
  413.        (setq tmp-buf (get-buffer-create "*gnus-unshar-tmp*")
  414.          tmp-buf2 (get-buffer-create "*gnus-unshar-log*"))
  415.        (save-excursion (set-buffer tmp-buf2) (erase-buffer))
  416.        (gnus-Subject-mark-map-articles
  417.     gnus-default-mark-char
  418.     (function (lambda (msg)
  419.       (message "Snarfing article %s..." (aref msg 0))
  420.       (or (eq gnus-current-article (aref msg 0))
  421.           (gnus-Subject-display-article (aref msg 0)))
  422.       (set-buffer tmp-buf)
  423.       (erase-buffer)
  424.       (insert-buffer gnus-Article-buffer)
  425.       (re-search-forward "^#!")
  426.       (beginning-of-line)
  427.       (delete-region (point-min) (point))
  428.       (goto-char (point-max))
  429.       ;; what kind of shithead has a signature after a shar file?
  430.       (if (re-search-backward "^--" nil t)
  431.           (delete-region (point) (point-max)))
  432.       (message "unsharing article %s..." (aref msg 0))
  433.       (shell-command-on-region (point-min) (point-max) command t)
  434.       (set-buffer tmp-buf2)
  435.       (goto-char (point-max))
  436.       (insert-buffer tmp-buf)
  437.       (message "unsharing article %s...done." (aref msg 0))
  438.       ))))
  439.       ;; protected
  440.       (kill-buffer tmp-buf)
  441.       (set-buffer tmp-buf2)
  442.       (goto-char (point-min))
  443.       (if (= (point-min) (point-max))
  444.       (kill-buffer tmp-buf2)
  445.     (display-buffer tmp-buf2)))))
  446.  
  447.