Context Navigation

wassr-mode.el @ 54

Revision 54, 31.8 kB (checked in by tsuyoshi, 16 years ago)
first porting commit.

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

Note: See TracBrowser for help on using the browser.

Context Navigation

root/lang/elisp/wassr-mode/trunk/wassr-mode.el @ 54

Download in other formats: