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