wl/wl-news.el.in

   1 ;;; wl-news.el --- Create notification from NEWS(.ja) for Wanderlust.
   2
   3 ;; Copyright (C) 2002 Yoichi NAKAYAMA <yoichi@eken.phys.nagoya-u.ac.jp>
   4 ;; Copyright (C) 2002 Kenichi OKADA <okada@opaopa.org>
   5
   6 ;; Author: Yoichi NAKAYAMA <yoichi@eken.phys.nagoya-u.ac.jp>
   7 ;;      Kenichi OKADA <okada@opaopa.org>
   8 ;; Keywords: mail, net news
   9
  10 ;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen).
  11
  12 ;; This program 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 ;; This program 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., 59 Temple Place - Suite 330,
  25 ;; Boston, MA 02111-1307, USA.
  26 ;;
  27
  28 ;;; Commentary:
  29 ;;
  30
  31 ;;; Code:
  32 ;;
  33
  34 (require 'elmo)
  35 (require 'wl-vars)
  36 (require 'wl-util)
  37 (require 'wl-address)
  38 (require 'wl-folder)
  39
  40 (defvar wl-news-version-file-name "previous-version")
  41 (defvar wl-news-default-previous-version '(2 0 0))
  42
  43 (defvar wl-news-lang
  44   (if (and (boundp 'current-language-environment)
  45            (string-equal "Japanese"
  46                          (symbol-value 'current-language-environment)))
  47       '("ja" "en") '("en" "ja"))
  48         "The list of languages to show NEWS. (order sensitive)")
  49
  50 (defun wl-news-check ()
  51   (let* ((updated (not (wl-news-already-current-p))))
  52     (if updated
  53         (if (and wl-news-lang
  54                  (wl-news-check-news
  55                   (cdr (wl-news-previous-version-load))
  56                   wl-news-lang)
  57                  (not (memq 'wl-news wl-hook)))
  58             (add-hook 'wl-hook 'wl-news))
  59       ;; update wl-news-version-file
  60       (wl-news-previous-version-save
  61        (product-version (product-find 'wl-version))
  62        (cdr (wl-news-previous-version-load))))
  63     updated))
  64
  65 ;;; -*- news-list -*-
  66
  67
  68 ;;; -*- news-list-end -*-
  69
  70 (defun wl-news-previous-version-load ()
  71   (save-excursion
  72     (let ((filename (expand-file-name
  73                      wl-news-version-file-name
  74                      elmo-msgdb-directory))
  75           (tmp-buffer (get-buffer-create " *wl-news-version-tmp*"))
  76           insert-file-contents-pre-hook
  77           insert-file-contents-post-hook
  78           ret-val)
  79       (if (not (file-readable-p filename))
  80           (cons wl-news-default-previous-version
  81                 wl-news-default-previous-version)
  82         (set-buffer tmp-buffer)
  83         (insert-file-contents filename)
  84         (setq ret-val
  85               (condition-case nil
  86                   (read (current-buffer))
  87                 (error nil nil)))
  88         (kill-buffer tmp-buffer)
  89         ret-val))))
  90
  91 (defun wl-news-previous-version-save (current-version previous-version)
  92   (save-excursion
  93     (let ((filename (expand-file-name
  94                      wl-news-version-file-name
  95                      elmo-msgdb-directory))
  96           (tmp-buffer (get-buffer-create " *wl-news-version-tmp*"))
  97           print-length print-level)
  98       (set-buffer tmp-buffer)
  99       (erase-buffer)
 100       (prin1 (cons current-version previous-version) tmp-buffer)
 101       (princ "\n" tmp-buffer)
 102       (if (file-writable-p filename)
 103           (write-region (point-min) (point-max)
 104                         filename nil 'no-msg)
 105         (message "%s is not writable." filename))
 106       (kill-buffer tmp-buffer))))
 107
 108 (defun wl-news-append-news (lang previous-version &optional no-mime-tag)
 109   (require 'wl-mime)
 110   (let ((news-list (cdr (assoc lang wl-news-news-alist)))
 111         ret)
 112     (when news-list
 113       (if no-mime-tag
 114           (insert "--------------\n")
 115         (mime-edit-insert-tag "text" "plain" "" ""))
 116       (while (< 0
 117                 (product-version-compare
 118                  (car (car news-list))
 119                  previous-version))
 120         (setq ret t)
 121         (insert (cdr (car news-list)) "\n\n")
 122         (setq news-list (cdr news-list))))
 123     ret))
 124
 125 (defun wl-news-check-news (version news-lang)
 126   (let ((lang news-lang)
 127         news-list ret)
 128     (while (car lang)
 129       (setq news-list (cdr (assoc (car lang) wl-news-news-alist)))
 130       (while (< 0
 131                 (product-version-compare
 132                  (car (car news-list)) version))
 133         (setq ret t)
 134         (setq news-list (cdr news-list)))
 135       (setq lang (cdr lang)))
 136     ret))
 137
 138 (defun wl-news-already-current-p ()
 139   (>= 0 (product-version-compare
 140          (product-version (product-find 'wl-version))
 141          (car (wl-news-previous-version-load)))))
 142
 143 (defun wl-news-send-news (version news-lang folder)
 144   (require 'wl-draft)
 145   (let ((lang (if (listp wl-news-lang)
 146                   wl-news-lang
 147                 (list wl-news-lang)))
 148         send-buffer
 149         wl-fcc wl-bcc ret)
 150     (save-window-excursion
 151       (set-buffer
 152        (setq send-buffer (wl-draft-create-buffer)))
 153       (wl-draft-create-contents
 154        (list (cons 'From "WL Release 'Bot <wl@lists.airs.net>")
 155              (cons 'To (wl-draft-eword-encode-address-list wl-from))
 156              (cons 'Subject "Wanderlust NEWS")
 157              (cons 'Date (wl-make-date-string))
 158              (cons 'User-Agent wl-generate-mailer-string-function)))
 159       (wl-draft-insert-mail-header-separator)
 160       (wl-draft-prepare-edit)
 161       (goto-char (point-max))
 162       (insert "\nThis message is automatically generated by Wanderlust.\n\n")
 163       ;; insert news
 164       (while (car lang)
 165         (wl-news-append-news (car lang) version)
 166         (setq lang (cdr lang)))
 167       ;; encode
 168       (let ((mime-header-encode-method-alist
 169              '((eword-encode-unstructured-field-body))))
 170         (mime-edit-translate-buffer))
 171       (wl-draft-get-header-delimiter t)
 172       (setq ret
 173             (and (elmo-folder-writable-p
 174                   (wl-folder-get-elmo-folder folder))
 175                  (elmo-folder-append-buffer
 176                   (wl-folder-get-elmo-folder folder))))
 177       (wl-draft-hide send-buffer)
 178       (wl-draft-delete send-buffer))
 179     ret))
 180
 181 ;;; wl-news-mode
 182
 183 (defvar wl-news-buf-name "NEWS")
 184 (defvar wl-news-mode-map nil)
 185 (defvar wl-news-winconf nil)
 186 (defvar wl-news-buffer-oldest-version nil)
 187 (make-variable-buffer-local 'wl-news-buffer-oldest-version)
 188
 189 (unless wl-news-mode-map
 190   (setq wl-news-mode-map (make-sparse-keymap))
 191   (define-key wl-news-mode-map "q"     'wl-news-exit)
 192   (define-key wl-news-mode-map "Q"     'wl-news-force-exit)
 193   (define-key wl-news-mode-map "\C-xk" 'wl-news-exit)
 194   (define-key wl-news-mode-map "a"     'wl-news-show-all)
 195   (define-key wl-news-mode-map "m"     'wl-news-append-to-folder)
 196   (define-key wl-news-mode-map "\C-m"  'wl-news-next-line)
 197   (define-key wl-news-mode-map " "     'wl-news-next-page))
 198
 199 (defun wl-news-mode ()
 200   "Mode for Wanderlust NEWS(.ja)."
 201   (interactive)
 202   (kill-all-local-variables)
 203   (use-local-map wl-news-mode-map)
 204   (setq major-mode 'wl-news-mode)
 205   (setq mode-name "NEWS")
 206   (setq buffer-read-only t))
 207
 208 (defun wl-news (&optional arg)
 209   (interactive "P")
 210   (remove-hook 'wl-hook 'wl-news)
 211   (let* ((previous-version (if arg wl-news-default-previous-version
 212                              (cdr (wl-news-previous-version-load))))
 213          (lang wl-news-lang)
 214          window-lines lines)
 215     (if (or (get-buffer wl-news-buf-name)
 216             (if (wl-news-check-news previous-version wl-news-lang)
 217                 (progn
 218                   (setq wl-news-winconf (current-window-configuration))
 219                   (set-buffer (get-buffer-create wl-news-buf-name))
 220                   (wl-news-mode)
 221                   (setq wl-news-buffer-oldest-version previous-version)
 222                   (buffer-disable-undo (current-buffer))
 223                   ;; insert news
 224                   (let ((buffer-read-only nil))
 225                     (insert "--- Wanderlust NEWS ---  press 'a' to show all NEWS\n")
 226                     (insert "                         press 'm' to mail this NEWS to your folder\n")
 227                     (insert "                         press 'q' to quit\n")
 228                     (insert "                         press 'Q' to force quit\n\n")
 229                     (while (car lang)
 230                       (wl-news-append-news
 231                        (car lang) previous-version t)
 232                       (setq lang (cdr lang))))
 233                   t)
 234               (message "No NEWS.")
 235               nil))
 236         (progn
 237           (switch-to-buffer wl-news-buf-name)
 238           (delete-other-windows)
 239           (goto-char (point-min))))))
 240
 241 (defun wl-news-next-line ()
 242   (interactive)
 243   (scroll-up 1))
 244
 245 (defun wl-news-next-page ()
 246   (interactive)
 247   (scroll-up))
 248
 249 (defun wl-news-show-all ()
 250   (interactive)
 251   (when (eq major-mode 'wl-news-mode)
 252     (kill-buffer (current-buffer))
 253     (wl-news t)))
 254
 255 (defun wl-news-exit ()
 256   (interactive)
 257   (let* ((oldest-version (cdr (wl-news-previous-version-load)))
 258          (current-version (product-version (product-find 'wl-version)))
 259          (new-old-version current-version)
 260          (buf (get-buffer wl-news-buf-name)))
 261     (when buf
 262       (if (wl-news-check-news oldest-version wl-news-lang)
 263           (if (y-or-n-p "Do you want to see this message again? ")
 264               (progn
 265                 (message "Please M-x wl-news if you want to see it.")
 266                 (setq new-old-version oldest-version))))
 267       (wl-news-previous-version-save
 268        current-version new-old-version)
 269       (kill-buffer (current-buffer))
 270       (if wl-news-winconf
 271           (set-window-configuration wl-news-winconf))
 272       (kill-buffer buf)
 273       (if wl-news-winconf
 274           (set-window-configuration wl-news-winconf)))))
 275
 276 (defun wl-news-append-to-folder ()
 277   (interactive)
 278   (let* ((current-version (product-version (product-find 'wl-version)))
 279          (new-old-version current-version)
 280          (folder wl-default-folder))
 281     (if (or (and (elmo-folder-writable-p
 282                   (wl-folder-get-elmo-folder folder))
 283                  (y-or-n-p (format
 284                             "Do you want to append this message to %s ? "
 285                             wl-default-folder)))
 286             (setq folder
 287                   (wl-summary-read-folder wl-default-folder "to append ")))
 288         (or (wl-news-send-news wl-news-buffer-oldest-version wl-news-lang folder)
 289             (error "Cannot append NEWS mail to %s" folder)))))
 290
 291 (defun wl-news-force-exit ()
 292   (interactive)
 293   (let ((buf))
 294     (when (setq buf (get-buffer wl-news-buf-name))
 295       (wl-news-previous-version-save
 296        (product-version (product-find 'wl-version))
 297        (cdr (wl-news-previous-version-load)))
 298       (kill-buffer buf)
 299       (if wl-news-winconf
 300           (set-window-configuration wl-news-winconf)))))
 301
 302
 303 (require 'product)
 304 (product-provide (provide 'wl-news) (require 'wl-version))
 305
 306 ;;; wl-news.el ends here