Context Navigation

← Previous Change
Next Change →

twittering-mode

Timestamp:

04/27/08 09:00:02 (16 years ago)

Author:

gan2

Message:

branches/tsuyoshi/ から twittering-mode.el をコピー

Files:

: 1 modified

lang/elisp/twittering-mode/branches/gan2/twittering-mode.el (modified) (36 diffs)

Legend:

: Unmodified
: Added
: Removed

lang/elisp/twittering-mode/branches/gan2/twittering-mode.el

r31	r35
52	52	(interactive)
53	53	(let ((version-string
54		(format "twittering-mode-v%s" twittering-mode-version)))
	54	(format "twittering-mode-v%s" twittering-mode-version)))
55	55	(if (interactive-p)
56		(message "%s" version-string)
	56	(message "%s" version-string)
57	57	version-string)))
58	58
…	…
108	108	(if (bufferp buffer)
109	109	(if (buffer-live-p buffer)
110		buffer
111		(generate-new-buffer (buffer-name buffer)))
	110	buffer
	111	(generate-new-buffer (buffer-name buffer)))
112	112	(if (stringp buffer)
113		(or (get-buffer buffer)
114		(generate-new-buffer buffer)))))
	113	(or (get-buffer buffer)
	114	(generate-new-buffer buffer)))))
115	115
116	116	(defun assocref (item alist)
…	…
129	129	(interactive)
130	130	(setq twittering-proxy-use
131		(not twittering-proxy-use))
	131	(not twittering-proxy-use))
132	132	(message "%s %s"
133		"Use Proxy:"
134		(if twittering-proxy-use
135		"on" "off")))
	133	"Use Proxy:"
	134	(if twittering-proxy-use
	135	"on" "off")))
136	136
137	137	(defun twittering-user-agent-default-function ()
138	138	"Twittering mode default User-Agent function."
139	139	(concat "Emacs/"
140		(int-to-string emacs-major-version) "." (int-to-string
141		emacs-minor-version)
142		" "
143		"Twittering-mode/"
144		twittering-mode-version))
	140	(int-to-string emacs-major-version) "." (int-to-string
	141	emacs-minor-version)
	142	" "
	143	"Twittering-mode/"
	144	twittering-mode-version))
145	145
146	146	(defvar twittering-user-agent-function 'twittering-user-agent-default-function)
…	…
158	158	(defvar twittering-tmp-dir
159	159	(expand-file-name (concat "twmode-images-" (user-login-name))
160		temporary-file-directory))
	160	temporary-file-directory))
161	161
162	162	(defvar twittering-icon-mode nil "You MUST NOT CHANGE this variable directory. You should change through function'twittering-icon-mode'")
…	…
164	164	(interactive)
165	165	(setq twittering-icon-mode
166		(if twittering-icon-mode
167		(if (null arg)
168		nil
169		(> (prefix-numeric-value arg) 0))
170		(when (or (null arg)
171		(and arg (> (prefix-numeric-value arg) 0)))
172		(when (file-writable-p twittering-tmp-dir)
173		(progn
174		(if (not (file-directory-p twittering-tmp-dir))
175		(make-directory twittering-tmp-dir))
176		t)))))
	166	(if twittering-icon-mode
	167	(if (null arg)
	168	nil
	169	(> (prefix-numeric-value arg) 0))
	170	(when (or (null arg)
	171	(and arg (> (prefix-numeric-value arg) 0)))
	172	(when (file-writable-p twittering-tmp-dir)
	173	(progn
	174	(if (not (file-directory-p twittering-tmp-dir))
	175	(make-directory twittering-tmp-dir))
	176	t)))))
177	177	(twittering-render-friends-timeline))
178	178
…	…
180	180	(interactive)
181	181	(setq twittering-scroll-mode
182		(if (null arg)
183		(not twittering-scroll-mode)
184		(> (prefix-numeric-value arg) 0))))
	182	(if (null arg)
	183	(not twittering-scroll-mode)
	184	(> (prefix-numeric-value arg) 0))))
185	185
186	186	(defun twittering-jojo-mode (&optional arg)
187	187	(interactive)
188	188	(setq twittering-jojo-mode
189		(if (null arg)
190		(not twittering-jojo-mode)
191		(> (prefix-numeric-value arg) 0))))
	189	(if (null arg)
	190	(not twittering-jojo-mode)
	191	(> (prefix-numeric-value arg) 0))))
192	192
193	193	(defvar twittering-image-stack nil)
…	…
202	202	(defun twittering-local-strftime (fmt string)
203	203	(format-time-string fmt ; like "%Y-%m-%d %H:%M:%S", shown in localtime
204		(apply 'encode-time (parse-time-string string))))
	204	(apply 'encode-time (parse-time-string string))))
205	205
206	206	(defvar twittering-debug-mode nil)
…	…
212	212	`(let ((,obsym ,obj))
213	213	(if twittering-debug-mode
214		(with-current-buffer (twittering-debug-buffer)
215		(insert (prin1-to-string ,obsym))
216		(newline)
217		,obsym)
218		,obsym))))
	214	(with-current-buffer (twittering-debug-buffer)
	215	(insert (prin1-to-string ,obsym))
	216	(newline)
	217	,obsym)
	218	,obsym))))
219	219
220	220	(defun twittering-debug-mode ()
221	221	(interactive)
222	222	(setq twittering-debug-mode
223		(not twittering-debug-mode))
	223	(not twittering-debug-mode))
224	224	(message (if twittering-debug-mode "debug mode:on" "debug mode:off")))
225	225
…	…
247	247	(define-key km "G" 'end-of-buffer)
248	248	(define-key km "H" 'beginning-of-buffer)
	249	(define-key km "i" 'twittering-icon-mode)
	250	(define-key km "s" 'twittering-scroll-mode)
	251	(define-key km "t" 'twittering-toggle-proxy)
249	252	(define-key km "\C-c\C-p" 'twittering-toggle-proxy)
250	253	nil))
…	…
279	282	,@(mapcar
280	283	(lambda (clause)
281		(let ((keylist (car clause))
282		(body (cdr clause)))
283		`(,(if (listp keylist)
284		`(or ,@(mapcar (lambda (key) `(string-equal ,str ,key)) keylist))
285		't)
286		,@body)))
	284	(let ((keylist (car clause))
	285	(body (cdr clause)))
	286	`(,(if (listp keylist)
	287	`(or ,@(mapcar (lambda (key) `(string-equal ,str ,key)) keylist))
	288	't)
	289	,@body)))
287	290	clauses)))
288	291
…	…
324	327
325	328	(let (proc server port
326		(proxy-user twittering-proxy-user)
327		(proxy-password twittering-proxy-password))
	329	(proxy-user twittering-proxy-user)
	330	(proxy-password twittering-proxy-password))
328	331	(condition-case nil
329		(progn
330		(if (and twittering-proxy-use twittering-proxy-server)
331		(setq server twittering-proxy-server
332		port (if (integerp twittering-proxy-port)
333		(int-to-string twittering-proxy-port)
334		twittering-proxy-port))
335		(setq server "twitter.com"
336		port "80"))
337		(setq proc
338		(open-network-stream
339		"network-connection-process" (twittering-http-buffer)
340		server (string-to-number port)))
341		(set-process-sentinel proc sentinel)
342		(process-send-string
343		proc
344		(let ((nl "\r\n")
345		request)
346		(setq request
347		(concat "GET http://twitter.com/" method-class "/" method ".xml HTTP/1.1" nl
348		"Host: twitter.com" nl
349		"User-Agent: " (twittering-user-agent) nl
350		"Authorization: Basic "
351		(base64-encode-string
352		(concat twittering-username ":" (twittering-get-password)))
353		nl
354		"Accept: text/xml"
355		",application/xml"
356		",application/xhtml+xml"
357		",application/html;q=0.9"
358		",text/plain;q=0.8"
359		",image/png,/;q=0.5" nl
360		"Accept-Charset: utf-8;q=0.7,*;q=0.7" nl
361		(when twittering-proxy-use
362		"Proxy-Connection: Keep-Alive" nl
363		(when (and proxy-user proxy-password)
364		(concat
365		"Proxy-Authorization: Basic "
366		(base64-encode-string
367		(concat proxy-user ":"
368		proxy-password))
369		nl)))
370		nl nl))
371		(debug-print (concat "GET Request\n" request))
372		request)))
	332	(progn
	333	(if (and twittering-proxy-use twittering-proxy-server)
	334	(setq server twittering-proxy-server
	335	port (if (integerp twittering-proxy-port)
	336	(int-to-string twittering-proxy-port)
	337	twittering-proxy-port))
	338	(setq server "twitter.com"
	339	port "80"))
	340	(setq proc
	341	(open-network-stream
	342	"network-connection-process" (twittering-http-buffer)
	343	server (string-to-number port)))
	344	(set-process-sentinel proc sentinel)
	345	(process-send-string
	346	proc
	347	(let ((nl "\r\n")
	348	request)
	349	(setq request
	350	(concat "GET http://twitter.com/" method-class "/" method ".xml HTTP/1.1" nl
	351	"Host: twitter.com" nl
	352	"User-Agent: " (twittering-user-agent) nl
	353	"Authorization: Basic "
	354	(base64-encode-string
	355	(concat twittering-username ":" (twittering-get-password)))
	356	nl
	357	"Accept: text/xml"
	358	",application/xml"
	359	",application/xhtml+xml"
	360	",application/html;q=0.9"
	361	",text/plain;q=0.8"
	362	",image/png,/;q=0.5" nl
	363	"Accept-Charset: utf-8;q=0.7,*;q=0.7" nl
	364	(when twittering-proxy-use
	365	"Proxy-Connection: Keep-Alive" nl
	366	(when (and proxy-user proxy-password)
	367	(concat
	368	"Proxy-Authorization: Basic "
	369	(base64-encode-string
	370	(concat proxy-user ":"
	371	proxy-password))
	372	nl)))
	373	nl nl))
	374	(debug-print (concat "GET Request\n" request))
	375	request)))
373	376	(error
374	377	(message "Failure: HTTP GET") nil))))
…	…
376	379	(defun twittering-http-get-default-sentinel (proc stat &optional suc-msg)
377	380	(let ((header (twittering-get-response-header))
378		(body (twittering-get-response-body))
379		(status nil)
380		)
	381	(body (twittering-get-response-body))
	382	(status nil)
	383	)
381	384	(if (string-match "HTTP/1\.[01] \$[a-z0-9 ]+\$\r?\n" header)
382		(progn
383		(setq status (match-string-no-properties 1 header))
384		(case-string
385		status
386		(("200 OK")
387		(mapcar
388		#'twittering-cache-status-datum
389		(reverse (twittering-xmltree-to-status
390		body)))
391		(twittering-render-friends-timeline)
392		(message (if suc-msg suc-msg "Success: Get.")))
393		(t (message status))))
	385	(progn
	386	(setq status (match-string-no-properties 1 header))
	387	(case-string
	388	status
	389	(("200 OK")
	390	(mapcar
	391	#'twittering-cache-status-datum
	392	(reverse (twittering-xmltree-to-status
	393	body)))
	394	(twittering-render-friends-timeline)
	395	(message (if suc-msg suc-msg "Success: Get.")))
	396	(t (message status))))
394	397	(message "Failure: Bad http response.")))
395	398	)
…	…
398	401	(with-current-buffer (twittering-buffer)
399	402	(let ((point (point))
400		(end (point-max)))
	403	(end (point-max)))
401	404	(setq buffer-read-only nil)
402	405	(erase-buffer)
403	406	(insert
404	407	(mapconcat (lambda (status)
405		(twittering-format-status status twittering-status-format))
406		twittering-friends-timeline-data
407		"\n"))
	408	(twittering-format-status status twittering-status-format))
	409	twittering-friends-timeline-data
	410	"\n"))
408	411	(if twittering-image-stack
409		(clear-image-cache))
	412	(clear-image-cache))
410	413	(setq buffer-read-only t)
411	414	(debug-print (current-buffer))
…	…
415	418	(defun twittering-format-status (status format-str)
416	419	(flet ((attr (key)
417		(assocref key status))
418		(profile-image
419		()
420		(let ((profile-image-url (attr 'user-profile-image-url))
421		(icon-string "\n "))
422		(if (string-match "/\$[^/?]+\$\$?:\\?\\\|$\$" profile-image-url)
423		(let ((filename (match-string-no-properties 1 profile-image-url)))
424		;; download icons if does not exist
425		(if (file-exists-p (concat twittering-tmp-dir
426		"/" filename))
427		t
428		(add-to-list 'twittering-image-stack profile-image-url))
429
430		(when (and icon-string twittering-icon-mode)
431		(set-text-properties
432		1 2 `(display
433		(image :type ,(twittering-image-type filename)
434		:file ,(concat twittering-tmp-dir
435		"/"
436		filename)))
437		icon-string)
438		icon-string)
439		)))))
	420	(assocref key status))
	421	(profile-image
	422	()
	423	(let ((profile-image-url (attr 'user-profile-image-url))
	424	(icon-string "\n "))
	425	(if (string-match "/\$[^/?]+\$\$?:\\?\\\|$\$" profile-image-url)
	426	(let ((filename (match-string-no-properties 1 profile-image-url)))
	427	;; download icons if does not exist
	428	(if (file-exists-p (concat twittering-tmp-dir
	429	"/" filename))
	430	t
	431	(add-to-list 'twittering-image-stack profile-image-url))
	432
	433	(when (and icon-string twittering-icon-mode)
	434	(set-text-properties
	435	1 2 `(display
	436	(image :type ,(twittering-image-type filename)
	437	:file ,(concat twittering-tmp-dir
	438	"/"
	439	filename)))
	440	icon-string)
	441	icon-string)
	442	)))))
440	443	(let ((cursor 0)
441		(result ())
442		c
443		found-at)
	444	(result ())
	445	c
	446	found-at)
444	447	(setq cursor 0)
445	448	(setq result '())
446	449	(while (setq found-at (string-match "%\$C{\\([^}]+\$}\\\|[A-Za-z#@']\\)" format-str cursor))
447		(setq c (string-to-char (match-string-no-properties 1 format-str)))
448		(if (> found-at cursor)
449		(list-push (substring format-str cursor found-at) result)
450		"\|")
451		(setq cursor (match-end 1))
452
453		(case c
454		((?s) ; %s - screen_name
455		(list-push (attr 'user-screen-name) result))
456		((?S) ; %S - name
457		(list-push (attr 'user-name) result))
458		((?i) ; %i - profile_image
459		(list-push (profile-image) result))
460		((?d) ; %d - description
461		(list-push (attr 'user-description) result))
462		((?l) ; %l - location
463		(list-push (attr 'user-location) result))
464		((?L) ; %L - " [location]"
465		(let ((location (attr 'user-location)))
466		(unless (or (null location) (string= "" location))
467		(list-push (concat " [" location "]") result)) ))
468		((?u) ; %u - url
469		(list-push (attr 'user-url) result))
470		((?j) ; %j - user.id
471		(list-push (attr 'user-id) result))
472		((?p) ; %p - protected?
473		(let ((protected (attr 'user-protected)))
474		(when (string= "true" protected)
475		(list-push "[x]" result))))
476		((?c) ; %c - created_at (raw UTC string)
477		(list-push (attr 'created-at) result))
478		((?C) ; %C{time-format-str} - created_at (formatted with time-format-str)
479		(list-push (twittering-local-strftime
480		(or (match-string-no-properties 2 format-str) "%H:%M:%S")
481		(attr 'created-at))
482		result))
483		((?@) ; %@ - X seconds ago
484		(let ((created-at
485		(apply
486		'encode-time
487		(parse-time-string (attr 'created-at))))
488		(now (current-time)))
489		(let ((secs (+ (* (- (car now) (car created-at)) 65536)
490		(- (cadr now) (cadr created-at)))))
491		(list-push (cond ((< secs 5) "less than 5 seconds ago")
492		((< secs 10) "less than 10 seconds ago")
493		((< secs 20) "less than 20 seconds ago")
494		((< secs 30) "half a minute ago")
495		((< secs 60) "less than a minute ago")
496		((< secs 150) "1 minute ago")
497		((< secs 2400) (format "%d minutes ago"
498		(/ (+ secs 30) 60)))
499		((< secs 5400) "about 1 hour ago")
500		((< secs 84600) (format "about %d hours ago"
501		(/ (+ secs 1800) 3600)))
502		(t (format-time-string "%I:%M %p %B %d, %Y" created-at)))
503		result))))
504		((?t) ; %t - text
505		(list-push ;(clickable-text)
506		(attr 'text)
507		result))
508		((?') ; %' - truncated
509		(let ((truncated (attr 'truncated)))
510		(when (string= "true" truncated)
511		(list-push "..." result))))
512		((?f) ; %f - source
513		(list-push (attr 'source) result))
514		((?#) ; %# - id
515		(list-push (attr 'id) result))
516		(t
517		(list-push (char-to-string c) result)))
518		)
	450	(setq c (string-to-char (match-string-no-properties 1 format-str)))
	451	(if (> found-at cursor)
	452	(list-push (substring format-str cursor found-at) result)
	453	"\|")
	454	(setq cursor (match-end 1))
	455
	456	(case c
	457	((?s) ; %s - screen_name
	458	(list-push (attr 'user-screen-name) result))
	459	((?S) ; %S - name
	460	(list-push (attr 'user-name) result))
	461	((?i) ; %i - profile_image
	462	(list-push (profile-image) result))
	463	((?d) ; %d - description
	464	(list-push (attr 'user-description) result))
	465	((?l) ; %l - location
	466	(list-push (attr 'user-location) result))
	467	((?L) ; %L - " [location]"
	468	(let ((location (attr 'user-location)))
	469	(unless (or (null location) (string= "" location))
	470	(list-push (concat " [" location "]") result)) ))
	471	((?u) ; %u - url
	472	(list-push (attr 'user-url) result))
	473	((?j) ; %j - user.id
	474	(list-push (attr 'user-id) result))
	475	((?p) ; %p - protected?
	476	(let ((protected (attr 'user-protected)))
	477	(when (string= "true" protected)
	478	(list-push "[x]" result))))
	479	((?c) ; %c - created_at (raw UTC string)
	480	(list-push (attr 'created-at) result))
	481	((?C) ; %C{time-format-str} - created_at (formatted with time-format-str)
	482	(list-push (twittering-local-strftime
	483	(or (match-string-no-properties 2 format-str) "%H:%M:%S")
	484	(attr 'created-at))
	485	result))
	486	((?@) ; %@ - X seconds ago
	487	(let ((created-at
	488	(apply
	489	'encode-time
	490	(parse-time-string (attr 'created-at))))
	491	(now (current-time)))
	492	(let ((secs (+ (* (- (car now) (car created-at)) 65536)
	493	(- (cadr now) (cadr created-at)))))
	494	(list-push (cond ((< secs 5) "less than 5 seconds ago")
	495	((< secs 10) "less than 10 seconds ago")
	496	((< secs 20) "less than 20 seconds ago")
	497	((< secs 30) "half a minute ago")
	498	((< secs 60) "less than a minute ago")
	499	((< secs 150) "1 minute ago")
	500	((< secs 2400) (format "%d minutes ago"
	501	(/ (+ secs 30) 60)))
	502	((< secs 5400) "about 1 hour ago")
	503	((< secs 84600) (format "about %d hours ago"
	504	(/ (+ secs 1800) 3600)))
	505	(t (format-time-string "%I:%M %p %B %d, %Y" created-at)))
	506	result))))
	507	((?t) ; %t - text
	508	(list-push ;(clickable-text)
	509	(attr 'text)
	510	result))
	511	((?') ; %' - truncated
	512	(let ((truncated (attr 'truncated)))
	513	(when (string= "true" truncated)
	514	(list-push "..." result))))
	515	((?f) ; %f - source
	516	(list-push (attr 'source) result))
	517	((?#) ; %# - id
	518	(list-push (attr 'id) result))
	519	(t
	520	(list-push (char-to-string c) result)))
	521	)
519	522	(list-push (substring format-str cursor) result)
520	523	(apply 'concat (nreverse result))
…	…
536	539
537	540	(let (proc server port
538		(proxy-user twittering-proxy-user)
539		(proxy-password twittering-proxy-password))
	541	(proxy-user twittering-proxy-user)
	542	(proxy-password twittering-proxy-password))
540	543	(progn
541	544	(if (and twittering-proxy-use twittering-proxy-server)
542		(setq server twittering-proxy-server
543		port (if (integerp twittering-proxy-port)
544		(int-to-string twittering-proxy-port)
545		twittering-proxy-port))
546		(setq server "twitter.com"
547		port "80"))
	545	(setq server twittering-proxy-server
	546	port (if (integerp twittering-proxy-port)
	547	(int-to-string twittering-proxy-port)
	548	twittering-proxy-port))
	549	(setq server "twitter.com"
	550	port "80"))
548	551	(setq proc
549		(open-network-stream
550		"network-connection-process" (twittering-http-buffer)
551		server (string-to-number port)))
	552	(open-network-stream
	553	"network-connection-process" (twittering-http-buffer)
	554	server (string-to-number port)))
552	555	(set-process-sentinel proc sentinel)
553	556	(process-send-string
554	557	proc
555	558	(let ((nl "\r\n")
556		request)
557		(setq request
558		(concat "POST http://twitter.com/" method-class "/" method ".xml?"
559		(if parameters
560		(mapconcat
561		(lambda (param-pair)
562		(format "%s=%s"
563		(twittering-percent-encode (car param-pair))
564		(twittering-percent-encode (cdr param-pair))))
565		parameters
566		"&"))
567		" HTTP/1.1" nl
568		"Host: twitter.com" nl
569		"User-Agent: " (twittering-user-agent) nl
570		"Authorization: Basic "
571		(base64-encode-string
572		(concat twittering-username ":" (twittering-get-password)))
573		nl
574		"Content-Type: text/plain" nl
575		"Content-Length: 0" nl
576		(when twittering-proxy-use
577		"Proxy-Connection: Keep-Alive" nl
578		(when (and proxy-user proxy-password)
579		(concat
580		"Proxy-Authorization: Basic "
581		(base64-encode-string
582		(concat proxy-user ":"
583		proxy-password))
584		nl)))
585		nl nl))
586		(debug-print (concat "POST Request\n" request))
587		request)))))
	559	request)
	560	(setq request
	561	(concat "POST http://twitter.com/" method-class "/" method ".xml?"
	562	(if parameters
	563	(mapconcat
	564	(lambda (param-pair)
	565	(format "%s=%s"
	566	(twittering-percent-encode (car param-pair))
	567	(twittering-percent-encode (cdr param-pair))))
	568	parameters
	569	"&"))
	570	" HTTP/1.1" nl
	571	"Host: twitter.com" nl
	572	"User-Agent: " (twittering-user-agent) nl
	573	"Authorization: Basic "
	574	(base64-encode-string
	575	(concat twittering-username ":" (twittering-get-password)))
	576	nl
	577	"Content-Type: text/plain" nl
	578	"Content-Length: 0" nl
	579	(when twittering-proxy-use
	580	"Proxy-Connection: Keep-Alive" nl
	581	(when (and proxy-user proxy-password)
	582	(concat
	583	"Proxy-Authorization: Basic "
	584	(base64-encode-string
	585	(concat proxy-user ":"
	586	proxy-password))
	587	nl)))
	588	nl nl))
	589	(debug-print (concat "POST Request\n" request))
	590	request)))))
588	591
589	592	(defun twittering-http-post-default-sentinel (proc stat &optional suc-msg)
…	…
591	594	(condition-case err-signal
592	595	(let ((header (twittering-get-response-header))
593		;; (body (twittering-get-response-body)) not used now.
594		(status nil))
595		(string-match "HTTP/1\.1 \$[a-z0-9 ]+\$\r?\n" header)
596		(setq status (match-string-no-properties 1 header))
597		(case-string status
598		(("200 OK")
599		(message (if suc-msg suc-msg "Success: Post")))
600		(t (message status)))
601		)
	596	;; (body (twittering-get-response-body)) not used now.
	597	(status nil))
	598	(string-match "HTTP/1\.1 \$[a-z0-9 ]+\$\r?\n" header)
	599	(setq status (match-string-no-properties 1 header))
	600	(case-string status
	601	(("200 OK")
	602	(message (if suc-msg suc-msg "Success: Post")))
	603	(t (message status)))
	604	)
602	605	(error (message (prin1-to-string err-signal))))
603	606	)
…	…
624	627	(let ((content (buffer-string)))
625	628	(let ((content (buffer-string)))
626		(xml-parse-region (+ (string-match "\r?\n\r?\n" content)
627		(length (match-string 0 content)))
628		(point-max)))
	629	(xml-parse-region (+ (string-match "\r?\n\r?\n" content)
	630	(length (match-string 0 content)))
	631	(point-max)))
629	632	)))
630	633
…	…
636	639	(let ((id (cdr (assq 'id status-datum))))
637	640	(if (or (null (symbol-value data-var))
638		(not (find-if
639		(lambda (item)
640		(eql id (cdr (assq 'id item))))
641		(symbol-value data-var))))
642		(progn
643		(if twittering-jojo-mode
644		(twittering-update-jojo (cdr (assq 'user-screen-name status-datum))
645		(cdr (assq 'text status-datum))))
646		(set data-var (cons status-datum (symbol-value data-var)))
647		t)
	641	(not (find-if
	642	(lambda (item)
	643	(eql id (cdr (assq 'id item))))
	644	(symbol-value data-var))))
	645	(progn
	646	(if twittering-jojo-mode
	647	(twittering-update-jojo (cdr (assq 'user-screen-name status-datum))
	648	(cdr (assq 'text status-datum))))
	649	(set data-var (cons status-datum (symbol-value data-var)))
	650	t)
648	651	nil)))
649	652
650	653	(defun twittering-status-to-status-datum (status)
651	654	(flet ((assq-get (item seq)
652		(car (cddr (assq item seq)))))
	655	(car (cddr (assq item seq)))))
653	656	(let* ((status-data (cddr status))
654		id text source created-at truncated
655		(user-data (cddr (assq 'user status-data)))
656		user-id user-name
657		user-screen-name
658		user-location
659		user-description
660		user-profile-image-url
661		user-url
662		user-protected
663		regex-index)
	657	id text source created-at truncated
	658	(user-data (cddr (assq 'user status-data)))
	659	user-id user-name
	660	user-screen-name
	661	user-location
	662	user-description
	663	user-profile-image-url
	664	user-url
	665	user-protected
	666	regex-index)
664	667
665	668	(setq id (string-to-number (assq-get 'id status-data)))
666	669	(setq text (twittering-decode-html-entities
667		(assq-get 'text status-data)))
	670	(assq-get 'text status-data)))
668	671	(setq source (twittering-decode-html-entities
669		(assq-get 'source status-data)))
	672	(assq-get 'source status-data)))
670	673	(setq created-at (assq-get 'created_at status-data))
671	674	(setq truncated (assq-get 'truncated status-data))
672	675	(setq user-id (string-to-number (assq-get 'id user-data)))
673	676	(setq user-name (twittering-decode-html-entities
674		(assq-get 'name user-data)))
	677	(assq-get 'name user-data)))
675	678	(setq user-screen-name (twittering-decode-html-entities
676		(assq-get 'screen_name user-data)))
	679	(assq-get 'screen_name user-data)))
677	680	(setq user-location (twittering-decode-html-entities
678		(assq-get 'location user-data)))
	681	(assq-get 'location user-data)))
679	682	(setq user-description (twittering-decode-html-entities
680		(assq-get 'description user-data)))
	683	(assq-get 'description user-data)))
681	684	(setq user-profile-image-url (assq-get 'profile_image_url user-data))
682	685	(setq user-url (assq-get 'url user-data))
…	…
685	688	;; make username clickable
686	689	(add-text-properties 0 (length user-screen-name)
687		`(mouse-face highlight
688		uri ,(concat "http://twitter.com/" user-screen-name)
689		username ,user-screen-name
690		face twittering-username-face)
691		user-screen-name)
	690	`(mouse-face highlight
	691	uri ,(concat "http://twitter.com/" user-screen-name)
	692	username ,user-screen-name
	693	face twittering-username-face)
	694	user-screen-name)
692	695
693	696	;; make URI clickable
694	697	(setq regex-index 0)
695	698	(while regex-index
696		(setq regex-index
697		(string-match "@\$[_a-zA-Z0-9]+\$\\\|\$https?://[-_.!~*'()a-zA-Z0-9;/?:@&=+$,%#]+\$"
698		text
699		regex-index))
700		(when regex-index
701		(let* ((matched-string (match-string-no-properties 0 text))
702		(screen-name (match-string-no-properties 1 text))
703		(uri (match-string-no-properties 2 text)))
704		(add-text-properties
705		(if screen-name
706		(+ 1 (match-beginning 0))
707		(match-beginning 0))
708		(match-end 0)
709		(if screen-name
710		`(mouse-face
711		highlight
712		face twittering-uri-face
713		username ,screen-name
714		uri ,(concat "http://twitter.com/" screen-name))
715		`(mouse-face highlight
716		face twittering-uri-face
717		uri ,uri))
718		text))
719		(setq regex-index (match-end 0)) ))
	699	(setq regex-index
	700	(string-match "@\$[_a-zA-Z0-9]+\$\\\|\$https?://[-_.!~*'()a-zA-Z0-9;/?:@&=+$,%#]+\$"
	701	text
	702	regex-index))
	703	(when regex-index
	704	(let* ((matched-string (match-string-no-properties 0 text))
	705	(screen-name (match-string-no-properties 1 text))
	706	(uri (match-string-no-properties 2 text)))
	707	(add-text-properties
	708	(if screen-name
	709	(+ 1 (match-beginning 0))
	710	(match-beginning 0))
	711	(match-end 0)
	712	(if screen-name
	713	`(mouse-face
	714	highlight
	715	face twittering-uri-face
	716	username ,screen-name
	717	uri ,(concat "http://twitter.com/" screen-name))
	718	`(mouse-face highlight
	719	face twittering-uri-face
	720	uri ,uri))
	721	text))
	722	(setq regex-index (match-end 0)) ))
720	723
721	724	;; make screen-name clickable
…	…
723	726	0 (length user-screen-name)
724	727	`(mouse-face highlight
725		face twittering-username-face
726		uri ,(concat "http://twitter.com/" user-screen-name)
727		username ,user-screen-name)
	728	face twittering-username-face
	729	uri ,(concat "http://twitter.com/" user-screen-name)
	730	username ,user-screen-name)
728	731	user-screen-name)
729	732
730	733	;; make source pretty and clickable
731	734	(if (string-match "<a href=\"\$.\$\">\$.\$</a>" source)
732		(let ((uri (match-string-no-properties 1 source))
733		(caption (match-string-no-properties 2 source)))
734		(setq source caption)
735		(add-text-properties
736		0 (length source)
737		`(mouse-face highlight
738		uri ,uri
739		face twittering-uri-face
740		source ,source)
741		source)
742		))
	735	(let ((uri (match-string-no-properties 1 source))
	736	(caption (match-string-no-properties 2 source)))
	737	(setq source caption)
	738	(add-text-properties
	739	0 (length source)
	740	`(mouse-face highlight
	741	uri ,uri
	742	face twittering-uri-face
	743	source ,source)
	744	source)
	745	))
743	746
744	747	(mapcar
745	748	(lambda (sym)
746		`(,sym . ,(symbol-value sym)))
	749	`(,sym . ,(symbol-value sym)))
747	750	'(id text source created-at truncated
748		user-id user-name user-screen-name user-location
749		user-description
750		user-profile-image-url
751		user-url
752		user-protected)))))
	751	user-id user-name user-screen-name user-location
	752	user-description
	753	user-profile-image-url
	754	user-url
	755	user-protected)))))
753	756
754	757	(defun twittering-xmltree-to-status (xmltree)
755	758	(mapcar #'twittering-status-to-status-datum
756		;; quirk to treat difference between xml.el in Emacs21 and Emacs22
757		;; On Emacs22, there may be blank strings
758		(let ((ret nil) (statuses (reverse (cddr (car xmltree)))))
759		(while statuses
760		(if (consp (car statuses))
761		(setq ret (cons (car statuses) ret)))
762		(setq statuses (cdr statuses)))
763		ret)))
	759	;; quirk to treat difference between xml.el in Emacs21 and Emacs22
	760	;; On Emacs22, there may be blank strings
	761	(let ((ret nil) (statuses (reverse (cddr (car xmltree)))))
	762	(while statuses
	763	(if (consp (car statuses))
	764	(setq ret (cons (car statuses) ret)))
	765	(setq statuses (cdr statuses)))
	766	ret)))
764	767
765	768	(defun twittering-percent-encode (str &optional coding-system)
766	769	(if (or (null coding-system)
767		(not (coding-system-p coding-system)))
	770	(not (coding-system-p coding-system)))
768	771	(setq coding-system 'utf-8))
769	772	(mapconcat
…	…
788	791	(if encoded-str
789	792	(let ((cursor 0)
790		(found-at nil)
791		(result '()))
792		(while (setq found-at
793		(string-match "&\$#\\([0-9]+\$\\\|\$[A-Za-z]+\$\\);"
794		encoded-str cursor))
795		(when (> found-at cursor)
796		(list-push (substring encoded-str cursor found-at) result))
797		(let ((number-entity (match-string-no-properties 2 encoded-str))
798		(letter-entity (match-string-no-properties 3 encoded-str)))
799		(cond (number-entity
800		(list-push
801		(char-to-string
802		(twittering-ucs-to-char
803		(string-to-number number-entity))) result))
804		(letter-entity
805		(cond ((string= "gt" letter-entity) (list-push ">" result))
806		((string= "lt" letter-entity) (list-push "<" result))
807		(t (list-push "?" result))))
808		(t (list-push "?" result)))
809		(setq cursor (match-end 0))))
810		(list-push (substring encoded-str cursor) result)
811		(apply 'concat (nreverse result)))
	793	(found-at nil)
	794	(result '()))
	795	(while (setq found-at
	796	(string-match "&\$#\\([0-9]+\$\\\|\$[A-Za-z]+\$\\);"
	797	encoded-str cursor))
	798	(when (> found-at cursor)
	799	(list-push (substring encoded-str cursor found-at) result))
	800	(let ((number-entity (match-string-no-properties 2 encoded-str))
	801	(letter-entity (match-string-no-properties 3 encoded-str)))
	802	(cond (number-entity
	803	(list-push
	804	(char-to-string
	805	(twittering-ucs-to-char
	806	(string-to-number number-entity))) result))
	807	(letter-entity
	808	(cond ((string= "gt" letter-entity) (list-push ">" result))
	809	((string= "lt" letter-entity) (list-push "<" result))
	810	(t (list-push "?" result))))
	811	(t (list-push "?" result)))
	812	(setq cursor (match-end 0))))
	813	(list-push (substring encoded-str cursor) result)
	814	(apply 'concat (nreverse result)))
812	815	""))
813	816
…	…
815	818	(let ((buf (get-buffer twittering-buffer)))
816	819	(if (null buf)
817		(twittering-stop)
	820	(twittering-stop)
818	821	(funcall func)
819	822	)))
…	…
823	826	nil
824	827	(twittering-http-post "statuses" "update"
825		`(("status" . ,status)
826		("source" . "twmode")))
	828	`(("status" . ,status)
	829	("source" . "twmode")))
827	830	t))
828	831
…	…
833	836	(setq status (read-from-minibuffer "status: " status nil nil nil nil t))
834	837	(setq not-posted-p
835		(not (twittering-update-status-if-not-blank status))))))
	838	(not (twittering-update-status-if-not-blank status))))))
836	839
837	840	(defun twittering-update-lambda ()
…	…
844	847	(defun twittering-update-jojo (usr msg)
845	848	(if (string-match "\xde21\xd24b\$\xd22a\xe0b0\\\|\xdaae\xe6cd\$\xd24f\xd0d6\$[^\xd0d7]+\$\xd0d7\xd248\xdc40\xd226"
846		msg)
	849	msg)
847	850	(twittering-http-post
848	851	"statuses" "update"
849	852	`(("status" . ,(concat
850		"@" usr " "
851		(match-string-no-properties 2 msg)
852		"\xd0a1\xd24f\xd243!?"))
853		("source" . "twmode")))))
	853	"@" usr " "
	854	(match-string-no-properties 2 msg)
	855	"\xd0a1\xd24f\xd243!?"))
	856	("source" . "twmode")))))
854	857
855	858	;;;
…	…
864	867	nil
865	868	(setq twittering-timer
866		(run-at-time "0 sec"
867		twittering-timer-interval
868		#'twittering-timer-action action))))
	869	(run-at-time "0 sec"
	870	twittering-timer-interval
	871	#'twittering-timer-action action))))
869	872
870	873	(defun twittering-stop ()
…	…
877	880	(let ((buf (get-buffer twittering-buffer)))
878	881	(if (not buf)
879		(twittering-stop)
	882	(twittering-stop)
880	883	(twittering-http-get "statuses" "friends_timeline")
881	884	))
…	…
883	886	(if twittering-icon-mode
884	887	(if twittering-image-stack
885		(let ((proc
886		(apply
887		#'start-process
888		"wget-images"
889		(twittering-wget-buffer)
890		"wget"
891		(format "--directory-prefix=%s" twittering-tmp-dir)
892		"--no-clobber"
893		"--quiet"
894		twittering-image-stack)))
895		(set-process-sentinel
896		proc
897		(lambda (proc stat)
898		(clear-image-cache)
899		(save-excursion
900		(set-buffer (twittering-wget-buffer))
901		)))))))
	888	(let ((proc
	889	(apply
	890	#'start-process
	891	"wget-images"
	892	(twittering-wget-buffer)
	893	"wget"
	894	(format "--directory-prefix=%s" twittering-tmp-dir)
	895	"--no-clobber"
	896	"--quiet"
	897	twittering-image-stack)))
	898	(set-process-sentinel
	899	proc
	900	(lambda (proc stat)
	901	(clear-image-cache)
	902	(save-excursion
	903	(set-buffer (twittering-wget-buffer))
	904	)))))))
902	905
903	906	(defun twittering-update-status-interactive ()
…	…
914	917	(let ((uri (get-text-property (point) 'uri)))
915	918	(if uri
916		(browse-url uri))))
	919	(browse-url uri))))
917	920
918	921	(defun twittering-enter ()
919	922	(interactive)
920	923	(let ((username (get-text-property (point) 'username))
921		(uri (get-text-property (point) 'uri)))
	924	(uri (get-text-property (point) 'uri)))
922	925	(if username
923		(twittering-update-status-from-minibuffer (concat "@" username " "))
	926	(twittering-update-status-from-minibuffer (concat "@" username " "))
924	927	(if uri
925		(browse-url uri)))))
	928	(browse-url uri)))))
926	929
927	930	(defun twittering-view-user-page ()
…	…
929	932	(let ((uri (get-text-property (point) 'uri)))
930	933	(if uri
931		(browse-url uri))))
	934	(browse-url uri))))
932	935
933	936	(defun twittering-reply-to-user ()
…	…
935	938	(let ((username (get-text-property (point) 'username)))
936	939	(if username
937		(twittering-update-status-from-minibuffer (concat "@" username " ")))))
	940	(twittering-update-status-from-minibuffer (concat "@" username " ")))))
938	941
939	942	(defun twittering-get-password ()
…	…
946	949	(let ((pos))
947	950	(setq pos (twittering-get-next-username-face-pos (point)))
948		(when pos
949		(goto-char pos))))
	951	(if pos
	952	(goto-char pos)
	953	(message "End of status."))))
950	954
951	955	(defun twittering-get-next-username-face-pos (pos)
952	956	(interactive)
953	957	(let ((prop))
954		(while (not (eq prop twittering-username-face))
955		(setq pos (next-single-property-change pos 'face))
956		(setq prop (get-text-property pos 'face)))
	958	(catch 'not-found
	959	(while (and pos (not (eq prop twittering-username-face)))
	960	(setq pos (next-single-property-change pos 'face))
	961	(when (eq pos nil) (throw 'not-found 0))
	962	(setq prop (get-text-property pos 'face))))
957	963	pos))
958	964
…	…
962	968	(let ((pos))
963	969	(setq pos (twittering-get-previous-username-face-pos (point)))
964		(when pos
965		(goto-char pos))))
	970	(if pos
	971	(goto-char pos)
	972	(message "Start of status."))))
966	973
967	974	(defun twittering-get-previous-username-face-pos (pos)
968	975	(interactive)
969	976	(let ((prop))
970		(while (not (eq prop twittering-username-face))
971		(setq pos (previous-single-property-change pos 'face))
972		(setq prop (get-text-property pos 'face)))
	977	(catch 'not-found
	978	(while (and pos (not (eq prop twittering-username-face)))
	979	(setq pos (previous-single-property-change pos 'face))
	980	(when (eq pos nil) (throw 'not-found 0))
	981	(setq prop (get-text-property pos 'face))))
973	982	pos))
974	983
…	…
977	986	(interactive)
978	987	(let ((user-name (twittering-get-username-at-pos (point)))
979		(pos (twittering-get-next-username-face-pos (point))))
980		(while (not (equal (twittering-get-username-at-pos pos) user-name))
981		(setq pos (twittering-get-next-username-face-pos pos)))
982		(goto-char pos)))
	988	(pos (twittering-get-next-username-face-pos (point))))
	989	(catch 'not-found
	990	(while (not (equal (twittering-get-username-at-pos pos) user-name))
	991	(setq pos (twittering-get-next-username-face-pos pos))
	992	(when (eq pos nil) (throw 'not-found 0))))
	993	(if pos
	994	(goto-char pos)
	995	(message "End of %s's status." user-name))))
983	996
984	997	(defun twittering-goto-previous-status-of-user ()
…	…
986	999	(interactive)
987	1000	(let ((user-name (twittering-get-username-at-pos (point)))
988		(pos (twittering-get-previous-username-face-pos (point))))
989		(while (not (equal (twittering-get-username-at-pos pos) user-name))
990		(setq pos (twittering-get-previous-username-face-pos pos)))
991		(goto-char pos)))
	1001	(pos (twittering-get-previous-username-face-pos (point))))
	1002	(catch 'not-found
	1003	(while (not (equal (twittering-get-username-at-pos pos) user-name))
	1004	(setq pos (twittering-get-previous-username-face-pos pos))
	1005	(when (eq pos nil) (throw 'not-found 0))))
	1006	(if pos
	1007	(goto-char pos)
	1008	(message "Start of %s's status." user-name))))
992	1009
993	1010	(defun twittering-get-username-at-pos (pos)
994	1011	(let ((start-pos pos)
995		(end-pos))
	1012	(end-pos))
996	1013	(while (eq (get-text-property start-pos 'face) twittering-username-face)
997	1014	(setq start-pos (1- start-pos)))
…	…
1000	1017	(buffer-substring start-pos end-pos)))
1001	1018
	1019	;;;###autoload
	1020	(defun twit ()
	1021	"Start twittering-mode."
	1022	(interactive)
	1023	(twittering-mode))
	1024
1002	1025	(provide 'twittering-mode)
1003	1026	;;; twittering.el ends here

Context Navigation

Changeset 35 for lang/elisp/twittering-mode

Legend:

lang/elisp/twittering-mode/branches/gan2/twittering-mode.el

Download in other formats: