Context Navigation

twittering-mode.el @ 37

Revision 37, 33.1 kB (checked in by tsuyoshi, 16 years ago)
append nico's patches and hook variable add.

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

Note: See TracBrowser for help on using the browser.

Context Navigation

root/lang/elisp/twittering-mode/branches/tsuyoshi/twittering-mode.el @ 37

Download in other formats: