1;;; gnus-uu.el --- extract (uu)encoded files in Gnus 2 3;; Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 1996, 1997, 1998, 4;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc. 5 6;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> 7;; Created: 2 Oct 1993 8;; Keyword: news 9 10;; This file is part of GNU Emacs. 11 12;; GNU Emacs is free software; you can redistribute it and/or modify 13;; it under the terms of the GNU General Public License as published by 14;; the Free Software Foundation; either version 2, or (at your option) 15;; any later version. 16 17;; GNU Emacs is distributed in the hope that it will be useful, 18;; but WITHOUT ANY WARRANTY; without even the implied warranty of 19;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 20;; GNU General Public License for more details. 21 22;; You should have received a copy of the GNU General Public License 23;; along with GNU Emacs; see the file COPYING. If not, write to the 24;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 25;; Boston, MA 02110-1301, USA. 26 27;;; Commentary: 28 29;;; Code: 30 31(eval-when-compile (require 'cl)) 32 33(require 'gnus) 34(require 'gnus-art) 35(require 'message) 36(require 'gnus-msg) 37(require 'mm-decode) 38 39(defgroup gnus-extract nil 40 "Extracting encoded files." 41 :prefix "gnus-uu-" 42 :group 'gnus) 43 44(defgroup gnus-extract-view nil 45 "Viewwing extracted files." 46 :group 'gnus-extract) 47 48(defgroup gnus-extract-archive nil 49 "Extracting encoded archives." 50 :group 'gnus-extract) 51 52(defgroup gnus-extract-post nil 53 "Extracting encoded archives." 54 :prefix "gnus-uu-post" 55 :group 'gnus-extract) 56 57;; Default viewing action rules 58 59(defcustom gnus-uu-default-view-rules 60 '(("\\.te?xt$\\|\\.doc$\\|read.*me\\|\\.c?$\\|\\.h$\\|\\.bat$\\|\\.asm$\\|makefile" "cat %s | sed 's/\r$//'") 61 ("\\.pas$" "cat %s | sed 's/\r$//'") 62 ("\\.[1-9]$" "groff -mandoc -Tascii %s | sed s/\b.//g") 63 ("\\.\\(jpe?g\\|gif\\|tiff?\\|p[pgb]m\\|xwd\\|xbm\\|pcx\\)$" "display") 64 ("\\.tga$" "tgatoppm %s | ee -") 65 ("\\.\\(wav\\|aiff\\|hcom\\|u[blw]\\|s[bfw]\\|voc\\|smp\\)$" 66 "sox -v .5 %s -t .au -u - > /dev/audio") 67 ("\\.au$" "cat %s > /dev/audio") 68 ("\\.midi?$" "playmidi -f") 69 ("\\.mod$" "str32") 70 ("\\.ps$" "ghostview") 71 ("\\.dvi$" "xdvi") 72 ("\\.html$" "xmosaic") 73 ("\\.mpe?g$" "mpeg_play") 74 ("\\.\\(flc\\|fli\\|rle\\|iff\\|pfx\\|avi\\|sme\\|rpza\\|dl\\|qt\\|rsrc\\|mov\\)$" "xanim") 75 ("\\.\\(tar\\|arj\\|zip\\|zoo\\|arc\\|gz\\|Z\\|lzh\\|ar\\|lha\\)$" 76 "gnus-uu-archive")) 77 "*Default actions to be taken when the user asks to view a file. 78To change the behaviour, you can either edit this variable or set 79`gnus-uu-user-view-rules' to something useful. 80 81For example: 82 83To make gnus-uu use 'xli' to display JPEG and GIF files, put the 84following in your .emacs file: 85 86 (setq gnus-uu-user-view-rules '((\"jpg$\\\\|gif$\" \"xli\"))) 87 88Both these variables are lists of lists with two string elements. The 89first string is a regular expression. If the file name matches this 90regular expression, the command in the second string is executed with 91the file as an argument. 92 93If the command string contains \"%s\", the file name will be inserted 94at that point in the command string. If there's no \"%s\" in the 95command string, the file name will be appended to the command string 96before executing. 97 98There are several user variables to tailor the behaviour of gnus-uu to 99your needs. First we have `gnus-uu-user-view-rules', which is the 100variable gnus-uu first consults when trying to decide how to view a 101file. If this variable contains no matches, gnus-uu examines the 102default rule variable provided in this package. If gnus-uu finds no 103match here, it uses `gnus-uu-user-view-rules-end' to try to make a 104match." 105 :group 'gnus-extract-view 106 :type '(repeat (group regexp (string :tag "Command")))) 107 108(defcustom gnus-uu-user-view-rules nil 109 "What actions are to be taken to view a file. 110See the documentation on the `gnus-uu-default-view-rules' variable for 111details." 112 :group 'gnus-extract-view 113 :type '(repeat (group regexp (string :tag "Command")))) 114 115(defcustom gnus-uu-user-view-rules-end 116 '(("" "file")) 117 "*What actions are to be taken if no rule matched the file name. 118See the documentation on the `gnus-uu-default-view-rules' variable for 119details." 120 :group 'gnus-extract-view 121 :type '(repeat (group regexp (string :tag "Command")))) 122 123;; Default unpacking commands 124 125(defcustom gnus-uu-default-archive-rules 126 '(("\\.tar$" "tar xf") 127 ("\\.zip$" "unzip -o") 128 ("\\.ar$" "ar x") 129 ("\\.arj$" "unarj x") 130 ("\\.zoo$" "zoo -e") 131 ("\\.\\(lzh\\|lha\\)$" "lha x") 132 ("\\.Z$" "uncompress") 133 ("\\.gz$" "gunzip") 134 ("\\.arc$" "arc -x")) 135 "*See `gnus-uu-user-archive-rules'." 136 :group 'gnus-extract-archive 137 :type '(repeat (group regexp (string :tag "Command")))) 138 139(defvar gnus-uu-destructive-archivers 140 (list "uncompress" "gunzip")) 141 142(defcustom gnus-uu-user-archive-rules nil 143 "A list that can be set to override the default archive unpacking commands. 144To use, for instance, 'untar' to unpack tar files and 'zip -x' to 145unpack zip files, say the following: 146 (setq gnus-uu-user-archive-rules 147 '((\"\\\\.tar$\" \"untar\") 148 (\"\\\\.zip$\" \"zip -x\")))" 149 :group 'gnus-extract-archive 150 :type '(repeat (group regexp (string :tag "Command")))) 151 152(defcustom gnus-uu-ignore-files-by-name nil 153 "*A regular expression saying what files should not be viewed based on name. 154If, for instance, you want gnus-uu to ignore all .au and .wav files, 155you could say something like 156 157 (setq gnus-uu-ignore-files-by-name \"\\\\.au$\\\\|\\\\.wav$\") 158 159Note that this variable can be used in conjunction with the 160`gnus-uu-ignore-files-by-type' variable." 161 :group 'gnus-extract 162 :type '(choice (const :tag "off" nil) 163 (regexp :format "%v"))) 164 165(defcustom gnus-uu-ignore-files-by-type nil 166 "*A regular expression saying what files that shouldn't be viewed, based on MIME file type. 167If, for instance, you want gnus-uu to ignore all audio files and all mpegs, 168you could say something like 169 170 (setq gnus-uu-ignore-files-by-type \"audio/\\\\|video/mpeg\") 171 172Note that this variable can be used in conjunction with the 173`gnus-uu-ignore-files-by-name' variable." 174 :group 'gnus-extract 175 :type '(choice (const :tag "off" nil) 176 (regexp :format "%v"))) 177 178;; Pseudo-MIME support 179 180(defconst gnus-uu-ext-to-mime-list 181 '(("\\.gif$" "image/gif") 182 ("\\.jpe?g$" "image/jpeg") 183 ("\\.tiff?$" "image/tiff") 184 ("\\.xwd$" "image/xwd") 185 ("\\.pbm$" "image/pbm") 186 ("\\.pgm$" "image/pgm") 187 ("\\.ppm$" "image/ppm") 188 ("\\.xbm$" "image/xbm") 189 ("\\.pcx$" "image/pcx") 190 ("\\.tga$" "image/tga") 191 ("\\.ps$" "image/postscript") 192 ("\\.fli$" "video/fli") 193 ("\\.wav$" "audio/wav") 194 ("\\.aiff$" "audio/aiff") 195 ("\\.hcom$" "audio/hcom") 196 ("\\.voc$" "audio/voc") 197 ("\\.smp$" "audio/smp") 198 ("\\.mod$" "audio/mod") 199 ("\\.dvi$" "image/dvi") 200 ("\\.mpe?g$" "video/mpeg") 201 ("\\.au$" "audio/basic") 202 ("\\.\\(te?xt\\|doc\\|c\\|h\\)$" "text/plain") 203 ("\\.\\(c\\|h\\)$" "text/source") 204 ("read.*me" "text/plain") 205 ("\\.html$" "text/html") 206 ("\\.bat$" "text/bat") 207 ("\\.[1-6]$" "text/man") 208 ("\\.flc$" "video/flc") 209 ("\\.rle$" "video/rle") 210 ("\\.pfx$" "video/pfx") 211 ("\\.avi$" "video/avi") 212 ("\\.sme$" "video/sme") 213 ("\\.rpza$" "video/prza") 214 ("\\.dl$" "video/dl") 215 ("\\.qt$" "video/qt") 216 ("\\.rsrc$" "video/rsrc") 217 ("\\..*$" "unknown/unknown"))) 218 219;; Various variables users may set 220 221(defcustom gnus-uu-tmp-dir 222 (cond ((fboundp 'temp-directory) (temp-directory)) 223 ((boundp 'temporary-file-directory) temporary-file-directory) 224 ("/tmp/")) 225 "*Variable saying where gnus-uu is to do its work. 226Default is \"/tmp/\"." 227 :group 'gnus-extract 228 :type 'directory) 229 230(defcustom gnus-uu-do-not-unpack-archives nil 231 "*Non-nil means that gnus-uu won't peek inside archives looking for files to display. 232Default is nil." 233 :group 'gnus-extract-archive 234 :type 'boolean) 235 236(defcustom gnus-uu-ignore-default-view-rules nil 237 "*Non-nil means that gnus-uu will ignore the default viewing rules. 238Only the user viewing rules will be consulted. Default is nil." 239 :group 'gnus-extract-view 240 :type 'boolean) 241 242(defcustom gnus-uu-grabbed-file-functions nil 243 "Functions run on each file after successful decoding. 244They will be called with the name of the file as the argument. 245Likely functions you can use in this list are `gnus-uu-grab-view' 246and `gnus-uu-grab-move'." 247 :group 'gnus-extract 248 :options '(gnus-uu-grab-view gnus-uu-grab-move) 249 :type 'hook) 250 251(defcustom gnus-uu-ignore-default-archive-rules nil 252 "*Non-nil means that gnus-uu will ignore the default archive unpacking commands. 253Only the user unpacking commands will be consulted. Default is nil." 254 :group 'gnus-extract-archive 255 :type 'boolean) 256 257(defcustom gnus-uu-kill-carriage-return t 258 "*Non-nil means that gnus-uu will strip all carriage returns from articles. 259Default is t." 260 :group 'gnus-extract 261 :type 'boolean) 262 263(defcustom gnus-uu-view-with-metamail nil 264 "*Non-nil means that files will be viewed with metamail. 265The gnus-uu viewing functions will be ignored and gnus-uu will try 266to guess at a content-type based on file name suffixes. Default 267it nil." 268 :group 'gnus-extract 269 :type 'boolean) 270 271(defcustom gnus-uu-unmark-articles-not-decoded nil 272 "*Non-nil means that gnus-uu will mark articles that were unsuccessfully decoded as unread. 273Default is nil." 274 :group 'gnus-extract 275 :type 'boolean) 276 277(defcustom gnus-uu-correct-stripped-uucode nil 278 "*Non-nil means that gnus-uu will *try* to fix uuencoded files that have had trailing spaces deleted. 279Default is nil." 280 :group 'gnus-extract 281 :type 'boolean) 282 283(defcustom gnus-uu-save-in-digest nil 284 "*Non-nil means that gnus-uu, when asked to save without decoding, will save in digests. 285If this variable is nil, gnus-uu will just save everything in a 286file without any embellishments. The digesting almost conforms to RFC1153 - 287no easy way to specify any meaningful volume and issue numbers were found, 288so I simply dropped them." 289 :group 'gnus-extract 290 :type 'boolean) 291 292(defcustom gnus-uu-pre-uudecode-hook nil 293 "Hook run before sending a message to uudecode." 294 :group 'gnus-extract 295 :type 'hook) 296 297(defcustom gnus-uu-digest-headers 298 '("^Date:" "^From:" "^To:" "^Cc:" "^Subject:" "^Message-ID:" "^Keywords:" 299 "^Summary:" "^References:" "^Content-Type:" "^Content-Transfer-Encoding:" 300 "^MIME-Version:" "^Content-Disposition:" "^Content-Description:" 301 "^Content-ID:") 302 "*List of regexps to match headers included in digested messages. 303The headers will be included in the sequence they are matched. If nil 304include all headers." 305 :group 'gnus-extract 306 :type '(repeat regexp)) 307 308(defcustom gnus-uu-save-separate-articles nil 309 "*Non-nil means that gnus-uu will save articles in separate files." 310 :group 'gnus-extract 311 :type 'boolean) 312 313(defcustom gnus-uu-be-dangerous 'ask 314 "*Specifies what to do if unusual situations arise during decoding. 315If nil, be as conservative as possible. If t, ignore things that 316didn't work, and overwrite existing files. Otherwise, ask each time." 317 :group 'gnus-extract 318 :type '(choice (const :tag "conservative" nil) 319 (const :tag "ask" ask) 320 (const :tag "liberal" t))) 321 322;; Internal variables 323 324(defvar gnus-uu-saved-article-name nil) 325 326(defvar gnus-uu-begin-string "^begin[ \t]+0?[0-7][0-7][0-7][ \t]+\\(.*\\)$") 327(defvar gnus-uu-end-string "^end[ \t]*$") 328 329(defvar gnus-uu-body-line "^M") 330(let ((i 61)) 331 (while (> (setq i (1- i)) 0) 332 (setq gnus-uu-body-line (concat gnus-uu-body-line "[^a-z]"))) 333 (setq gnus-uu-body-line (concat gnus-uu-body-line ".?$"))) 334 335;"^M.............................................................?$" 336 337(defvar gnus-uu-shar-begin-string "^#! */bin/sh") 338 339(defvar gnus-uu-shar-file-name nil) 340(defvar gnus-uu-shar-name-marker 341 "begin 0?[0-7][0-7][0-7][ \t]+\\(\\(\\w\\|[.\\:]\\)*\\b\\)") 342 343(defvar gnus-uu-postscript-begin-string "^%!PS-") 344(defvar gnus-uu-postscript-end-string "^%%EOF$") 345 346(defvar gnus-uu-file-name nil) 347(defvar gnus-uu-uudecode-process nil) 348(defvar gnus-uu-binhex-article-name nil) 349 350(defvar gnus-uu-work-dir nil) 351 352(defvar gnus-uu-output-buffer-name " *Gnus UU Output*") 353 354(defvar gnus-uu-default-dir gnus-article-save-directory) 355(defvar gnus-uu-digest-from-subject nil) 356(defvar gnus-uu-digest-buffer nil) 357 358;; Commands. 359 360(defun gnus-uu-decode-uu (&optional n) 361 "Uudecodes the current article." 362 (interactive "P") 363 (gnus-uu-decode-with-method 'gnus-uu-uustrip-article n)) 364 365(defun gnus-uu-decode-uu-and-save (n dir) 366 "Decodes and saves the resulting file." 367 (interactive 368 (list current-prefix-arg 369 (file-name-as-directory 370 (read-file-name "Uudecode and save in dir: " 371 gnus-uu-default-dir 372 gnus-uu-default-dir t)))) 373 (gnus-uu-decode-with-method 'gnus-uu-uustrip-article n dir nil nil t)) 374 375(defun gnus-uu-decode-unshar (&optional n) 376 "Unshars the current article." 377 (interactive "P") 378 (gnus-uu-decode-with-method 'gnus-uu-unshar-article n nil nil 'scan t)) 379 380(defun gnus-uu-decode-unshar-and-save (n dir) 381 "Unshars and saves the current article." 382 (interactive 383 (list current-prefix-arg 384 (file-name-as-directory 385 (read-file-name "Unshar and save in dir: " 386 gnus-uu-default-dir 387 gnus-uu-default-dir t)))) 388 (gnus-uu-decode-with-method 'gnus-uu-unshar-article n dir nil 'scan t)) 389 390(defun gnus-uu-decode-save (n file) 391 "Saves the current article." 392 (interactive 393 (list current-prefix-arg 394 (read-file-name 395 (if gnus-uu-save-separate-articles 396 "Save articles is dir: " 397 "Save articles in file: ") 398 gnus-uu-default-dir 399 gnus-uu-default-dir))) 400 (setq gnus-uu-saved-article-name file) 401 (gnus-uu-decode-with-method 'gnus-uu-save-article n nil t)) 402 403(defun gnus-uu-decode-binhex (n dir) 404 "Unbinhexes the current article." 405 (interactive 406 (list current-prefix-arg 407 (file-name-as-directory 408 (read-file-name "Unbinhex and save in dir: " 409 gnus-uu-default-dir 410 gnus-uu-default-dir)))) 411 (setq gnus-uu-binhex-article-name 412 (mm-make-temp-file (expand-file-name "binhex" gnus-uu-work-dir))) 413 (gnus-uu-decode-with-method 'gnus-uu-binhex-article n dir)) 414 415(defun gnus-uu-decode-uu-view (&optional n) 416 "Uudecodes and views the current article." 417 (interactive "P") 418 (let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic))) 419 (gnus-uu-decode-uu n))) 420 421(defun gnus-uu-decode-uu-and-save-view (n dir) 422 "Decodes, views and saves the resulting file." 423 (interactive 424 (list current-prefix-arg 425 (read-file-name "Uudecode, view and save in dir: " 426 gnus-uu-default-dir 427 gnus-uu-default-dir t))) 428 (let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic))) 429 (gnus-uu-decode-uu-and-save n dir))) 430 431(defun gnus-uu-decode-unshar-view (&optional n) 432 "Unshars and views the current article." 433 (interactive "P") 434 (let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic))) 435 (gnus-uu-decode-unshar n))) 436 437(defun gnus-uu-decode-unshar-and-save-view (n dir) 438 "Unshars and saves the current article." 439 (interactive 440 (list current-prefix-arg 441 (read-file-name "Unshar, view and save in dir: " 442 gnus-uu-default-dir 443 gnus-uu-default-dir t))) 444 (let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic))) 445 (gnus-uu-decode-unshar-and-save n dir))) 446 447(defun gnus-uu-decode-save-view (n file) 448 "Saves and views the current article." 449 (interactive 450 (list current-prefix-arg 451 (read-file-name (if gnus-uu-save-separate-articles 452 "Save articles is dir: " 453 "Save articles in file: ") 454 gnus-uu-default-dir gnus-uu-default-dir))) 455 (let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic))) 456 (gnus-uu-decode-save n file))) 457 458(defun gnus-uu-decode-binhex-view (n file) 459 "Unbinhexes and views the current article." 460 (interactive 461 (list current-prefix-arg 462 (read-file-name "Unbinhex, view and save in dir: " 463 gnus-uu-default-dir gnus-uu-default-dir))) 464 (setq gnus-uu-binhex-article-name 465 (mm-make-temp-file (expand-file-name "binhex" gnus-uu-work-dir))) 466 (let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic))) 467 (gnus-uu-decode-binhex n file))) 468 469 470;; Digest and forward articles 471 472(defun gnus-uu-digest-mail-forward (&optional n post) 473 "Digests and forwards all articles in this series." 474 (interactive "P") 475 (let ((gnus-uu-save-in-digest t) 476 (file (mm-make-temp-file (nnheader-concat gnus-uu-tmp-dir "forward"))) 477 (message-forward-as-mime message-forward-as-mime) 478 (mail-parse-charset gnus-newsgroup-charset) 479 (mail-parse-ignored-charsets gnus-newsgroup-ignored-charsets) 480 gnus-uu-digest-buffer subject from) 481 (if (and n (not (numberp n))) 482 (setq message-forward-as-mime (not message-forward-as-mime) 483 n nil)) 484 (let ((gnus-article-reply (gnus-summary-work-articles n))) 485 (gnus-setup-message 'forward 486 (setq gnus-uu-digest-from-subject nil) 487 (setq gnus-uu-digest-buffer 488 (gnus-get-buffer-create " *gnus-uu-forward*")) 489 (gnus-uu-decode-save n file) 490 (switch-to-buffer gnus-uu-digest-buffer) 491 (let ((fs gnus-uu-digest-from-subject)) 492 (when fs 493 (setq from (caar fs) 494 subject (gnus-simplify-subject-fuzzy (cdar fs)) 495 fs (cdr fs)) 496 (while (and fs (or from subject)) 497 (when from 498 (unless (string= from (caar fs)) 499 (setq from nil))) 500 (when subject 501 (unless (string= (gnus-simplify-subject-fuzzy (cdar fs)) 502 subject) 503 (setq subject nil))) 504 (setq fs (cdr fs)))) 505 (unless subject 506 (setq subject "Digested Articles")) 507 (unless from 508 (setq from 509 (if (gnus-news-group-p gnus-newsgroup-name) 510 gnus-newsgroup-name 511 "Various")))) 512 (goto-char (point-min)) 513 (when (re-search-forward "^Subject: ") 514 (delete-region (point) (gnus-point-at-eol)) 515 (insert subject)) 516 (goto-char (point-min)) 517 (when (re-search-forward "^From:") 518 (delete-region (point) (gnus-point-at-eol)) 519 (insert " " from)) 520 (let ((message-forward-decoded-p t)) 521 (message-forward post t)))) 522 (setq gnus-uu-digest-from-subject nil))) 523 524(defun gnus-uu-digest-post-forward (&optional n) 525 "Digest and forward to a newsgroup." 526 (interactive "P") 527 (gnus-uu-digest-mail-forward n t)) 528 529;; Process marking. 530 531(defun gnus-message-process-mark (unmarkp new-marked) 532 (let ((old (- (length gnus-newsgroup-processable) (length new-marked)))) 533 (message "%d mark%s %s%s" 534 (length new-marked) 535 (if (= (length new-marked) 1) "" "s") 536 (if unmarkp "removed" "added") 537 (cond 538 ((and (zerop old) 539 (not unmarkp)) 540 "") 541 (unmarkp 542 (format ", %d remain marked" 543 (length gnus-newsgroup-processable))) 544 (t 545 (format ", %d already marked" old)))))) 546 547(defun gnus-new-processable (unmarkp articles) 548 (if unmarkp 549 (gnus-intersection gnus-newsgroup-processable articles) 550 (gnus-set-difference articles gnus-newsgroup-processable))) 551 552(defun gnus-uu-mark-by-regexp (regexp &optional unmark) 553 "Set the process mark on articles whose subjects match REGEXP. 554When called interactively, prompt for REGEXP. 555Optional UNMARK non-nil means unmark instead of mark." 556 (interactive "sMark (regexp): \nP") 557 (save-excursion 558 (let* ((articles (gnus-uu-find-articles-matching regexp)) 559 (new-marked (gnus-new-processable unmark articles))) 560 (while articles 561 (if unmark 562 (gnus-summary-remove-process-mark (pop articles)) 563 (gnus-summary-set-process-mark (pop articles)))) 564 (gnus-message-process-mark unmark new-marked))) 565 (gnus-summary-position-point)) 566 567(defun gnus-uu-unmark-by-regexp (regexp) 568 "Remove the process mark from articles whose subjects match REGEXP. 569When called interactively, prompt for REGEXP." 570 (interactive "sUnmark (regexp): ") 571 (gnus-uu-mark-by-regexp regexp t)) 572 573(defun gnus-uu-mark-series () 574 "Mark the current series with the process mark." 575 (interactive) 576 (let* ((articles (gnus-uu-find-articles-matching)) 577 (l (length articles))) 578 (while articles 579 (gnus-summary-set-process-mark (car articles)) 580 (setq articles (cdr articles))) 581 (message "Marked %d articles" l)) 582 (gnus-summary-position-point)) 583 584(defun gnus-uu-mark-region (beg end &optional unmark) 585 "Set the process mark on all articles between point and mark." 586 (interactive "r") 587 (save-excursion 588 (goto-char beg) 589 (while (< (point) end) 590 (if unmark 591 (gnus-summary-remove-process-mark (gnus-summary-article-number)) 592 (gnus-summary-set-process-mark (gnus-summary-article-number))) 593 (forward-line 1))) 594 (gnus-summary-position-point)) 595 596(defun gnus-uu-unmark-region (beg end) 597 "Remove the process mark from all articles between point and mark." 598 (interactive "r") 599 (gnus-uu-mark-region beg end t)) 600 601(defun gnus-uu-mark-buffer () 602 "Set the process mark on all articles in the buffer." 603 (interactive) 604 (gnus-uu-mark-region (point-min) (point-max))) 605 606(defun gnus-uu-unmark-buffer () 607 "Remove the process mark on all articles in the buffer." 608 (interactive) 609 (gnus-uu-mark-region (point-min) (point-max) t)) 610 611(defun gnus-uu-mark-thread () 612 "Marks all articles downwards in this thread." 613 (interactive) 614 (gnus-save-hidden-threads 615 (let ((level (gnus-summary-thread-level))) 616 (while (and (gnus-summary-set-process-mark 617 (gnus-summary-article-number)) 618 (zerop (gnus-summary-next-subject 1 nil t)) 619 (> (gnus-summary-thread-level) level))))) 620 (gnus-summary-position-point)) 621 622(defun gnus-uu-unmark-thread () 623 "Unmarks all articles downwards in this thread." 624 (interactive) 625 (let ((level (gnus-summary-thread-level))) 626 (while (and (gnus-summary-remove-process-mark 627 (gnus-summary-article-number)) 628 (zerop (gnus-summary-next-subject 1)) 629 (> (gnus-summary-thread-level) level)))) 630 (gnus-summary-position-point)) 631 632(defun gnus-uu-invert-processable () 633 "Invert the list of process-marked articles." 634 (interactive) 635 (let ((data gnus-newsgroup-data) 636 number) 637 (save-excursion 638 (while data 639 (if (memq (setq number (gnus-data-number (pop data))) 640 gnus-newsgroup-processable) 641 (gnus-summary-remove-process-mark number) 642 (gnus-summary-set-process-mark number))))) 643 (gnus-summary-position-point)) 644 645(defun gnus-uu-mark-over (&optional score) 646 "Mark all articles with a score over SCORE (the prefix)." 647 (interactive "P") 648 (let ((score (or score gnus-summary-default-score 0)) 649 (data gnus-newsgroup-data)) 650 (save-excursion 651 (while data 652 (when (> (or (cdr (assq (gnus-data-number (car data)) 653 gnus-newsgroup-scored)) 654 gnus-summary-default-score 0) 655 score) 656 (gnus-summary-set-process-mark (caar data))) 657 (setq data (cdr data)))) 658 (gnus-summary-position-point))) 659 660(defun gnus-uu-mark-sparse () 661 "Mark all series that have some articles marked." 662 (interactive) 663 (let ((marked (nreverse gnus-newsgroup-processable)) 664 subject articles total headers) 665 (unless marked 666 (error "No articles marked with the process mark")) 667 (setq gnus-newsgroup-processable nil) 668 (save-excursion 669 (while marked 670 (and (vectorp (setq headers 671 (gnus-summary-article-header (car marked)))) 672 (setq subject (mail-header-subject headers) 673 articles (gnus-uu-find-articles-matching 674 (gnus-uu-reginize-string subject)) 675 total (nconc total articles))) 676 (while articles 677 (gnus-summary-set-process-mark (car articles)) 678 (setcdr marked (delq (car articles) (cdr marked))) 679 (setq articles (cdr articles))) 680 (setq marked (cdr marked))) 681 (setq gnus-newsgroup-processable (nreverse total))) 682 (gnus-summary-position-point))) 683 684(defun gnus-uu-mark-all () 685 "Mark all articles in \"series\" order." 686 (interactive) 687 (setq gnus-newsgroup-processable nil) 688 (save-excursion 689 (let ((data gnus-newsgroup-data) 690 number) 691 (while data 692 (when (and (not (memq (setq number (gnus-data-number (car data))) 693 gnus-newsgroup-processable)) 694 (vectorp (gnus-data-header (car data)))) 695 (gnus-summary-goto-subject number) 696 (gnus-uu-mark-series)) 697 (setq data (cdr data))))) 698 (gnus-summary-position-point)) 699 700;; All PostScript functions written by Erik Selberg <speed@cs.washington.edu>. 701 702(defun gnus-uu-decode-postscript (&optional n) 703 "Gets postscript of the current article." 704 (interactive "P") 705 (gnus-uu-decode-with-method 'gnus-uu-decode-postscript-article n)) 706 707(defun gnus-uu-decode-postscript-view (&optional n) 708 "Gets and views the current article." 709 (interactive "P") 710 (let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic))) 711 (gnus-uu-decode-postscript n))) 712 713(defun gnus-uu-decode-postscript-and-save (n dir) 714 "Extracts postscript and saves the current article." 715 (interactive 716 (list current-prefix-arg 717 (file-name-as-directory 718 (read-file-name "Save in dir: " 719 gnus-uu-default-dir 720 gnus-uu-default-dir t)))) 721 (gnus-uu-decode-with-method 'gnus-uu-decode-postscript-article 722 n dir nil nil t)) 723 724(defun gnus-uu-decode-postscript-and-save-view (n dir) 725 "Decodes, views and saves the resulting file." 726 (interactive 727 (list current-prefix-arg 728 (read-file-name "Where do you want to save the file(s)? " 729 gnus-uu-default-dir 730 gnus-uu-default-dir t))) 731 (let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic))) 732 (gnus-uu-decode-postscript-and-save n dir))) 733 734 735;; Internal functions. 736 737(defun gnus-uu-decode-with-method (method n &optional save not-insert 738 scan cdir) 739 (gnus-uu-initialize scan) 740 (when save 741 (setq gnus-uu-default-dir save)) 742 ;; Create the directory we save to. 743 (when (and scan cdir save 744 (not (file-exists-p save))) 745 (make-directory save t)) 746 (let ((articles (gnus-uu-get-list-of-articles n)) 747 files) 748 (setq files (gnus-uu-grab-articles articles method t)) 749 (let ((gnus-current-article (car articles))) 750 (when scan 751 (setq files (gnus-uu-scan-directory gnus-uu-work-dir)))) 752 (when save 753 (gnus-uu-save-files files save)) 754 (when (eq gnus-uu-do-not-unpack-archives nil) 755 (setq files (gnus-uu-unpack-files files))) 756 (setq files (nreverse (gnus-uu-get-actions files))) 757 (or not-insert (not gnus-insert-pseudo-articles) 758 (gnus-summary-insert-pseudos files save)))) 759 760(defun gnus-uu-scan-directory (dir &optional rec) 761 "Return a list of all files under DIR." 762 (let ((files (directory-files dir t)) 763 out file) 764 (while (setq file (pop files)) 765 (unless (member (file-name-nondirectory file) '("." "..")) 766 (push (list (cons 'name file) 767 (cons 'article gnus-current-article)) 768 out) 769 (when (file-directory-p file) 770 (setq out (nconc (gnus-uu-scan-directory file t) out))))) 771 (if rec 772 out 773 (nreverse out)))) 774 775(defun gnus-uu-save-files (files dir) 776 "Save FILES in DIR." 777 (let ((len (length files)) 778 (reg (concat "^" (regexp-quote gnus-uu-work-dir))) 779 to-file file fromdir) 780 (while (setq file (cdr (assq 'name (pop files)))) 781 (when (file-exists-p file) 782 (string-match reg file) 783 (setq fromdir (substring file (match-end 0))) 784 (if (file-directory-p file) 785 (gnus-make-directory (concat dir fromdir)) 786 (setq to-file (concat dir fromdir)) 787 (when (or (not (file-exists-p to-file)) 788 (eq gnus-uu-be-dangerous t) 789 (and gnus-uu-be-dangerous 790 (gnus-y-or-n-p (format "%s exists; overwrite? " 791 to-file)))) 792 (copy-file file to-file t t))))) 793 (gnus-message 5 "Saved %d file%s" len (if (= len 1) "" "s")))) 794 795;; Functions for saving and possibly digesting articles without 796;; any decoding. 797 798;; Function called by gnus-uu-grab-articles to treat each article. 799(defun gnus-uu-save-article (buffer in-state) 800 (cond 801 (gnus-uu-save-separate-articles 802 (save-excursion 803 (set-buffer buffer) 804 (let ((coding-system-for-write mm-text-coding-system)) 805 (gnus-write-buffer 806 (concat gnus-uu-saved-article-name gnus-current-article))) 807 (cond ((eq in-state 'first) (list gnus-uu-saved-article-name 'begin)) 808 ((eq in-state 'first-and-last) (list gnus-uu-saved-article-name 809 'begin 'end)) 810 ((eq in-state 'last) (list 'end)) 811 (t (list 'middle))))) 812 ((not gnus-uu-save-in-digest) 813 (save-excursion 814 (set-buffer buffer) 815 (write-region (point-min) (point-max) gnus-uu-saved-article-name t) 816 (cond ((eq in-state 'first) (list gnus-uu-saved-article-name 'begin)) 817 ((eq in-state 'first-and-last) (list gnus-uu-saved-article-name 818 'begin 'end)) 819 ((eq in-state 'last) (list 'end)) 820 (t (list 'middle))))) 821 (t 822 (let ((header (gnus-summary-article-header))) 823 (push (cons (mail-header-from header) 824 (mail-header-subject header)) 825 gnus-uu-digest-from-subject)) 826 (let ((name (file-name-nondirectory gnus-uu-saved-article-name)) 827 beg subj headers headline sorthead body end-string state) 828 (if (or (eq in-state 'first) 829 (eq in-state 'first-and-last)) 830 (progn 831 (setq state (list 'begin)) 832 (save-excursion 833 (set-buffer (gnus-get-buffer-create "*gnus-uu-body*")) 834 (erase-buffer)) 835 (save-excursion 836 (set-buffer (gnus-get-buffer-create "*gnus-uu-pre*")) 837 (erase-buffer) 838 (insert (format 839 "Date: %s\nFrom: %s\nSubject: %s Digest\n\n" 840 (message-make-date) name name)) 841 (when (and message-forward-as-mime gnus-uu-digest-buffer) 842 (insert 843 "<#mml type=message/rfc822>\nSubject: Topics\n\n<#/mml>\n") 844 (forward-line -1)) 845 (insert "Topics:\n"))) 846 (when (not (eq in-state 'end)) 847 (setq state (list 'middle)))) 848 (save-excursion 849 (set-buffer "*gnus-uu-body*") 850 (goto-char (setq beg (point-max))) 851 (save-excursion 852 (save-restriction 853 (set-buffer buffer) 854 (let (buffer-read-only) 855 (gnus-set-text-properties (point-min) (point-max) nil) 856 ;; These two are necessary for XEmacs 19.12 fascism. 857 (put-text-property (point-min) (point-max) 'invisible nil) 858 (put-text-property (point-min) (point-max) 'intangible nil)) 859 (when (and message-forward-as-mime 860 message-forward-show-mml 861 gnus-uu-digest-buffer) 862 (mm-enable-multibyte) 863 (mime-to-mml)) 864 (goto-char (point-min)) 865 (re-search-forward "\n\n") 866 (unless (and message-forward-as-mime gnus-uu-digest-buffer) 867 ;; Quote all 30-dash lines. 868 (save-excursion 869 (while (re-search-forward "^-" nil t) 870 (beginning-of-line) 871 (delete-char 1) 872 (insert "- ")))) 873 (setq body (buffer-substring (1- (point)) (point-max))) 874 (narrow-to-region (point-min) (point)) 875 (if (not (setq headers gnus-uu-digest-headers)) 876 (setq sorthead (buffer-string)) 877 (while headers 878 (setq headline (car headers)) 879 (setq headers (cdr headers)) 880 (goto-char (point-min)) 881 (while (re-search-forward headline nil t) 882 (setq sorthead 883 (concat sorthead 884 (buffer-substring 885 (match-beginning 0) 886 (or (and (re-search-forward "^[^ \t]" nil t) 887 (1- (point))) 888 (progn (forward-line 1) (point))))))))) 889 (widen))) 890 (if (and message-forward-as-mime gnus-uu-digest-buffer) 891 (if message-forward-show-mml 892 (progn 893 (insert "\n<#mml type=message/rfc822>\n") 894 (insert sorthead) (goto-char (point-max)) 895 (insert body) (goto-char (point-max)) 896 (insert "\n<#/mml>\n")) 897 (let ((buf (mml-generate-new-buffer " *mml*"))) 898 (with-current-buffer buf 899 (insert sorthead) 900 (goto-char (point-min)) 901 (when (re-search-forward "^Subject: \\(.*\\)$" nil t) 902 (setq subj (buffer-substring (match-beginning 1) 903 (match-end 1)))) 904 (goto-char (point-max)) 905 (insert body)) 906 (insert "\n<#part type=message/rfc822" 907 " buffer=\"" (buffer-name buf) "\">\n"))) 908 (insert sorthead) (goto-char (point-max)) 909 (insert body) (goto-char (point-max)) 910 (insert (concat "\n" (make-string 30 ?-) "\n\n"))) 911 (goto-char beg) 912 (when (re-search-forward "^Subject: \\(.*\\)$" nil t) 913 (setq subj (buffer-substring (match-beginning 1) (match-end 1)))) 914 (when subj 915 (save-excursion 916 (set-buffer "*gnus-uu-pre*") 917 (insert (format " %s\n" subj))))) 918 (when (or (eq in-state 'last) 919 (eq in-state 'first-and-last)) 920 (if (and message-forward-as-mime gnus-uu-digest-buffer) 921 (with-current-buffer gnus-uu-digest-buffer 922 (erase-buffer) 923 (insert-buffer-substring "*gnus-uu-pre*") 924 (goto-char (point-max)) 925 (insert-buffer-substring "*gnus-uu-body*")) 926 (save-excursion 927 (set-buffer "*gnus-uu-pre*") 928 (insert (format "\n\n%s\n\n" (make-string 70 ?-))) 929 (if gnus-uu-digest-buffer 930 (with-current-buffer gnus-uu-digest-buffer 931 (erase-buffer) 932 (insert-buffer-substring "*gnus-uu-pre*")) 933 (let ((coding-system-for-write mm-text-coding-system)) 934 (gnus-write-buffer gnus-uu-saved-article-name)))) 935 (save-excursion 936 (set-buffer "*gnus-uu-body*") 937 (goto-char (point-max)) 938 (insert 939 (concat (setq end-string (format "End of %s Digest" name)) 940 "\n")) 941 (insert (concat (make-string (length end-string) ?*) "\n")) 942 (if gnus-uu-digest-buffer 943 (with-current-buffer gnus-uu-digest-buffer 944 (goto-char (point-max)) 945 (insert-buffer-substring "*gnus-uu-body*")) 946 (let ((coding-system-for-write mm-text-coding-system) 947 (file-name-coding-system nnmail-pathname-coding-system)) 948 (write-region 949 (point-min) (point-max) gnus-uu-saved-article-name t))))) 950 (gnus-kill-buffer "*gnus-uu-pre*") 951 (gnus-kill-buffer "*gnus-uu-body*") 952 (push 'end state)) 953 (if (memq 'begin state) 954 (cons gnus-uu-saved-article-name state) 955 state))))) 956 957;; Binhex treatment - not very advanced. 958 959(defvar gnus-uu-binhex-body-line 960 "^[^:]...............................................................$") 961(defvar gnus-uu-binhex-begin-line 962 "^:...............................................................$") 963(defvar gnus-uu-binhex-end-line 964 ":$") 965 966(defun gnus-uu-binhex-article (buffer in-state) 967 (let (state start-char) 968 (save-excursion 969 (set-buffer buffer) 970 (widen) 971 (goto-char (point-min)) 972 (when (not (re-search-forward gnus-uu-binhex-begin-line nil t)) 973 (when (not (re-search-forward gnus-uu-binhex-body-line nil t)) 974 (setq state (list 'wrong-type)))) 975 976 (if (memq 'wrong-type state) 977 () 978 (beginning-of-line) 979 (setq start-char (point)) 980 (if (looking-at gnus-uu-binhex-begin-line) 981 (progn 982 (setq state (list 'begin)) 983 (write-region (point-min) (point-min) 984 gnus-uu-binhex-article-name)) 985 (setq state (list 'middle))) 986 (goto-char (point-max)) 987 (re-search-backward (concat gnus-uu-binhex-body-line "\\|" 988 gnus-uu-binhex-end-line) 989 nil t) 990 (when (looking-at gnus-uu-binhex-end-line) 991 (setq state (if (memq 'begin state) 992 (cons 'end state) 993 (list 'end)))) 994 (beginning-of-line) 995 (forward-line 1) 996 (when (file-exists-p gnus-uu-binhex-article-name) 997 (mm-append-to-file start-char (point) gnus-uu-binhex-article-name)))) 998 (if (memq 'begin state) 999 (cons gnus-uu-binhex-article-name state) 1000 state))) 1001 1002;; PostScript 1003 1004(defun gnus-uu-decode-postscript-article (process-buffer in-state) 1005 (let ((state (list 'ok)) 1006 start-char end-char file-name) 1007 (save-excursion 1008 (set-buffer process-buffer) 1009 (goto-char (point-min)) 1010 (if (not (re-search-forward gnus-uu-postscript-begin-string nil t)) 1011 (setq state (list 'wrong-type)) 1012 (beginning-of-line) 1013 (setq start-char (point)) 1014 (if (not (re-search-forward gnus-uu-postscript-end-string nil t)) 1015 (setq state (list 'wrong-type)) 1016 (setq end-char (point)) 1017 (set-buffer (gnus-get-buffer-create gnus-uu-output-buffer-name)) 1018 (insert-buffer-substring process-buffer start-char end-char) 1019 (setq file-name (concat gnus-uu-work-dir 1020 (cdr gnus-article-current) ".ps")) 1021 (write-region (point-min) (point-max) file-name) 1022 (setq state (list file-name 'begin 'end))))) 1023 state)) 1024 1025 1026;; Find actions. 1027 1028(defun gnus-uu-get-actions (files) 1029 (let ((ofiles files) 1030 action name) 1031 (while files 1032 (setq name (cdr (assq 'name (car files)))) 1033 (and 1034 (setq action (gnus-uu-get-action name)) 1035 (setcar files (nconc (list (if (string= action "gnus-uu-archive") 1036 (cons 'action "file") 1037 (cons 'action action)) 1038 (cons 'execute (gnus-uu-command 1039 action name))) 1040 (car files)))) 1041 (setq files (cdr files))) 1042 ofiles)) 1043 1044(defun gnus-uu-get-action (file-name) 1045 (let (action) 1046 (setq action 1047 (gnus-uu-choose-action 1048 file-name 1049 (append 1050 gnus-uu-user-view-rules 1051 (if gnus-uu-ignore-default-view-rules 1052 nil 1053 gnus-uu-default-view-rules) 1054 gnus-uu-user-view-rules-end))) 1055 (when (and (not (string= (or action "") "gnus-uu-archive")) 1056 gnus-uu-view-with-metamail) 1057 (when (setq action 1058 (gnus-uu-choose-action file-name gnus-uu-ext-to-mime-list)) 1059 (setq action (format "metamail -d -b -c \"%s\"" action)))) 1060 action)) 1061 1062 1063;; Functions for treating subjects and collecting series. 1064 1065(defun gnus-uu-reginize-string (string) 1066 ;; Takes a string and puts a \ in front of every special character; 1067 ;; replaces the last thing that looks like "2/3" with "[0-9]+/3" 1068 ;; or, if it can't find something like that, tries "2 of 3", then 1069 ;; finally just replaces the next to last number with "[0-9]+". 1070 (save-excursion 1071 (set-buffer (gnus-get-buffer-create gnus-uu-output-buffer-name)) 1072 (buffer-disable-undo) 1073 (erase-buffer) 1074 (insert (regexp-quote string)) 1075 1076 (setq case-fold-search nil) 1077 1078 (end-of-line) 1079 (if (re-search-backward "\\([^0-9]\\)[0-9]+/\\([0-9]+\\)" nil t) 1080 (replace-match "\\1[0-9]+/\\2") 1081 1082 (end-of-line) 1083 (if (re-search-backward "\\([^0-9]\\)[0-9]+[ \t]*of[ \t]*\\([0-9]+\\)" 1084 nil t) 1085 (replace-match "\\1[0-9]+ of \\2") 1086 1087 (end-of-line) 1088 (if (re-search-backward "\\([^0-9]\\)[0-9]+\\([^0-9]+\\)[0-9]+" 1089 nil t) 1090 (replace-match "\\1[0-9]+\\2[0-9]+" t nil nil nil)))) 1091 1092 (goto-char 1) 1093 (while (re-search-forward "[ \t]+" nil t) 1094 (replace-match "[ \t]+" t t)) 1095 1096 (buffer-string))) 1097 1098(defun gnus-uu-get-list-of-articles (n) 1099 ;; If N is non-nil, the article numbers of the N next articles 1100 ;; will be returned. 1101 ;; If any articles have been marked as processable, they will be 1102 ;; returned. 1103 ;; Failing that, articles that have subjects that are part of the 1104 ;; same "series" as the current will be returned. 1105 (let (articles) 1106 (cond 1107 (n 1108 (setq n (prefix-numeric-value n)) 1109 (let ((backward (< n 0)) 1110 (n (abs n))) 1111 (save-excursion 1112 (while (and (> n 0) 1113 (push (gnus-summary-article-number) 1114 articles) 1115 (gnus-summary-search-forward nil nil backward)) 1116 (setq n (1- n)))) 1117 (nreverse articles))) 1118 (gnus-newsgroup-processable 1119 (reverse gnus-newsgroup-processable)) 1120 (t 1121 (gnus-uu-find-articles-matching))))) 1122 1123(defun gnus-uu-string< (l1 l2) 1124 (string< (car l1) (car l2))) 1125 1126(defun gnus-uu-find-articles-matching 1127 (&optional subject only-unread do-not-translate) 1128 ;; Finds all articles that matches the regexp SUBJECT. If it is 1129 ;; nil, the current article name will be used. If ONLY-UNREAD is 1130 ;; non-nil, only unread articles are chosen. If DO-NOT-TRANSLATE is 1131 ;; non-nil, article names are not equalized before sorting. 1132 (let ((subject (or subject 1133 (gnus-uu-reginize-string (gnus-summary-article-subject)))) 1134 list-of-subjects) 1135 (save-excursion 1136 (when subject 1137 ;; Collect all subjects matching subject. 1138 (let ((case-fold-search t) 1139 (data gnus-newsgroup-data) 1140 subj mark d) 1141 (while data 1142 (setq d (pop data)) 1143 (and (not (gnus-data-pseudo-p d)) 1144 (or (not only-unread) 1145 (= (setq mark (gnus-data-mark d)) 1146 gnus-unread-mark) 1147 (= mark gnus-ticked-mark) 1148 (= mark gnus-dormant-mark)) 1149 (setq subj (mail-header-subject (gnus-data-header d))) 1150 (string-match subject subj) 1151 (push (cons subj (gnus-data-number d)) 1152 list-of-subjects)))) 1153 1154 ;; Expand numbers, sort, and return the list of article 1155 ;; numbers. 1156 (mapcar (lambda (sub) (cdr sub)) 1157 (sort (gnus-uu-expand-numbers 1158 list-of-subjects 1159 (not do-not-translate)) 1160 'gnus-uu-string<)))))) 1161 1162(defun gnus-uu-expand-numbers (string-list &optional translate) 1163 ;; Takes a list of strings and "expands" all numbers in all the 1164 ;; strings. That is, this function makes all numbers equal length by 1165 ;; prepending lots of zeroes before each number. This is to ease later 1166 ;; sorting to find out what sequence the articles are supposed to be 1167 ;; decoded in. Returns the list of expanded strings. 1168 (let ((out-list string-list) 1169 string) 1170 (save-excursion 1171 (set-buffer (gnus-get-buffer-create gnus-uu-output-buffer-name)) 1172 (buffer-disable-undo) 1173 (while string-list 1174 (erase-buffer) 1175 (insert (caar string-list)) 1176 ;; Translate multiple spaces to one space. 1177 (goto-char (point-min)) 1178 (while (re-search-forward "[ \t]+" nil t) 1179 (replace-match " ")) 1180 ;; Translate all characters to "a". 1181 (goto-char (point-min)) 1182 (when translate 1183 (while (re-search-forward "[A-Za-z]" nil t) 1184 (replace-match "a" t t))) 1185 ;; Expand numbers. 1186 (goto-char (point-min)) 1187 (while (re-search-forward "[0-9]+" nil t) 1188 (ignore-errors 1189 (replace-match 1190 (format "%06d" 1191 (string-to-number (buffer-substring 1192 (match-beginning 0) (match-end 0))))))) 1193 (setq string (buffer-substring 1 (point-max))) 1194 (setcar (car string-list) string) 1195 (setq string-list (cdr string-list)))) 1196 out-list)) 1197 1198 1199;; `gnus-uu-grab-articles' is the general multi-article treatment 1200;; function. It takes a list of articles to be grabbed and a function 1201;; to apply to each article. 1202;; 1203;; The function to be called should take two parameters. The first 1204;; parameter is the article buffer. The function should leave the 1205;; result, if any, in this buffer. Most treatment functions will just 1206;; generate files... 1207;; 1208;; The second parameter is the state of the list of articles, and can 1209;; have four values: `first', `middle', `last' and `first-and-last'. 1210;; 1211;; The function should return a list. The list may contain the 1212;; following symbols: 1213;; `error' if an error occurred 1214;; `begin' if the beginning of an encoded file has been received 1215;; If the list returned contains a `begin', the first element of 1216;; the list *must* be a string with the file name of the decoded 1217;; file. 1218;; `end' if the end of an encoded file has been received 1219;; `middle' if the article was a body part of an encoded file 1220;; `wrong-type' if the article was not a part of an encoded file 1221;; `ok', which can be used everything is ok 1222 1223(defvar gnus-uu-has-been-grabbed nil) 1224 1225(defun gnus-uu-unmark-list-of-grabbed (&optional dont-unmark-last-article) 1226 (let (art) 1227 (if (not (and gnus-uu-has-been-grabbed 1228 gnus-uu-unmark-articles-not-decoded)) 1229 () 1230 (when dont-unmark-last-article 1231 (setq art (car gnus-uu-has-been-grabbed)) 1232 (setq gnus-uu-has-been-grabbed (cdr gnus-uu-has-been-grabbed))) 1233 (while gnus-uu-has-been-grabbed 1234 (gnus-summary-tick-article (car gnus-uu-has-been-grabbed) t) 1235 (setq gnus-uu-has-been-grabbed (cdr gnus-uu-has-been-grabbed))) 1236 (when dont-unmark-last-article 1237 (setq gnus-uu-has-been-grabbed (list art)))))) 1238 1239;; This function takes a list of articles and a function to apply to 1240;; each article grabbed. 1241;; 1242;; This function returns a list of files decoded if the grabbing and 1243;; the process-function has been successful and nil otherwise. 1244(defun gnus-uu-grab-articles (articles process-function 1245 &optional sloppy limit no-errors) 1246 (let ((state 'first) 1247 (gnus-asynchronous nil) 1248 (gnus-inhibit-treatment t) 1249 has-been-begin article result-file result-files process-state 1250 gnus-summary-display-article-function 1251 gnus-article-prepare-hook gnus-display-mime-function 1252 article-series files) 1253 1254 (while (and articles 1255 (not (memq 'error process-state)) 1256 (or sloppy 1257 (not (memq 'end process-state)))) 1258 1259 (setq article (pop articles)) 1260 (when (vectorp (gnus-summary-article-header article)) 1261 (push article article-series) 1262 1263 (unless articles 1264 (if (eq state 'first) 1265 (setq state 'first-and-last) 1266 (setq state 'last))) 1267 1268 (let ((part (gnus-uu-part-number article))) 1269 (gnus-message 6 "Getting article %d%s..." 1270 article (if (string= part "") "" (concat ", " part)))) 1271 (gnus-summary-display-article article) 1272 1273 ;; Push the article to the processing function. 1274 (save-excursion 1275 (set-buffer gnus-original-article-buffer) 1276 (let ((buffer-read-only nil)) 1277 (save-excursion 1278 (set-buffer gnus-summary-buffer) 1279 (setq process-state 1280 (funcall process-function 1281 gnus-original-article-buffer state))))) 1282 1283 (gnus-summary-remove-process-mark article) 1284 1285 ;; If this is the beginning of a decoded file, we push it 1286 ;; on to a list. 1287 (when (or (memq 'begin process-state) 1288 (and (or (eq state 'first) 1289 (eq state 'first-and-last)) 1290 (memq 'ok process-state))) 1291 (when has-been-begin 1292 ;; If there is a `result-file' here, that means that the 1293 ;; file was unsuccessfully decoded, so we delete it. 1294 (when (and result-file 1295 (file-exists-p result-file) 1296 (not gnus-uu-be-dangerous) 1297 (or (eq gnus-uu-be-dangerous t) 1298 (gnus-y-or-n-p 1299 (format "Delete unsuccessfully decoded file %s? " 1300 result-file)))) 1301 (delete-file result-file))) 1302 (when (memq 'begin process-state) 1303 (setq result-file (car process-state))) 1304 (setq has-been-begin t)) 1305 1306 ;; Check whether we have decoded one complete file. 1307 (when (memq 'end process-state) 1308 (setq article-series nil) 1309 (setq has-been-begin nil) 1310 (if (stringp result-file) 1311 (setq files (list result-file)) 1312 (setq files result-file)) 1313 (setq result-file (car files)) 1314 (while files 1315 (push (list (cons 'name (pop files)) 1316 (cons 'article article)) 1317 result-files)) 1318 ;; Allow user-defined functions to be run on this file. 1319 (when gnus-uu-grabbed-file-functions 1320 (let ((funcs gnus-uu-grabbed-file-functions)) 1321 (unless (listp funcs) 1322 (setq funcs (list funcs))) 1323 (while funcs 1324 (funcall (pop funcs) result-file)))) 1325 (setq result-file nil) 1326 ;; Check whether we have decoded enough articles. 1327 (and limit (= (length result-files) limit) 1328 (setq articles nil))) 1329 1330 ;; If this is the last article to be decoded, and 1331 ;; we still haven't reached the end, then we delete 1332 ;; the partially decoded file. 1333 (and (or (eq state 'last) (eq state 'first-and-last)) 1334 (not (memq 'end process-state)) 1335 result-file 1336 (file-exists-p result-file) 1337 (not gnus-uu-be-dangerous) 1338 (or (eq gnus-uu-be-dangerous t) 1339 (gnus-y-or-n-p 1340 (format "Delete incomplete file %s? " result-file))) 1341 (delete-file result-file)) 1342 1343 ;; If this was a file of the wrong sort, then 1344 (when (and (or (memq 'wrong-type process-state) 1345 (memq 'error process-state)) 1346 gnus-uu-unmark-articles-not-decoded) 1347 (gnus-summary-tick-article article t)) 1348 1349 ;; Set the new series state. 1350 (if (and (not has-been-begin) 1351 (not sloppy) 1352 (or (memq 'end process-state) 1353 (memq 'middle process-state))) 1354 (progn 1355 (setq process-state (list 'error)) 1356 (gnus-message 2 "No begin part at the beginning") 1357 (sleep-for 2)) 1358 (setq state 'middle)))) 1359 1360 ;; When there are no result-files, then something must be wrong. 1361 (if result-files 1362 (message "") 1363 (cond 1364 ((not has-been-begin) 1365 (gnus-message 2 "Wrong type file")) 1366 ((memq 'error process-state) 1367 (gnus-message 2 "An error occurred during decoding")) 1368 ((not (or (memq 'ok process-state) 1369 (memq 'end process-state))) 1370 (gnus-message 2 "End of articles reached before end of file"))) 1371 ;; Make unsuccessfully decoded articles unread. 1372 (when gnus-uu-unmark-articles-not-decoded 1373 (while article-series 1374 (gnus-summary-tick-article (pop article-series) t)))) 1375 1376 ;; The original article buffer is hosed, shoot it down. 1377 (gnus-kill-buffer gnus-original-article-buffer) 1378 (setq gnus-current-article nil) 1379 result-files)) 1380 1381(defun gnus-uu-grab-view (file) 1382 "View FILE using the gnus-uu methods." 1383 (let ((action (gnus-uu-get-action file))) 1384 (gnus-execute-command 1385 (if (string-match "%" action) 1386 (format action file) 1387 (concat action " " file)) 1388 (eq gnus-view-pseudos 'not-confirm)))) 1389 1390(defun gnus-uu-grab-move (file) 1391 "Move FILE to somewhere." 1392 (when gnus-uu-default-dir 1393 (let ((to-file (concat (file-name-as-directory gnus-uu-default-dir) 1394 (file-name-nondirectory file)))) 1395 (rename-file file to-file) 1396 (unless (file-exists-p file) 1397 (make-symbolic-link to-file file))))) 1398 1399(defun gnus-uu-part-number (article) 1400 (let* ((header (gnus-summary-article-header article)) 1401 (subject (and header (mail-header-subject header))) 1402 (part nil)) 1403 (if subject 1404 (while (string-match "[0-9]+/[0-9]+\\|[0-9]+[ \t]+of[ \t]+[0-9]+" 1405 subject) 1406 (setq part (match-string 0 subject)) 1407 (setq subject (substring subject (match-end 0))))) 1408 (or part 1409 (while (string-match "\\([0-9]+\\)[^0-9]+\\([0-9]+\\)" subject) 1410 (setq part (match-string 0 subject)) 1411 (setq subject (substring subject (match-end 0))))) 1412 (or part ""))) 1413 1414(defun gnus-uu-uudecode-sentinel (process event) 1415 (delete-process (get-process process))) 1416 1417(defun gnus-uu-uustrip-article (process-buffer in-state) 1418 ;; Uudecodes a file asynchronously. 1419 (save-excursion 1420 (set-buffer process-buffer) 1421 (let ((state (list 'wrong-type)) 1422 process-connection-type case-fold-search buffer-read-only 1423 files start-char) 1424 (goto-char (point-min)) 1425 1426 ;; Deal with ^M at the end of the lines. 1427 (when gnus-uu-kill-carriage-return 1428 (save-excursion 1429 (while (search-forward "\r" nil t) 1430 (delete-backward-char 1)))) 1431 1432 (while (or (re-search-forward gnus-uu-begin-string nil t) 1433 (re-search-forward gnus-uu-body-line nil t)) 1434 (setq state (list 'ok)) 1435 ;; Ok, we are at the first uucoded line. 1436 (beginning-of-line) 1437 (setq start-char (point)) 1438 1439 (if (not (looking-at gnus-uu-begin-string)) 1440 (setq state (list 'middle)) 1441 ;; This is the beginning of a uuencoded article. 1442 ;; We replace certain characters that could make things messy. 1443 (setq gnus-uu-file-name 1444 (gnus-map-function 1445 mm-file-name-rewrite-functions 1446 (file-name-nondirectory (match-string 1)))) 1447 (replace-match (concat "begin 644 " gnus-uu-file-name) t t) 1448 1449 ;; Remove any non gnus-uu-body-line right after start. 1450 (forward-line 1) 1451 (while (and (not (eobp)) 1452 (not (looking-at gnus-uu-body-line))) 1453 (gnus-delete-line)) 1454 1455 ;; If a process is running, we kill it. 1456 (when (and gnus-uu-uudecode-process 1457 (memq (process-status gnus-uu-uudecode-process) 1458 '(run stop))) 1459 (delete-process gnus-uu-uudecode-process) 1460 (gnus-uu-unmark-list-of-grabbed t)) 1461 1462 ;; Start a new uudecoding process. 1463 (let ((cdir default-directory)) 1464 (unwind-protect 1465 (progn 1466 (cd gnus-uu-work-dir) 1467 (setq gnus-uu-uudecode-process 1468 (start-process 1469 "*uudecode*" 1470 (gnus-get-buffer-create gnus-uu-output-buffer-name) 1471 shell-file-name shell-command-switch 1472 (format "cd %s %s uudecode" gnus-uu-work-dir 1473 gnus-shell-command-separator)))) 1474 (cd cdir))) 1475 (set-process-sentinel 1476 gnus-uu-uudecode-process 'gnus-uu-uudecode-sentinel) 1477 (setq state (list 'begin)) 1478 (push (concat gnus-uu-work-dir gnus-uu-file-name) files)) 1479 1480 ;; We look for the end of the thing to be decoded. 1481 (if (re-search-forward gnus-uu-end-string nil t) 1482 (push 'end state) 1483 (goto-char (point-max)) 1484 (re-search-backward gnus-uu-body-line nil t)) 1485 1486 (forward-line 1) 1487 1488 (when gnus-uu-uudecode-process 1489 (when (memq (process-status gnus-uu-uudecode-process) '(run stop)) 1490 ;; Try to correct mishandled uucode. 1491 (when gnus-uu-correct-stripped-uucode 1492 (gnus-uu-check-correct-stripped-uucode start-char (point))) 1493 (gnus-run-hooks 'gnus-uu-pre-uudecode-hook) 1494 1495 ;; Send the text to the process. 1496 (condition-case nil 1497 (process-send-region 1498 gnus-uu-uudecode-process start-char (point)) 1499 (error 1500 (progn 1501 (delete-process gnus-uu-uudecode-process) 1502 (gnus-message 2 "gnus-uu: Couldn't uudecode") 1503 (setq state (list 'wrong-type))))) 1504 1505 (if (memq 'end state) 1506 (progn 1507 ;; Send an EOF, just in case. 1508 (ignore-errors 1509 (process-send-eof gnus-uu-uudecode-process)) 1510 (while (memq (process-status gnus-uu-uudecode-process) 1511 '(open run)) 1512 (accept-process-output gnus-uu-uudecode-process 1))) 1513 (when (or (not gnus-uu-uudecode-process) 1514 (not (memq (process-status gnus-uu-uudecode-process) 1515 '(run stop)))) 1516 (setq state (list 'wrong-type))))))) 1517 1518 (if (memq 'begin state) 1519 (cons (if (= (length files) 1) (car files) files) state) 1520 state)))) 1521 1522(defvar gnus-uu-unshar-warning 1523 "*** WARNING *** 1524 1525Shell archives are an archaic method of bundling files for distribution 1526across computer networks. During the unpacking process, arbitrary commands 1527are executed on your system, and all kinds of nasty things can happen. 1528Please examine the archive very carefully before you instruct Emacs to 1529unpack it. You can browse the archive buffer using \\[scroll-other-window]. 1530 1531If you are unsure what to do, please answer \"no\"." 1532 "Text of warning message displayed by `gnus-uu-unshar-article'. 1533Make sure that this text consists only of few text lines. Otherwise, 1534Gnus might fail to display all of it.") 1535 1536 1537;; This function is used by `gnus-uu-grab-articles' to treat 1538;; a shared article. 1539(defun gnus-uu-unshar-article (process-buffer in-state) 1540 (let ((state (list 'ok)) 1541 start-char) 1542 (save-excursion 1543 (set-buffer process-buffer) 1544 (goto-char (point-min)) 1545 (if (not (re-search-forward gnus-uu-shar-begin-string nil t)) 1546 (setq state (list 'wrong-type)) 1547 (save-window-excursion 1548 (save-excursion 1549 (switch-to-buffer (current-buffer)) 1550 (delete-other-windows) 1551 (let ((buffer (get-buffer-create (generate-new-buffer-name 1552 "*Warning*")))) 1553 (unless 1554 (unwind-protect 1555 (with-current-buffer buffer 1556 (insert (substitute-command-keys 1557 gnus-uu-unshar-warning)) 1558 (goto-char (point-min)) 1559 (display-buffer buffer) 1560 (yes-or-no-p "This is a shell archive, unshar it? ")) 1561 (kill-buffer buffer)) 1562 (setq state (list 'error)))))) 1563 (unless (memq 'error state) 1564 (beginning-of-line) 1565 (setq start-char (point)) 1566 (call-process-region 1567 start-char (point-max) shell-file-name nil 1568 (gnus-get-buffer-create gnus-uu-output-buffer-name) nil 1569 shell-command-switch 1570 (concat "cd " gnus-uu-work-dir " " 1571 gnus-shell-command-separator " sh"))))) 1572 state)) 1573 1574;; Returns the name of what the shar file is going to unpack. 1575(defun gnus-uu-find-name-in-shar () 1576 (let ((oldpoint (point)) 1577 res) 1578 (goto-char (point-min)) 1579 (when (re-search-forward gnus-uu-shar-name-marker nil t) 1580 (setq res (buffer-substring (match-beginning 1) (match-end 1)))) 1581 (goto-char oldpoint) 1582 res)) 1583 1584;; `gnus-uu-choose-action' chooses what action to perform given the name 1585;; and `gnus-uu-file-action-list'. Returns either nil if no action is 1586;; found, or the name of the command to run if such a rule is found. 1587(defun gnus-uu-choose-action (file-name file-action-list &optional no-ignore) 1588 (let ((action-list (copy-sequence file-action-list)) 1589 (case-fold-search t) 1590 rule action) 1591 (and 1592 (unless no-ignore 1593 (and (not 1594 (and gnus-uu-ignore-files-by-name 1595 (string-match gnus-uu-ignore-files-by-name file-name))) 1596 (not 1597 (and gnus-uu-ignore-files-by-type 1598 (string-match gnus-uu-ignore-files-by-type 1599 (or (gnus-uu-choose-action 1600 file-name gnus-uu-ext-to-mime-list t) 1601 "")))))) 1602 (while (not (or (eq action-list ()) action)) 1603 (setq rule (car action-list)) 1604 (setq action-list (cdr action-list)) 1605 (when (string-match (car rule) file-name) 1606 (setq action (cadr rule))))) 1607 action)) 1608 1609(defun gnus-uu-treat-archive (file-path) 1610 ;; Unpacks an archive. Returns t if unpacking is successful. 1611 (let ((did-unpack t) 1612 action command dir) 1613 (setq action (gnus-uu-choose-action 1614 file-path (append gnus-uu-user-archive-rules 1615 (if gnus-uu-ignore-default-archive-rules 1616 nil 1617 gnus-uu-default-archive-rules)))) 1618 1619 (when (not action) 1620 (error "No unpackers for the file %s" file-path)) 1621 1622 (string-match "/[^/]*$" file-path) 1623 (setq dir (substring file-path 0 (match-beginning 0))) 1624 1625 (when (member action gnus-uu-destructive-archivers) 1626 (copy-file file-path (concat file-path "~") t)) 1627 1628 (setq command (format "cd %s ; %s" dir (gnus-uu-command action file-path))) 1629 1630 (save-excursion 1631 (set-buffer (gnus-get-buffer-create gnus-uu-output-buffer-name)) 1632 (erase-buffer)) 1633 1634 (gnus-message 5 "Unpacking: %s..." (gnus-uu-command action file-path)) 1635 1636 (if (eq 0 (call-process shell-file-name nil 1637 (gnus-get-buffer-create gnus-uu-output-buffer-name) 1638 nil shell-command-switch command)) 1639 (message "") 1640 (gnus-message 2 "Error during unpacking of archive") 1641 (setq did-unpack nil)) 1642 1643 (when (member action gnus-uu-destructive-archivers) 1644 (rename-file (concat file-path "~") file-path t)) 1645 1646 did-unpack)) 1647 1648(defun gnus-uu-dir-files (dir) 1649 (let ((dirs (directory-files dir t "[^/][^\\.][^\\.]?$")) 1650 files file) 1651 (while dirs 1652 (if (file-directory-p (setq file (car dirs))) 1653 (setq files (append files (gnus-uu-dir-files file))) 1654 (push file files)) 1655 (setq dirs (cdr dirs))) 1656 files)) 1657 1658(defun gnus-uu-unpack-files (files &optional ignore) 1659 ;; Go through FILES and look for files to unpack. 1660 (let* ((totfiles (gnus-uu-ls-r gnus-uu-work-dir)) 1661 (ofiles files) 1662 file did-unpack) 1663 (while files 1664 (setq file (cdr (assq 'name (car files)))) 1665 (when (and (not (member file ignore)) 1666 (equal (gnus-uu-get-action (file-name-nondirectory file)) 1667 "gnus-uu-archive")) 1668 (push file did-unpack) 1669 (unless (gnus-uu-treat-archive file) 1670 (gnus-message 2 "Error during unpacking of %s" file)) 1671 (let* ((newfiles (gnus-uu-ls-r gnus-uu-work-dir)) 1672 (nfiles newfiles)) 1673 (while nfiles 1674 (unless (member (car nfiles) totfiles) 1675 (push (list (cons 'name (car nfiles)) 1676 (cons 'original file)) 1677 ofiles)) 1678 (setq nfiles (cdr nfiles))) 1679 (setq totfiles newfiles))) 1680 (setq files (cdr files))) 1681 (if did-unpack 1682 (gnus-uu-unpack-files ofiles (append did-unpack ignore)) 1683 ofiles))) 1684 1685(defun gnus-uu-ls-r (dir) 1686 (let* ((files (gnus-uu-directory-files dir t)) 1687 (ofiles files)) 1688 (while files 1689 (when (file-directory-p (car files)) 1690 (setq ofiles (delete (car files) ofiles)) 1691 (setq ofiles (append ofiles (gnus-uu-ls-r (car files))))) 1692 (setq files (cdr files))) 1693 ofiles)) 1694 1695;; Various stuff 1696 1697(defun gnus-uu-directory-files (dir &optional full) 1698 (let (files out file) 1699 (setq files (directory-files dir full)) 1700 (while files 1701 (setq file (car files)) 1702 (setq files (cdr files)) 1703 (unless (member (file-name-nondirectory file) '("." "..")) 1704 (push file out))) 1705 (setq out (nreverse out)) 1706 out)) 1707 1708(defun gnus-uu-check-correct-stripped-uucode (start end) 1709 (save-excursion 1710 (let (found beg length) 1711 (if (not gnus-uu-correct-stripped-uucode) 1712 () 1713 (goto-char start) 1714 1715 (if (re-search-forward " \\|`" end t) 1716 (progn 1717 (goto-char start) 1718 (while (not (eobp)) 1719 (progn 1720 (when (looking-at "\n") 1721 (replace-match "")) 1722 (forward-line 1)))) 1723 1724 (while (not (eobp)) 1725 (if (looking-at (concat gnus-uu-begin-string "\\|" 1726 gnus-uu-end-string)) 1727 () 1728 (when (not found) 1729 (beginning-of-line) 1730 (setq beg (point)) 1731 (end-of-line) 1732 (setq length (- (point) beg))) 1733 (setq found t) 1734 (beginning-of-line) 1735 (setq beg (point)) 1736 (end-of-line) 1737 (when (not (= length (- (point) beg))) 1738 (insert (make-string (- length (- (point) beg)) ? )))) 1739 (forward-line 1))))))) 1740 1741(defvar gnus-uu-tmp-alist nil) 1742 1743(defun gnus-uu-initialize (&optional scan) 1744 (let (entry) 1745 (if (and (not scan) 1746 (when (setq entry (assoc gnus-newsgroup-name gnus-uu-tmp-alist)) 1747 (if (file-exists-p (cdr entry)) 1748 (setq gnus-uu-work-dir (cdr entry)) 1749 (setq gnus-uu-tmp-alist (delq entry gnus-uu-tmp-alist)) 1750 nil))) 1751 t 1752 (setq gnus-uu-tmp-dir (file-name-as-directory 1753 (expand-file-name gnus-uu-tmp-dir))) 1754 (if (not (file-directory-p gnus-uu-tmp-dir)) 1755 (error "Temp directory %s doesn't exist" gnus-uu-tmp-dir) 1756 (when (not (file-writable-p gnus-uu-tmp-dir)) 1757 (error "Temp directory %s can't be written to" 1758 gnus-uu-tmp-dir))) 1759 1760 (setq gnus-uu-work-dir 1761 (mm-make-temp-file (concat gnus-uu-tmp-dir "gnus") 'dir)) 1762 (set-file-modes gnus-uu-work-dir 448) 1763 (setq gnus-uu-work-dir (file-name-as-directory gnus-uu-work-dir)) 1764 (push (cons gnus-newsgroup-name gnus-uu-work-dir) 1765 gnus-uu-tmp-alist)))) 1766 1767 1768;; Kills the temporary uu buffers, kills any processes, etc. 1769(defun gnus-uu-clean-up () 1770 (let (buf) 1771 (and gnus-uu-uudecode-process 1772 (memq (process-status (or gnus-uu-uudecode-process "nevair")) 1773 '(stop run)) 1774 (delete-process gnus-uu-uudecode-process)) 1775 (when (setq buf (get-buffer gnus-uu-output-buffer-name)) 1776 (kill-buffer buf)))) 1777 1778;; Inputs an action and a filename and returns a full command, making sure 1779;; that the filename will be treated as a single argument when the shell 1780;; executes the command. 1781(defun gnus-uu-command (action file) 1782 (let ((quoted-file (mm-quote-arg file))) 1783 (if (string-match "%s" action) 1784 (format action quoted-file) 1785 (concat action " " quoted-file)))) 1786 1787(defun gnus-uu-delete-work-dir (&optional dir) 1788 "Delete recursively all files and directories under `gnus-uu-work-dir'." 1789 (if dir 1790 (gnus-message 7 "Deleting directory %s..." dir) 1791 (setq dir gnus-uu-work-dir)) 1792 (when (and dir 1793 (file-exists-p dir)) 1794 (let ((files (directory-files dir t nil t)) 1795 file) 1796 (while (setq file (pop files)) 1797 (unless (member (file-name-nondirectory file) '("." "..")) 1798 (if (file-directory-p file) 1799 (gnus-uu-delete-work-dir file) 1800 (gnus-message 9 "Deleting file %s..." file) 1801 (condition-case err 1802 (delete-file file) 1803 (error (gnus-message 3 "Deleting file %s failed... %s" file err)))))) 1804 (condition-case err 1805 (delete-directory dir) 1806 (error (gnus-message 3 "Deleting directory %s failed... %s" file err)))) 1807 (gnus-message 7 ""))) 1808 1809;; Initializing 1810 1811(add-hook 'gnus-exit-group-hook 'gnus-uu-clean-up) 1812(add-hook 'gnus-exit-group-hook 'gnus-uu-delete-work-dir) 1813 1814 1815 1816;;; 1817;;; uuencoded posting 1818;;; 1819 1820;; Any function that is to be used as and encoding method will take two 1821;; parameters: PATH-NAME and FILE-NAME. (E.g. "/home/gaga/spiral.jpg" 1822;; and "spiral.jpg", respectively.) The function should return nil if 1823;; the encoding wasn't successful. 1824(defcustom gnus-uu-post-encode-method 'gnus-uu-post-encode-uuencode 1825 "Function used for encoding binary files. 1826There are three functions supplied with gnus-uu for encoding files: 1827`gnus-uu-post-encode-uuencode', which does straight uuencoding; 1828`gnus-uu-post-encode-mime', which encodes with base64 and adds MIME 1829headers; and `gnus-uu-post-encode-mime-uuencode', which encodes with 1830uuencode and adds MIME headers." 1831 :group 'gnus-extract-post 1832 :type '(radio (function-item gnus-uu-post-encode-uuencode) 1833 (function-item gnus-uu-post-encode-mime) 1834 (function-item gnus-uu-post-encode-mime-uuencode) 1835 (function :tag "Other"))) 1836 1837(defcustom gnus-uu-post-include-before-composing nil 1838 "Non-nil means that gnus-uu will ask for a file to encode before you compose the article. 1839If this variable is t, you can either include an encoded file with 1840\\[gnus-uu-post-insert-binary-in-article] or have one included for you when you post the article." 1841 :group 'gnus-extract-post 1842 :type 'boolean) 1843 1844(defcustom gnus-uu-post-length 990 1845 "Maximum length of an article. 1846The encoded file will be split into how many articles it takes to 1847post the entire file." 1848 :group 'gnus-extract-post 1849 :type 'integer) 1850 1851(defcustom gnus-uu-post-threaded nil 1852 "Non-nil means that gnus-uu will post the encoded file in a thread. 1853This may not be smart, as no other decoder I have seen are able to 1854follow threads when collecting uuencoded articles. (Well, I have seen 1855one package that does that - gnus-uu, but somehow, I don't think that 1856counts...) The default is nil." 1857 :group 'gnus-extract-post 1858 :type 'boolean) 1859 1860(defcustom gnus-uu-post-separate-description t 1861 "Non-nil means that the description will be posted in a separate article. 1862The first article will typically be numbered (0/x). If this variable 1863is nil, the description the user enters will be included at the 1864beginning of the first article, which will be numbered (1/x). Default 1865is t." 1866 :group 'gnus-extract-post 1867 :type 'boolean) 1868 1869(defvar gnus-uu-post-binary-separator "--binary follows this line--") 1870(defvar gnus-uu-post-message-id nil) 1871(defvar gnus-uu-post-inserted-file-name nil) 1872(defvar gnus-uu-winconf-post-news nil) 1873 1874(defun gnus-uu-post-news () 1875 "Compose an article and post an encoded file." 1876 (interactive) 1877 (setq gnus-uu-post-inserted-file-name nil) 1878 (setq gnus-uu-winconf-post-news (current-window-configuration)) 1879 1880 (gnus-summary-post-news) 1881 1882 (let ((map (make-sparse-keymap))) 1883 (set-keymap-parent map (current-local-map)) 1884 (use-local-map map)) 1885 ;;(local-set-key "\C-c\C-c" 'gnus-summary-edit-article-done) 1886 (local-set-key "\C-c\C-c" 'gnus-uu-post-news-inews) 1887 (local-set-key "\C-c\C-s" 'gnus-uu-post-news-inews) 1888 (local-set-key "\C-c\C-i" 'gnus-uu-post-insert-binary-in-article) 1889 1890 (when gnus-uu-post-include-before-composing 1891 (save-excursion (setq gnus-uu-post-inserted-file-name 1892 (gnus-uu-post-insert-binary))))) 1893 1894(defun gnus-uu-post-insert-binary-in-article () 1895 "Inserts an encoded file in the buffer. 1896The user will be asked for a file name." 1897 (interactive) 1898 (save-excursion 1899 (setq gnus-uu-post-inserted-file-name (gnus-uu-post-insert-binary)))) 1900 1901;; Encodes with uuencode and substitutes all spaces with backticks. 1902(defun gnus-uu-post-encode-uuencode (path file-name) 1903 (when (gnus-uu-post-encode-file "uuencode" path file-name) 1904 (goto-char (point-min)) 1905 (forward-line 1) 1906 (while (re-search-forward " " nil t) 1907 (replace-match "`")) 1908 t)) 1909 1910;; Encodes with uuencode and adds MIME headers. 1911(defun gnus-uu-post-encode-mime-uuencode (path file-name) 1912 (when (gnus-uu-post-encode-uuencode path file-name) 1913 (gnus-uu-post-make-mime file-name "x-uue") 1914 t)) 1915 1916;; Encodes with base64 and adds MIME headers 1917(defun gnus-uu-post-encode-mime (path file-name) 1918 (when (eq 0 (call-process shell-file-name nil t nil shell-command-switch 1919 (format "%s %s -o %s" "mmencode" path file-name))) 1920 (gnus-uu-post-make-mime file-name "base64") 1921 t)) 1922 1923;; Adds MIME headers. 1924(defun gnus-uu-post-make-mime (file-name encoding) 1925 (goto-char (point-min)) 1926 (insert (format "Content-Type: %s; name=\"%s\"\n" 1927 (gnus-uu-choose-action file-name gnus-uu-ext-to-mime-list) 1928 file-name)) 1929 (insert (format "Content-Transfer-Encoding: %s\n\n" encoding)) 1930 (save-restriction 1931 (set-buffer gnus-message-buffer) 1932 (goto-char (point-min)) 1933 (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$")) 1934 (forward-line -1) 1935 (narrow-to-region (point-min) (point)) 1936 (unless (mail-fetch-field "mime-version") 1937 (widen) 1938 (insert "MIME-Version: 1.0\n")) 1939 (widen))) 1940 1941;; Encodes a file PATH with COMMAND, leaving the result in the 1942;; current buffer. 1943(defun gnus-uu-post-encode-file (command path file-name) 1944 (eq 0 (call-process shell-file-name nil t nil shell-command-switch 1945 (format "%s %s %s" command path file-name)))) 1946 1947(defun gnus-uu-post-news-inews () 1948 "Posts the composed news article and encoded file. 1949If no file has been included, the user will be asked for a file." 1950 (interactive) 1951 1952 (let (file-name) 1953 1954 (if gnus-uu-post-inserted-file-name 1955 (setq file-name gnus-uu-post-inserted-file-name) 1956 (setq file-name (gnus-uu-post-insert-binary))) 1957 1958 (gnus-uu-post-encoded file-name gnus-uu-post-threaded)) 1959 (setq gnus-uu-post-inserted-file-name nil) 1960 (when gnus-uu-winconf-post-news 1961 (set-window-configuration gnus-uu-winconf-post-news))) 1962 1963;; Asks for a file to encode, encodes it and inserts the result in 1964;; the current buffer. Returns the file name the user gave. 1965(defun gnus-uu-post-insert-binary () 1966 (let ((uuencode-buffer-name "*uuencode buffer*") 1967 file-path uubuf file-name) 1968 1969 (setq file-path (read-file-name 1970 "What file do you want to encode? ")) 1971 (when (not (file-exists-p file-path)) 1972 (error "%s: No such file" file-path)) 1973 1974 (goto-char (point-max)) 1975 (insert (format "\n%s\n" gnus-uu-post-binary-separator)) 1976 1977 ;; #### Unix-specific? 1978 (when (string-match "^~/" file-path) 1979 (setq file-path (concat "$HOME" (substring file-path 1)))) 1980 ;; #### Unix-specific? 1981 (if (string-match "/[^/]*$" file-path) 1982 (setq file-name (substring file-path (1+ (match-beginning 0)))) 1983 (setq file-name file-path)) 1984 1985 (unwind-protect 1986 (if (save-excursion 1987 (set-buffer (setq uubuf 1988 (gnus-get-buffer-create uuencode-buffer-name))) 1989 (erase-buffer) 1990 (funcall gnus-uu-post-encode-method file-path file-name)) 1991 (insert-buffer-substring uubuf) 1992 (error "Encoding unsuccessful")) 1993 (kill-buffer uubuf)) 1994 file-name)) 1995 1996;; Posts the article and all of the encoded file. 1997(defun gnus-uu-post-encoded (file-name &optional threaded) 1998 (let ((send-buffer-name "*uuencode send buffer*") 1999 (encoded-buffer-name "*encoded buffer*") 2000 (top-string "[ cut here %s (%s %d/%d) %s gnus-uu ]") 2001 (separator (concat mail-header-separator "\n\n")) 2002 uubuf length parts header i end beg 2003 beg-line minlen post-buf whole-len beg-binary end-binary) 2004 2005 (setq post-buf (current-buffer)) 2006 2007 (goto-char (point-min)) 2008 (when (not (re-search-forward 2009 (if gnus-uu-post-separate-description 2010 (concat "^" (regexp-quote gnus-uu-post-binary-separator) 2011 "$") 2012 (concat "^" (regexp-quote mail-header-separator) "$")) 2013 nil t)) 2014 (error "Internal error: No binary/header separator")) 2015 (beginning-of-line) 2016 (forward-line 1) 2017 (setq beg-binary (point)) 2018 (setq end-binary (point-max)) 2019 2020 (save-excursion 2021 (set-buffer (setq uubuf (gnus-get-buffer-create encoded-buffer-name))) 2022 (erase-buffer) 2023 (insert-buffer-substring post-buf beg-binary end-binary) 2024 (goto-char (point-min)) 2025 (setq length (count-lines (point-min) (point-max))) 2026 (setq parts (/ length gnus-uu-post-length)) 2027 (unless (< (% length gnus-uu-post-length) 4) 2028 (incf parts))) 2029 2030 (when gnus-uu-post-separate-description 2031 (forward-line -1)) 2032 (delete-region (point) (point-max)) 2033 2034 (goto-char (point-min)) 2035 (re-search-forward 2036 (concat "^" (regexp-quote mail-header-separator) "$") nil t) 2037 (beginning-of-line) 2038 (setq header (buffer-substring (point-min) (point))) 2039 2040 (goto-char (point-min)) 2041 (when gnus-uu-post-separate-description 2042 (when (re-search-forward "^Subject: " nil t) 2043 (end-of-line) 2044 (insert (format " (0/%d)" parts))) 2045 (save-excursion 2046 (message-send)) 2047 (setq gnus-uu-post-message-id (message-fetch-field "message-id"))) 2048 2049 (save-excursion 2050 (setq i 1) 2051 (setq beg 1) 2052 (while (not (> i parts)) 2053 (set-buffer (gnus-get-buffer-create send-buffer-name)) 2054 (erase-buffer) 2055 (insert header) 2056 (when (and threaded gnus-uu-post-message-id) 2057 (insert "References: " gnus-uu-post-message-id "\n")) 2058 (insert separator) 2059 (setq whole-len 2060 (- 62 (length (format top-string "" file-name i parts "")))) 2061 (when (> 1 (setq minlen (/ whole-len 2))) 2062 (setq minlen 1)) 2063 (setq 2064 beg-line 2065 (format top-string 2066 (make-string minlen ?-) 2067 file-name i parts 2068 (make-string 2069 (if (= 0 (% whole-len 2)) (1- minlen) minlen) ?-))) 2070 2071 (goto-char (point-min)) 2072 (when (re-search-forward "^Subject: " nil t) 2073 (end-of-line) 2074 (insert (format " (%d/%d)" i parts))) 2075 2076 (goto-char (point-max)) 2077 (save-excursion 2078 (set-buffer uubuf) 2079 (goto-char beg) 2080 (if (= i parts) 2081 (goto-char (point-max)) 2082 (forward-line gnus-uu-post-length)) 2083 (when (and (= (1+ i) parts) (< (count-lines (point) (point-max)) 4)) 2084 (forward-line -4)) 2085 (setq end (point))) 2086 (insert-buffer-substring uubuf beg end) 2087 (insert beg-line "\n") 2088 (setq beg end) 2089 (incf i) 2090 (goto-char (point-min)) 2091 (re-search-forward 2092 (concat "^" (regexp-quote mail-header-separator) "$") nil t) 2093 (beginning-of-line) 2094 (forward-line 2) 2095 (when (re-search-forward 2096 (concat "^" (regexp-quote gnus-uu-post-binary-separator) "$") 2097 nil t) 2098 (replace-match "") 2099 (forward-line 1)) 2100 (insert beg-line) 2101 (insert "\n") 2102 (let (message-sent-message-via) 2103 (save-excursion 2104 (message-send)) 2105 (setq gnus-uu-post-message-id 2106 (concat (message-fetch-field "references") " " 2107 (message-fetch-field "message-id")))))) 2108 2109 (gnus-kill-buffer send-buffer-name) 2110 (gnus-kill-buffer encoded-buffer-name) 2111 2112 (when (not gnus-uu-post-separate-description) 2113 (set-buffer-modified-p nil) 2114 (when (fboundp 'bury-buffer) 2115 (bury-buffer))))) 2116 2117(provide 'gnus-uu) 2118 2119;;; arch-tag: 05312384-0a83-4720-9a58-b3160b888853 2120;;; gnus-uu.el ends here 2121
