navi2ch-machibbs.el

   1 ;;; navi2ch-machibbs.el --- View machiBBS module for Navi2ch. -*- coding: iso-2022-7bit; -*-
   2
   3 ;; Copyright (C) 2002, 2003, 2004, 2009 by Navi2ch Project
   4
   5 ;; Author:
   6 ;; Part5 \e$B%9%l$N\e(B 509 \e$B$NL>L5$7$5$s\e(B
   7 ;; <http://pc.2ch.net/test/read.cgi/unix/1013457056/509>
   8
   9 ;; Keywords: 2ch, network
  10
  11 ;; This file 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 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; This file 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; see the file COPYING.  If not, write to
  23 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Commentary:
  27
  28 ;;
  29
  30 ;;; Code:
  31 (provide 'navi2ch-machibbs)
  32 (defconst navi2ch-machibbs-ident
  33   "$Id$")
  34
  35 (eval-when-compile
  36   (require 'cl-lib)
  37   (require 'navi2ch-decls)
  38   (require 'navi2ch-inline))
  39 (require 'navi2ch-vars)
  40
  41
  42 (defvar navi2ch-machibbs-func-alist
  43   '((bbs-p              . navi2ch-machibbs-p)
  44     (subject-callback   . navi2ch-machibbs-subject-callback)
  45     (article-update     . navi2ch-machibbs-article-update)
  46     (article-to-url     . navi2ch-machibbs-article-to-url)
  47     (url-to-board       . navi2ch-machibbs-url-to-board)
  48     (url-to-article     . navi2ch-machibbs-url-to-article)
  49     (send-message       . navi2ch-machibbs-send-message)
  50     (send-success-p     . navi2ch-machibbs-send-message-success-p)
  51     (board-update       . navi2ch-machibbs-board-update)))
  52
  53 (defvar navi2ch-machibbs-variable-alist
  54   (list (cons 'coding-system navi2ch-coding-system)))
  55
  56 (navi2ch-multibbs-regist 'machibbs
  57                          navi2ch-machibbs-func-alist
  58                          navi2ch-machibbs-variable-alist)
  59
  60 ;; (defvar navi2ch-machibbs-subject-max-bytes 5000
  61 ;;   "\e$B%9%l$N0lMw$r$I$l$@$1I=<($9$k$+!#\e(B
  62 ;; 0\e$B$N>l9g$OA4$FI=<($9$k!#\e(B")
  63
  64 ;;-------------
  65
  66 (defun navi2ch-machibbs-p (uri)
  67   "URI \e$B$,\e(B machibbs \e$B$J$i\e(B non-nil\e$B$rJV$9!#\e(B"
  68   (or (string-match "http://[^\\.]+\\.machibbs\\.com/" uri)
  69       (string-match "http://[^\\.]+\\.machi\\.to/" uri)))
  70
  71 ;; (defun navi2ch-machibbs-subject-callback (string)
  72 ;;   "subject.txt \e$B$r<hF@$9$k$H$-\e(B navi2ch-net-update-file
  73 ;; \e$B$G;H$o$l$k%3!<%k%P%C%/4X?t\e(B"
  74 ;;   (let ((sub-string (if (> navi2ch-machibbs-subject-max-bytes 0)
  75 ;;                      (substring string 0 navi2ch-machibbs-subject-max-bytes)
  76 ;;                    string)))
  77 ;;     (navi2ch-replace-string
  78 ;;      "\\([0-9]+\\.\\)cgi\\([^\n]+\n\\)" "\\1dat\\2" sub-string t)))
  79
  80 (navi2ch-multibbs-defcallback navi2ch-machibbs-subject-callback (machibbs)
  81   "subject.txt \e$B$r<hF@$9$k$H$-\e(B navi2ch-net-update-file
  82 \e$B$G;H$o$l$k%3!<%k%P%C%/4X?t\e(B"
  83   (while (re-search-forward "[0-9]+<>\\([0-9]+\\)<>\\([^\n]+\n\\)" nil t)
  84     (replace-match "\\1.dat<>\\2")))
  85
  86 (defun navi2ch-machibbs-article-update (board article start)
  87   "BOARD ARTICLE \e$B$N5-;v$r99?7$9$k!#\e(B
  88 START \e$B$,\e(B non-nil \e$B$J$i$P%l%9HV9f\e(B START \e$B$+$i$N:9J,$r<hF@$9$k!#\e(B
  89 \e$BJV$jCM$O\e(B HEADER\e$B!#\e(B"
  90   (let ((file (navi2ch-article-get-file-name board article))
  91         (time (cdr (assq 'time article)))
  92         (url  (navi2ch-machibbs-article-to-url board article start nil start))
  93         (func (if start 'navi2ch-machibbs-article-callback-diff
  94                 'navi2ch-machibbs-article-callback)))
  95     (message "URL %s" url)
  96     (navi2ch-net-update-file url file time func nil start)))
  97
  98 (defun navi2ch-machibbs-article-to-url (board article &optional start end nofirst)
  99   "BOARD, ARTICLE \e$B$+$i\e(B url \e$B$KJQ49!#\e(B
 100 START, END, NOFIRST \e$B$GHO0O$r;XDj$9$k\e(B"
 101   (let ((uri (navi2ch-board-get-uri board))
 102         (start (if (numberp start)
 103                    (number-to-string start)
 104                  start))
 105         (end (if (numberp end)
 106                  (number-to-string end)
 107                end)))
 108     (if (string-match "\\(.+\\)/\\([^/]+\\)/$" uri)
 109         (format "%s/bbs/read.cgi/%s/%s/%s"
 110                 (match-string 1 uri) (match-string 2 uri)
 111                 (cdr (assq 'artid article))
 112                 (if (equal start end)
 113                     (or start "")
 114                   (concat start (and (or start end) "-") end))))))
 115
 116 (defun navi2ch-machibbs-url-to-board (url)
 117   "url \e$B$+$i\e(B BOARD \e$B$KJQ49!#\e(B"
 118   (cond
 119    ;; http://www.machi.to/bbs/read.pl?BBS=tawara&KEY=1059722839
 120    ;; http://tohoku.machi.to/bbs/read.pl?BBS=touhoku&KEY=1062265542
 121    ((string-match
 122      "http://\\(.+\\)/bbs/read\\..*BBS=\\([^&]+\\)"
 123      url)
 124     (list (cons 'uri (format "http://%s/%s/"
 125                              (match-string 1 url)
 126                              (match-string 2 url)))
 127           (cons 'id  (match-string 2 url))))
 128    ;; http://hokkaido.machi.to/bbs/read.cgi/hokkaidou/
 129    ((string-match
 130      "http://\\([^/]+\\)/bbs/read.cgi/\\([^/]+\\)/"
 131      url)
 132     (list (cons 'uri (format "http://%s/%s/"
 133                              (match-string 1 url)
 134                              (match-string 2 url)))
 135           (cons 'id  (match-string 2 url))))
 136    ;; http://www.machi.to/tawara/
 137    ;; http://tohoku.machi.to/touhoku/
 138    ((string-match
 139      "http://\\([^/]+\\)/\\([^/]+\\)"
 140      url)
 141     (list (cons 'uri (format "http://%s/%s/"
 142                              (match-string 1 url)
 143                              (match-string 2 url)))
 144           (cons 'id  (match-string 2 url))))))
 145
 146 (defun navi2ch-machibbs-url-to-article (url)
 147   (cond ((string-match
 148           "http://.+/bbs/read\\..*KEY=\\([0-9]+\\)"
 149           url)
 150          (list (cons 'artid (match-string 1 url))))
 151         ((string-match
 152           "http://[^/]+/bbs/read.cgi/[^/]+/\\([0-9]+\\)"
 153           url)
 154          (list (cons 'artid (match-string 1 url))))))
 155
 156 (defun navi2ch-machibbs-send-message
 157   (from mail message subject bbs key time board article &optional post)
 158   (let ((url          (navi2ch-machibbs-get-writecgi-url board))
 159         (referer      (navi2ch-board-get-uri board))
 160         (param-alist  (list
 161                        (cons "submit" (if subject "\e$B=q$-9~$`\e(B" "\e$B?75,=q$-9~$_\e(B"))
 162                        (cons "NAME" (or from ""))
 163                        (cons "MAIL" (or mail ""))
 164                        (cons "MESSAGE" message)
 165                        (cons "BBS" bbs)
 166                        (if subject (cons "SUBJECT" subject ) (cons "KEY" key))
 167                        (cons "TIME" time))))
 168     (navi2ch-net-send-request
 169      url "POST"
 170      (list (cons "Content-Type" "application/x-www-form-urlencoded")
 171            (cons "Referer" referer))
 172      (navi2ch-net-get-param-string param-alist))))
 173
 174 (defun navi2ch-machibbs-get-writecgi-url (board)
 175   (let ((uri (navi2ch-board-get-uri board)))
 176     (string-match "\\(.+\\)/[^/]+/$" uri)
 177     (format "%s/bbs/write.cgi" (match-string 1 uri))))
 178
 179 (defun navi2ch-machibbs-send-message-success-p (proc)
 180   (string-match "302 Found" (navi2ch-net-get-content proc)))
 181
 182 ;; -- parse html --
 183 (defvar navi2ch-machibbs-parse-regexp "\
 184 <dt>\\([0-9]+\\) ?\e$BL>A0!'\e(B\\(<a href=\"mailto:\\([^\"]*\\)\"><b> ?\\|<font[^>]*>\
 185 <b> ?\\)\\(.*\\) ?</b>.+ ?\e$BEj9FF|!'\e(B ?\\(.*\\)\\(\n\\( ?]</font>\\)\\)?<br>\
 186 <dd> ?\\(.*\\) ?<br><br>$")
 187 (defvar navi2ch-machibbs-parse-subject-regexp "<title>\\(.*\\)</title>")
 188
 189 (defun navi2ch-machibbs-parse-subject ()
 190   (let ((case-fold-search t))
 191     (and (re-search-forward navi2ch-machibbs-parse-subject-regexp nil t)
 192          (match-string 1))))
 193
 194 (defun navi2ch-machibbs-parse ()
 195   (let ((case-fold-search t))
 196     (re-search-forward navi2ch-machibbs-parse-regexp nil t)))
 197
 198 (defun navi2ch-machibbs-make-article (&optional subject)
 199   (let ((mail (match-string 3))
 200         (name (match-string 4))
 201         (date (match-string 5))
 202         (date-tail (match-string 7))
 203         (contents (match-string 8)))
 204     (format "%s<>%s<>%s<>%s<>%s\n"
 205             name (or mail "") (concat date (or date-tail ""))
 206             contents (or subject ""))))
 207
 208 (navi2ch-multibbs-defcallback navi2ch-machibbs-article-callback
 209     (machibbs &optional diff)
 210   (let ((beg (point))
 211         (max-num 0)
 212         subject alist num min-num)
 213     (unless diff
 214       (setq subject (navi2ch-machibbs-parse-subject)))
 215     (while (navi2ch-machibbs-parse)
 216       (setq num (string-to-number (match-string 1))
 217             min-num (or min-num num)
 218             max-num (max max-num num)
 219             alist (cons (cons (string-to-number (match-string 1))
 220                               (navi2ch-machibbs-make-article subject))
 221                         alist)
 222             subject nil))
 223     (delete-region beg (point-max))
 224     (when (and min-num max-num)
 225       (let ((i min-num))
 226         (while (<= i max-num)
 227           (insert (or (cdr (assoc i alist))
 228                       "\e$B$"$\!<$s\e(B<>\e$B$"$\!<$s\e(B<>\e$B$"$\!<$s\e(B<>\e$B$"$\!<$s\e(B<>\n"))
 229           (setq i (1+ i)))))))
 230
 231 (defun navi2ch-machibbs-article-callback-diff ()
 232   (navi2ch-machibbs-article-callback t))
 233
 234 (defun navi2ch-machibbs-board-update (board)
 235   (let ((uri (navi2ch-board-get-uri board)))
 236     (when (string-match "\\(.+\\)/\\([^/]+\\)/$" uri)
 237       (let ((url (format "%s/bbs/offlaw.cgi/%s/"
 238                          (match-string 1 uri)
 239                          (cdr (assq 'id board))))
 240             (file (navi2ch-board-get-file-name board))
 241             (time (cdr (assq 'time board)))
 242             (func (navi2ch-multibbs-subject-callback board)))
 243         (navi2ch-net-update-file url file time func)))))
 244
 245 ;;; navi2ch-machibbs.el ends here