navi2ch-message.el

   1 ;;; navi2ch-message.el --- write message module for navi2ch -*- coding: iso-2022-7bit; -*-
   2
   3 ;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2008, 2009
   4 ;; by Navi2ch Project
   5
   6 ;; Author: Taiki SUGAWARA <taiki@users.sourceforge.net>
   7 ;; Keywords: network, 2ch
   8
   9 ;; This file is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2, or (at your option)
  12 ;; any later version.
  13
  14 ;; This file is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs; see the file COPYING.  If not, write to
  21 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22 ;; Boston, MA 02111-1307, USA.
  23
  24 ;;; Commentary:
  25
  26 ;;
  27
  28 ;;; Code:
  29 (provide 'navi2ch-message)
  30 (defconst navi2ch-message-ident
  31   "$Id$")
  32 (defconst navi2ch-message-samba24-sambatxt-url
  33   "http://nullpo.s101.xrea.com/samba24/conv.xcg?browser=bbs2chreader&decsec=majority&offset=0&newline=crlf&output=download")
  34
  35 (eval-when-compile
  36   (require 'cl-lib)
  37   (require 'navi2ch-decls)
  38   (require 'navi2ch-inline))
  39 (require 'navi2ch-vars)
  40
  41 (eval-and-compile
  42   (when (featurep 'xemacs)
  43     (require 'timer)))
  44
  45 (defvar navi2ch-message-aa-map nil)
  46 (unless navi2ch-message-aa-map
  47   (let ((map (make-sparse-keymap "Type ? for further options")))
  48     (navi2ch-set-keymap-default-binding map 'navi2ch-message-self-insert-aa)
  49     (define-key map "?" 'navi2ch-message-insert-aa)
  50     (setq navi2ch-message-aa-map map)))
  51
  52 (defvar navi2ch-message-mode-map nil)
  53 (unless navi2ch-message-mode-map
  54   (let ((map (make-sparse-keymap)))
  55     (set-keymap-parent map navi2ch-global-map)
  56     (define-key map "\C-c\C-c" 'navi2ch-message-send-message)
  57     (define-key map "\C-c\C-k" 'navi2ch-message-exit)
  58     (define-key map "\C-c\C-y" 'navi2ch-message-cite-original)
  59     (define-key map "\C-c\C-j" 'navi2ch-message-cite-original-from-number)
  60     (define-key map "\C-c\C-i" 'navi2ch-message-insert-backup)
  61     (define-key map "\C-c\C-b" 'navi2ch-base64-insert-file)
  62     (define-key map navi2ch-message-aa-prefix-key navi2ch-message-aa-map)
  63     (setq navi2ch-message-mode-map map)))
  64
  65 (defvar navi2ch-message-mode-menu-spec
  66   '("Message"
  67     ["Toggle offline" navi2ch-toggle-offline]
  68     ["Send message" navi2ch-message-send-message]
  69     ["Cancel" navi2ch-message-exit]
  70     ["Cite message" navi2ch-message-cite-original]))
  71
  72 (defvar navi2ch-message-buffer-name "*navi2ch message*")
  73 (defvar navi2ch-message-backup-buffer-name "*navi2ch message backup*")
  74 (defvar navi2ch-message-current-article-buffer nil)
  75 (defvar navi2ch-message-current-article nil)
  76 (defvar navi2ch-message-current-board nil)
  77 (defvar navi2ch-message-new-message-p nil)
  78 (defvar navi2ch-message-window-configuration nil)
  79 (defvar navi2ch-message-header-separator "----------------\n")
  80
  81 (defvar navi2ch-message-paragraph-separate
  82   (concat (regexp-quote navi2ch-message-header-separator) "\\|"
  83           ">\\|"                        ; \e$B0zMQ\e(B
  84           "[ \t]*$")                    ; \e$B6u9T\e(B
  85   "*`navi2ch-message-mode' \e$B$G;HMQ$5$l$k\e(B `paragraph-separate'\e$B!#\e(B")
  86
  87 (defvar navi2ch-message-paragraph-start
  88   navi2ch-message-paragraph-separate
  89   "*`navi2ch-message-mode' \e$B$G;HMQ$5$l$k\e(B `paragraph-start'\e$B!#\e(B")
  90
  91 (defvar navi2ch-message-sendlog-board
  92   `((name . "\e$BAw?.95$(\e(B")
  93     (type . board)
  94     (id . "sendlog")
  95     (bbstype . localfile)
  96     (uri . ,(concat "x-localbbs://" (navi2ch-expand-file-name "sendlog/")))))
  97
  98 (defvar navi2ch-message-font-lock-keywords
  99   `(("^>\\s-+.*$" . navi2ch-message-citation-face)
 100     ("[>\e$B!d\e(B]+[0-9\e$B#0\e(B-\e$B#9\e(B]+" 0 navi2ch-message-link-face t)
 101     (,navi2ch-article-url-regexp 0 navi2ch-message-url-face t)))
 102
 103 (defvar navi2ch-message-link-face 'navi2ch-message-link-face)
 104 (defvar navi2ch-message-url-face 'navi2ch-message-url-face)
 105 (defvar navi2ch-message-citation-face 'navi2ch-message-citation-face)
 106
 107 ;; SAMBA24\e$B$N%G!<%?\e(B(url\e$B$@$NHDL>$@$N;~4V$@$N\e(B)
 108 (defvar navi2ch-message-samba24-samba-data nil)
 109 (defvar navi2ch-message-samba24-send-time nil
 110   "\e$BHD\e(BID\e$B$H=q$-9~$_;~4V$rJ];}\e(B")
 111 ;; \e$B%b!<%I%i%$%s$KI=<($9$k%+%&%s%H%@%&%s\e(B
 112 (defvar navi2ch-message-samba24-mode-string nil)
 113 (defvar navi2ch-message-samba24-show t
 114   "non-nil \e$B$J$i=q$-9~$_5,@);~4V$rI=<(\e(B.")
 115 ;; \e$B8=:_I=<(Cf$N=q$-9~$_5,@);~4V%b!<%I%i%$%s\e(B
 116 (defvar navi2ch-message-samba24-mode-string nil)
 117 (defvar navi2ch-message-samba24-file-name "samba.txt"
 118   "Samba24 \e$B$N5,@)IC?t>pJs$rJ];}$9$k%U%!%$%k$N%U%!%$%kL>\e(B.")
 119 (defvar navi2ch-message-samba24-update-timer nil)
 120
 121 (defun navi2ch-message-write-message (board article &optional new sage cite)
 122   (when (or (not navi2ch-message-ask-before-write)
 123             (if (functionp navi2ch-message-ask-before-write)
 124                 (funcall navi2ch-message-ask-before-write "Write new message? ")
 125               (y-or-n-p "Write new message? ")))
 126     (if (and (get-buffer navi2ch-message-buffer-name)
 127              (or navi2ch-message-always-pop-message
 128                  (not (navi2ch-message-kill-message))))
 129         (navi2ch-message-pop-message-buffer)
 130       (setq navi2ch-message-window-configuration
 131             (current-window-configuration))
 132       (delete-other-windows)
 133       (split-window-vertically)
 134       (other-window 1)
 135       (setq navi2ch-message-current-article article)
 136       (setq navi2ch-message-current-board board)
 137       (setq navi2ch-message-new-message-p new)
 138       (setq navi2ch-message-current-article-buffer
 139             (if new nil (current-buffer)))
 140       (switch-to-buffer (get-buffer-create navi2ch-message-buffer-name))
 141       (navi2ch-message-mode)
 142       (erase-buffer)
 143       (navi2ch-message-insert-header new sage)
 144       (setq navi2ch-mode-line-identification
 145             (navi2ch-message-make-mode-line-identification new))
 146       (navi2ch-set-mode-line-identification)
 147       (when cite
 148         (navi2ch-message-cite-original))
 149       (run-hooks 'navi2ch-message-setup-message-hook)
 150       (when sage
 151         (run-hooks 'navi2ch-message-setup-sage-message-hook)))))
 152
 153 (defun navi2ch-message-make-mode-line-identification (new)
 154   (if new
 155       (format "*new message* [%s]"
 156               (cdr (assq 'name navi2ch-message-current-board)))
 157     (format "Re: %s [%s]"
 158             (cdr (assq 'subject navi2ch-message-current-article))
 159             (cdr (assq 'name navi2ch-message-current-board)))))
 160
 161 (defun navi2ch-message-pop-message-buffer ()
 162   (interactive)
 163   (let ((buf (get-buffer navi2ch-message-buffer-name)))
 164     (when buf
 165       (cond ((get-buffer-window buf)
 166              (select-window (get-buffer-window buf)))
 167             (buf
 168              (setq navi2ch-message-window-configuration
 169                    (current-window-configuration))
 170              (delete-other-windows)
 171              (split-window-vertically)
 172              (other-window 1)
 173              (switch-to-buffer navi2ch-message-buffer-name))))))
 174
 175 (defun navi2ch-message-insert-backup ()
 176   (interactive)
 177   (when (get-buffer navi2ch-message-backup-buffer-name)
 178     (let ((inhibit-read-only t))
 179       (erase-buffer))
 180     (insert-buffer-substring navi2ch-message-backup-buffer-name)))
 181
 182 (defun navi2ch-message-insert-header (new sage)
 183   (and sage (setq sage "sage"))
 184   (when new
 185     (insert (navi2ch-read-only-string "Subject: ")
 186             (navi2ch-read-only-string "\n" t)))
 187   (insert (navi2ch-read-only-string "From: ")
 188           (or (and navi2ch-message-remember-user-name
 189                    (cdr (assq 'name navi2ch-message-current-article)))
 190               (cdr (assoc (cdr (assq 'id navi2ch-message-current-board))
 191                           navi2ch-message-user-name-alist))
 192               navi2ch-message-user-name "")
 193           (navi2ch-read-only-string "\n" t)
 194           (navi2ch-read-only-string "Mail: ")
 195           (or sage
 196               (and navi2ch-message-remember-user-name
 197                    (cdr (assq 'mail navi2ch-message-current-article)))
 198               (cdr (assoc (cdr (assq 'id navi2ch-message-current-board))
 199                           navi2ch-message-mail-address-alist))
 200               navi2ch-message-mail-address "")
 201           (navi2ch-read-only-string "\n" t)
 202           (navi2ch-read-only-string
 203            (navi2ch-propertize navi2ch-message-header-separator
 204                                'navi2ch-message-header-separator t)))
 205   (setq buffer-undo-list nil)
 206   (set-buffer-modified-p nil))
 207
 208 (defun navi2ch-message-header-end ()
 209   (save-restriction
 210     (widen)
 211     (if (get-text-property (point-min) 'navi2ch-message-header-separator)
 212         (point-min)
 213       (next-single-property-change (point-min) 'navi2ch-message-header-separator))))
 214
 215 (defun navi2ch-message-cleanup-message ()
 216   (save-excursion
 217     (let ((start (progn (goto-char (navi2ch-message-header-end))
 218                         (forward-line)
 219                         (point))))
 220       (when navi2ch-message-cleanup-trailing-whitespace
 221         (goto-char start)
 222         (while (re-search-forward "[ \t]+$" nil t)
 223           (replace-match "")))
 224       (when navi2ch-message-cleanup-trailing-newline
 225         (goto-char start)
 226         (if (re-search-forward "[ \t\n]+\\'" nil t)
 227             (replace-match ""))))))
 228
 229 (defun navi2ch-message-insert-notice (msg)
 230   "\e$B%a%C%;!<%8Ej9F%P%C%U%!$K2r@b$d%(%i!<%a%C%;!<%8$J$I\e(B `msg' \e$B$rI=<($9$k!#\e(B
 231
 232 \e$B>r7o\e(B: \e$B%a%C%;!<%8Ej9F%P%C%U%!Fb$G8F$P$l$k$3$H!#\e(B"
 233   (let ((inhibit-read-only t)
 234         (end (navi2ch-message-header-end))
 235         pos)
 236     (when end
 237       (save-excursion
 238         ;; (point-min) \e$B$G$O\e(B text-property `navi2ch-message-notice' \e$B$,$J$$!"\e(B
 239         ;; \e$B$^$?$O\e(B nil \e$B$G$"$k$3$H$,J]>Z$5$l$k!#\e(B \e$B$^$?!"\e(B text-property
 240         ;; `navi2ch-message-notice' \e$B$,\e(B non-nil \e$B$G$"$kE@$+$i\e(B
 241         ;; (navi2ch-message-header-end) \e$B$^$G$O\e(B notice \e$B$N$_$,F~$k$H$9$k!#\e(B
 242         (when (setq pos (next-single-property-change (point-min)
 243                                                      'navi2ch-message-notice))
 244           (delete-region pos end))
 245         (goto-char (navi2ch-message-header-end))
 246         (insert
 247          (navi2ch-read-only-string
 248           (navi2ch-propertize navi2ch-message-header-separator
 249                               'navi2ch-message-notice t))
 250          (navi2ch-read-only-string (concat msg "\n")))))))
 251
 252 (defun navi2ch-message-send-message ()
 253   (interactive)
 254   (if navi2ch-offline
 255       (message "Now offline")
 256     (when (or (not navi2ch-message-ask-before-send)
 257               (if (functionp navi2ch-message-ask-before-send)
 258                   (funcall navi2ch-message-ask-before-send "Send message? ")
 259                 (y-or-n-p "Send message? ")))
 260       (widen)
 261       (run-hooks 'navi2ch-message-before-send-hook)
 262       (navi2ch-message-cleanup-message)
 263       (let (result)
 264         (save-excursion
 265           (let ((end (navi2ch-message-header-end))
 266                 (from "")
 267                 (mail "")
 268                 subject message)
 269             (goto-char (point-min))
 270             (when navi2ch-message-new-message-p
 271               (if (re-search-forward "^Subject: ?\\(.*\\)" end t)
 272                   (setq subject (match-string 1))
 273                 (setq subject "")))
 274             (goto-char (point-min))
 275             (when (re-search-forward "^From: ?\\(.*\\)" end t)
 276               (setq from (match-string 1))
 277               (when (and (not navi2ch-message-new-message-p)
 278                          navi2ch-message-remember-user-name)
 279                 (navi2ch-message-set-name from)))
 280             (goto-char (point-min))
 281             (when (re-search-forward "^Mail: ?\\(.*\\)" end t)
 282               (setq mail (match-string 1))
 283               (when (and (not navi2ch-message-new-message-p)
 284                          navi2ch-message-remember-user-name)
 285                 (navi2ch-message-set-mail mail)))
 286             (goto-char end)
 287             (forward-line)
 288             (setq message (buffer-substring-no-properties (point) (point-max)))
 289             (let ((buffer (current-buffer))
 290                   (inhibit-read-only t))
 291               (with-current-buffer (get-buffer-create
 292                                     navi2ch-message-backup-buffer-name)
 293                 (erase-buffer)
 294                 (insert-buffer-substring buffer)))
 295             (when navi2ch-message-trip
 296               (setq from (concat from "#" navi2ch-message-trip)))
 297             (let ((board navi2ch-message-current-board)
 298                   (article navi2ch-message-current-article))
 299               (navi2ch-net-cleanup)
 300               ;; \e$B"-\e(Bresult\e$B$r8E$$;EMM$KLa$7$?!#\e(Bspid\e$B$O!"\e(Bnavi2ch-multibbs.el\e$B$N\e(B
 301               ;; \e$B"-\e(B   navi2ch-2ch-send-message \e$B$G=hM}$9$k!#\e(B
 302               (setq result (navi2ch-multibbs-send-message
 303                             from mail message subject board article))
 304               (navi2ch-net-cleanup)
 305               (when result
 306                 (when navi2ch-message-save-sendlog
 307                   (navi2ch-message-add-sendlog from mail message subject
 308                                                board article))
 309                 (message "Waiting new message...")
 310                 (sleep-for navi2ch-message-wait-time)
 311                 (message "%s%s" (current-message) "done")
 312                 (save-excursion
 313                   (if navi2ch-message-new-message-p
 314                       (progn
 315                         (set-buffer navi2ch-board-buffer-name)
 316                         (navi2ch-board-sync))
 317                     (when (buffer-live-p navi2ch-message-current-article-buffer)
 318                       (set-buffer navi2ch-message-current-article-buffer)
 319                       (navi2ch-article-sync navi2ch-message-force-sync)))))
 320               (when (get-buffer navi2ch-message-backup-buffer-name)
 321                 (bury-buffer navi2ch-message-backup-buffer-name)))))
 322         (navi2ch-message-samba24)
 323         (run-hooks 'navi2ch-message-after-send-hook)
 324         (if result
 325             (navi2ch-message-exit 'after-send)
 326           (let ((errmsg (current-message)))
 327             (when (and errmsg
 328                        (string-match ": " errmsg))
 329               (setq errmsg (substring errmsg (match-end 0)))
 330               (navi2ch-message-insert-notice (concat "\e$BEj9F%(%i!<\e(B: " errmsg)))))))))
 331
 332 (defun navi2ch-message-set-name (name)
 333   (save-excursion
 334     (if (buffer-live-p navi2ch-message-current-article-buffer)
 335         (set-buffer navi2ch-message-current-article-buffer)
 336       (navi2ch-article-view-article navi2ch-message-current-board
 337                                     navi2ch-message-current-article
 338                                     nil))
 339     (setq navi2ch-article-current-article
 340           (navi2ch-put-alist 'name name
 341                              navi2ch-article-current-article))))
 342
 343 (defun navi2ch-message-set-mail (mail)
 344   (let ((case-fold-search t))
 345     (unless (string-match "sage" mail)
 346       (save-excursion
 347         (if (buffer-live-p navi2ch-message-current-article-buffer)
 348             (set-buffer navi2ch-message-current-article-buffer)
 349           (navi2ch-article-view-article navi2ch-message-current-board
 350                                         navi2ch-message-current-article
 351                                         nil))
 352         (setq navi2ch-article-current-article
 353               (navi2ch-put-alist 'mail mail
 354                                  navi2ch-article-current-article))))))
 355
 356 (defun navi2ch-message-cite-original (&optional arg)
 357   "\e$B0zMQ$9$k!#\e(B"
 358   (interactive "P")
 359   (let (nums from to)
 360     (setq nums
 361           (with-current-buffer (navi2ch-article-current-buffer)
 362             (if (navi2ch-region-active-p)
 363                 (progn
 364                   (setq from (save-excursion
 365                                (goto-char (region-beginning))
 366                                (navi2ch-article-get-current-number))
 367                         to (save-excursion
 368                              (goto-char (region-end))
 369                              (navi2ch-article-get-current-number)))
 370                   (navi2ch-number-sequence from to))
 371               `(,(navi2ch-article-get-current-number)))))
 372     (if arg
 373         (progn
 374           (navi2ch-message-cite-original-from-number (or from (car nums))
 375                                                      arg)
 376           (when to
 377             (goto-char (1- (point)))
 378             (insert "-" (number-to-string to))
 379             (goto-char (1+ (point)))))
 380       (dolist (n nums)
 381         (navi2ch-message-cite-original-from-number n)))))
 382
 383 (defun navi2ch-message-cite-original-from-number (num &optional arg)
 384   "\e$BHV9f$rA*$s$G!"0zMQ$9$k!#\e(B"
 385   (interactive "nInput number: \nP")
 386   (when (< (point) (navi2ch-message-header-end))
 387     (error "Cannot cite in header"))
 388   (let (same msg board article)
 389     (with-current-buffer (navi2ch-article-current-buffer)
 390       (setq msg (navi2ch-article-get-message-string num))
 391       (setq article navi2ch-article-current-article)
 392       (setq board navi2ch-article-current-board)
 393       (setq same (and (string-equal (cdr (assq 'id board))
 394                                     (cdr (assq 'id navi2ch-message-current-board)))
 395                       (string-equal (cdr (assq 'artid article))
 396                                     (cdr (assq 'artid navi2ch-message-current-article))))))
 397     (if same
 398         (insert ">>" (number-to-string num) "\n")
 399       (insert (navi2ch-article-to-url board article num num nil) "\n"))
 400     (unless arg
 401       (push-mark)
 402       (let ((point (point)))
 403         (insert msg "\n")
 404         (string-rectangle point (point) navi2ch-message-cite-prefix)))))
 405
 406 (defun navi2ch-message-exit (&optional after-send)
 407   (interactive)
 408   (run-hooks 'navi2ch-message-exit-hook)
 409   (when (navi2ch-message-kill-message after-send)
 410     ;; \e$B$`$%!"\e(Bset-window-configuration \e$B$r;H$&$H%+!<%=%k0LCV$,JQ$K$J$k$s$+$$!)\e(B
 411     (set-window-configuration navi2ch-message-window-configuration)
 412     (when (and (not navi2ch-message-new-message-p)
 413                after-send)
 414       (if (buffer-live-p navi2ch-message-current-article-buffer)
 415           (set-buffer navi2ch-message-current-article-buffer)
 416         (navi2ch-article-view-article navi2ch-message-current-board
 417                                       navi2ch-message-current-article
 418                                       navi2ch-message-force-sync)))
 419     (navi2ch-article-load-number)))
 420
 421 (defun navi2ch-message-kill-message (&optional no-ask)
 422   (when (or no-ask
 423             (not navi2ch-message-ask-before-kill)
 424             (if (functionp navi2ch-message-ask-before-kill)
 425                 (funcall navi2ch-message-ask-before-kill "Kill current message? ")
 426               (y-or-n-p "Kill current message? ")))
 427     (kill-buffer navi2ch-message-buffer-name)
 428     t))
 429
 430 (easy-menu-define navi2ch-message-mode-menu
 431   navi2ch-message-mode-map
 432   "Menu used in navi2ch-message"
 433   navi2ch-message-mode-menu-spec)
 434
 435 (defun navi2ch-message-setup-menu ()
 436   (easy-menu-add navi2ch-message-mode-menu))
 437
 438 (defun navi2ch-message-fill-paragraph (arg)
 439   (interactive)
 440   (let ((before (point)))
 441     (save-excursion
 442       (forward-paragraph)
 443       (or (bolp) (newline 1))
 444       (let ((end (point))
 445             (beg (progn (backward-paragraph) (point))))
 446         (when (eq beg (point-min))
 447           (forward-line 3)
 448           (setq beg (point)))
 449         (goto-char before)
 450         (fill-region-as-paragraph beg end arg)
 451         t))))
 452
 453 (defun navi2ch-message-substitute-key-definitions ()
 454   (dolist (old-new-def
 455            '((beginning-of-line . navi2ch-message-beginning-of-line)
 456              (back-to-indentation . navi2ch-message-back-to-indentation)))
 457     (substitute-key-definition (car old-new-def) (cdr old-new-def)
 458                                navi2ch-message-mode-map (current-global-map))))
 459
 460 (define-derived-mode navi2ch-message-mode text-mode
 461   "Navi2ch Message"
 462   "\\{navi2ch-message-mode-map}"
 463   (set (make-local-variable 'fill-paragraph-function)
 464        'navi2ch-message-fill-paragraph)
 465   (set (make-local-variable 'paragraph-separate)
 466        navi2ch-message-paragraph-separate)
 467   (set (make-local-variable 'paragraph-start)
 468        navi2ch-message-paragraph-start)
 469   (set (make-local-variable 'auto-fill-inhibit-regexp)
 470        "^[A-Z][^: \n\t]+:")             ; \e$B%X%C%@\e(B
 471   (set (make-local-variable 'font-lock-defaults)
 472        '(navi2ch-message-font-lock-keywords t))
 473   (navi2ch-message-setup-menu)
 474   (navi2ch-message-substitute-key-definitions))
 475
 476 (defun navi2ch-message-self-insert-aa ()
 477   "\e$B:G8eF~NO$7$?%-!<$K$7$?$,$C$F\e(B AA \e$B$rF~NO$9$k!#\e(B"
 478   (interactive)
 479   (let ((char last-command-event) aa)
 480     (if (and (navi2ch-char-valid-p char)
 481              (setq aa (cdr (assoc (string last-command-event)
 482                                   (append navi2ch-message-aa-alist
 483                                           navi2ch-message-aa-default-alist)))))
 484         (insert aa)
 485       (ding))))
 486
 487 (defun navi2ch-message-insert-aa-list ()
 488   (let ((aa-width navi2ch-message-popup-aa-width)
 489         (nl nil)
 490         alist keys)
 491     (dolist (elt (append navi2ch-message-aa-alist
 492                          navi2ch-message-aa-default-alist))
 493       (when (and (not (member (car elt) keys))
 494                  (stringp (car elt))
 495                  (stringp (cdr elt)))
 496         (setq alist (cons elt alist))
 497         (setq keys (cons (car elt) keys))))
 498     (dolist (key (sort keys 'string<))
 499       (let ((val (cdr (assoc key alist)))
 500             string width)
 501         (setq string (format "%s: %s" (key-description key) val)
 502               width (string-width string))
 503         (if (> width aa-width)
 504             (setq string (concat (navi2ch-truncate-string-to-width
 505                                   string (- aa-width 3))
 506                                  "...")))
 507         (insert (navi2ch-truncate-string-to-width string aa-width nil ?\ )
 508                 (if nl "\n" " "))
 509         (setq nl (not nl))))))
 510
 511 (defun navi2ch-message-popup-aa-list ()
 512   "aa \e$B$N%j%9%H$rI=<($9$k!#\e(B"
 513   (interactive)
 514   (let ((buffer (get-buffer-create "*AA List*"))
 515         (continue t)
 516         c)
 517     (unwind-protect
 518         (save-window-excursion
 519           (with-current-buffer buffer
 520             (erase-buffer)
 521             (navi2ch-message-insert-aa-list)
 522             (goto-char (point-min))
 523             (pop-to-buffer (current-buffer))
 524             (while continue
 525               (setq c (navi2ch-read-char
 526                        "Type key for AA (or SPC forward, DEL back): "))
 527               (cond
 528                ((memq c '(?\  ?\C-v))
 529                 (ignore-errors (scroll-up)))
 530                ((memq c '(?\C-h ?\177))
 531                 (ignore-errors (scroll-down)))
 532                ((eq c ?\C-l)
 533                 (recenter))
 534                (t (setq continue nil)))))
 535           c)
 536       (if (bufferp buffer)
 537           (kill-buffer buffer)))))
 538
 539 (defun navi2ch-message-insert-aa ()
 540   "aa \e$B$rF~NO$9$k!#\e(B"
 541   (interactive)
 542   (let* ((char (navi2ch-message-popup-aa-list))
 543          (aa (cdr (assoc (char-to-string char)
 544                          (append navi2ch-message-aa-alist
 545                                  navi2ch-message-aa-default-alist)))))
 546     (if (stringp aa)
 547         (insert aa)
 548       (ding))))
 549
 550 (defun navi2ch-message-jump-to-message-buffer ()
 551   "message buffer \e$B$,$"$k$H$-!"=q$-9~$_@h$N%9%l\e(B/\e$BHD$rI=<($7\e(B message buffer \e$B$K@Z$jBX$(!#\e(B"
 552   (interactive)
 553   (if (not (get-buffer navi2ch-message-buffer-name))
 554       (message "No message buffer")
 555     (delete-other-windows)
 556     (if navi2ch-message-current-article-buffer
 557         ;; \e$B4{B8%9%l$K=q$-9~$_\e(B \e$B"*\e(B \e$B=q$-9~$_@h$N%9%l$rI=<(\e(B
 558         (if (buffer-live-p navi2ch-message-current-article-buffer)
 559             (switch-to-buffer navi2ch-message-current-article-buffer)
 560           (navi2ch-article-view-article navi2ch-message-current-board
 561                                         navi2ch-message-current-article)
 562           (setq navi2ch-message-current-article-buffer (current-buffer)))
 563       ;; \e$B?75,%9%lN)$F\e(B \e$B"*\e(B \e$B=q$-9~$_@h$NHD$rI=<(\e(B
 564       (or (and (get-buffer navi2ch-board-buffer-name)
 565                (progn (switch-to-buffer (get-buffer
 566                                          navi2ch-board-buffer-name))
 567                       t)
 568                (eq major-mode 'navi2ch-board-mode)
 569                (eq navi2ch-board-current-board
 570                    navi2ch-message-current-board))
 571           (navi2ch-bm-select-board navi2ch-message-current-board)))
 572     (split-window-vertically)
 573     (other-window 1)
 574     (switch-to-buffer (get-buffer navi2ch-message-buffer-name))))
 575
 576 (defun navi2ch-message-beginning-of-line (&optional n)
 577   "\e$B9T$N@hF,$X0\F0!#\e(B
 578 header field \e$B$X0\F0$7$J$$0J30$O\e(B `beginning-of-line' \e$B$HF1$8!#\e(B"
 579   (interactive "p")
 580   (beginning-of-line n)
 581   (when (< (point) (navi2ch-message-header-end))
 582     (search-forward ": " nil t)))
 583
 584 (defun navi2ch-message-back-to-indentation ()
 585   "\e$B9T$N:G=i$N6uGr$G$J$$2U=j$X0\F0!#\e(B
 586 header field \e$B$X0\F0$7$J$$0J30$O\e(B `back-to-indentation' \e$B$HF1$8!#\e(B"
 587   (interactive)
 588   (navi2ch-message-beginning-of-line)
 589   (skip-chars-forward " \t"))
 590
 591 ;; sendlog\e$B5!G=\e(B
 592 (defun navi2ch-message-sendlog-subject (board article)
 593   ;; \e$BAw?.$7$?%l%9$rJ]B8$9$k%9%l$N%?%$%H%k$rJV$9!#\e(B
 594   ;; \e$B%?%$%H%k$r:Y$+$/;XDj$7$?$$$H$-$O$3$N4X?t$r>e=q$-$7$F$M!#\e(B
 595   ;; nil \e$B$rJV$9$H!"MzNr$OJ]B8$5$l$^$;$s!#\e(B
 596   navi2ch-message-sendlog-subject)
 597
 598 (defun navi2ch-message-sendlog-subject-with-volume (base format limit
 599                                                          subject-list)
 600   (let ((subject base)
 601         (regexp (concat "\\`"
 602                         (format (regexp-quote format)
 603                                 (regexp-quote base) "\\([0-9]+\\)")
 604                         "\\'"))
 605         (max 0)
 606         article)
 607     (when limit
 608       (dolist (x subject-list)
 609         (let ((sbj (cdr (assq 'subject x)))
 610               num)
 611           (when (and (or (and (string= base sbj)
 612                               (setq num 1))
 613                          (and (string-match regexp sbj)
 614                               (setq num
 615                                     (string-to-number (match-string 1 sbj)))))
 616                      (> num max))
 617             (setq max num
 618                   article x))))
 619       (when article
 620         (if (>= (string-to-number (cdr (assq 'response article))) limit)
 621             (setq subject (format format base (number-to-string (1+ max))))
 622           (setq subject (cdr (assq 'subject article))))))
 623     subject))
 624
 625 (defun navi2ch-message-add-sendlog (from mail message subject board article)
 626   (let ((navi2ch-localfile-default-file-modes (* 64 7))
 627         ;; \e$BAw?.95$(\e(B \e$B$N%9%l%?%$$K\e(B &hearts; \e$B$H$+$r;H$($k$h$&$K!#\e(B
 628         (navi2ch-decode-character-references nil)
 629         (url (navi2ch-article-to-url board article))
 630         (sbj (or subject (cdr (assq 'subject article))))
 631         (lsubject (navi2ch-message-sendlog-subject board article))
 632         (lboard navi2ch-message-sendlog-board)
 633         (fmt navi2ch-message-sendlog-volume-format)
 634         (limit navi2ch-message-sendlog-response-limit)
 635         larticle lsbj-list)
 636     (when (and lsubject lboard)
 637       (setq message (funcall navi2ch-message-sendlog-message-format-function
 638                              message sbj url board article)
 639             lsbj-list (navi2ch-board-get-updated-subject-list lboard)
 640             lsubject (navi2ch-message-sendlog-subject-with-volume
 641                       lsubject fmt limit lsbj-list))
 642       (catch 'loop
 643         (dolist (s lsbj-list)
 644           (when (string= (cdr (assq 'subject s)) lsubject)
 645             (throw 'loop (setq larticle s)))))
 646       (when larticle (setq lsubject nil))
 647       (navi2ch-multibbs-send-message from mail message
 648                                      lsubject lboard larticle))))
 649
 650 (defun navi2ch-message-sendlog-simple-message-format
 651   (message subject url board article)
 652   "\e$BAw?.95$($N%l%9$N%7%s%W%k$J%U%)!<%^%C%H!#\e(B"
 653   (format "Subject: %s\nURL: %s\n\n%s" subject url message))
 654
 655 (defun navi2ch-message-sendlog-message-format-with-board-name
 656   (message subject url board article)
 657   "\e$BAw?.95$($N%l%9$NHDL>IU$-$N%U%)!<%^%C%H!#\e(B"
 658   (format "[%s]: %s\nURL: %s\n\n%s" (cdr (assq 'name board)) subject url message))
 659
 660 ;; TODO: 2ch \e$BFb$K$*$$$F$OHD\e(BID\e$B$,=EJ#$7$J$$$3$H$rA0Ds$H$7$F$$$k!#:#$N$H$3\e(B
 661 ;; \e$B$m$OM-8z$@$,>-Mh$N$3$H$b9M$($k$HD>$9$Y$-!#\e(B
 662
 663 (defun navi2ch-message-samba24-modeline ()
 664   "\e$B=q$-9~$_7P2a;~4V$r%+%&%s%H%@%&%s$9$k\e(B."
 665   (let* ((tmp-time (current-time))
 666          (now-time (+ (lsh (car tmp-time) 16) (nth 1 tmp-time)))
 667          samba-time time-diff)
 668     (setq navi2ch-message-samba24-mode-string "")
 669     (dolist (x navi2ch-message-samba24-send-time)
 670       (let* ((id (car x))
 671              (id-normalized (if (string-match "^\\([^:]*\\):" id)
 672                                 (match-string 1 id)
 673                               id)))
 674         (setq time-diff (- now-time (cdr x)))
 675         (setq samba-time
 676               (navi2ch-message-samba24-search-samba
 677                (navi2ch-message-samba24-board-conversion 'id id-normalized 'uri)
 678                id-normalized))
 679         (when samba-time
 680           (if (<= time-diff samba-time)
 681               (setq navi2ch-message-samba24-mode-string
 682                     (format "%s:%d %s"
 683                             (navi2ch-message-samba24-board-conversion 'id id 'name)
 684                             (- samba-time time-diff)
 685                             navi2ch-message-samba24-mode-string))
 686             (setq navi2ch-message-samba24-send-time
 687                   (delete x navi2ch-message-samba24-send-time))
 688             (unless navi2ch-message-samba24-send-time
 689               (cancel-timer navi2ch-message-samba24-update-timer)
 690               (setq navi2ch-message-samba24-update-timer nil))))))
 691     (force-mode-line-update t)))
 692
 693 (defun navi2ch-message-samba24 ()
 694   "SAMBA24(\e$BO"B3Ej9F5,@)\e(B)\e$B$NBP1~$N$?$a!"=q$-9~$_5v2DBT$A;~4V$rI=<($9$k!#\e(B
 695 \e$B%l%9Aw?.;~$K%3!<%k$5$l!"%b!<%I%i%$%s$G%+%&%s%H%@%&%s$rI=<($9$k\e(B"
 696   (when navi2ch-message-samba24-show
 697     (if (and (null navi2ch-message-samba24-samba-data)
 698              (null (navi2ch-message-samba24-read-samba)))
 699         (message "samba.txt\e$B$,$"$j$^$;$s\e(B")
 700       (let* ((tmp-time (current-time))
 701              (last-write-time (+ (lsh (car tmp-time) 16) (cadr tmp-time)))
 702              (id (cdr (assq 'id navi2ch-message-current-board)))
 703              (id-list (assoc id navi2ch-message-samba24-send-time))
 704              (id-normalized (if (string-match "^\\([^:]*\\):" id)
 705                                 (match-string 1 id)
 706                               id)))
 707         (when (navi2ch-message-samba24-search-samba
 708                (navi2ch-message-samba24-board-conversion 'id id-normalized 'uri)
 709                id-normalized)
 710           (when id-list
 711             (setq navi2ch-message-samba24-send-time
 712                   (delete id-list navi2ch-message-samba24-send-time)))
 713           (setq navi2ch-message-samba24-send-time
 714                 (cons (cons id last-write-time)
 715                       navi2ch-message-samba24-send-time))
 716           (setq navi2ch-message-samba24-update-timer
 717                 (or navi2ch-message-samba24-update-timer
 718                     (run-at-time 1 1 'navi2ch-message-samba24-modeline))))))))
 719
 720 (defun navi2ch-message-samba24-board-conversion (src val dst)
 721   "\e$BHDL>!"\e(BID\e$B!"\e(BURL\e$B$J$I$NAj8_JQ49!#\e(B
 722 SRC=\e$BJQ4985$NO"A[%j%9%H:8B&\e(B VAL=\e$BJQ4985$NCM\e(B(\e$B1&B&\e(B) DST=\e$BJQ49@h$N:8B&;XDj\e(B"
 723   (catch 'loop
 724     (dolist (x navi2ch-list-board-name-list)
 725       (if (string= val (cdr (assq src x)))
 726           (throw 'loop (cdr (assq dst x)))))))
 727
 728 (defun navi2ch-message-samba24-read-samba ()
 729   "samba.txt \e$B$+$i3F%5!<%P!"HD$4$H$NO"B3Ej9F5,@);~4V$rFI$_9~$_!"%j%9%H$H$7$FJ];}$9$k\e(B.
 730 samba.txt \e$B$O\e(B http://nullpo.s101.xrea.com/samba24/ \e$B$+$i<hF@\e(B."
 731   (interactive)
 732   (let (navi2ch-message-samba24-file)
 733     ;; \e$B:G?7$N\e(Bsamba.txt\e$B$r<hF@\e(B
 734     (navi2ch-message-samba24-update)
 735     (setq navi2ch-message-samba24-samba-data nil)
 736     (setq navi2ch-message-samba24-file
 737           (navi2ch-expand-file-name navi2ch-message-samba24-file-name))
 738     (when (and (file-exists-p navi2ch-message-samba24-file)
 739                (file-readable-p navi2ch-message-samba24-file))
 740       (with-temp-buffer
 741         (insert-file-contents navi2ch-message-samba24-file)
 742         (goto-char (point-min))
 743         (while (re-search-forward "\\([a-z0-9.]+\\)=\\([0-9]+\\)" nil t)
 744           (setq navi2ch-message-samba24-samba-data
 745                 (cons (cons (match-string 1)
 746                             (string-to-number (match-string 2)))
 747                       navi2ch-message-samba24-samba-data)))))
 748     navi2ch-message-samba24-samba-data))
 749
 750 ;; FIXME: defsubst \e$B$K$7$?$$!#\e(B
 751 (defun navi2ch-message-samba24-search-samba (url id)
 752   "\e$B%5!<%PL>!"HDL>$+$iO"B3Ej9F5,@);~4V$rF@$k\e(B.p2\e$B$G$N=q$-9~$_$N>l9g!"\e(B10\e$BIC%W%i%9$N%Z%J%k%F%#$,$"$k\e(B"
 753   (let (samba-time
 754         (samba-p2-time 0))
 755     (when (and (stringp url)
 756                (string-match "http://\\([^/]+\\)" url))
 757       (when (navi2ch-p2-board-p id)
 758         (setq samba-p2-time 10))
 759       (setq samba-time (or (cdr (assoc id navi2ch-message-samba24-samba-data))
 760                            (cdr (assoc (match-string 1 url) navi2ch-message-samba24-samba-data))))
 761       (when samba-time
 762          (+ samba-time samba-p2-time)))))
 763
 764 (defun navi2ch-message-samba24-update ()
 765   "samba24 \e$B$N5,@)>pJs$r99?7\e(B."
 766   ;; \e$B%U%!%$%k$,F0E*@8@.$C$]$$$N$G\e(BIf-Modified-Since\e$B8+$J$$!)!J9bIi2Y!)!K\e(B
 767   (navi2ch-net-update-file navi2ch-message-samba24-sambatxt-url
 768                            (navi2ch-expand-file-name navi2ch-message-samba24-file-name)
 769                            'file))
 770
 771 (defun navi2ch-message-samba24-check (board)
 772   "Samba24 \e$B$K$R$C$+$+$k$+$I$&$+%A%'%C%/\e(B."
 773   (let* ((id (cdr (assq 'id board)))
 774          (last-write-time (cdr (assoc id
 775                                       navi2ch-message-samba24-send-time))))
 776     (or (null last-write-time)
 777         (let* ((samba-time (navi2ch-message-samba24-search-samba
 778                             (navi2ch-message-samba24-board-conversion 'id id 'uri)
 779                             id))
 780                (tmp-time (current-time))
 781                (cur-time (+ (lsh (car tmp-time) 16) (cadr tmp-time)))
 782                (diff-time (- (+ last-write-time samba-time)
 783                              cur-time)))
 784           (or (<= diff-time 0)
 785               (if navi2ch-message-samba24-wait-sleep
 786                   (progn
 787                     (while (> diff-time 0)
 788                       (message "samba\e$BCY1d=q$-9~$_%U%j!<%:Cf\e(B %s sec %s %s" diff-time (current-time-string) samba-time)
 789                       (sleep-for 1)
 790                       (setq diff-time (1- diff-time)))
 791                     (message "samba\e$BCY1d=q$-9~$_%U%j!<%:=*N;\e(B %s" (current-time-string)))
 792               (yes-or-no-p (format
 793                             "\e$B$"$H\e(B %d \e$BICBT$C$?$[$&$,$$$$$H;W$&$1$I!"K\Ev$K=q$-$3$`\e(B? "
 794                             diff-time))))))))
 795
 796 (defun navi2ch-message-samba24-modify-by-error (id error)
 797   "\e$B%5!<%P$+$i<u$1<h$C$?%(%i!<%a%C%;!<%8$+$i\e(Bsamba\e$BIC?t$r@_Dj\e(B"
 798   (when (string-match "593 \\([0-9]+\\) sec \e$B$?$?$J$$$H=q$1$^$;$s!#\e(B" error)
 799     (navi2ch-message-samba24-modify id (string-to-number (match-string 1 error)))))
 800
 801 (defun navi2ch-message-samba24-modify (id samba-time)
 802   (when (assoc id navi2ch-message-samba24-samba-data)
 803     (setq navi2ch-message-samba24-samba-data
 804           (delq (assoc id navi2ch-message-samba24-samba-data) navi2ch-message-samba24-samba-data)))
 805   (setq navi2ch-message-samba24-samba-data
 806         (cons (cons id samba-time) navi2ch-message-samba24-samba-data)))
 807
 808 (run-hooks 'navi2ch-message-load-hook)
 809 ;;; navi2ch-message.el ends here