/[emacs]/emacs/lisp/gnus/gnus-uu.el
ViewVC logotype

Diff of /emacs/lisp/gnus/gnus-uu.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.15.2.1 by miles, Tue Oct 14 23:34:50 2003 UTC revision 1.15.2.2 by miles, Thu Sep 16 00:12:16 2004 UTC
# Line 1  Line 1 
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
# Line 299  so I simply dropped them." Line 299  so I simply dropped them."
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    
# Line 321  didn't work, and overwrite existing file Line 322  didn't work, and overwrite existing file
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")
# Line 336  didn't work, and overwrite existing file Line 337  didn't work, and overwrite existing file
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$")
# Line 353  didn't work, and overwrite existing file Line 354  didn't work, and overwrite existing file
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)
# Line 529  didn't work, and overwrite existing file Line 480  didn't work, and overwrite existing file
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)
# Line 575  didn't work, and overwrite existing file Line 527  didn't work, and overwrite existing file
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)
# Line 597  When called interactively, prompt for RE Line 572  When called interactively, prompt for RE
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)
# Line 862  When called interactively, prompt for RE Line 838  When called interactively, prompt for RE
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))))
# Line 896  When called interactively, prompt for RE Line 870  When called interactively, prompt for RE
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))
# Line 1116  When called interactively, prompt for RE Line 1090  When called interactively, prompt for RE
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
# Line 1208  When called interactively, prompt for RE Line 1182  When called interactively, prompt for RE
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))
# Line 1377  When called interactively, prompt for RE Line 1352  When called interactively, prompt for RE
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)
# Line 1463  When called interactively, prompt for RE Line 1438  When called interactively, prompt for RE
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)
# Line 1655  Gnus might fail to display all of it.") Line 1630  Gnus might fail to display all of it.")
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 "")
# Line 1820  Gnus might fail to display all of it.") Line 1795  Gnus might fail to display all of it.")
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    
# Line 1900  is t." Line 1879  is t."
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)
# Line 1933  The user will be asked for a file name." Line 1912  The user will be asked for a file name."
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    
# Line 1959  The user will be asked for a file name." Line 1938  The user will be asked for a file name."
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.

Legend:
Removed from v.1.15.2.1  
changed lines
  Added in v.1.15.2.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26