[10] | 1 | ;;; twittering-mode.el --- Major mode for Twitter |
---|
| 2 | |
---|
| 3 | ;; Copyright (C) 2007 Yuto Hayamizu. |
---|
| 4 | |
---|
| 5 | ;; Author: Y. Hayamizu <y.hayamizu@gmail.com> |
---|
| 6 | ;; Created: Sep 4, 2007 |
---|
| 7 | ;; Version: 0.2.0 |
---|
| 8 | ;; Keywords: twitter web |
---|
| 9 | ;; URL: http://hayamin.com/ |
---|
| 10 | |
---|
| 11 | ;; Contributors: |
---|
| 12 | ;; naoya_t |
---|
| 13 | ;; * the templete string system for status |
---|
| 14 | ;; id:masa_edw |
---|
| 15 | ;; * twittering-scroll-mode |
---|
| 16 | |
---|
| 17 | ;; This file is free software; you can redistribute it and/or modify |
---|
| 18 | ;; it under the terms of the GNU General Public License as published by |
---|
| 19 | ;; the Free Software Foundation; either version 2, or (at your option) |
---|
| 20 | ;; any later version. |
---|
| 21 | |
---|
| 22 | ;; This file is distributed in the hope that it will be useful, |
---|
| 23 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
---|
| 24 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
---|
| 25 | ;; GNU General Public License for more details. |
---|
| 26 | |
---|
| 27 | ;; You should have received a copy of the GNU General Public License |
---|
| 28 | ;; along with GNU Emacs; see the file COPYING. If not, write to |
---|
| 29 | ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, |
---|
| 30 | ;; Boston, MA 02111-1307, USA. |
---|
| 31 | |
---|
| 32 | ;;; Commentary: |
---|
| 33 | |
---|
| 34 | ;; twittering-mode.el is a major mode for Twitter. |
---|
| 35 | ;; You can check friends timeline, and update your status on Emacs. |
---|
| 36 | |
---|
| 37 | ;;; Code: |
---|
| 38 | |
---|
| 39 | (require 'cl) |
---|
| 40 | (require 'xml) |
---|
| 41 | (require 'parse-time) |
---|
| 42 | |
---|
| 43 | (defvar twittering-mode-map (make-sparse-keymap)) |
---|
| 44 | |
---|
| 45 | (defvar twittering-timer nil) |
---|
| 46 | |
---|
| 47 | (defvar twittering-idle-time 20) |
---|
| 48 | |
---|
| 49 | (defvar twittering-timer-interval 90) |
---|
| 50 | |
---|
| 51 | (defvar twittering-username nil) |
---|
| 52 | |
---|
| 53 | (defvar twittering-password nil) |
---|
| 54 | |
---|
| 55 | (defvar twittering-scroll-mode nil) |
---|
| 56 | |
---|
| 57 | (defvar twittering-status-format nil) |
---|
| 58 | (setq twittering-status-format "%i %s, %@:\n %t // from %f%L") |
---|
| 59 | ; %s - screen_name |
---|
| 60 | ; %S - name |
---|
| 61 | ; %i - profile_image |
---|
| 62 | ; %d - description |
---|
| 63 | ; %l - location |
---|
| 64 | ; %L - " [location]" |
---|
| 65 | ; %u - url |
---|
| 66 | ; %j - user.id |
---|
| 67 | ; %p - protected? |
---|
| 68 | ; %c - created_at (raw UTC string) |
---|
| 69 | ; %C{time-format-str} - created_at (formatted with time-format-str) |
---|
| 70 | ; %@ - X seconds ago |
---|
| 71 | ; %t - text |
---|
| 72 | ; %' - truncated |
---|
| 73 | ; %f - source |
---|
| 74 | ; %# - id |
---|
| 75 | |
---|
| 76 | (defvar twittering-buffer "*twittering*") |
---|
| 77 | (defun twittering-buffer () |
---|
| 78 | (twittering-get-or-generate-buffer twittering-buffer)) |
---|
| 79 | |
---|
| 80 | (defvar twittering-http-buffer "*twittering-http-buffer*") |
---|
| 81 | (defun twittering-http-buffer () |
---|
| 82 | (twittering-get-or-generate-buffer twittering-http-buffer)) |
---|
| 83 | |
---|
| 84 | (defvar twittering-friends-timeline-data nil) |
---|
| 85 | |
---|
| 86 | (defvar twittering-username-face 'twittering-username-face) |
---|
| 87 | (defvar twittering-uri-face 'twittering-uri-face) |
---|
| 88 | |
---|
| 89 | (defun twittering-get-or-generate-buffer (buffer) |
---|
| 90 | (if (bufferp buffer) |
---|
| 91 | (if (buffer-live-p buffer) |
---|
| 92 | buffer |
---|
| 93 | (generate-new-buffer (buffer-name buffer))) |
---|
| 94 | (if (stringp buffer) |
---|
| 95 | (or (get-buffer buffer) |
---|
| 96 | (generate-new-buffer buffer))))) |
---|
| 97 | |
---|
| 98 | (defun assocref (item alist) |
---|
| 99 | (cdr (assoc item alist))) |
---|
| 100 | |
---|
| 101 | ;;; |
---|
| 102 | ;;; to show image files |
---|
| 103 | |
---|
| 104 | (defvar twittering-wget-buffer "*twittering-wget-buffer*") |
---|
| 105 | (defun twittering-wget-buffer () |
---|
| 106 | (twittering-get-or-generate-buffer twittering-wget-buffer)) |
---|
| 107 | |
---|
| 108 | (defvar twittering-tmp-dir "/tmp/twmode-images") |
---|
| 109 | |
---|
| 110 | (defvar twittering-icon-mode nil "You MUST NOT CHANGE this variable directory. You should change through function'twittering-icon-mode'") |
---|
| 111 | (defun twittering-icon-mode (&optional arg) |
---|
| 112 | (interactive) |
---|
| 113 | (setq twittering-icon-mode |
---|
| 114 | (if twittering-icon-mode |
---|
| 115 | (if (null arg) |
---|
| 116 | nil |
---|
| 117 | (> (prefix-numeric-value arg) 0)) |
---|
| 118 | (when (or (null arg) |
---|
| 119 | (and arg (> (prefix-numeric-value arg) 0))) |
---|
| 120 | (when (file-writable-p twittering-tmp-dir) |
---|
| 121 | (progn |
---|
| 122 | (if (not (file-directory-p twittering-tmp-dir)) |
---|
| 123 | (make-directory twittering-tmp-dir)) |
---|
| 124 | t))))) |
---|
| 125 | (twittering-render-friends-timeline)) |
---|
| 126 | |
---|
| 127 | (defun twittering-scroll-mode (&optional arg) |
---|
| 128 | (interactive) |
---|
| 129 | (setq twittering-scroll-mode |
---|
| 130 | (if (null arg) |
---|
| 131 | (not twittering-scroll-mode) |
---|
| 132 | (> (prefix-numeric-value arg) 0)))) |
---|
| 133 | |
---|
| 134 | (defvar twittering-image-stack nil) |
---|
| 135 | |
---|
| 136 | (defun twittering-image-type (file-name) |
---|
| 137 | (cond |
---|
| 138 | ((string-match "\\.jpe?g" file-name) 'jpeg) |
---|
| 139 | ((string-match "\\.png" file-name) 'png) |
---|
| 140 | ((string-match "\\.gif" file-name) 'gif) |
---|
| 141 | (t nil))) |
---|
| 142 | |
---|
| 143 | (defun twittering-local-strftime (fmt string) |
---|
| 144 | (format-time-string fmt ; like "%Y-%m-%d %H:%M:%S", shown in localtime |
---|
| 145 | (apply 'encode-time (parse-time-string string)))) |
---|
| 146 | |
---|
| 147 | (defvar twittering-debug-mode nil) |
---|
| 148 | (defvar twittering-debug-buffer "*debug*") |
---|
| 149 | (defun twittering-debug-buffer () |
---|
| 150 | (twittering-get-or-generate-buffer twittering-debug-buffer)) |
---|
| 151 | (defmacro debug-print (obj) |
---|
| 152 | (let ((obsym (gensym))) |
---|
| 153 | `(let ((,obsym ,obj)) |
---|
| 154 | (if twittering-debug-mode |
---|
| 155 | (with-current-buffer (twittering-debug-buffer) |
---|
| 156 | (insert (prin1-to-string ,obsym)) |
---|
| 157 | (newline) |
---|
| 158 | ,obsym) |
---|
| 159 | ,obsym)))) |
---|
| 160 | |
---|
| 161 | (defun twittering-debug-mode () |
---|
| 162 | (interactive) |
---|
| 163 | (setq twittering-debug-mode |
---|
| 164 | (not twittering-debug-mode)) |
---|
| 165 | (message (if twittering-debug-mode "debug mode:on" "debug mode:off"))) |
---|
| 166 | |
---|
| 167 | (if twittering-mode-map |
---|
| 168 | (let ((km twittering-mode-map)) |
---|
| 169 | (define-key km "\C-c\C-f" 'twittering-friends-timeline) |
---|
| 170 | (define-key km "\C-c\C-s" 'twittering-update-status-interactive) |
---|
| 171 | (define-key km "\C-c\C-e" 'twittering-erase-old-statuses) |
---|
| 172 | (define-key km "\C-m" 'twittering-enter) |
---|
| 173 | (define-key km "\C-c\C-l" 'twittering-update-lambda) |
---|
| 174 | (define-key km [mouse-1] 'twittering-click) |
---|
| 175 | (define-key km "\C-c\C-v" 'twittering-view-user-page) |
---|
| 176 | (define-key km "j" 'next-line) |
---|
| 177 | (define-key km "k" 'previous-line) |
---|
| 178 | (define-key km "l" 'forward-char) |
---|
| 179 | (define-key km "h" 'backward-char) |
---|
| 180 | (define-key km "0" 'beginning-of-line) |
---|
| 181 | (define-key km "^" 'beginning-of-line-text) |
---|
| 182 | (define-key km "$" 'end-of-line) |
---|
| 183 | (define-key km [backspace] 'backward-char) |
---|
| 184 | (define-key km "G" 'end-of-buffer) |
---|
| 185 | (define-key km "H" 'beginning-of-buffer) |
---|
| 186 | nil)) |
---|
| 187 | |
---|
| 188 | (defvar twittering-mode-syntax-table nil "") |
---|
| 189 | |
---|
| 190 | (if twittering-mode-syntax-table |
---|
| 191 | () |
---|
| 192 | (setq twittering-mode-syntax-table (make-syntax-table)) |
---|
| 193 | ; (modify-syntax-entry ? "" twittering-mode-syntax-table) |
---|
| 194 | (modify-syntax-entry ?\" "w" twittering-mode-syntax-table) |
---|
| 195 | ) |
---|
| 196 | |
---|
| 197 | (defun twittering-mode-init-variables () |
---|
| 198 | ;(make-variable-buffer-local 'variable) |
---|
| 199 | ;(setq variable nil) |
---|
| 200 | (font-lock-mode -1) |
---|
| 201 | (defface twittering-username-face |
---|
| 202 | `((t nil)) "" :group 'faces) |
---|
| 203 | (copy-face 'font-lock-string-face 'twittering-username-face) |
---|
| 204 | (set-face-attribute 'twittering-username-face nil :underline t) |
---|
| 205 | (defface twittering-uri-face |
---|
| 206 | `((t nil)) "" :group 'faces) |
---|
| 207 | (set-face-attribute 'twittering-uri-face nil :underline t) |
---|
| 208 | (add-to-list 'minor-mode-alist '(twittering-icon-mode " tw-icon")) |
---|
| 209 | (add-to-list 'minor-mode-alist '(twittering-scroll-mode " tw-scroll")) |
---|
| 210 | ) |
---|
| 211 | |
---|
| 212 | (defmacro case-string (str &rest clauses) |
---|
| 213 | `(cond |
---|
| 214 | ,@(mapcar |
---|
| 215 | (lambda (clause) |
---|
| 216 | (let ((keylist (car clause)) |
---|
| 217 | (body (cdr clause))) |
---|
| 218 | `(,(if (listp keylist) |
---|
| 219 | `(or ,@(mapcar (lambda (key) `(string-equal ,str ,key)) keylist)) |
---|
| 220 | 't) |
---|
| 221 | ,@body))) |
---|
| 222 | clauses))) |
---|
| 223 | |
---|
| 224 | ;; If you use Emacs21, decode-char 'ucs will fail unless Mule-UCS is loaded. |
---|
| 225 | ;; TODO: Show error messages if Emacs 21 without Mule-UCS |
---|
| 226 | (defmacro twittering-ucs-to-char (num) |
---|
| 227 | (if (functionp 'ucs-to-char) |
---|
| 228 | `(ucs-to-char ,num) |
---|
| 229 | `(decode-char 'ucs ,num))) |
---|
| 230 | |
---|
| 231 | (defun twittering-mode () |
---|
| 232 | "Major mode for Twitter" |
---|
| 233 | (interactive) |
---|
| 234 | (switch-to-buffer (twittering-buffer)) |
---|
| 235 | (kill-all-local-variables) |
---|
| 236 | (twittering-mode-init-variables) |
---|
| 237 | (use-local-map twittering-mode-map) |
---|
| 238 | (setq major-mode 'twittering-mode) |
---|
| 239 | (setq mode-name "Twittering mode") |
---|
| 240 | (set-syntax-table twittering-mode-syntax-table) |
---|
| 241 | (run-hooks 'twittering-mode-hook) |
---|
| 242 | (font-lock-mode -1) |
---|
| 243 | (twittering-start) |
---|
| 244 | ) |
---|
| 245 | |
---|
| 246 | ;;; |
---|
| 247 | ;;; Basic HTTP functions |
---|
| 248 | ;;; |
---|
| 249 | |
---|
| 250 | (defun twittering-http-get (method-class method &optional sentinel) |
---|
| 251 | (if (null sentinel) (setq sentinel 'twittering-http-get-default-sentinel)) |
---|
| 252 | |
---|
| 253 | ;; clear the buffer |
---|
| 254 | (save-excursion |
---|
| 255 | (set-buffer (twittering-http-buffer)) |
---|
| 256 | (erase-buffer)) |
---|
| 257 | |
---|
| 258 | (let (proc) |
---|
| 259 | (condition-case nil |
---|
| 260 | (progn |
---|
| 261 | (setq proc |
---|
| 262 | (open-network-stream |
---|
| 263 | "network-connection-process" (twittering-http-buffer) |
---|
| 264 | "twitter.com" 80)) |
---|
| 265 | (set-process-sentinel proc sentinel) |
---|
| 266 | (process-send-string |
---|
| 267 | proc |
---|
| 268 | (let ((nl "\r\n")) |
---|
| 269 | (concat "GET /" method-class "/" method ".xml HTTP/1.1" nl |
---|
| 270 | "Host: twitter.com" nl |
---|
| 271 | "Authorization: Basic " |
---|
| 272 | (base64-encode-string |
---|
| 273 | (concat twittering-username ":" twittering-password)) |
---|
| 274 | nl |
---|
| 275 | "Accept: text/xml" |
---|
| 276 | ",application/xml" |
---|
| 277 | ",application/xhtml+xml" |
---|
| 278 | ",application/html;q=0.9" |
---|
| 279 | ",text/plain;q=0.8" |
---|
| 280 | ",image/png,*/*;q=0.5" nl |
---|
| 281 | "Accept-Charset: utf-8;q=0.7,*;q=0.7" |
---|
| 282 | nl nl)))) |
---|
| 283 | (error |
---|
| 284 | (message "Failure: HTTP GET") nil)))) |
---|
| 285 | |
---|
| 286 | (defun twittering-http-get-default-sentinel (proc stat &optional suc-msg) |
---|
| 287 | (let ((header (twittering-get-response-header)) |
---|
| 288 | (body (twittering-get-response-body)) |
---|
| 289 | (status nil) |
---|
| 290 | ) |
---|
| 291 | (if (string-match "HTTP/1\.[01] \\([a-z0-9 ]+\\)\r?\n" header) |
---|
| 292 | (progn |
---|
| 293 | (setq status (match-string-no-properties 1 header)) |
---|
| 294 | (case-string |
---|
| 295 | status |
---|
| 296 | (("200 OK") |
---|
| 297 | (mapcar |
---|
| 298 | #'twittering-cache-status-datum |
---|
| 299 | (reverse (twittering-xmltree-to-status |
---|
| 300 | body))) |
---|
| 301 | (twittering-render-friends-timeline) |
---|
| 302 | (message (if suc-msg suc-msg "Success: Get."))) |
---|
| 303 | (t (message status)))) |
---|
| 304 | (message "Failure: Bad http response."))) |
---|
| 305 | ) |
---|
| 306 | |
---|
| 307 | (defun twittering-render-friends-timeline () |
---|
| 308 | (with-current-buffer (twittering-buffer) |
---|
| 309 | (let ((point (point)) |
---|
| 310 | (end (point-max))) |
---|
| 311 | (setq buffer-read-only nil) |
---|
| 312 | (erase-buffer) |
---|
| 313 | (insert |
---|
| 314 | (mapconcat (lambda (status) |
---|
| 315 | (twittering-format-status status twittering-status-format)) |
---|
| 316 | twittering-friends-timeline-data |
---|
| 317 | "\n")) |
---|
| 318 | (if twittering-image-stack |
---|
| 319 | (clear-image-cache)) |
---|
| 320 | (setq buffer-read-only t) |
---|
| 321 | (debug-print (current-buffer)) |
---|
| 322 | (goto-char (+ point (if twittering-scroll-mode (- (point-max) end) 0)))) |
---|
| 323 | )) |
---|
| 324 | |
---|
| 325 | (defun twittering-format-status (status format-str) |
---|
| 326 | (flet ((attr (key) |
---|
| 327 | (assocref key status)) |
---|
| 328 | (profile-image |
---|
| 329 | () |
---|
| 330 | (let ((profile-image-url (attr 'user-profile-image-url)) |
---|
| 331 | (icon-string "\n ")) |
---|
| 332 | (if (string-match "/\\([^/?]+\\)\\(?:\\?\\|$\\)" profile-image-url) |
---|
| 333 | (let ((filename (match-string-no-properties 1 profile-image-url))) |
---|
| 334 | ;; download icons if does not exist |
---|
| 335 | (if (file-exists-p (concat twittering-tmp-dir |
---|
| 336 | "/" filename)) |
---|
| 337 | t |
---|
| 338 | (add-to-list 'twittering-image-stack profile-image-url)) |
---|
| 339 | |
---|
| 340 | (when (and icon-string twittering-icon-mode) |
---|
| 341 | (set-text-properties |
---|
| 342 | 1 2 `(display |
---|
| 343 | (image :type ,(twittering-image-type filename) |
---|
| 344 | :file ,(concat twittering-tmp-dir |
---|
| 345 | "/" |
---|
| 346 | filename))) |
---|
| 347 | icon-string) |
---|
| 348 | icon-string) |
---|
| 349 | ))))) |
---|
| 350 | (let ((cursor 0) |
---|
| 351 | (result ()) |
---|
| 352 | c |
---|
| 353 | found-at) |
---|
| 354 | (setq cursor 0) |
---|
| 355 | (setq result '()) |
---|
| 356 | (while (setq found-at (string-match "%\\(C{\\([^}]+\\)}\\|[A-Za-z#@']\\)" format-str cursor)) |
---|
| 357 | (setq c (string-to-char (match-string-no-properties 1 format-str))) |
---|
| 358 | (if (> found-at cursor) |
---|
| 359 | (push (substring format-str cursor found-at) result) |
---|
| 360 | "|") |
---|
| 361 | (setq cursor (match-end 1)) |
---|
| 362 | |
---|
| 363 | (case c |
---|
| 364 | ((?s) ; %s - screen_name |
---|
| 365 | (push (attr 'user-screen-name) result)) |
---|
| 366 | ((?S) ; %S - name |
---|
| 367 | (push (attr 'user-name) result)) |
---|
| 368 | ((?i) ; %i - profile_image |
---|
| 369 | (push (profile-image) result)) |
---|
| 370 | ((?d) ; %d - description |
---|
| 371 | (push (attr 'user-description) result)) |
---|
| 372 | ((?l) ; %l - location |
---|
| 373 | (push (attr 'user-location) result)) |
---|
| 374 | ((?L) ; %L - " [location]" |
---|
| 375 | (let ((location (attr 'user-location))) |
---|
| 376 | (unless (or (null location) (string= "" location)) |
---|
| 377 | (push (concat " [" location "]") result)) )) |
---|
| 378 | ((?u) ; %u - url |
---|
| 379 | (push (attr 'user-url) result)) |
---|
| 380 | ((?j) ; %j - user.id |
---|
| 381 | (push (attr 'user-id) result)) |
---|
| 382 | ((?p) ; %p - protected? |
---|
| 383 | (let ((protected (attr 'user-protected))) |
---|
| 384 | (when (string= "true" protected) |
---|
| 385 | (push "[x]" result)))) |
---|
| 386 | ((?c) ; %c - created_at (raw UTC string) |
---|
| 387 | (push (attr 'created-at) result)) |
---|
| 388 | ((?C) ; %C{time-format-str} - created_at (formatted with time-format-str) |
---|
| 389 | (push (twittering-local-strftime |
---|
| 390 | (or (match-string-no-properties 2 format-str) "%H:%M:%S") |
---|
| 391 | (attr 'created-at)) |
---|
| 392 | result)) |
---|
| 393 | ((?@) ; %@ - X seconds ago |
---|
| 394 | (let ((created-at |
---|
| 395 | (apply |
---|
| 396 | 'encode-time |
---|
| 397 | (parse-time-string (attr 'created-at)))) |
---|
| 398 | (now (current-time))) |
---|
| 399 | (let ((secs (+ (* (- (car now) (car created-at)) 65536) |
---|
| 400 | (- (cadr now) (cadr created-at))))) |
---|
| 401 | (push (cond ((< secs 5) "less than 5 seconds ago") |
---|
| 402 | ((< secs 10) "less than 10 seconds ago") |
---|
| 403 | ((< secs 20) "less than 20 seconds ago") |
---|
| 404 | ((< secs 30) "half a minute ago") |
---|
| 405 | ((< secs 60) "less than a minute ago") |
---|
| 406 | ((< secs 150) "1 minute ago") |
---|
| 407 | ((< secs 2400) (format "%d minutes ago" |
---|
| 408 | (/ (+ secs 30) 60))) |
---|
| 409 | ((< secs 5400) "about 1 hour ago") |
---|
| 410 | ((< secs 84600) (format "about %d hours ago" |
---|
| 411 | (/ (+ secs 1800) 3600))) |
---|
| 412 | (t (format-time-string "%I:%M %p %B %d, %Y" created-at))) |
---|
| 413 | result)))) |
---|
| 414 | ((?t) ; %t - text |
---|
| 415 | (push ;(clickable-text) |
---|
| 416 | (attr 'text) |
---|
| 417 | result)) |
---|
| 418 | ((?') ; %' - truncated |
---|
| 419 | (let ((truncated (attr 'truncated))) |
---|
| 420 | (when (string= "true" truncated) |
---|
| 421 | (push "..." result)))) |
---|
| 422 | ((?f) ; %f - source |
---|
| 423 | (push (attr 'source) result)) |
---|
| 424 | ((?#) ; %# - id |
---|
| 425 | (push (attr 'id) result)) |
---|
| 426 | (t |
---|
| 427 | (push (char-to-string c) result))) |
---|
| 428 | ) |
---|
| 429 | (push (substring format-str cursor) result) |
---|
| 430 | (apply 'concat (nreverse result)) |
---|
| 431 | ))) |
---|
| 432 | |
---|
| 433 | (defun twittering-http-post |
---|
| 434 | (method-class method &optional parameters contents sentinel) |
---|
| 435 | "Send HTTP POST request to twitter.com |
---|
| 436 | |
---|
| 437 | METHOD-CLASS must be one of Twitter API method classes(statuses, users or direct_messages). |
---|
| 438 | METHOD must be one of Twitter API method which belongs to METHOD-CLASS. |
---|
| 439 | PARAMETERS is alist of URI parameters. ex) ((\"mode\" . \"view\") (\"page\" . \"6\")) => <URI>?mode=view&page=6" |
---|
| 440 | (if (null sentinel) (setq sentinel 'twittering-http-post-default-sentinel)) |
---|
| 441 | |
---|
| 442 | ;; clear the buffer |
---|
| 443 | (save-excursion |
---|
| 444 | (set-buffer (twittering-http-buffer)) |
---|
| 445 | (erase-buffer)) |
---|
| 446 | |
---|
| 447 | (let (proc) |
---|
| 448 | (progn |
---|
| 449 | (setq proc |
---|
| 450 | (open-network-stream |
---|
| 451 | "network-connection-process" (twittering-http-buffer) |
---|
| 452 | "twitter.com" 80)) |
---|
| 453 | (set-process-sentinel proc sentinel) |
---|
| 454 | (process-send-string |
---|
| 455 | proc |
---|
| 456 | (let ((nl "\r\n")) |
---|
| 457 | (concat "POST /" method-class "/" method ".xml?" |
---|
| 458 | (if parameters |
---|
| 459 | (mapconcat |
---|
| 460 | (lambda (param-pair) |
---|
| 461 | (format "%s=%s" |
---|
| 462 | (twittering-percent-encode (car param-pair)) |
---|
| 463 | (twittering-percent-encode (cdr param-pair)))) |
---|
| 464 | parameters |
---|
| 465 | "&")) |
---|
| 466 | " HTTP/1.1" nl |
---|
| 467 | "Host: twitter.com" nl |
---|
| 468 | "Authorization: Basic " |
---|
| 469 | (base64-encode-string |
---|
| 470 | (concat twittering-username ":" twittering-password)) |
---|
| 471 | nl |
---|
| 472 | "Content-Type: text/plain" nl |
---|
| 473 | "Content-Length: 0" nl |
---|
| 474 | nl nl)))))) |
---|
| 475 | |
---|
| 476 | (defun twittering-http-post-default-sentinel (proc stat &optional suc-msg) |
---|
| 477 | |
---|
| 478 | (condition-case err-signal |
---|
| 479 | (let ((header (twittering-get-response-header)) |
---|
| 480 | ; (body (twittering-get-response-body)) not used now. |
---|
| 481 | (status nil)) |
---|
| 482 | (string-match "HTTP/1\.1 \\([a-z0-9 ]+\\)\r?\n" header) |
---|
| 483 | (setq status (match-string-no-properties 1 header)) |
---|
| 484 | (case-string status |
---|
| 485 | (("200 OK") |
---|
| 486 | (message (if suc-msg suc-msg "Success: Post"))) |
---|
| 487 | (t (message status))) |
---|
| 488 | ) |
---|
| 489 | (error (message (prin1-to-string err-signal)))) |
---|
| 490 | ) |
---|
| 491 | |
---|
| 492 | (defun twittering-get-response-header (&optional buffer) |
---|
| 493 | "Exract HTTP response header from HTTP response. |
---|
| 494 | `buffer' may be a buffer or the name of an existing buffer. |
---|
| 495 | If `buffer' is omitted, the value of `twittering-http-buffer' is used as `buffer'." |
---|
| 496 | (if (stringp buffer) (setq buffer (get-buffer buffer))) |
---|
| 497 | (if (null buffer) (setq buffer (twittering-http-buffer))) |
---|
| 498 | (save-excursion |
---|
| 499 | (set-buffer buffer) |
---|
| 500 | (let ((content (buffer-string))) |
---|
| 501 | (substring content 0 (string-match "\r?\n\r?\n" content))))) |
---|
| 502 | |
---|
| 503 | (defun twittering-get-response-body (&optional buffer) |
---|
| 504 | "Exract HTTP response body from HTTP response, parse it as XML, and return a XML tree as list. |
---|
| 505 | `buffer' may be a buffer or the name of an existing buffer. |
---|
| 506 | If `buffer' is omitted, the value of `twittering-http-buffer' is used as `buffer'." |
---|
| 507 | (if (stringp buffer) (setq buffer (get-buffer buffer))) |
---|
| 508 | (if (null buffer) (setq buffer (twittering-http-buffer))) |
---|
| 509 | (save-excursion |
---|
| 510 | (set-buffer buffer) |
---|
| 511 | (let ((content (buffer-string))) |
---|
| 512 | (let ((content (buffer-string))) |
---|
| 513 | (xml-parse-region (+ (string-match "\r?\n\r?\n" content) |
---|
| 514 | (length (match-string 0 content))) |
---|
| 515 | (point-max))) |
---|
| 516 | ))) |
---|
| 517 | |
---|
| 518 | (defun twittering-cache-status-datum (status-datum &optional data-var) |
---|
| 519 | "Cache status datum into data-var(default twittering-friends-timeline-data) |
---|
| 520 | If STATUS-DATUM is already in DATA-VAR, return nil. If not, return t." |
---|
| 521 | (if (null data-var) |
---|
| 522 | (setf data-var 'twittering-friends-timeline-data)) |
---|
| 523 | (let ((id (cdr (assq 'id status-datum)))) |
---|
| 524 | (if (or (null (symbol-value data-var)) |
---|
| 525 | (not (find-if |
---|
| 526 | (lambda (item) |
---|
| 527 | (eql id (cdr (assq 'id item)))) |
---|
| 528 | (symbol-value data-var)))) |
---|
| 529 | (progn |
---|
| 530 | (set data-var (cons status-datum (symbol-value data-var))) |
---|
| 531 | t) |
---|
| 532 | nil))) |
---|
| 533 | |
---|
| 534 | (defun twittering-status-to-status-datum (status) |
---|
| 535 | (flet ((assq-get (item seq) |
---|
| 536 | (car (cddr (assq item seq))))) |
---|
| 537 | (let* ((status-data (cddr status)) |
---|
| 538 | id text source created-at truncated |
---|
| 539 | (user-data (cddr (assq 'user status-data))) |
---|
| 540 | user-id user-name |
---|
| 541 | user-screen-name |
---|
| 542 | user-location |
---|
| 543 | user-description |
---|
| 544 | user-profile-image-url |
---|
| 545 | user-url |
---|
| 546 | user-protected |
---|
| 547 | regex-index) |
---|
| 548 | |
---|
| 549 | (setq id (string-to-number (assq-get 'id status-data))) |
---|
| 550 | (setq text (twittering-decode-html-entities |
---|
| 551 | (assq-get 'text status-data))) |
---|
| 552 | (setq source (twittering-decode-html-entities |
---|
| 553 | (assq-get 'source status-data))) |
---|
| 554 | (setq created-at (assq-get 'created_at status-data)) |
---|
| 555 | (setq truncated (assq-get 'truncated status-data)) |
---|
| 556 | (setq user-id (string-to-number (assq-get 'id user-data))) |
---|
| 557 | (setq user-name (twittering-decode-html-entities |
---|
| 558 | (assq-get 'name user-data))) |
---|
| 559 | (setq user-screen-name (twittering-decode-html-entities |
---|
| 560 | (assq-get 'screen_name user-data))) |
---|
| 561 | (setq user-location (twittering-decode-html-entities |
---|
| 562 | (assq-get 'location user-data))) |
---|
| 563 | (setq user-description (twittering-decode-html-entities |
---|
| 564 | (assq-get 'description user-data))) |
---|
| 565 | (setq user-profile-image-url (assq-get 'profile_image_url user-data)) |
---|
| 566 | (setq user-url (assq-get 'url user-data)) |
---|
| 567 | (setq user-protected (assq-get 'protected user-data)) |
---|
| 568 | |
---|
| 569 | ;; make username clickable |
---|
| 570 | (add-text-properties 0 (length user-screen-name) |
---|
| 571 | `(mouse-face highlight |
---|
| 572 | uri ,(concat "http://twitter.com/" user-screen-name) |
---|
| 573 | username ,user-screen-name |
---|
| 574 | face twittering-username-face) |
---|
| 575 | user-screen-name) |
---|
| 576 | |
---|
| 577 | ;; make URI clickable |
---|
| 578 | (setq regex-index 0) |
---|
| 579 | (while regex-index |
---|
| 580 | (setq regex-index |
---|
| 581 | (string-match "@\\([_a-zA-Z0-9]+\\)\\|\\(https?://[-_.!~*'()a-zA-Z0-9;/?:@&=+$,%#]+\\)" |
---|
| 582 | text |
---|
| 583 | regex-index)) |
---|
| 584 | (when regex-index |
---|
| 585 | (let* ((matched-string (match-string-no-properties 0 text)) |
---|
| 586 | (screen-name (match-string-no-properties 1 text)) |
---|
| 587 | (uri (match-string-no-properties 2 text))) |
---|
| 588 | (add-text-properties |
---|
| 589 | (if screen-name |
---|
| 590 | (+ 1 (match-beginning 0)) |
---|
| 591 | (match-beginning 0)) |
---|
| 592 | (match-end 0) |
---|
| 593 | (if screen-name |
---|
| 594 | `(mouse-face |
---|
| 595 | highlight |
---|
| 596 | face twittering-uri-face |
---|
| 597 | username ,screen-name |
---|
| 598 | uri ,(concat "http://twitter.com/" screen-name)) |
---|
| 599 | `(mouse-face highlight |
---|
| 600 | face twittering-uri-face |
---|
| 601 | uri ,uri)) |
---|
| 602 | text)) |
---|
| 603 | (setq regex-index (match-end 0)) )) |
---|
| 604 | |
---|
| 605 | ;; make screen-name clickable |
---|
| 606 | (add-text-properties |
---|
| 607 | 0 (length user-screen-name) |
---|
| 608 | `(mouse-face highlight |
---|
| 609 | face twittering-username-face |
---|
| 610 | uri ,(concat "http://twitter.com/" user-screen-name) |
---|
| 611 | username ,user-screen-name) |
---|
| 612 | user-screen-name) |
---|
| 613 | |
---|
| 614 | ;; make source pretty and clickable |
---|
| 615 | (if (string-match "<a href=\"\\(.*\\)\">\\(.*\\)</a>" source) |
---|
| 616 | (let ((uri (match-string-no-properties 1 source)) |
---|
| 617 | (caption (match-string-no-properties 2 source))) |
---|
| 618 | (setq source caption) |
---|
| 619 | (add-text-properties |
---|
| 620 | 0 (length source) |
---|
| 621 | `(mouse-face highlight |
---|
| 622 | uri ,uri |
---|
| 623 | face twittering-uri-face |
---|
| 624 | source ,source) |
---|
| 625 | source) |
---|
| 626 | )) |
---|
| 627 | |
---|
| 628 | (mapcar |
---|
| 629 | (lambda (sym) |
---|
| 630 | `(,sym . ,(symbol-value sym))) |
---|
| 631 | '(id text source created-at truncated |
---|
| 632 | user-id user-name user-screen-name user-location |
---|
| 633 | user-description |
---|
| 634 | user-profile-image-url |
---|
| 635 | user-url |
---|
| 636 | user-protected))))) |
---|
| 637 | |
---|
| 638 | (defun twittering-xmltree-to-status (xmltree) |
---|
| 639 | (mapcar #'twittering-status-to-status-datum |
---|
| 640 | ;; quirk to treat difference between xml.el in Emacs21 and Emacs22 |
---|
| 641 | ;; On Emacs22, there may be blank strings |
---|
| 642 | (let ((ret nil) (statuses (reverse (cddr (car xmltree))))) |
---|
| 643 | (while statuses |
---|
| 644 | (if (consp (car statuses)) |
---|
| 645 | (setq ret (cons (car statuses) ret))) |
---|
| 646 | (setq statuses (cdr statuses))) |
---|
| 647 | ret))) |
---|
| 648 | |
---|
| 649 | (defun twittering-percent-encode (str &optional coding-system) |
---|
| 650 | (if (or (null coding-system) |
---|
| 651 | (not (coding-system-p coding-system))) |
---|
| 652 | (setq coding-system 'utf-8)) |
---|
| 653 | (mapconcat |
---|
| 654 | (lambda (c) |
---|
| 655 | (cond |
---|
| 656 | ((twittering-url-reserved-p c) |
---|
| 657 | (char-to-string c)) |
---|
| 658 | ((eq c ? ) "+") |
---|
| 659 | (t (format "%%%x" c)))) |
---|
| 660 | (encode-coding-string str coding-system) |
---|
| 661 | "")) |
---|
| 662 | |
---|
| 663 | (defun twittering-url-reserved-p (ch) |
---|
| 664 | (or (and (<= ?A ch) (<= ch ?z)) |
---|
| 665 | (and (<= ?0 ch) (<= ch ?9)) |
---|
| 666 | (eq ?. ch) |
---|
| 667 | (eq ?- ch) |
---|
| 668 | (eq ?_ ch) |
---|
| 669 | (eq ?~ ch))) |
---|
| 670 | |
---|
| 671 | (defun twittering-decode-html-entities (encoded-str) |
---|
| 672 | (if encoded-str |
---|
| 673 | (let ((cursor 0) |
---|
| 674 | (found-at nil) |
---|
| 675 | (result '())) |
---|
| 676 | (while (setq found-at |
---|
| 677 | (string-match "&\\(#\\([0-9]+\\)\\|\\([A-Za-z]+\\)\\);" |
---|
| 678 | encoded-str cursor)) |
---|
| 679 | (when (> found-at cursor) |
---|
| 680 | (push (substring encoded-str cursor found-at) result)) |
---|
| 681 | (let ((number-entity (match-string-no-properties 2 encoded-str)) |
---|
| 682 | (letter-entity (match-string-no-properties 3 encoded-str))) |
---|
| 683 | (cond (number-entity |
---|
| 684 | (push |
---|
| 685 | (char-to-string |
---|
| 686 | (twittering-ucs-to-char |
---|
| 687 | (string-to-number number-entity))) result)) |
---|
| 688 | (letter-entity |
---|
| 689 | (cond ((string= "gt" letter-entity) (push ">" result)) |
---|
| 690 | ((string= "lt" letter-entity) (push "<" result)) |
---|
| 691 | (t push "?" result))) |
---|
| 692 | (t (push "?" result))) |
---|
| 693 | (setq cursor (match-end 0)))) |
---|
| 694 | (push (substring encoded-str cursor) result) |
---|
| 695 | (apply 'concat (nreverse result))) |
---|
| 696 | "")) |
---|
| 697 | |
---|
| 698 | (defun twittering-timer-action (func) |
---|
| 699 | (let ((buf (get-buffer twittering-buffer))) |
---|
| 700 | (if (null buf) |
---|
| 701 | (twittering-stop) |
---|
| 702 | (funcall func) |
---|
| 703 | ))) |
---|
| 704 | |
---|
| 705 | (defun twittering-update-status-if-not-blank (status) |
---|
| 706 | (if (string-match "^\\s-*\\(?:@[-_a-z0-9]+\\)?\\s-*$" status) |
---|
| 707 | nil |
---|
| 708 | (twittering-http-post "statuses" "update" |
---|
| 709 | `(("status" . ,status) |
---|
| 710 | ("source" . "twmode"))) |
---|
| 711 | t)) |
---|
| 712 | |
---|
| 713 | (defun twittering-update-status-from-minibuffer (&optional init-str) |
---|
| 714 | (if (null init-str) (setq init-str "")) |
---|
| 715 | (let ((status init-str) (not-posted-p t)) |
---|
| 716 | (while not-posted-p |
---|
| 717 | (setq status (read-from-minibuffer "status: " status nil nil nil nil t)) |
---|
| 718 | (setq not-posted-p |
---|
| 719 | (not (twittering-update-status-if-not-blank status)))))) |
---|
| 720 | |
---|
| 721 | (defun twittering-update-lambda () |
---|
| 722 | (interactive) |
---|
| 723 | (twittering-http-post |
---|
| 724 | "statuses" "update" |
---|
| 725 | `(("status" . "\xd34b\xd22b\xd26f\xd224\xd224\xd268\xd34b") |
---|
| 726 | ("source" . "twmode")))) |
---|
| 727 | |
---|
| 728 | ;;; |
---|
| 729 | ;;; Commands |
---|
| 730 | ;;; |
---|
| 731 | |
---|
| 732 | (defun twittering-start (&optional action) |
---|
| 733 | (interactive) |
---|
| 734 | (if (null action) |
---|
| 735 | (setq action #'twittering-friends-timeline)) |
---|
| 736 | (if twittering-timer |
---|
| 737 | nil |
---|
| 738 | (setq twittering-timer |
---|
| 739 | (run-at-time "0 sec" |
---|
| 740 | twittering-timer-interval |
---|
| 741 | #'twittering-timer-action action)))) |
---|
| 742 | |
---|
| 743 | (defun twittering-stop () |
---|
| 744 | (interactive) |
---|
| 745 | (cancel-timer twittering-timer) |
---|
| 746 | (setq twittering-timer nil)) |
---|
| 747 | |
---|
| 748 | (defun twittering-friends-timeline () |
---|
| 749 | (interactive) |
---|
| 750 | (let ((buf (get-buffer twittering-buffer))) |
---|
| 751 | (if (not buf) |
---|
| 752 | (twittering-stop) |
---|
| 753 | (twittering-http-get "statuses" "friends_timeline") |
---|
| 754 | )) |
---|
| 755 | |
---|
| 756 | (if twittering-icon-mode |
---|
| 757 | (if twittering-image-stack |
---|
| 758 | (let ((proc |
---|
| 759 | (apply |
---|
| 760 | #'start-process |
---|
| 761 | "wget-images" |
---|
| 762 | (twittering-wget-buffer) |
---|
| 763 | "wget" |
---|
| 764 | (format "--directory-prefix=%s" twittering-tmp-dir) |
---|
| 765 | "--no-clobber" |
---|
| 766 | "--quiet" |
---|
| 767 | twittering-image-stack))) |
---|
| 768 | (set-process-sentinel |
---|
| 769 | proc |
---|
| 770 | (lambda (proc stat) |
---|
| 771 | (clear-image-cache) |
---|
| 772 | (save-excursion |
---|
| 773 | (set-buffer (twittering-wget-buffer)) |
---|
| 774 | ))))))) |
---|
| 775 | |
---|
| 776 | (defun twittering-update-status-interactive () |
---|
| 777 | (interactive) |
---|
| 778 | (twittering-update-status-from-minibuffer)) |
---|
| 779 | |
---|
| 780 | (defun twittering-erase-old-statuses () |
---|
| 781 | (interactive) |
---|
| 782 | (setq twittering-friends-timeline-data nil) |
---|
| 783 | (twittering-http-get "statuses" "friends_timeline")) |
---|
| 784 | |
---|
| 785 | (defun twittering-click () |
---|
| 786 | (interactive) |
---|
| 787 | (let ((uri (get-text-property (point) 'uri))) |
---|
| 788 | (if uri |
---|
| 789 | (browse-url uri)))) |
---|
| 790 | |
---|
| 791 | (defun twittering-enter () |
---|
| 792 | (interactive) |
---|
| 793 | (let ((username (get-text-property (point) 'username)) |
---|
| 794 | (uri (get-text-property (point) 'uri))) |
---|
| 795 | (if username |
---|
| 796 | (twittering-update-status-from-minibuffer (concat "@" username " ")) |
---|
| 797 | (if uri |
---|
| 798 | (browse-url uri))))) |
---|
| 799 | |
---|
| 800 | (defun twittering-view-user-page () |
---|
| 801 | (interactive) |
---|
| 802 | (let ((uri (get-text-property (point) 'uri))) |
---|
| 803 | (if uri |
---|
| 804 | (browse-url uri)))) |
---|
| 805 | |
---|
| 806 | (defun twittering-reply-to-user () |
---|
| 807 | (interactive) |
---|
| 808 | (let ((username (get-text-property (point) 'username))) |
---|
| 809 | (if username |
---|
| 810 | (twittering-update-status-from-minibuffer (concat "@" username " "))))) |
---|
| 811 | |
---|
| 812 | (provide 'twittering-mode) |
---|
| 813 | ;;; twittering.el ends here |
---|