root/lang/elisp/twittering-mode/branches/RB-0.1/twittering-mode.el @ 130

Revision 10, 19.4 kB (checked in by hayamizu, 17 years ago)

lang/elisp/twittering-mode: Initial import

Line 
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.1.1
8;; Keywords: twitter web
9;; URL: http://hayamin.com/
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;; twittering-mode.el is a major mode for Twitter.
29;; You can check friends timeline, and update your status on Emacs.
30
31;;; Code:
32
33(require 'cl)
34(require 'xml)
35
36(defvar twittering-mode-map (make-sparse-keymap))
37
38(defvar twittering-timer nil)
39
40(defvar twittering-idle-time 20)
41
42(defvar twittering-timer-interval 90)
43
44(defvar twittering-username nil)
45
46(defvar twittering-password nil)
47
48(defvar twittering-buffer "*twittering*")
49(defun twittering-buffer ()
50  (twittering-get-or-generate-buffer twittering-buffer))
51
52(defvar twittering-http-buffer "*twittering-http-buffer*")
53(defun twittering-http-buffer ()
54  (twittering-get-or-generate-buffer twittering-http-buffer))
55
56(defvar twittering-friends-timeline-data nil)
57
58(defvar twittering-font-lock-keywords nil)
59
60(defvar twittering-username-face 'twittering-username-face)
61(defvar twittering-uri-face 'twittering-uri-face)
62
63(defun twittering-get-or-generate-buffer (buffer)
64  (if (bufferp buffer)
65      (if (buffer-live-p buffer)
66          buffer
67        (generate-new-buffer (buffer-name buffer)))
68    (if (stringp buffer)
69        (or (get-buffer buffer)
70            (generate-new-buffer buffer)))))
71
72(defun assocref (item alist)
73    (cdr (assoc item alist)))
74
75;;;
76;;; to show image files
77
78(defvar twittering-wget-buffer "*twittering-wget-buffer*")
79(defun twittering-wget-buffer ()
80  (twittering-get-or-generate-buffer twittering-wget-buffer))
81
82(defvar twittering-tmp-dir "/tmp/twmode-images")
83
84(defvar twittering-icon-mode nil "You MUST NOT CHANGE this variable directory. You should change through function'twittering-icon-mode'")
85(defun twittering-icon-mode (&rest arg)
86  (interactive)
87  (setq twittering-icon-mode
88        (if (or (and arg (car arg)) (not twittering-icon-mode))
89            (if (file-writable-p twittering-tmp-dir)
90                (progn
91                  (if (not (file-directory-p twittering-tmp-dir))
92                      (make-directory twittering-tmp-dir))
93                  t)
94              nil)
95          nil))
96  (twittering-render-friends-timeline))
97
98(defvar twittering-image-stack nil)
99
100(defun twittering-image-type (file-name)
101  (cond
102   ((string-match "\\.jpe?g" file-name) 'jpeg)
103   ((string-match "\\.png" file-name) 'png)
104   ((string-match "\\.gif" file-name) 'gif)
105   (t nil)))
106
107(if twittering-font-lock-keywords
108    ()
109  (setq
110   twittering-font-lock-keywords
111   (list
112    ;; screen name
113    '("\\([-_\.a-zA-Z0-9]+\\):$" 1 twittering-username-face)
114    ;; status
115    ;; '("\\s-\\s-\\(.*\\)$" 1 font-lock-constant-face)
116
117    ;; uri
118    '("https?://[-_.!~*'()a-zA-Z0-9;/?:@&=+$,%#]+" 0 twittering-uri-face)
119    ))
120
121  (defun twittering-set-font-lock-keywords ()
122    (setq font-lock-defaults
123          (list 'twittering-font-lock-keywords nil nil nil nil)))
124
125  (add-hook 'twittering-mode-hook 'twittering-set-font-lock-keywords)
126  t)
127
128(defvar twittering-debug-mode nil)
129(defvar twittering-debug-buffer nil)
130(defmacro debug-print (obj)
131  `(if twittering-debug-mode
132       (progn
133         (if (or (null twittering-debug-buffer)
134                 (not (buffer-live-p twittering-debug-buffer)))
135             (setq twittering-debug-buffer (generate-new-buffer "*debug*")))
136         (save-excursion
137           (set-buffer twittering-debug-buffer)
138           (insert (twittering-inspect-object ,obj))
139           (newline)
140           ,obj))
141    ,obj))
142
143(defun twittering-debug-mode ()
144  (interactive)
145  (setq twittering-debug-mode
146        (not twittering-debug-mode))
147  (message (if twittering-debug-mode "debug mode:on" "debug mode:off")))
148
149(if twittering-mode-map
150    (let ((km twittering-mode-map))
151      (define-key km "\C-c\C-f" 'twittering-friends-timeline)
152      (define-key km "\C-c\C-s" 'twittering-update-status-interactive)
153      (define-key km "\C-c\C-e" 'twittering-erase-old-statuses)
154      (define-key km "\C-m" 'twittering-enter)
155      (define-key km [mouse-1] 'twittering-click)
156      (define-key km "\C-c\C-v" 'twittering-view-user-page)
157      (define-key km "j" 'next-line)
158      (define-key km "k" 'previous-line)
159      (define-key km "l" 'forward-char)
160      (define-key km "h" 'backward-char)
161      (define-key km "0" 'beginning-of-line)
162      (define-key km "^" 'beginning-of-line-text)
163      (define-key km "$" 'end-of-line)
164      (define-key km [backspace] 'backward-char)
165      (define-key km "G" 'end-of-buffer)
166      (define-key km "H" 'beginning-of-buffer)
167      nil))
168
169(defvar twittering-mode-syntax-table nil "")
170
171(if twittering-mode-syntax-table
172    ()
173  (setq twittering-mode-syntax-table (make-syntax-table))
174;  (modify-syntax-entry ?  "" twittering-mode-syntax-table)
175  (modify-syntax-entry ?\" "w"  twittering-mode-syntax-table)
176  )
177
178(defun twittering-mode-init-variables ()
179  ;(make-variable-buffer-local 'variable)
180  ;(setq variable nil)
181  (font-lock-mode t)
182  (defface twittering-username-face
183    `((t nil)) "" :group 'faces)
184  (copy-face 'font-lock-string-face 'twittering-username-face)
185  (set-face-attribute 'twittering-username-face nil :underline t)
186  (defface twittering-uri-face
187    `((t nil)) "" :group 'faces)
188  (set-face-attribute 'twittering-uri-face nil :underline t)
189  )
190
191(defmacro case-string (str &rest clauses)
192  `(cond
193    ,@(mapcar
194       (lambda (clause)
195         (let ((keylist (car clause))
196               (body (cdr clause)))
197           `(,(if (listp keylist)
198                  `(or ,@(mapcar (lambda (key) `(string-equal ,str ,key)) keylist))
199                't)
200             ,@body)))
201       clauses)))
202
203;; If you use Emacs21, decode-char 'ucs will fail unless Mule-UCS is loaded.
204;; TODO: Show error messages if Emacs 21 without Mule-UCS
205(defmacro twittering-ucs-to-char (num)
206  (if (functionp 'ucs-to-char)
207      `(ucs-to-char ,num)
208    `(decode-char 'ucs ,num)))
209
210(defun twittering-inspect-object (obj)
211  (cond
212   ((stringp obj) (format "\"%s\"" obj))
213   ((symbolp obj) (format "%s" obj))
214   ((integerp obj) (format "%d" obj))
215   ((floatp obj) (format "%f" obj))
216   ((listp obj)
217    (let ((ret nil))
218      (while obj
219        (if (atom obj)
220            (progn (setq ret `(,(twittering-inspect-object obj) "." ,@ret))
221                   (setq obj nil))
222          (setq ret (cons (twittering-inspect-object (car obj)) ret))
223          (setq obj (cdr obj))))
224      (concat "(" (mapconcat #'identity (reverse ret) " ") ")")))
225   ((arrayp obj)
226    (concat "[" (mapconcat #'twittering-inspect-object obj " ") "]"))
227   (t (error "Unknown type object!"))))
228
229(defun twittering-mode ()
230  "Major mode for Twitter"
231  (interactive)
232  (switch-to-buffer (twittering-buffer))
233  (kill-all-local-variables)
234  (twittering-mode-init-variables)
235  (use-local-map twittering-mode-map)
236  (setq major-mode 'twittering-mode)
237  (setq mode-name "Twittering mode")
238  (set-syntax-table twittering-mode-syntax-table)
239  (run-hooks 'twittering-mode-hook)
240  (font-lock-mode nil)
241  (font-lock-mode t)
242  (twittering-start)
243  )
244
245;;;
246;;; Basic HTTP functions
247;;;
248
249(defun twittering-http-get (method-class method &optional sentinel)
250  (if (null sentinel) (setq sentinel 'twittering-http-get-default-sentinel))
251
252  ;; clear the buffer
253  (save-excursion
254    (set-buffer (twittering-http-buffer))
255    (erase-buffer))
256
257  (let (proc)
258    (condition-case nil
259        (progn
260          (setq proc
261                (open-network-stream
262                 "network-connection-process" (twittering-http-buffer)
263                 "twitter.com" 80))
264          (set-process-sentinel proc sentinel)
265          (process-send-string
266           proc
267           (let ((nl "\r\n"))
268             (concat "GET /" method-class "/" method ".xml HTTP/1.1" nl
269                     "Host: twitter.com" nl
270                     "Authorization: Basic "
271                     (base64-encode-string
272                      (concat twittering-username ":" twittering-password))
273                     nl
274                     "Accept: text/xml"
275                     ",application/xml"
276                     ",application/xhtml+xml"
277                     ",application/html;q=0.9"
278                     ",text/plain;q=0.8"
279                     ",image/png,*/*;q=0.5" nl
280                     "Accept-Charset: utf-8;q=0.7,*;q=0.7"
281                     nl nl))))
282      (error
283       (message "Failure: HTTP GET") nil))))
284
285(defun twittering-http-get-default-sentinel (proc stat &optional suc-msg)
286  (let ((header (twittering-get-response-header))
287          (body (twittering-get-response-body))
288          (status nil)
289          )
290      (if (string-match "HTTP/1\.[01] \\([a-z0-9 ]+\\)\r?\n" header)
291          (progn
292            (setq status (match-string-no-properties 1 header))
293            (case-string
294             status
295             (("200 OK")
296              (mapcar
297               #'twittering-cache-status-datum
298               (reverse (twittering-xmltree-to-status
299                         body)))
300              (twittering-render-friends-timeline)
301              (message (if suc-msg suc-msg "Success: Get.")))
302             (t (message status))))
303        (message "Failure: Bad http response.")))
304  )
305
306(defun twittering-render-friends-timeline ()
307  (let ((point (save-excursion (set-buffer (twittering-buffer)) (point))))
308    (save-excursion
309      (set-buffer (twittering-buffer))
310      (setq buffer-read-only nil)
311      (erase-buffer)
312      (insert
313       (mapconcat (lambda (status)
314                    (concat
315                     (let ((icon-string "\n  ")
316                           (filename (assocref 'icon-string status)))
317                       (if (and icon-string twittering-icon-mode)
318                           (progn
319                             (set-text-properties
320                              1 2 `(display
321                                    (image :type ,(twittering-image-type filename)
322                                           :file ,(concat twittering-tmp-dir
323                                                          "/"
324                                                          filename)))
325                              icon-string)
326                             icon-string)
327                         nil))
328                     (assocref 'username status) ":\n  "
329                     (assocref 'text status)))
330                  twittering-friends-timeline-data
331                  "\n"))
332      (if twittering-image-stack
333          (clear-image-cache))
334      (setq buffer-read-only t))
335    (let ((cb (current-buffer))
336          (tb (get-buffer (twittering-buffer))))
337      (if (eq cb tb)
338          (goto-char point)))))
339
340(defun twittering-http-post
341  (method-class method &optional parameters contents sentinel)
342  "Send HTTP POST request to twitter.com
343
344METHOD-CLASS must be one of Twitter API method classes(statuses, users or direct_messages).
345METHOD must be one of Twitter API method which belongs to METHOD-CLASS.
346PARAMETERS is alist of URI parameters. ex) ((\"mode\" . \"view\") (\"page\" . \"6\")) => <URI>?mode=view&page=6"
347  (if (null sentinel) (setq sentinel 'twittering-http-post-default-sentinel))
348
349  ;; clear the buffer
350  (save-excursion
351    (set-buffer (twittering-http-buffer))
352    (erase-buffer))
353
354  (let (proc)
355    (condition-case nil
356        (progn
357          (setq proc
358                (open-network-stream
359                 "network-connection-process" (twittering-http-buffer)
360                 "twitter.com" 80))
361          (set-process-sentinel proc sentinel)
362          (process-send-string
363           proc
364           (let ((nl "\r\n"))
365             (concat "POST /" method-class "/" method ".xml?"
366                     (if parameters
367                         (mapconcat
368                          (lambda (param-pair)
369                            (format "%s=%s"
370                                    (twittering-percent-encode (car param-pair))
371                                    (twittering-percent-encode (cdr param-pair))))
372                          parameters
373                          "&"))
374                     " HTTP/1.1" nl
375                     "Host: twitter.com" nl
376                     "Authorization: Basic "
377                     (base64-encode-string
378                      (concat twittering-username ":" twittering-password))
379                     nl
380                     "Content-Type: text/plain" nl
381                     "Content-Length: 0" nl
382                     nl nl))))
383      (error
384       (message "Failure: HTTP POST") nil))))
385
386(defun twittering-http-post-default-sentinel (proc stat &optional suc-msg)
387 
388  (condition-case err-signal
389      (let ((header (twittering-get-response-header))
390            ; (body (twittering-get-response-body)) not used now.
391            (status nil))
392        (string-match "HTTP/1\.1 \\([a-z0-9 ]+\\)\r?\n" header)
393        (setq status (match-string-no-properties 1 header))
394        (case-string status
395                     (("200 OK")
396                      (message (if suc-msg suc-msg "Success: Post")))
397                     (t (message status)))
398        )
399    (error (message (twittering-inspect-object err-signal))))
400  )
401
402(defun twittering-get-response-header (&optional buffer)
403  "Exract HTTP response header from HTTP response.
404`buffer' may be a buffer or the name of an existing buffer.
405 If `buffer' is omitted, the value of `twittering-http-buffer' is used as `buffer'."
406  (if (stringp buffer) (setq buffer (get-buffer buffer)))
407  (if (null buffer) (setq buffer (twittering-http-buffer)))
408  (save-excursion
409    (set-buffer buffer)
410    (let ((content (buffer-string)))
411      (substring content 0 (string-match "\r?\n\r?\n" content)))))
412
413(defun twittering-get-response-body (&optional buffer)
414  "Exract HTTP response body from HTTP response, parse it as XML, and return a XML tree as list.
415`buffer' may be a buffer or the name of an existing buffer.
416 If `buffer' is omitted, the value of `twittering-http-buffer' is used as `buffer'."
417  (if (stringp buffer) (setq buffer (get-buffer buffer)))
418  (if (null buffer) (setq buffer (twittering-http-buffer)))
419  (save-excursion
420    (set-buffer buffer)
421    (let ((content (buffer-string)))
422      (let ((content (buffer-string)))
423        (xml-parse-region (+ (string-match "\r?\n\r?\n" content)
424                             (length (match-string 0 content)))
425                          (point-max)))
426      )))
427
428(defun twittering-cache-status-datum (status-datum &optional data-var)
429  "Cache status datum into data-var(default twittering-friends-timeline-data)
430If STATUS-DATUM is already in DATA-VAR, return nil. If not, return t."
431  (if (null data-var)
432      (setf data-var 'twittering-friends-timeline-data))
433  (let ((id (cdr (assq 'id status-datum))))
434    (if (or (null (symbol-value data-var))
435            (not (find-if
436                  (lambda (item)
437                    (eql id (cdr (assq 'id item))))
438                  (symbol-value data-var))))
439        (progn
440          (set data-var (cons status-datum (symbol-value data-var)))
441          t)
442      nil)))
443
444(defun twittering-status-to-status-datum (status)
445  (let ((status-data (cddr status))
446        id text time user-data username icon-url icon-string regex-index)
447    (setq id (string-to-number (car (cddr (assq 'id status-data)))))
448    (setq text (car (cddr (assq 'text status-data))))
449    (setq text (twittering-decode-html-entities text))
450    (setq time (car (cddr (assq 'created_at status-data))))
451    (setq user-data (cddr (assq 'user status-data)))
452    (setq username (car (cddr (assq 'screen_name user-data))))
453    (setq icon-url (car (cddr (assq 'profile_image_url user-data))))
454
455    ;; download icons if does not exist
456    (if (string-match "/\\([^/?]+\\)\\(?:\\?\\|$\\)" icon-url)
457        (let ((filename (match-string-no-properties 1 icon-url)))
458          (setq icon-string filename)
459          (if (file-exists-p (concat twittering-tmp-dir
460                                     "/" filename))
461              t
462            (add-to-list 'twittering-image-stack icon-url))))
463   
464    ;; make username clickable
465    (add-text-properties 0 (length username)
466                         `(mouse-face highlight
467                           uri ,(concat "http://twitter.com/" username)
468                           username ,username)
469                         username)
470
471    ;; make URI clickable
472    (setq regex-index 0)
473    (while regex-index
474      (setq regex-index
475            (string-match "https?://[-_.!~*'()a-zA-Z0-9;/?:@&=+$,%#]+"
476                          text
477                          regex-index))
478      (if regex-index
479          (progn
480            (incf regex-index)
481            (add-text-properties
482             (match-beginning 0) (match-end 0)
483             `(mouse-face highlight
484               uri ,(match-string 0 text))
485             text))))
486    `((id . ,id)
487      (username . ,username)
488      (text . ,text)
489      (time . ,time)
490      (icon-string . ,icon-string))))
491
492
493(defun twittering-xmltree-to-status (xmltree)
494  (mapcar #'twittering-status-to-status-datum
495          ;; quirk to treat difference between xml.el in Emacs21 and Emacs22
496          ;; On Emacs22, there may be blank strings
497          (let ((ret nil) (statuses (reverse (cddr (car xmltree)))))
498            (while statuses
499              (if (consp (car statuses))
500                  (setq ret (cons (car statuses) ret)))
501              (setq statuses (cdr statuses)))
502            ret)))
503
504(defun twittering-url-encode (str)
505  str)
506
507(defun twittering-percent-encode (str &optional coding-system)
508  (if (or (null coding-system)
509          (not (coding-system-p coding-system)))
510      (setq coding-system 'utf-8))
511  (mapconcat
512   (lambda (c)
513     (cond
514      ((twittering-url-reserved-p c)
515       (char-to-string c))
516      ((eq c ? ) "+")
517      (t (format "%%%x" c))))
518   (encode-coding-string str coding-system)
519   ""))
520
521(defun twittering-url-reserved-p (ch)
522  (or (and (<= ?A ch) (<= ch ?z))
523      (and (<= ?0 ch) (<= ch ?9))
524      (eq ?. ch)
525      (eq ?- ch)
526      (eq ?_ ch)
527      (eq ?~ ch)))
528
529(defun twittering-decode-html-entities (encoded-str)
530  (let (entity (ret encoded-str))
531    (while (string-match "&#\\([0-9]+\\);" ret)
532      (setq entity (match-string-no-properties 1 ret))
533      (setq
534       ret
535       (replace-match
536        (char-to-string
537         (twittering-ucs-to-char (string-to-number entity)))
538        t t ret)))
539    ret))
540
541(defun twittering-timer-action (func)
542  (let ((buf (get-buffer twittering-buffer)))
543    (if (null buf)
544        (twittering-stop)
545      (funcall func)
546      )))
547
548(defun twittering-update-status-if-not-blank (status)
549  (if (string-match "^\\s-*\\(?:@[-_a-z0-9]+\\)?\\s-*$" status)
550      nil
551    (twittering-http-post "statuses" "update"
552                          `(("status" . ,status)
553                            ("source" . "twmode")))
554    t))
555
556(defun twittering-update-status-from-minibuffer (&optional init-str)
557  (if (null init-str) (setq init-str ""))
558  (let ((status init-str) (not-posted-p t))
559    (while not-posted-p
560      (setq status (read-from-minibuffer "status: " status nil nil nil nil t))
561      (setq not-posted-p
562            (not (twittering-update-status-if-not-blank status))))))
563
564;;;
565;;; Commands
566;;;
567
568(defun twittering-start (&optional action)
569  (interactive)
570  (if (null action)
571      (setq action #'twittering-friends-timeline))
572  (if twittering-timer
573      nil
574    (setq twittering-timer
575          (run-at-time "0 sec"
576                       twittering-timer-interval
577                       #'twittering-timer-action action))))
578
579(defun twittering-stop ()
580  (interactive)
581  (cancel-timer twittering-timer)
582  (setq twittering-timer nil))
583
584(defun twittering-friends-timeline ()
585  (interactive)
586  (let ((buf (get-buffer twittering-buffer)))
587    (if (not buf)
588        (twittering-stop)
589      (twittering-http-get "statuses" "friends_timeline")
590      ))
591
592  (if twittering-icon-mode
593      (if twittering-image-stack
594          (let ((proc
595                 (apply
596                  #'start-process
597                  "wget-images"
598                  (twittering-wget-buffer)
599                  "wget"
600                  (format "--directory-prefix=%s" twittering-tmp-dir)
601                  "--no-clobber"
602                  "--quiet"
603                  twittering-image-stack)))
604            (set-process-sentinel
605             proc
606             (lambda (proc stat)
607               (clear-image-cache)
608               (save-excursion
609                 (set-buffer (twittering-wget-buffer))
610                 )))))))
611
612(defun twittering-update-status-interactive ()
613  (interactive)
614  (twittering-update-status-from-minibuffer))
615
616(defun twittering-erase-old-statuses ()
617  (interactive)
618  (setq twittering-friends-timeline-data nil)
619  (twittering-http-get "statuses" "friends_timeline"))
620
621(defun twittering-click ()
622  (interactive)
623  (let ((uri (get-text-property (point) 'uri)))
624    (if uri
625        (browse-url uri))))
626
627(defun twittering-enter ()
628  (interactive)
629  (let ((username (get-text-property (point) 'username))
630        (uri (get-text-property (point) 'uri)))
631    (if username
632        (twittering-update-status-from-minibuffer (concat "@" username " "))
633      (if uri
634          (browse-url uri)))))
635
636(defun twittering-view-user-page ()
637  (interactive)
638  (let ((uri (get-text-property (point) 'uri)))
639    (if uri
640        (browse-url uri))))
641
642(defun twittering-reply-to-user ()
643  (interactive)
644  (let ((username (get-text-property (point) 'username)))
645    (if username
646        (twittering-update-status-from-minibuffer (concat "@" username " ")))))
647
648(provide 'twittering-mode)
649;;; twittering.el ends here
Note: See TracBrowser for help on using the browser.