1 |
;;; gnus-uu.el --- extract (uu)encoded files in Gnus |
;;; gnus-uu.el --- extract (uu)encoded files in Gnus |
2 |
;; Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 1996, 1997, 1998, 2000, |
;; Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 1996, 1997, 1998, 2000, |
3 |
;; 2001 Free Software Foundation, Inc. |
;; 2001, 2002, 2003 Free Software Foundation, Inc. |
4 |
|
|
5 |
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> |
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> |
6 |
;; Created: 2 Oct 1993 |
;; Created: 2 Oct 1993 |
299 |
"^MIME-Version:" "^Content-Disposition:" "^Content-Description:" |
"^MIME-Version:" "^Content-Disposition:" "^Content-Description:" |
300 |
"^Content-ID:") |
"^Content-ID:") |
301 |
"*List of regexps to match headers included in digested messages. |
"*List of regexps to match headers included in digested messages. |
302 |
The headers will be included in the sequence they are matched." |
The headers will be included in the sequence they are matched. If nil |
303 |
|
include all headers." |
304 |
:group 'gnus-extract |
:group 'gnus-extract |
305 |
:type '(repeat regexp)) |
:type '(repeat regexp)) |
306 |
|
|
322 |
|
|
323 |
(defvar gnus-uu-saved-article-name nil) |
(defvar gnus-uu-saved-article-name nil) |
324 |
|
|
325 |
(defvar gnus-uu-begin-string "^begin[ \t]+[0-7][0-7][0-7][ \t]+\\(.*\\)$") |
(defvar gnus-uu-begin-string "^begin[ \t]+0?[0-7][0-7][0-7][ \t]+\\(.*\\)$") |
326 |
(defvar gnus-uu-end-string "^end[ \t]*$") |
(defvar gnus-uu-end-string "^end[ \t]*$") |
327 |
|
|
328 |
(defvar gnus-uu-body-line "^M") |
(defvar gnus-uu-body-line "^M") |
337 |
|
|
338 |
(defvar gnus-uu-shar-file-name nil) |
(defvar gnus-uu-shar-file-name nil) |
339 |
(defvar gnus-uu-shar-name-marker |
(defvar gnus-uu-shar-name-marker |
340 |
"begin [0-7][0-7][0-7][ \t]+\\(\\(\\w\\|\\.\\)*\\b\\)") |
"begin 0?[0-7][0-7][0-7][ \t]+\\(\\(\\w\\|[.\\:]\\)*\\b\\)") |
341 |
|
|
342 |
(defvar gnus-uu-postscript-begin-string "^%!PS-") |
(defvar gnus-uu-postscript-begin-string "^%!PS-") |
343 |
(defvar gnus-uu-postscript-end-string "^%%EOF$") |
(defvar gnus-uu-postscript-end-string "^%%EOF$") |
354 |
(defvar gnus-uu-digest-from-subject nil) |
(defvar gnus-uu-digest-from-subject nil) |
355 |
(defvar gnus-uu-digest-buffer nil) |
(defvar gnus-uu-digest-buffer nil) |
356 |
|
|
|
;; Keymaps |
|
|
|
|
|
(gnus-define-keys (gnus-uu-mark-map "P" gnus-summary-mark-map) |
|
|
"p" gnus-summary-mark-as-processable |
|
|
"u" gnus-summary-unmark-as-processable |
|
|
"U" gnus-summary-unmark-all-processable |
|
|
"v" gnus-uu-mark-over |
|
|
"s" gnus-uu-mark-series |
|
|
"r" gnus-uu-mark-region |
|
|
"g" gnus-uu-unmark-region |
|
|
"R" gnus-uu-mark-by-regexp |
|
|
"G" gnus-uu-unmark-by-regexp |
|
|
"t" gnus-uu-mark-thread |
|
|
"T" gnus-uu-unmark-thread |
|
|
"a" gnus-uu-mark-all |
|
|
"b" gnus-uu-mark-buffer |
|
|
"S" gnus-uu-mark-sparse |
|
|
"k" gnus-summary-kill-process-mark |
|
|
"y" gnus-summary-yank-process-mark |
|
|
"w" gnus-summary-save-process-mark |
|
|
"i" gnus-uu-invert-processable) |
|
|
|
|
|
(gnus-define-keys (gnus-uu-extract-map "X" gnus-summary-mode-map) |
|
|
;;"x" gnus-uu-extract-any |
|
|
"m" gnus-summary-save-parts |
|
|
"u" gnus-uu-decode-uu |
|
|
"U" gnus-uu-decode-uu-and-save |
|
|
"s" gnus-uu-decode-unshar |
|
|
"S" gnus-uu-decode-unshar-and-save |
|
|
"o" gnus-uu-decode-save |
|
|
"O" gnus-uu-decode-save |
|
|
"b" gnus-uu-decode-binhex |
|
|
"B" gnus-uu-decode-binhex |
|
|
"p" gnus-uu-decode-postscript |
|
|
"P" gnus-uu-decode-postscript-and-save) |
|
|
|
|
|
(gnus-define-keys |
|
|
(gnus-uu-extract-view-map "v" gnus-uu-extract-map) |
|
|
"u" gnus-uu-decode-uu-view |
|
|
"U" gnus-uu-decode-uu-and-save-view |
|
|
"s" gnus-uu-decode-unshar-view |
|
|
"S" gnus-uu-decode-unshar-and-save-view |
|
|
"o" gnus-uu-decode-save-view |
|
|
"O" gnus-uu-decode-save-view |
|
|
"b" gnus-uu-decode-binhex-view |
|
|
"B" gnus-uu-decode-binhex-view |
|
|
"p" gnus-uu-decode-postscript-view |
|
|
"P" gnus-uu-decode-postscript-and-save-view) |
|
|
|
|
|
|
|
357 |
;; Commands. |
;; Commands. |
358 |
|
|
359 |
(defun gnus-uu-decode-uu (&optional n) |
(defun gnus-uu-decode-uu (&optional n) |
480 |
(if (and n (not (numberp n))) |
(if (and n (not (numberp n))) |
481 |
(setq message-forward-as-mime (not message-forward-as-mime) |
(setq message-forward-as-mime (not message-forward-as-mime) |
482 |
n nil)) |
n nil)) |
483 |
(gnus-setup-message 'forward |
(let ((gnus-article-reply (gnus-summary-work-articles n))) |
484 |
(setq gnus-uu-digest-from-subject nil) |
(gnus-setup-message 'forward |
485 |
(setq gnus-uu-digest-buffer |
(setq gnus-uu-digest-from-subject nil) |
486 |
(gnus-get-buffer-create " *gnus-uu-forward*")) |
(setq gnus-uu-digest-buffer |
487 |
(gnus-uu-decode-save n file) |
(gnus-get-buffer-create " *gnus-uu-forward*")) |
488 |
(switch-to-buffer gnus-uu-digest-buffer) |
(gnus-uu-decode-save n file) |
489 |
(let ((fs gnus-uu-digest-from-subject)) |
(switch-to-buffer gnus-uu-digest-buffer) |
490 |
(when fs |
(let ((fs gnus-uu-digest-from-subject)) |
491 |
(setq from (caar fs) |
(when fs |
492 |
subject (gnus-simplify-subject-fuzzy (cdar fs)) |
(setq from (caar fs) |
493 |
fs (cdr fs)) |
subject (gnus-simplify-subject-fuzzy (cdar fs)) |
494 |
(while (and fs (or from subject)) |
fs (cdr fs)) |
495 |
(when from |
(while (and fs (or from subject)) |
496 |
(unless (string= from (caar fs)) |
(when from |
497 |
(setq from nil))) |
(unless (string= from (caar fs)) |
498 |
(when subject |
(setq from nil))) |
499 |
(unless (string= (gnus-simplify-subject-fuzzy (cdar fs)) |
(when subject |
500 |
subject) |
(unless (string= (gnus-simplify-subject-fuzzy (cdar fs)) |
501 |
(setq subject nil))) |
subject) |
502 |
(setq fs (cdr fs)))) |
(setq subject nil))) |
503 |
(unless subject |
(setq fs (cdr fs)))) |
504 |
(setq subject "Digested Articles")) |
(unless subject |
505 |
(unless from |
(setq subject "Digested Articles")) |
506 |
(setq from |
(unless from |
507 |
(if (gnus-news-group-p gnus-newsgroup-name) |
(setq from |
508 |
gnus-newsgroup-name |
(if (gnus-news-group-p gnus-newsgroup-name) |
509 |
"Various")))) |
gnus-newsgroup-name |
510 |
(goto-char (point-min)) |
"Various")))) |
511 |
(when (re-search-forward "^Subject: ") |
(goto-char (point-min)) |
512 |
(delete-region (point) (gnus-point-at-eol)) |
(when (re-search-forward "^Subject: ") |
513 |
(insert subject)) |
(delete-region (point) (gnus-point-at-eol)) |
514 |
(goto-char (point-min)) |
(insert subject)) |
515 |
(when (re-search-forward "^From:") |
(goto-char (point-min)) |
516 |
(delete-region (point) (gnus-point-at-eol)) |
(when (re-search-forward "^From:") |
517 |
(insert " " from)) |
(delete-region (point) (gnus-point-at-eol)) |
518 |
(let ((message-forward-decoded-p t)) |
(insert " " from)) |
519 |
(message-forward post t))) |
(let ((message-forward-decoded-p t)) |
520 |
|
(message-forward post t)))) |
521 |
(setq gnus-uu-digest-from-subject nil))) |
(setq gnus-uu-digest-from-subject nil))) |
522 |
|
|
523 |
(defun gnus-uu-digest-post-forward (&optional n) |
(defun gnus-uu-digest-post-forward (&optional n) |
527 |
|
|
528 |
;; Process marking. |
;; Process marking. |
529 |
|
|
530 |
|
(defun gnus-message-process-mark (unmarkp new-marked) |
531 |
|
(let ((old (- (length gnus-newsgroup-processable) (length new-marked)))) |
532 |
|
(message "%d mark%s %s%s" |
533 |
|
(length new-marked) |
534 |
|
(if (= (length new-marked) 1) "" "s") |
535 |
|
(if unmarkp "removed" "added") |
536 |
|
(cond |
537 |
|
((and (zerop old) |
538 |
|
(not unmarkp)) |
539 |
|
"") |
540 |
|
(unmarkp |
541 |
|
(format ", %d remain marked" |
542 |
|
(length gnus-newsgroup-processable))) |
543 |
|
(t |
544 |
|
(format ", %d already marked" old)))))) |
545 |
|
|
546 |
|
(defun gnus-new-processable (unmarkp articles) |
547 |
|
(if unmarkp |
548 |
|
(gnus-intersection gnus-newsgroup-processable articles) |
549 |
|
(gnus-set-difference articles gnus-newsgroup-processable))) |
550 |
|
|
551 |
(defun gnus-uu-mark-by-regexp (regexp &optional unmark) |
(defun gnus-uu-mark-by-regexp (regexp &optional unmark) |
552 |
"Set the process mark on articles whose subjects match REGEXP. |
"Set the process mark on articles whose subjects match REGEXP. |
553 |
When called interactively, prompt for REGEXP. |
When called interactively, prompt for REGEXP. |
554 |
Optional UNMARK non-nil means unmark instead of mark." |
Optional UNMARK non-nil means unmark instead of mark." |
555 |
(interactive "sMark (regexp): \nP") |
(interactive "sMark (regexp): \nP") |
556 |
(let ((articles (gnus-uu-find-articles-matching regexp))) |
(save-excursion |
557 |
(while articles |
(let* ((articles (gnus-uu-find-articles-matching regexp)) |
558 |
(if unmark |
(new-marked (gnus-new-processable unmark articles))) |
559 |
(gnus-summary-remove-process-mark (pop articles)) |
(while articles |
560 |
(gnus-summary-set-process-mark (pop articles)))) |
(if unmark |
561 |
(message "")) |
(gnus-summary-remove-process-mark (pop articles)) |
562 |
|
(gnus-summary-set-process-mark (pop articles)))) |
563 |
|
(gnus-message-process-mark unmark new-marked))) |
564 |
(gnus-summary-position-point)) |
(gnus-summary-position-point)) |
565 |
|
|
566 |
(defun gnus-uu-unmark-by-regexp (regexp) |
(defun gnus-uu-unmark-by-regexp (regexp) |
572 |
(defun gnus-uu-mark-series () |
(defun gnus-uu-mark-series () |
573 |
"Mark the current series with the process mark." |
"Mark the current series with the process mark." |
574 |
(interactive) |
(interactive) |
575 |
(let ((articles (gnus-uu-find-articles-matching))) |
(let* ((articles (gnus-uu-find-articles-matching)) |
576 |
|
(l (length articles))) |
577 |
(while articles |
(while articles |
578 |
(gnus-summary-set-process-mark (car articles)) |
(gnus-summary-set-process-mark (car articles)) |
579 |
(setq articles (cdr articles))) |
(setq articles (cdr articles))) |
580 |
(message "")) |
(message "Marked %d articles" l)) |
581 |
(gnus-summary-position-point)) |
(gnus-summary-position-point)) |
582 |
|
|
583 |
(defun gnus-uu-mark-region (beg end &optional unmark) |
(defun gnus-uu-mark-region (beg end &optional unmark) |
838 |
"Date: %s\nFrom: %s\nSubject: %s Digest\n\n" |
"Date: %s\nFrom: %s\nSubject: %s Digest\n\n" |
839 |
(current-time-string) name name)) |
(current-time-string) name name)) |
840 |
(when (and message-forward-as-mime gnus-uu-digest-buffer) |
(when (and message-forward-as-mime gnus-uu-digest-buffer) |
841 |
;; The default part in multipart/digest is message/rfc822. |
(insert "<#part type=message/rfc822>\nSubject: Topics\n\n")) |
|
;; Subject is a fake head. |
|
|
(insert "<#part type=text/plain>\nSubject: Topics\n\n")) |
|
842 |
(insert "Topics:\n"))) |
(insert "Topics:\n"))) |
843 |
(when (not (eq in-state 'end)) |
(when (not (eq in-state 'end)) |
844 |
(setq state (list 'middle)))) |
(setq state (list 'middle)))) |
870 |
(setq body (buffer-substring (1- (point)) (point-max))) |
(setq body (buffer-substring (1- (point)) (point-max))) |
871 |
(narrow-to-region (point-min) (point)) |
(narrow-to-region (point-min) (point)) |
872 |
(if (not (setq headers gnus-uu-digest-headers)) |
(if (not (setq headers gnus-uu-digest-headers)) |
873 |
(setq sorthead (buffer-substring (point-min) (point-max))) |
(setq sorthead (buffer-string)) |
874 |
(while headers |
(while headers |
875 |
(setq headline (car headers)) |
(setq headline (car headers)) |
876 |
(setq headers (cdr headers)) |
(setq headers (cdr headers)) |
1090 |
(while (re-search-forward "[ \t]+" nil t) |
(while (re-search-forward "[ \t]+" nil t) |
1091 |
(replace-match "[ \t]+" t t)) |
(replace-match "[ \t]+" t t)) |
1092 |
|
|
1093 |
(buffer-substring (point-min) (point-max)))) |
(buffer-string))) |
1094 |
|
|
1095 |
(defun gnus-uu-get-list-of-articles (n) |
(defun gnus-uu-get-list-of-articles (n) |
1096 |
;; If N is non-nil, the article numbers of the N next articles |
;; If N is non-nil, the article numbers of the N next articles |
1182 |
;; Expand numbers. |
;; Expand numbers. |
1183 |
(goto-char (point-min)) |
(goto-char (point-min)) |
1184 |
(while (re-search-forward "[0-9]+" nil t) |
(while (re-search-forward "[0-9]+" nil t) |
1185 |
(replace-match |
(ignore-errors |
1186 |
(format "%06d" |
(replace-match |
1187 |
(string-to-int (buffer-substring |
(format "%06d" |
1188 |
(match-beginning 0) (match-end 0)))))) |
(string-to-int (buffer-substring |
1189 |
(setq string (buffer-substring (point-min) (point-max))) |
(match-beginning 0) (match-end 0))))))) |
1190 |
|
(setq string (buffer-substring 1 (point-max))) |
1191 |
(setcar (car string-list) string) |
(setcar (car string-list) string) |
1192 |
(setq string-list (cdr string-list)))) |
(setq string-list (cdr string-list)))) |
1193 |
out-list)) |
out-list)) |
1352 |
(setq process-state (list 'error)) |
(setq process-state (list 'error)) |
1353 |
(gnus-message 2 "No begin part at the beginning") |
(gnus-message 2 "No begin part at the beginning") |
1354 |
(sleep-for 2)) |
(sleep-for 2)) |
1355 |
(setq state 'middle))) |
(setq state 'middle)))) |
1356 |
|
|
1357 |
;; When there are no result-files, then something must be wrong. |
;; When there are no result-files, then something must be wrong. |
1358 |
(if result-files |
(if result-files |
1359 |
(message "") |
(message "") |
1360 |
(cond |
(cond |
1361 |
((not has-been-begin) |
((not has-been-begin) |
1362 |
(gnus-message 2 "Wrong type file")) |
(gnus-message 2 "Wrong type file")) |
1363 |
((memq 'error process-state) |
((memq 'error process-state) |
1364 |
(gnus-message 2 "An error occurred during decoding")) |
(gnus-message 2 "An error occurred during decoding")) |
1365 |
((not (or (memq 'ok process-state) |
((not (or (memq 'ok process-state) |
1366 |
(memq 'end process-state))) |
(memq 'end process-state))) |
1367 |
(gnus-message 2 "End of articles reached before end of file"))) |
(gnus-message 2 "End of articles reached before end of file"))) |
1368 |
;; Make unsuccessfully decoded articles unread. |
;; Make unsuccessfully decoded articles unread. |
1369 |
(when gnus-uu-unmark-articles-not-decoded |
(when gnus-uu-unmark-articles-not-decoded |
1370 |
(while article-series |
(while article-series |
1371 |
(gnus-summary-tick-article (pop article-series) t))))) |
(gnus-summary-tick-article (pop article-series) t)))) |
1372 |
|
|
1373 |
;; The original article buffer is hosed, shoot it down. |
;; The original article buffer is hosed, shoot it down. |
1374 |
(gnus-kill-buffer gnus-original-article-buffer) |
(gnus-kill-buffer gnus-original-article-buffer) |
1375 |
|
(setq gnus-current-article nil) |
1376 |
result-files)) |
result-files)) |
1377 |
|
|
1378 |
(defun gnus-uu-grab-view (file) |
(defun gnus-uu-grab-view (file) |
1438 |
;; This is the beginning of a uuencoded article. |
;; This is the beginning of a uuencoded article. |
1439 |
;; We replace certain characters that could make things messy. |
;; We replace certain characters that could make things messy. |
1440 |
(setq gnus-uu-file-name |
(setq gnus-uu-file-name |
1441 |
(let ((nnheader-file-name-translation-alist |
(gnus-map-function |
1442 |
'((?/ . ?,) (? . ?_) (?* . ?_) (?$ . ?_)))) |
mm-file-name-rewrite-functions |
1443 |
(nnheader-translate-file-chars (match-string 1)))) |
(file-name-nondirectory (match-string 1)))) |
1444 |
(replace-match (concat "begin 644 " gnus-uu-file-name) t t) |
(replace-match (concat "begin 644 " gnus-uu-file-name) t t) |
1445 |
|
|
1446 |
;; Remove any non gnus-uu-body-line right after start. |
;; Remove any non gnus-uu-body-line right after start. |
1447 |
(forward-line 1) |
(forward-line 1) |
1630 |
|
|
1631 |
(gnus-message 5 "Unpacking: %s..." (gnus-uu-command action file-path)) |
(gnus-message 5 "Unpacking: %s..." (gnus-uu-command action file-path)) |
1632 |
|
|
1633 |
(if (= 0 (call-process shell-file-name nil |
(if (eq 0 (call-process shell-file-name nil |
1634 |
(gnus-get-buffer-create gnus-uu-output-buffer-name) |
(gnus-get-buffer-create gnus-uu-output-buffer-name) |
1635 |
nil shell-command-switch command)) |
nil shell-command-switch command)) |
1636 |
(message "") |
(message "") |
1795 |
(if (file-directory-p file) |
(if (file-directory-p file) |
1796 |
(gnus-uu-delete-work-dir file) |
(gnus-uu-delete-work-dir file) |
1797 |
(gnus-message 9 "Deleting file %s..." file) |
(gnus-message 9 "Deleting file %s..." file) |
1798 |
(delete-file file)))) |
(condition-case err |
1799 |
(delete-directory dir))) |
(delete-file file) |
1800 |
(gnus-message 7 "")) |
(error (gnus-message 3 "Deleting file %s failed... %s" file err)))))) |
1801 |
|
(condition-case err |
1802 |
|
(delete-directory dir) |
1803 |
|
(error (gnus-message 3 "Deleting directory %s failed... %s" file err)))) |
1804 |
|
(gnus-message 7 ""))) |
1805 |
|
|
1806 |
;; Initializing |
;; Initializing |
1807 |
|
|
1879 |
(let ((map (make-sparse-keymap))) |
(let ((map (make-sparse-keymap))) |
1880 |
(set-keymap-parent map (current-local-map)) |
(set-keymap-parent map (current-local-map)) |
1881 |
(use-local-map map)) |
(use-local-map map)) |
1882 |
(local-set-key "\C-c\C-c" 'gnus-summary-edit-article-done) |
;;(local-set-key "\C-c\C-c" 'gnus-summary-edit-article-done) |
1883 |
(local-set-key "\C-c\C-c" 'gnus-uu-post-news-inews) |
(local-set-key "\C-c\C-c" 'gnus-uu-post-news-inews) |
1884 |
(local-set-key "\C-c\C-s" 'gnus-uu-post-news-inews) |
(local-set-key "\C-c\C-s" 'gnus-uu-post-news-inews) |
1885 |
(local-set-key "\C-c\C-i" 'gnus-uu-post-insert-binary-in-article) |
(local-set-key "\C-c\C-i" 'gnus-uu-post-insert-binary-in-article) |
1912 |
|
|
1913 |
;; Encodes with base64 and adds MIME headers |
;; Encodes with base64 and adds MIME headers |
1914 |
(defun gnus-uu-post-encode-mime (path file-name) |
(defun gnus-uu-post-encode-mime (path file-name) |
1915 |
(when (zerop (call-process shell-file-name nil t nil shell-command-switch |
(when (eq 0 (call-process shell-file-name nil t nil shell-command-switch |
1916 |
(format "%s %s -o %s" "mmencode" path file-name))) |
(format "%s %s -o %s" "mmencode" path file-name))) |
1917 |
(gnus-uu-post-make-mime file-name "base64") |
(gnus-uu-post-make-mime file-name "base64") |
1918 |
t)) |
t)) |
1919 |
|
|
1938 |
;; Encodes a file PATH with COMMAND, leaving the result in the |
;; Encodes a file PATH with COMMAND, leaving the result in the |
1939 |
;; current buffer. |
;; current buffer. |
1940 |
(defun gnus-uu-post-encode-file (command path file-name) |
(defun gnus-uu-post-encode-file (command path file-name) |
1941 |
(= 0 (call-process shell-file-name nil t nil shell-command-switch |
(eq 0 (call-process shell-file-name nil t nil shell-command-switch |
1942 |
(format "%s %s %s" command path file-name)))) |
(format "%s %s %s" command path file-name)))) |
1943 |
|
|
1944 |
(defun gnus-uu-post-news-inews () |
(defun gnus-uu-post-news-inews () |
1945 |
"Posts the composed news article and encoded file. |
"Posts the composed news article and encoded file. |