dot-files/_navi2ch/elisp/navi2ch-async_el

   1 ;; ¿·µ¬¼èÆÀ¤Î¤ß async¡£
   2
   3 (require 'navi2ch)
   4
   5 ;; get async or not
   6 (defvar navi2ch-async-get t)
   7
   8
   9 (defvar navi2ch-async-process-buffer " *navi2ch async process*")
  10
  11 ;; buffer-local ¤Ê vector¤Ë¤Ç¤â¤¹¤ë¡©
  12 (defvar navi2ch-async-process nil)
  13 (defvar navi2ch-async-output-buffer nil)
  14 (defvar navi2ch-async-status nil)       ;navi2ch-net-status?
  15 (defvar navi2ch-async-header nil)       ;navi2ch-net-header?
  16 (defvar navi2ch-async-first nil)
  17 (defvar navi2ch-async-number nil)
  18 (defvar navi2ch-async-filter-position nil)
  19 (defvar navi2ch-async-gzip-p nil)
  20
  21 (defmacro navi2ch-async-net-ignore-errors (&rest body)
  22   "BODY ¤òÉ¾²Á¤·¡¢¤½¤ÎÃÍ¤òÊÖ¤¹¡£
  23 BODY ¤ÎÉ¾²ÁÃæ¤Ë¥¨¥é¡¼¤¬µ¯¤³¤ë¤È nil ¤òÊÖ¤¹¡£"
  24   `(condition-case err
  25        ,(cons 'progn body)
  26      (error
  27       (condition-case nil
  28           (navi2ch-async-net-cleanup-process)
  29         (error nil))
  30       (ding)
  31       (if err
  32           (message "Error: %s" (error-message-string err))
  33         (message "Error"))
  34       (sleep-for 1)
  35       nil)
  36      (quit
  37       (condition-case nil
  38           (navi2ch-async-net-cleanup-process)
  39         (error nil))
  40       (signal (car err) (cdr err)))))
  41
  42 ;;for debug
  43 ;; (defmacro navi2ch-async-net-ignore-errors (&rest body)
  44 ;;   "BODY ¤òÉ¾²Á¤·¡¢¤½¤ÎÃÍ¤òÊÖ¤¹¡£
  45 ;; BODY ¤ÎÉ¾²ÁÃæ¤Ë¥¨¥é¡¼¤¬µ¯¤³¤ë¤È nil ¤òÊÖ¤¹¡£"
  46 ;;   `,(cons 'progn body))
  47
  48 (defun navi2ch-async-net-cleanup ()
  49   (navi2ch-async-net-cleanup-process)
  50   (navi2ch-async-net-cleanup-vars))
  51
  52 (defun navi2ch-async-net-cleanup-process ()
  53   (let ((proc navi2ch-async-process))
  54     (when (processp proc)
  55       (set-process-filter proc 'ignore)
  56       (set-process-sentinel proc 'ignore)
  57       (when (eq (process-status proc) 'open)
  58         (delete-process proc))
  59       (setq navi2ch-async-process nil))))
  60
  61 (defun navi2ch-async-net-cleanup-vars ()
  62   (setq navi2ch-async-status nil
  63         navi2ch-async-header nil
  64         navi2ch-async-first nil
  65         navi2ch-async-number nil
  66         navi2ch-async-filter-position nil
  67         navi2ch-async-gzip-p nil))
  68
  69 ;; mew-filter
  70 (defmacro navi2ch-async-filter (&rest body)
  71   `(let ((pbuf (process-buffer process)) ;; MUST use 'process'
  72          (obuf (buffer-name)))
  73      (if (and (bufferp pbuf)
  74               (buffer-name pbuf)) ;; check a killed buffer
  75          ;; must use buffer-name instead of current-buffer
  76          ;; so that get-buffer can detect killed buffer.
  77          (unwind-protect
  78              (progn
  79                ;; buffer surely exists.
  80                (set-buffer (process-buffer process)) ;; necessary
  81                (navi2ch-async-net-ignore-errors ,@body))
  82            (if (get-buffer obuf)
  83                ;; the body sometimes kills obuf.
  84                (set-buffer obuf))))))
  85
  86 (defun navi2ch-async-article-filter (process string)
  87   (navi2ch-async-filter
  88    (goto-char (point-max))
  89    (insert string)
  90    (if (null navi2ch-async-status)
  91        (navi2ch-async-get-header)
  92      (when (string= navi2ch-async-status "200")
  93        (navi2ch-async-article-insert-lines 10) ;xxx
  94        (when (and navi2ch-async-number
  95                   (buffer-live-p navi2ch-async-output-buffer))
  96          (with-current-buffer navi2ch-async-output-buffer
  97            (when (and (listp navi2ch-article-message-list)
  98                       (assq navi2ch-async-number navi2ch-article-message-list))
  99              (navi2ch-article-goto-number navi2ch-async-number)
 100              (setq navi2ch-async-number nil))))))))
 101
 102
 103 (defun navi2ch-async-article-sentinel (process event)
 104   (cond
 105    ((and navi2ch-async-status
 106          (string= navi2ch-async-status "200"))
 107     (let (cont)
 108       (navi2ch-async-filter
 109        (navi2ch-async-article-insert-lines)
 110        (setq cont (navi2ch-string-as-multibyte
 111                    (buffer-substring-no-properties
 112                     (progn
 113                       (goto-char (point-min))
 114                       (re-search-forward "\r\n\r?\n" nil t))
 115                     (point-max)))))
 116       (when (buffer-live-p navi2ch-async-output-buffer)
 117         (with-current-buffer navi2ch-async-output-buffer
 118           (let* ((article navi2ch-article-current-article)
 119                  (board navi2ch-article-current-board)
 120                  (file (navi2ch-article-get-file-name board article))
 121                  (dir (file-name-directory file)))
 122             (unless (file-exists-p dir)
 123               (make-directory dir t))
 124             (let ((coding-system-for-write 'binary)
 125                   (coding-system-for-read 'binary))
 126               (with-temp-file file
 127                 ;;xxx
 128                 (when (file-exists-p file)
 129                   (insert-file-contents file)
 130                   (goto-char (point-max)))
 131                 (insert cont)))
 132             (navi2ch-article-save-info board article navi2ch-async-first)
 133             (run-hooks 'navi2ch-article-after-sync-hook)
 134             (when navi2ch-async-number
 135               (navi2ch-article-goto-number navi2ch-async-number))
 136             (navi2ch-article-set-summary-element board article nil)))))
 137     (message "inserting current messages...done"))
 138    (t
 139     (message "Async ¤Îµ¡Ç½ÉÔÂ¤Ç¤¹¡£\8e½\8eÏ\8e¿")
 140     (let ((navi2ch-async-get nil))
 141       (when (buffer-live-p navi2ch-async-output-buffer)
 142         (with-current-buffer navi2ch-async-output-buffer
 143           (unless (listp navi2ch-article-message-list)
 144             (setq navi2ch-article-message-list nil))
 145           (navi2ch-article-sync))))))
 146   (navi2ch-async-net-cleanup))
 147
 148 (defun navi2ch-async-article-sync (&optional force first number)
 149   "¥¹¥ì¤ò¹¹¿·¤¹¤ë¡£force ¤Ê¤é¶¯À©¡£
 150 first ¤¬ nil ¤Ê¤é¤Ð¡¢¥Õ¥¡¥¤¥ë¤¬¹¹¿·¤µ¤ì¤Æ¤Ê¤±¤ì¤Ð²¿¤â¤·¤Ê¤¤"
 151   (interactive "P")
 152   (when (not (navi2ch-board-from-file-p navi2ch-article-current-board))
 153     (run-hooks 'navi2ch-article-before-sync-hook)
 154     (let* ((article navi2ch-article-current-article)
 155            (board navi2ch-article-current-board)
 156            (navi2ch-net-force-update (or navi2ch-net-force-update
 157                                          force))
 158            (file (navi2ch-article-get-file-name board article))
 159            header)
 160       (when first
 161         (setq article (navi2ch-article-load-info)
 162               navi2ch-article-message-list
 163               (navi2ch-article-get-message-list file)))
 164       (navi2ch-article-set-mode-line)
 165       (if (and (cdr (assq 'kako article))
 166                (file-exists-p file)
 167                (not (and force ; force ¤¬»ØÄê¤µ¤ì¤Ê¤¤¸Â¤êsync¤·¤Ê¤¤
 168                          (y-or-n-p "re-sync kako article?"))))
 169           (setq navi2ch-article-current-article article)
 170         (setq navi2ch-async-output-buffer (current-buffer)
 171               navi2ch-async-number (or number (cdr (assq 'number article)))
 172               navi2ch-async-first first
 173               ;; navi2ch-async-output-buffer ¤¬¾Ã¤µ¤ì¤Ê¤¤¤è¤¦¤Ë¡£
 174               ;; see navi2ch-article-view-article()
 175               navi2ch-article-message-list 'async)
 176         (navi2ch-async-article-update-file board article force))
 177       (setq navi2ch-article-hide-mode nil
 178             navi2ch-article-important-mode nil))
 179     t                                   ;for board-mode state
 180     ))
 181
 182 (defun navi2ch-async-article-update-file (board article force)
 183   (if navi2ch-offline
 184       (unless (listp navi2ch-article-message-list)
 185         (setq navi2ch-article-message-list nil))
 186     (if navi2ch-async-process
 187         (message "Another process is running.")
 188       (message "inserting current messages...")
 189       (setq navi2ch-article-view-range nil) ;display all in async
 190       (let* ((article navi2ch-article-current-article)
 191              (board navi2ch-article-current-board)
 192              (process-connection-type nil)
 193              (inherit-process-coding-system
 194               navi2ch-net-inherit-process-coding-system)
 195              (url (navi2ch-article-get-url board article))
 196              (list (navi2ch-net-split-url url navi2ch-net-http-proxy))
 197              (host (cdr (assq 'host list)))
 198              (file (cdr (assq 'file list)))
 199              (port (cdr (assq 'port list)))
 200              (host2ch (cdr (assq 'host2ch list)))
 201              (pbuf (get-buffer-create navi2ch-async-process-buffer))
 202              proc)
 203         (save-excursion
 204           (set-buffer pbuf)
 205           (erase-buffer)
 206           (setq navi2ch-async-status nil
 207                 navi2ch-async-header nil)
 208           (navi2ch-set-buffer-multibyte nil))
 209         (message "now connecting...")
 210         (setq proc (open-network-stream "navi2ch-async-test" pbuf host port))
 211         (message "%sdone" (current-message))
 212         (process-kill-without-query proc)
 213         (set-process-coding-system proc 'binary 'binary)
 214         (set-process-filter proc 'navi2ch-async-article-filter)
 215         (set-process-sentinel proc 'navi2ch-async-article-sentinel)
 216         (message "sending request...")
 217         (process-send-string proc
 218                              (format (concat
 219                                       "%s %s %s\r\n"
 220                                       "MIME-Version: 1.0\r\n"
 221                                       "Host: %s\r\n"
 222                                       "Pragma: no-cache\r\n"
 223                                       "User-Agent: " navi2ch-net-user-agent
 224                                       "\r\n"
 225                                       "\r\n")
 226                                      "GET" file "HTTP/1.0" host2ch))
 227         (message "%sdone" (current-message))
 228         (setq navi2ch-async-process proc)))))
 229
 230 (define-key navi2ch-global-map "\C-c\C-k" 'navi2ch-async-process-stop)
 231 (defun navi2ch-async-process-stop ()
 232   (interactive)
 233   (if (not (processp navi2ch-async-process))
 234       (message "No process is running.")
 235     (navi2ch-async-net-cleanup)
 236     (message "Process is stopped.")))
 237
 238 ;; ¿·µ¬¼èÆÀ¤Î¤ß async¡£
 239 (defadvice navi2ch-article-sync (around async-sync activate)
 240   (if (or (not navi2ch-async-get)
 241           force                         ;C-u s in article-mode
 242           (cdr (assq 'kako navi2ch-article-current-article)) ;kako
 243           (not (eq (cdr (assq 'bbstype navi2ch-article-current-board))
 244                    'unknown))           ;2ch
 245           (file-exists-p (navi2ch-article-get-file-name
 246                           navi2ch-article-current-board
 247                           navi2ch-article-current-article)))
 248       ad-do-it
 249     (setq ad-return-value
 250           (navi2ch-async-article-sync force first number))))
 251
 252 ;; If navi2ch-article-view-article's arg NUMBER is specified,
 253 ;; (setq navi2ch-article-message-list 'async) causes error
 254 ;; in navi2ch-article-goto-number.
 255 (defadvice navi2ch-article-goto-number (around async-hack activate)
 256   "Bind `navi2ch-article-message-list' to nil when async."
 257   (let ((navi2ch-article-message-list (and (listp navi2ch-article-message-list)
 258                                            navi2ch-article-message-list)))
 259     ad-do-it))
 260
 261 ;; ¤Á¤ç¤³¤Ã¤ÈÊÑ¹¹¡£
 262 (defun navi2ch-async-get-header ()
 263   (save-excursion
 264     (goto-char (point-min))
 265     (when (re-search-forward "\r\n\r?\n" nil t)
 266       (let ((end (match-end 0))
 267             list)
 268         (goto-char (point-min))
 269         ;; get-status
 270         (when (looking-at "HTTP/1\\.[01] \\([0-9]+\\)")
 271           (setq navi2ch-async-status (match-string 1)))
 272         (while (re-search-forward "^\\([^\r\n:]+\\): \\(.+\\)\r\n" end t)
 273           (setq list (cons (cons (match-string 1) (match-string 2))
 274                            list)))
 275         (let ((date (assoc-ignore-case "Date" list)))
 276           (when (and date (stringp (cdr date)))
 277             (setq navi2ch-net-last-date (cdr date))))
 278         (when (buffer-live-p navi2ch-async-output-buffer)
 279           (with-current-buffer navi2ch-async-output-buffer
 280             (setq navi2ch-article-current-article
 281                   (navi2ch-put-alist 'time
 282                                      (or (cdr (assoc "Last-Modified" list))
 283                                          (cdr (assoc "Date" list)))
 284                                      navi2ch-article-current-article))))
 285         (setq navi2ch-async-header (nreverse list))
 286         (setq navi2ch-async-filter-position end)))))
 287
 288
 289 ;; navi2ch-article-get-message-list
 290 (defun navi2ch-async-article-get-message-list-buffer (dat)
 291   (let ((board navi2ch-article-current-board)
 292         (sep navi2ch-article-separator)
 293         (i (1+ (if (listp navi2ch-article-message-list)
 294                    (length navi2ch-article-message-list)
 295                  0)))
 296         message-list)
 297     (with-temp-buffer
 298       (insert dat)
 299       (decode-coding-region (point-min) (point-max) navi2ch-coding-system)
 300       (goto-char (point-min))
 301       (unless sep
 302         (setq sep (navi2ch-article-get-separator)))
 303       (goto-char (point-min))
 304       (while (not (eobp))
 305         (setq message-list
 306               (cons (cons i
 307                           (let ((str (buffer-substring-no-properties
 308                                       (point)
 309                                       (progn (forward-line 1)
 310                                              (1- (point))))))
 311                             (unless (string= str "") str)))
 312                     message-list))
 313         (setq i (1+ i))))
 314     (unless navi2ch-article-separator
 315       (setq navi2ch-article-separator sep)) ; it's a buffer local variable...
 316     (nreverse message-list)))
 317
 318 (defun navi2ch-async-article-insert-lines (&optional num)
 319   (when (buffer-live-p navi2ch-async-output-buffer)
 320     (save-excursion
 321       (goto-char navi2ch-async-filter-position)
 322       (when (> (- (buffer-size) (forward-line (buffer-size))) (or num 0))
 323         (beginning-of-line)
 324         (let ((dat (navi2ch-string-as-multibyte
 325                     (buffer-substring-no-properties
 326                      navi2ch-async-filter-position (point))))
 327               mlist)
 328           (setq navi2ch-async-filter-position (point))
 329           (set-buffer navi2ch-async-output-buffer)
 330           (save-excursion
 331             (setq mlist (navi2ch-async-article-get-message-list-buffer dat)
 332                   navi2ch-article-message-list
 333                   (append (and (listp navi2ch-article-message-list)
 334                                navi2ch-article-message-list)
 335                           mlist))
 336             (when (listp navi2ch-article-message-list)
 337               ;; navi2ch-article-current-article ¤Ï subject ¤ò»ý¤Ã¤Æ¤Ê¤¤¤«¤â¡£
 338               (unless (cdr (assq 'subject navi2ch-article-current-article))
 339                 (let ((msg (cdr (car navi2ch-article-message-list))))
 340                   (setq navi2ch-article-current-article
 341                         (navi2ch-put-alist
 342                          'subject
 343                          (cdr (assq 'subject
 344                                     (if (stringp msg)
 345                                         (navi2ch-article-parse-message msg)
 346                                       msg)))
 347                          navi2ch-article-current-article))))
 348               (let ((buffer-read-only nil))
 349                 (goto-char (point-max))
 350                 (navi2ch-async-article-insert-messages mlist nil))
 351               (navi2ch-article-set-mode-line))))))))
 352
 353 ;; message ½Ð¤µ¤Ê¤¤¤è¤¦¤Ë¤·¤¿¤À¤±¡£
 354 (defun navi2ch-async-article-insert-messages (list range)
 355   "LIST ¤òÀ°·Á¤·¤ÆÁÞÆþ¤¹¤ë"
 356 ;;  (message "inserting current messages...")
 357   (let ((len (length list))
 358         (hide (cdr (assq 'hide navi2ch-article-current-article)))
 359         (imp (cdr (assq 'important navi2ch-article-current-article))))
 360     (dolist (x list)
 361       (let ((num (car x))
 362             (alist (cdr x)))
 363         (when (and alist
 364                    (cond (navi2ch-article-hide-mode
 365                           (memq num hide))
 366                          (navi2ch-article-important-mode
 367                           (memq num imp))
 368                          (t
 369                           (and (navi2ch-article-inside-range-p num range len)
 370                                (not (memq num hide))))))
 371           (when (stringp alist)
 372             (setq alist (navi2ch-article-parse-message alist)))
 373           (let (filter-result)
 374             (setq filter-result
 375                   (let ((filtered (navi2ch-article-apply-message-filters alist)))
 376                     (when filtered
 377                       (cond ((stringp filtered)
 378                              (navi2ch-put-alist 'name filtered alist)
 379                              (navi2ch-put-alist 'data filtered alist)
 380                              (navi2ch-put-alist 'mail
 381                                                 (if (string-match "sage"
 382                                                                   (cdr (assq 'mail alist)))
 383                                                     "sage"
 384                                                   "")
 385                                                 alist))
 386                             ((eq filtered 'hide)
 387                              'hide)
 388                             ((eq filtered 'important)
 389                              'important)))))
 390             (if (and (eq filter-result 'hide)
 391                      (not navi2ch-article-hide-mode))
 392                 (progn
 393                   (setq hide (cons num hide))
 394                   (setq navi2ch-article-current-article
 395                         (navi2ch-put-alist 'hide
 396                                            hide
 397                                            navi2ch-article-current-article)))
 398               (when (and (eq filter-result 'important)
 399                          (not navi2ch-article-important-mode))
 400                     (setq imp (cons num imp))
 401                     (setq navi2ch-article-current-article
 402                           (navi2ch-put-alist 'important
 403                                              imp
 404                                              navi2ch-article-current-article)))
 405               (setcdr x (navi2ch-put-alist 'point (point-marker) alist))
 406               ;; (setcdr x (navi2ch-put-alist 'point (point) alist))
 407               (navi2ch-article-insert-message num alist))))))
 408 ;;    (garbage-collect) ; navi2ch-parse-message ¤ÏÂçÎÌ¤Ë¥´¥ß¤ò»Ä¤¹
 409 ;;    (message "inserting current messages...done")))
 410     ))
 411
 412 (provide 'navi2ch-async)
 413
 414 ;;; navi2ch-async.el ends here