| 1 | ;;; nneething.el --- arbitrary file access for Gnus |
| 2 | |
| 3 | ;; Copyright (C) 1995-2014 Free Software Foundation, Inc. |
| 4 | |
| 5 | ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> |
| 6 | ;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> |
| 7 | ;; Keywords: news, mail |
| 8 | |
| 9 | ;; This file is part of GNU Emacs. |
| 10 | |
| 11 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
| 12 | ;; it under the terms of the GNU General Public License as published by |
| 13 | ;; the Free Software Foundation, either version 3 of the License, or |
| 14 | ;; (at your option) any later version. |
| 15 | |
| 16 | ;; GNU Emacs is distributed in the hope that it will be useful, |
| 17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 19 | ;; GNU General Public License for more details. |
| 20 | |
| 21 | ;; You should have received a copy of the GNU General Public License |
| 22 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
| 23 | |
| 24 | ;;; Commentary: |
| 25 | |
| 26 | ;;; Code: |
| 27 | |
| 28 | (eval-when-compile (require 'cl)) |
| 29 | |
| 30 | (require 'mailcap) |
| 31 | (require 'nnheader) |
| 32 | (require 'nnmail) |
| 33 | (require 'nnoo) |
| 34 | (require 'gnus-util) |
| 35 | |
| 36 | (nnoo-declare nneething) |
| 37 | |
| 38 | (defvoo nneething-map-file-directory |
| 39 | (nnheader-concat gnus-directory ".nneething/") |
| 40 | "Where nneething stores the map files.") |
| 41 | |
| 42 | (defvoo nneething-map-file ".nneething" |
| 43 | "Name of the map files.") |
| 44 | |
| 45 | (defvoo nneething-exclude-files nil |
| 46 | "Regexp saying what files to exclude from the group. |
| 47 | If this variable is nil, no files will be excluded.") |
| 48 | |
| 49 | (defvoo nneething-include-files nil |
| 50 | "Regexp saying what files to include in the group. |
| 51 | If this variable is non-nil, only files matching this regexp will be |
| 52 | included.") |
| 53 | |
| 54 | \f |
| 55 | |
| 56 | ;;; Internal variables. |
| 57 | |
| 58 | (defconst nneething-version "nneething 1.0" |
| 59 | "nneething version.") |
| 60 | |
| 61 | (defvoo nneething-current-directory nil |
| 62 | "Current news group directory.") |
| 63 | |
| 64 | (defvoo nneething-status-string "") |
| 65 | |
| 66 | (defvoo nneething-work-buffer " *nneething work*") |
| 67 | |
| 68 | (defvoo nneething-group nil) |
| 69 | (defvoo nneething-map nil) |
| 70 | (defvoo nneething-read-only nil) |
| 71 | (defvoo nneething-active nil) |
| 72 | (defvoo nneething-address nil) |
| 73 | |
| 74 | \f |
| 75 | |
| 76 | ;;; Interface functions. |
| 77 | |
| 78 | (nnoo-define-basics nneething) |
| 79 | |
| 80 | (deffoo nneething-retrieve-headers (articles &optional group server fetch-old) |
| 81 | (nneething-possibly-change-directory group) |
| 82 | |
| 83 | (with-current-buffer nntp-server-buffer |
| 84 | (erase-buffer) |
| 85 | (let* ((number (length articles)) |
| 86 | (count 0) |
| 87 | (large (and (numberp nnmail-large-newsgroup) |
| 88 | (> number nnmail-large-newsgroup))) |
| 89 | article file) |
| 90 | |
| 91 | (if (stringp (car articles)) |
| 92 | 'headers |
| 93 | |
| 94 | (while (setq article (pop articles)) |
| 95 | (setq file (nneething-file-name article)) |
| 96 | |
| 97 | (when (and (file-exists-p file) |
| 98 | (or (file-directory-p file) |
| 99 | (not (zerop (nnheader-file-size file))))) |
| 100 | (insert (format "221 %d Article retrieved.\n" article)) |
| 101 | (nneething-insert-head file) |
| 102 | (insert ".\n")) |
| 103 | |
| 104 | (incf count) |
| 105 | |
| 106 | (and large |
| 107 | (zerop (% count 20)) |
| 108 | (nnheader-message 5 "nneething: Receiving headers... %d%%" |
| 109 | (/ (* count 100) number)))) |
| 110 | |
| 111 | (when large |
| 112 | (nnheader-message 5 "nneething: Receiving headers...done")) |
| 113 | |
| 114 | (nnheader-fold-continuation-lines) |
| 115 | 'headers)))) |
| 116 | |
| 117 | (deffoo nneething-request-article (id &optional group server buffer) |
| 118 | (nneething-possibly-change-directory group) |
| 119 | (let ((file (unless (stringp id) |
| 120 | (nneething-file-name id))) |
| 121 | (nntp-server-buffer (or buffer nntp-server-buffer))) |
| 122 | (and (stringp file) ; We did not request by Message-ID. |
| 123 | (file-exists-p file) ; The file exists. |
| 124 | (not (file-directory-p file)) ; It's not a dir. |
| 125 | (save-excursion |
| 126 | (let ((nnmail-file-coding-system 'binary)) |
| 127 | (nnmail-find-file file)) ; Insert the file in the nntp buf. |
| 128 | (unless (nnheader-article-p) ; Either it's a real article... |
| 129 | (let ((type |
| 130 | (unless (file-directory-p file) |
| 131 | (or (cdr (assoc (concat "." (file-name-extension file)) |
| 132 | mailcap-mime-extensions)) |
| 133 | "text/plain"))) |
| 134 | (charset |
| 135 | (mm-detect-mime-charset-region (point-min) (point-max))) |
| 136 | (encoding)) |
| 137 | (unless (string-match "\\`text/" type) |
| 138 | (base64-encode-region (point-min) (point-max)) |
| 139 | (setq encoding "base64")) |
| 140 | (goto-char (point-min)) |
| 141 | (nneething-make-head file (current-buffer) |
| 142 | nil type charset encoding)) |
| 143 | (insert "\n")) |
| 144 | t)))) |
| 145 | |
| 146 | (deffoo nneething-request-group (group &optional server dont-check info) |
| 147 | (nneething-possibly-change-directory group server) |
| 148 | (unless dont-check |
| 149 | (nneething-create-mapping) |
| 150 | (if (> (car nneething-active) (cdr nneething-active)) |
| 151 | (nnheader-insert "211 0 1 0 %s\n" group) |
| 152 | (nnheader-insert |
| 153 | "211 %d %d %d %s\n" |
| 154 | (- (1+ (cdr nneething-active)) (car nneething-active)) |
| 155 | (car nneething-active) (cdr nneething-active) |
| 156 | group))) |
| 157 | t) |
| 158 | |
| 159 | (deffoo nneething-request-list (&optional server dir) |
| 160 | (nnheader-report 'nneething "LIST is not implemented.")) |
| 161 | |
| 162 | (deffoo nneething-request-newgroups (date &optional server) |
| 163 | (nnheader-report 'nneething "NEWSGROUPS is not implemented.")) |
| 164 | |
| 165 | (deffoo nneething-request-type (group &optional article) |
| 166 | 'unknown) |
| 167 | |
| 168 | (deffoo nneething-close-group (group &optional server) |
| 169 | (setq nneething-current-directory nil) |
| 170 | t) |
| 171 | |
| 172 | (deffoo nneething-open-server (server &optional defs) |
| 173 | (nnheader-init-server-buffer) |
| 174 | (if (nneething-server-opened server) |
| 175 | t |
| 176 | (unless (assq 'nneething-address defs) |
| 177 | (setq defs (append defs (list (list 'nneething-address server))))) |
| 178 | (nnoo-change-server 'nneething server defs))) |
| 179 | |
| 180 | \f |
| 181 | ;;; Internal functions. |
| 182 | |
| 183 | (defun nneething-possibly-change-directory (group &optional server) |
| 184 | (when (and server |
| 185 | (not (nneething-server-opened server))) |
| 186 | (nneething-open-server server)) |
| 187 | (when (and group |
| 188 | (not (equal nneething-group group))) |
| 189 | (setq nneething-group group) |
| 190 | (setq nneething-map nil) |
| 191 | (setq nneething-active (cons 1 0)) |
| 192 | (nneething-create-mapping))) |
| 193 | |
| 194 | (defun nneething-map-file () |
| 195 | ;; We make sure that the .nneething directory exists. |
| 196 | (gnus-make-directory nneething-map-file-directory) |
| 197 | ;; We store it in a special directory under the user's home dir. |
| 198 | (concat (file-name-as-directory nneething-map-file-directory) |
| 199 | nneething-group nneething-map-file)) |
| 200 | |
| 201 | (defun nneething-create-mapping () |
| 202 | ;; Read nneething-active and nneething-map. |
| 203 | (when (file-exists-p nneething-address) |
| 204 | (let ((map-file (nneething-map-file)) |
| 205 | (files (directory-files nneething-address)) |
| 206 | touched map-files) |
| 207 | (when (file-exists-p map-file) |
| 208 | (ignore-errors |
| 209 | (load map-file nil t t))) |
| 210 | (unless nneething-active |
| 211 | (setq nneething-active (cons 1 0))) |
| 212 | ;; Old nneething had a different map format. |
| 213 | (when (and (cdar nneething-map) |
| 214 | (atom (cdar nneething-map))) |
| 215 | (setq nneething-map |
| 216 | (mapcar (lambda (n) |
| 217 | (list (cdr n) (car n) |
| 218 | (nth 5 (file-attributes |
| 219 | (nneething-file-name (car n)))))) |
| 220 | nneething-map))) |
| 221 | ;; Remove files matching the exclusion regexp. |
| 222 | (when nneething-exclude-files |
| 223 | (let ((f files) |
| 224 | prev) |
| 225 | (while f |
| 226 | (if (string-match nneething-exclude-files (car f)) |
| 227 | (if prev (setcdr prev (cdr f)) |
| 228 | (setq files (cdr files))) |
| 229 | (setq prev f)) |
| 230 | (setq f (cdr f))))) |
| 231 | ;; Remove files not matching the inclusion regexp. |
| 232 | (when nneething-include-files |
| 233 | (let ((f files) |
| 234 | prev) |
| 235 | (while f |
| 236 | (if (not (string-match nneething-include-files (car f))) |
| 237 | (if prev (setcdr prev (cdr f)) |
| 238 | (setq files (cdr files))) |
| 239 | (setq prev f)) |
| 240 | (setq f (cdr f))))) |
| 241 | ;; Remove deleted files from the map. |
| 242 | (let ((map nneething-map) |
| 243 | prev) |
| 244 | (while map |
| 245 | (if (and (member (cadr (car map)) files) |
| 246 | ;; We also remove files that have changed mod times. |
| 247 | (equal (nth 5 (file-attributes |
| 248 | (nneething-file-name (cadr (car map))))) |
| 249 | (cadr (cdar map)))) |
| 250 | (progn |
| 251 | (push (cadr (car map)) map-files) |
| 252 | (setq prev map)) |
| 253 | (setq touched t) |
| 254 | (if prev |
| 255 | (setcdr prev (cdr map)) |
| 256 | (setq nneething-map (cdr nneething-map)))) |
| 257 | (setq map (cdr map)))) |
| 258 | ;; Find all new files and enter them into the map. |
| 259 | (while files |
| 260 | (unless (member (car files) map-files) |
| 261 | ;; This file is not in the map, so we enter it. |
| 262 | (setq touched t) |
| 263 | (setcdr nneething-active (1+ (cdr nneething-active))) |
| 264 | (push (list (cdr nneething-active) (car files) |
| 265 | (nth 5 (file-attributes |
| 266 | (nneething-file-name (car files))))) |
| 267 | nneething-map)) |
| 268 | (setq files (cdr files))) |
| 269 | (when (and touched |
| 270 | (not nneething-read-only)) |
| 271 | (with-temp-file map-file |
| 272 | (insert "(setq nneething-map '") |
| 273 | (gnus-prin1 nneething-map) |
| 274 | (insert ")\n(setq nneething-active '") |
| 275 | (gnus-prin1 nneething-active) |
| 276 | (insert ")\n")))))) |
| 277 | |
| 278 | (defun nneething-insert-head (file) |
| 279 | "Insert the head of FILE." |
| 280 | (when (nneething-get-head file) |
| 281 | (insert-buffer-substring nneething-work-buffer) |
| 282 | (goto-char (point-max)))) |
| 283 | |
| 284 | (defun nneething-encode-file-name (file &optional coding-system) |
| 285 | "Encode the name of the FILE in CODING-SYSTEM." |
| 286 | (let ((pos 0) buf) |
| 287 | (setq file (mm-encode-coding-string |
| 288 | file (or coding-system nnmail-pathname-coding-system))) |
| 289 | (while (string-match "[^-0-9a-zA-Z_:/.]" file pos) |
| 290 | (setq buf (cons (format "%%%02x" (aref file (match-beginning 0))) |
| 291 | (cons (substring file pos (match-beginning 0)) buf)) |
| 292 | pos (match-end 0))) |
| 293 | (apply (function concat) |
| 294 | (nreverse (cons (substring file pos) buf))))) |
| 295 | |
| 296 | (defun nneething-decode-file-name (file &optional coding-system) |
| 297 | "Decode the name of the FILE is encoded in CODING-SYSTEM." |
| 298 | (let ((pos 0) buf) |
| 299 | (while (string-match "%\\([0-9a-fA-F][0-9a-fA-F]\\)" file pos) |
| 300 | (setq buf (cons (string (string-to-number (match-string 1 file) 16)) |
| 301 | (cons (substring file pos (match-beginning 0)) buf)) |
| 302 | pos (match-end 0))) |
| 303 | (mm-decode-coding-string |
| 304 | (apply (function concat) |
| 305 | (nreverse (cons (substring file pos) buf))) |
| 306 | (or coding-system nnmail-pathname-coding-system)))) |
| 307 | |
| 308 | (defun nneething-get-file-name (id) |
| 309 | "Extract the file name from the message ID string." |
| 310 | (when (string-match "\\`<nneething-\\([^@]+\\)@.*>\\'" id) |
| 311 | (nneething-decode-file-name (match-string 1 id)))) |
| 312 | |
| 313 | (defun nneething-make-head (file &optional buffer extra-msg |
| 314 | mime-type mime-charset mime-encoding) |
| 315 | "Create a head by looking at the file attributes of FILE." |
| 316 | (let ((atts (file-attributes file))) |
| 317 | (insert |
| 318 | "Subject: " (file-name-nondirectory file) (or extra-msg "") "\n" |
| 319 | "Message-ID: <nneething-" (nneething-encode-file-name file) |
| 320 | "@" (system-name) ">\n" |
| 321 | (if (equal '(0 0) (nth 5 atts)) "" |
| 322 | (concat "Date: " (current-time-string (nth 5 atts)) "\n")) |
| 323 | (or (when buffer |
| 324 | (with-current-buffer buffer |
| 325 | (when (re-search-forward "<[a-zA-Z0-9_]@[-a-zA-Z0-9_]>" 1000 t) |
| 326 | (concat "From: " (match-string 0) "\n")))) |
| 327 | (nneething-from-line (nth 2 atts) file)) |
| 328 | (if (> (string-to-number (int-to-string (nth 7 atts))) 0) |
| 329 | (concat "Chars: " (int-to-string (nth 7 atts)) "\n") |
| 330 | "") |
| 331 | (if buffer |
| 332 | (with-current-buffer buffer |
| 333 | (concat "Lines: " (int-to-string |
| 334 | (count-lines (point-min) (point-max))) |
| 335 | "\n")) |
| 336 | "") |
| 337 | (if mime-type |
| 338 | (concat "Content-Type: " mime-type |
| 339 | (if mime-charset |
| 340 | (concat "; charset=" |
| 341 | (if (stringp mime-charset) |
| 342 | mime-charset |
| 343 | (symbol-name mime-charset))) |
| 344 | "") |
| 345 | (if mime-encoding |
| 346 | (concat "\nContent-Transfer-Encoding: " mime-encoding) |
| 347 | "") |
| 348 | "\nMIME-Version: 1.0\n") |
| 349 | "")))) |
| 350 | |
| 351 | (defun nneething-from-line (uid &optional file) |
| 352 | "Return a From header based of UID." |
| 353 | (let* ((login (condition-case nil |
| 354 | (user-login-name uid) |
| 355 | (error |
| 356 | (cond ((= uid (user-uid)) (user-login-name)) |
| 357 | ((zerop uid) "root") |
| 358 | (t (int-to-string uid)))))) |
| 359 | (name (condition-case nil |
| 360 | (user-full-name uid) |
| 361 | (error |
| 362 | (cond ((= uid (user-uid)) (user-full-name)) |
| 363 | ((zerop uid) "Ms. Root"))))) |
| 364 | (host (if (string-match "\\`/[^/@]*@\\([^:/]+\\):" file) |
| 365 | (prog1 |
| 366 | (substring file |
| 367 | (match-beginning 1) |
| 368 | (match-end 1)) |
| 369 | (when (string-match |
| 370 | "/\\(users\\|home\\)/\\([^/]+\\)/" file) |
| 371 | (setq login (substring file |
| 372 | (match-beginning 2) |
| 373 | (match-end 2)) |
| 374 | name nil))) |
| 375 | (system-name)))) |
| 376 | (concat "From: " login "@" host |
| 377 | (if name (concat " (" name ")") "") "\n"))) |
| 378 | |
| 379 | (defun nneething-get-head (file) |
| 380 | "Either find the head in FILE or make a head for FILE." |
| 381 | (with-current-buffer (get-buffer-create nneething-work-buffer) |
| 382 | (setq case-fold-search nil) |
| 383 | (buffer-disable-undo) |
| 384 | (erase-buffer) |
| 385 | (cond |
| 386 | ((not (file-exists-p file)) |
| 387 | ;; The file do not exist. |
| 388 | nil) |
| 389 | ((or (file-directory-p file) |
| 390 | (file-symlink-p file)) |
| 391 | ;; It's a dir, so we fudge a head. |
| 392 | (nneething-make-head file) t) |
| 393 | (t |
| 394 | ;; We examine the file. |
| 395 | (condition-case () |
| 396 | (progn |
| 397 | (nnheader-insert-head file) |
| 398 | (if (nnheader-article-p) |
| 399 | (delete-region |
| 400 | (progn |
| 401 | (goto-char (point-min)) |
| 402 | (or (and (search-forward "\n\n" nil t) |
| 403 | (1- (point))) |
| 404 | (point-max))) |
| 405 | (point-max)) |
| 406 | (goto-char (point-min)) |
| 407 | (nneething-make-head file (current-buffer)) |
| 408 | (delete-region (point) (point-max)))) |
| 409 | (file-error |
| 410 | (nneething-make-head file (current-buffer) " (unreadable)"))) |
| 411 | t)))) |
| 412 | |
| 413 | (defun nneething-file-name (article) |
| 414 | "Return the file name of ARTICLE." |
| 415 | (let ((dir (file-name-as-directory nneething-address)) |
| 416 | fname) |
| 417 | (if (numberp article) |
| 418 | (if (setq fname (cadr (assq article nneething-map))) |
| 419 | (expand-file-name fname dir) |
| 420 | (make-temp-name (expand-file-name "nneething" dir))) |
| 421 | (expand-file-name article dir)))) |
| 422 | |
| 423 | (provide 'nneething) |
| 424 | |
| 425 | ;;; nneething.el ends here |