navi2ch-jbbs-shitaraba.el

   1 ;;; navi2ch-jbbs-shitaraba.el --- View jbbs-shitaraba module for Navi2ch. -*- coding: iso-2022-7bit; lexical-binding: t; -*-
   2
   3 ;; Copyright (C) 2002, 2003, 2004, 2006 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 ;; \e$B#J#B#B#S!w$7$?$i$P$N;EMM$O2<5-;2>H!#\e(B
  29 ;; http://jbbs.shitaraba.com/bbs/read.cgi/computer/351/1040452916/126-140n
  30
  31 ;;; Code:
  32 (provide 'navi2ch-jbbs-shitaraba)
  33 (defconst navi2ch-jbbs-shitaraba-ident
  34   "$Id$")
  35
  36 (eval-when-compile
  37   (require 'cl-lib)
  38   (require 'navi2ch-decls)
  39   (require 'navi2ch-inline))
  40 (require 'navi2ch-vars)
  41
  42 (eval-when-compile
  43   (navi2ch-defalias-maybe 'coding-system-list 'ignore))
  44
  45 (defvar navi2ch-js-func-alist
  46   '((bbs-p              . navi2ch-js-p)
  47     (subject-callback   . navi2ch-js-subject-callback)
  48     (article-update     . navi2ch-js-article-update)
  49     (article-to-url     . navi2ch-js-article-to-url)
  50     (url-to-board       . navi2ch-js-url-to-board)
  51     (url-to-article     . navi2ch-js-url-to-article)
  52     (send-message       . navi2ch-js-send-message)
  53     (send-success-p     . navi2ch-js-send-message-success-p)
  54     (error-string       . navi2ch-js-send-message-error-string)
  55     (board-update       . navi2ch-js-board-update)))
  56
  57 (defvar navi2ch-js-coding-system
  58   (or (car (memq 'eucjp-ms (coding-system-list)))
  59       'euc-japan))
  60
  61 (defvar navi2ch-js-variable-alist
  62   (list (cons 'coding-system navi2ch-js-coding-system)))
  63
  64 (navi2ch-multibbs-regist 'jbbs-shitaraba
  65                          navi2ch-js-func-alist
  66                          navi2ch-js-variable-alist)
  67
  68 (defvar navi2ch-js-host-list '("jbbs.shitaraba.com"
  69                                "jbbs.shitaraba.net"
  70                                "jbbs.livedoor.com"
  71                                "jbbs.livedoor.jp"))
  72
  73 ;;-------------
  74
  75 (defun navi2ch-js-p (uri)
  76   "URI \e$B$,\e(BJBBS\e$B!w$7$?$i$P$J$i\e(B non-nil \e$B$rJV$9!#\e(B"
  77   (let ((list navi2ch-js-host-list)
  78         host result)
  79     (while (and list (not result))
  80       (setq host (car list))
  81       (setq list (cdr list))
  82       (setq result (string-match (format "^http://%s" (regexp-quote host))
  83                                  uri)))
  84     result))
  85
  86 (navi2ch-multibbs-defcallback navi2ch-js-subject-callback (jbbs-shitaraba)
  87   "subject.txt \e$B$r<hF@$9$k$H$-\e(B navi2ch-net-update-file
  88 \e$B$G;H$o$l$k%3!<%k%P%C%/4X?t\e(B"
  89   (while (re-search-forward "\\([0-9]+\\.\\)cgi\\([^\n]+\n\\)" nil t)
  90     (replace-match "\\1dat\\2"))
  91   (re-search-backward "\\(\n.*\n\\)")
  92   (replace-match "\n"))
  93
  94 (defun navi2ch-js-article-update (board article start)
  95   "BOARD ARTICLE \e$B$N5-;v$r99?7$9$k!#\e(B
  96 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
  97 \e$BJV$jCM$O\e(B HEADER\e$B!#\e(B"
  98   (let ((file (navi2ch-article-get-file-name board article))
  99         (time (cdr (assq 'time article)))
 100         (url  (navi2ch-js-article-to-rawmode-url board article start nil start))
 101         (func (if start
 102                   (lexical-let ((start start))
 103                     (lambda () (navi2ch-js-article-callback start)))
 104                 'navi2ch-js-article-callback)))
 105     (navi2ch-net-update-file url file time func nil start)))
 106
 107 (defun navi2ch-js-url-to-board (url)
 108   (let (prefix category id)
 109     (when (or
 110            ;; http://jbbs.shitaraba.com/computer/bbs/read.cgi?BBS=351&KEY=1040452814&START=1&END=5
 111            (string-match
 112             "http://\\(.+\\)/\\([^/]+\\)/bbs/read\\.cgi.*BBS=\\([0-9]+\\)" url)
 113            ;; http://jbbs.shitaraba.com/bbs/read.cgi/computer/351/1040452814/1-5
 114            (string-match
 115             "http://\\(.+\\)/bbs/[^/]+\\.cgi/\\([^/]+\\)/\\([0-9]+\\)" url)
 116            ;; http://jbbs.shitaraba.com/computer/351/
 117            (string-match
 118             "http://\\(.+\\)/\\([^/]+\\)/\\([0-9]+\\)/" url))
 119       (setq prefix (match-string 1 url)
 120             category (match-string 2 url)
 121             id (match-string 3 url)))
 122     (if id (list (cons 'uri (format "http://%s/%s/%s/" prefix category id))
 123                  (cons 'id id)))))
 124
 125 (defun navi2ch-js-url-to-article (url)
 126   "URL \e$B$+$i\e(B article \e$B$KJQ49!#\e(B"
 127   (let (artid number kako)
 128     (cond
 129      ;; http://jbbs.shitaraba.com/computer/bbs/read.cgi?BBS=351&KEY=1040452814&START=1&END=5
 130      ((string-match
 131        "http://.+/bbs/read\\.cgi.*KEY=\\([0-9]+\\)" url)
 132       (setq artid (match-string 1 url))
 133       (when (string-match "&START=\\([0-9]+\\)" url)
 134         (setq number (string-to-number (match-string 1 url)))))
 135      ;; http://jbbs.shitaraba.com/computer/351/storage/1014729216.html
 136      ((string-match
 137        "http://.+/storage/\\([0-9]+\\)\\.html" url)
 138       (setq artid (match-string 1 url)
 139             kako t))
 140      ;; http://jbbs.shitaraba.com/bbs/read.cgi/computer/351/1040452814/1-5
 141      ((string-match
 142        "http://.+/bbs/[^/]+\\.cgi/[^/]+/[^/]+/\\([^/]+\\)" url)
 143       (setq artid (match-string 1 url))
 144       (when (string-match
 145              (format
 146               "http://.+/bbs/[^/]+\\.cgi/[^/]+/[^/]+/%s/[ni.]?\\([0-9]+\\)[^/]*$"
 147               artid)
 148              url)
 149         (setq number (string-to-number (match-string 1 url))))))
 150     (let (list)
 151       (when artid
 152         (setq list (cons (cons 'artid artid) list))
 153         (when number
 154           (setq list (cons (cons 'number number) list)))
 155         (when kako
 156           (setq list (cons (cons 'kako kako) list)))
 157         list))))
 158
 159 (defun navi2ch-js-send-message
 160   (from mail message subject bbs key time board article &optional post)
 161   (let ((url         (navi2ch-js-get-cgi-url "write" board))
 162         (referer     (navi2ch-board-get-uri board))
 163         (param-alist (list
 164                       (cons "submit" (if subject
 165                                          "\e$B?75,=q$-9~$_\e(B"
 166                                        "\e$B=q$-9~$`\e(B"))
 167                       (cons "NAME" (or from ""))
 168                       (cons "MAIL" (or mail ""))
 169                       (cons "MESSAGE" message)
 170                       (cons "BBS" bbs)
 171                       (cons "DIR" (navi2ch-js-get-dir board))
 172                       (if subject
 173                           (cons "SUBJECT" subject)
 174                         (cons "KEY" key))
 175                       (cons "TIME" time))))
 176     (navi2ch-net-send-request
 177      url "POST"
 178      (list (cons "Content-Type" "application/x-www-form-urlencoded")
 179            (cons "Referer" referer))
 180      (let ((navi2ch-coding-system navi2ch-js-coding-system))
 181        (navi2ch-net-get-param-string param-alist)))))
 182
 183 (defun navi2ch-js-send-message-success-p (proc)
 184   (let ((str (decode-coding-string (navi2ch-net-get-content proc)
 185                                    navi2ch-js-coding-system)))
 186     (or (string-match "<title>\e$B=q$-$3$_$^$7$?!#\e(B</title>" str)
 187         (string= "" str))))
 188
 189 (defun navi2ch-js-send-message-error-string (proc)
 190   (let ((str (decode-coding-string (navi2ch-net-get-content proc)
 191                                    navi2ch-js-coding-system)))
 192     (cond ((string-match "\e$B#E#R#R#O#R!'\e(B\\([^<]+\\)" str)
 193            (match-string 1 str))
 194           ((string-match "<b>\\([^<]+\\)" str)
 195            (match-string 1 str)))))
 196
 197 (defun navi2ch-js-article-to-url-subr
 198   (string board article &optional start end nofirst)
 199   "BOARD, ARTICLE \e$B$+$i\e(B  STRING.cgi \e$B$N\e(B url \e$B$KJQ49!#\e(B
 200 START, END, NOFIRST \e$B$GHO0O$r;XDj$9$k!#\e(B"
 201   (let ((url (concat (navi2ch-js-get-cgi-url string board)
 202                      (cdr (assq 'artid article))
 203                      "/")))
 204     (if (numberp start)
 205         (setq start (number-to-string start)))
 206     (if (numberp end)
 207         (setq end (number-to-string end)))
 208     (if (equal start end)
 209         (concat url start)
 210       (concat url
 211               start (and (or start end) "-") end
 212               (and nofirst "n")))))
 213
 214 (defun navi2ch-js-article-to-url (board article &optional start end nofirst)
 215   "BOARD, ARTICLE \e$B$+$i\e(B read.cgi \e$B$N\e(B url \e$B$KJQ49!#\e(B
 216 START, END, NOFIRST \e$B$GHO0O$r;XDj$9$k\e(B"
 217   (navi2ch-js-article-to-url-subr "read"
 218                                   board article start end nofirst))
 219
 220 (defun navi2ch-js-article-to-rawmode-url (board article &optional start end nofirst)
 221   "BOARD, ARTICLE \e$B$+$i\e(B rawmode.cgi \e$B$N\e(B url \e$B$KJQ49!#\e(B
 222 START, END, NOFIRST \e$B$GHO0O$r;XDj$9$k\e(B"
 223   (navi2ch-js-article-to-url-subr "rawmode"
 224                                   board article start end nofirst))
 225
 226 ;;------------------
 227
 228 (defvar navi2ch-js-parse-regexp
 229   ;; \e$B%l%9HV\e(B        \e$BL>A0\e(B      \e$B%a!<%k\e(B  \e$BEj9FF|;~\e(B    \e$BK\J8\e(B  \e$B%9%l%?%$%H%k\e(B  ID/\e$B%j%b%[\e(B
 230   "\\([0-9]+\\)<>\\(.*\\)<>\\(.*\\)<>\\(.*\\)<>\\(.*\\)<>\\(.*\\)<>\\(.*\\)\n")
 231
 232 (defun navi2ch-js-parse ()
 233   (let ((case-fold-search t))
 234     (re-search-forward navi2ch-js-parse-regexp nil t)))
 235
 236 (navi2ch-multibbs-defcallback navi2ch-js-article-callback
 237     (jbbs-shitaraba &optional start)
 238   (let ((i (or start 1))
 239         (beg (point))
 240         num name mail date contents subject id)
 241     (while (navi2ch-js-parse)
 242       (setq num         (match-string 1)
 243             name        (match-string 2)
 244             mail        (match-string 3)
 245             date        (match-string 4)
 246             contents    (match-string 5)
 247             subject     (match-string 6)
 248             id          (match-string 7))
 249       (delete-region beg (match-end 0))
 250       (while (< i (string-to-number num))
 251         (insert "\e$B$"$\!<$s\e(B<>\e$B$"$\!<$s\e(B<>\e$B$"$\!<$s\e(B<>\e$B$"$\!<$s\e(B<>\n")
 252         (setq i (1+ i)))
 253       (insert (format "%s<>%s<>%s%s<>%s<>%s\n"
 254                       name
 255                       (or mail "")
 256                       date
 257                       (if (= 0 (length id)) "" (concat " ID:" id))
 258                       contents
 259                       (or subject "")))
 260       (setq i (1+ i))
 261       (setq beg (point)))))
 262
 263 (defconst navi2ch-js-url-regexp
 264   ;;    prefix   \e$B%+%F%4%j\e(B     BBS\e$BHV9f\e(B
 265   "\\`\\(.+\\)/\\([^/]+\\)/\\([^/]+\\)/\\'")
 266
 267 (defun navi2ch-js-get-cgi-url (string board)
 268   "STRING.cgi \e$B$N\e(B url \e$B$rJV$9!#\e(B"
 269   (let ((uri (navi2ch-board-get-uri board)))
 270     (and (string-match navi2ch-js-url-regexp uri)
 271          (format "%s/bbs/%s.cgi/%s/%s/"
 272                  (match-string 1 uri)
 273                  string
 274                  (match-string 2 uri)
 275                  (match-string 3 uri)))))
 276
 277 (defun navi2ch-js-get-dir (board)
 278   "write.cgi \e$B$KEO$9\e(B DIR \e$B%Q%i%a!<%?$rJV$9!#\e(B"
 279   (let ((uri (navi2ch-board-get-uri board)))
 280     (and (string-match navi2ch-js-url-regexp uri)
 281          (match-string 2 uri))))
 282
 283 (defun navi2ch-js-board-update (board)
 284   (let ((url (navi2ch-board-get-url board))
 285         (file (navi2ch-board-get-file-name board))
 286         (time (cdr (assq 'time board)))
 287         (func (navi2ch-multibbs-subject-callback board)))
 288     (navi2ch-net-update-file url file time func)))
 289
 290 ;;; navi2ch-jbbs-shitaraba.el ends here