Index: /lang/elisp/wassr-mode/trunk/wassr-mode.el =================================================================== --- /lang/elisp/wassr-mode/trunk/wassr-mode.el (revision 54) +++ /lang/elisp/wassr-mode/trunk/wassr-mode.el (revision 54) @@ -0,0 +1,1048 @@ +;;; wassr-mode.el --- Major mode for Wassr + +;; Copyright (C) 2008 Tsuyoshi CHO + +;; Author: Y. Hayamizu +;; Tsuyoshi CHO +;; Created: Sep 4, 2007 +;; Version: 0.4 +;; Keywords: wassr web +;; URL: + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; wassr-mode.el based on wassr-mode.el is a major mode for Wassr. +;; You can check friends timeline, and update your status on Emacs. + +;;; Feature Request: + +;;; Code: + +(require 'cl) +(require 'xml) +(require 'parse-time) + +(defconst wassr-mode-version "0.1") + +(defun wassr-mode-version () + "Display a message for wassr-mode version." + (interactive) + (let ((version-string + (format "wassr-mode-v%s" wassr-mode-version))) + (if (interactive-p) + (message "%s" version-string) + version-string))) + +(defvar wassr-mode-map (make-sparse-keymap)) + +(defvar wassr-timer nil "Timer object for timeline refreshing will be stored here. DO NOT SET VALUE MANUALLY.") + +(defvar wassr-idle-time 20) + +(defvar wassr-timer-interval 90) + +(defvar wassr-username nil) + +(defvar wassr-password nil) + +(defvar wassr-scroll-mode nil) +(make-variable-buffer-local 'wassr-scroll-mode) + +(defvar wassr-jojo-mode nil) +(make-variable-buffer-local 'wassr-jojo-mode) + +(defvar wassr-status-format nil) +(setq wassr-status-format "%i %s, %@:\n %t // from %f%L") +;; %s - screen_name +;; %S - name +;; %i - profile_image +;; %d - description +;; %l - location +;; %L - " [location]" +;; %u - url +;; %j - user.id +;; %p - protected? +;; %c - created_at (raw UTC string) +;; %C{time-format-str} - created_at (formatted with time-format-str) +;; %@ - X seconds ago +;; %t - text +;; %' - truncated +;; %f - source +;; %# - id + +(defvar wassr-buffer "*wassr*") +(defun wassr-buffer () + (wassr-get-or-generate-buffer wassr-buffer)) + +(defvar wassr-http-buffer "*wassr-http-buffer*") +(defun wassr-http-buffer () + (wassr-get-or-generate-buffer wassr-http-buffer)) + +(defvar wassr-friends-timeline-data nil) + +(defvar wassr-username-face 'wassr-username-face) +(defvar wassr-uri-face 'wassr-uri-face) + +(defun wassr-get-or-generate-buffer (buffer) + (if (bufferp buffer) + (if (buffer-live-p buffer) + buffer + (generate-new-buffer (buffer-name buffer))) + (if (stringp buffer) + (or (get-buffer buffer) + (generate-new-buffer buffer))))) + +(defun assocref (item alist) + (cdr (assoc item alist))) +(defmacro list-push (value listvar) + `(setq ,listvar (cons ,value ,listvar))) + +;;; Proxy +(defvar wassr-proxy-use nil) +(defvar wassr-proxy-server nil) +(defvar wassr-proxy-port 8080) +(defvar wassr-proxy-user nil) +(defvar wassr-proxy-password nil) + +(defun wassr-toggle-proxy () "" + (interactive) + (setq wassr-proxy-use + (not wassr-proxy-use)) + (message "%s %s" + "Use Proxy:" + (if wassr-proxy-use + "on" "off"))) + +(defun wassr-user-agent-default-function () + "Wassr mode default User-Agent function." + (concat "Emacs/" + (int-to-string emacs-major-version) "." (int-to-string + emacs-minor-version) + " " + "Wassr-mode/" + wassr-mode-version)) + +(defvar wassr-user-agent-function 'wassr-user-agent-default-function) + +(defun wassr-user-agent () + "Return User-Agent header string." + (funcall wassr-user-agent-function)) + +;;; to show image files + +(defvar wassr-wget-buffer "*wassr-wget-buffer*") +(defun wassr-wget-buffer () + (wassr-get-or-generate-buffer wassr-wget-buffer)) + +(defvar wassr-tmp-dir + (expand-file-name (concat "wassr-mode-images-" (user-login-name)) + temporary-file-directory)) + +(defvar wassr-icon-mode nil "You MUST NOT CHANGE this variable directory. You should change through function'wassr-icon-mode'") +(make-variable-buffer-local 'wassr-icon-mode) +(defun wassr-icon-mode (&optional arg) + (interactive) + (setq wassr-icon-mode + (if wassr-icon-mode + (if (null arg) + nil + (> (prefix-numeric-value arg) 0)) + (when (or (null arg) + (and arg (> (prefix-numeric-value arg) 0))) + (when (file-writable-p wassr-tmp-dir) + (progn + (if (not (file-directory-p wassr-tmp-dir)) + (make-directory wassr-tmp-dir)) + t))))) + (wassr-render-friends-timeline)) + +(defun wassr-scroll-mode (&optional arg) + (interactive) + (setq wassr-scroll-mode + (if (null arg) + (not wassr-scroll-mode) + (> (prefix-numeric-value arg) 0)))) + +(defun wassr-jojo-mode (&optional arg) + (interactive) + (setq wassr-jojo-mode + (if (null arg) + (not wassr-jojo-mode) + (> (prefix-numeric-value arg) 0)))) + +(defvar wassr-image-stack nil) + +(defun wassr-image-type (file-name) + (cond + ((string-match "\\.jpe?g" file-name) 'jpeg) + ((string-match "\\.png" file-name) 'png) + ((string-match "\\.gif" file-name) 'gif) + (t nil))) + +(defun wassr-local-strftime (fmt string) + (format-time-string fmt ; like "%Y-%m-%d %H:%M:%S", shown in localtime + (apply 'encode-time (parse-time-string string)))) + +(defvar wassr-debug-mode nil) +(defvar wassr-debug-buffer "*debug*") +(defun wassr-debug-buffer () + (wassr-get-or-generate-buffer wassr-debug-buffer)) +(defmacro debug-print (obj) + (let ((obsym (gensym))) + `(let ((,obsym ,obj)) + (if wassr-debug-mode + (with-current-buffer (wassr-debug-buffer) + (insert (prin1-to-string ,obsym)) + (newline) + ,obsym) + ,obsym)))) + +(defun wassr-debug-mode () + (interactive) + (setq wassr-debug-mode + (not wassr-debug-mode)) + (message (if wassr-debug-mode "debug mode:on" "debug mode:off"))) + +(if wassr-mode-map + (let ((km wassr-mode-map)) + (define-key km "\C-c\C-f" 'wassr-friends-timeline) + (define-key km "\C-c\C-s" 'wassr-update-status-interactive) + (define-key km "\C-c\C-e" 'wassr-erase-old-statuses) + (define-key km "\C-m" 'wassr-enter) + (define-key km "\C-c\C-l" 'wassr-update-lambda) + (define-key km [mouse-1] 'wassr-click) + (define-key km "\C-c\C-v" 'wassr-view-user-page) + ;; (define-key km "j" 'next-line) + ;; (define-key km "k" 'previous-line) + (define-key km "j" 'wassr-goto-next-status) + (define-key km "k" 'wassr-goto-previous-status) + (define-key km "l" 'forward-char) + (define-key km "h" 'backward-char) + (define-key km "0" 'beginning-of-line) + (define-key km "^" 'beginning-of-line-text) + (define-key km "$" 'end-of-line) + (define-key km "n" 'wassr-goto-next-status-of-user) + (define-key km "p" 'wassr-goto-previous-status-of-user) + (define-key km [backspace] 'backward-char) + (define-key km "G" 'end-of-buffer) + (define-key km "H" 'beginning-of-buffer) + (define-key km "i" 'wassr-icon-mode) + (define-key km "s" 'wassr-scroll-mode) + (define-key km "t" 'wassr-toggle-proxy) + (define-key km "\C-c\C-p" 'wassr-toggle-proxy) + nil)) + +(defvar wassr-mode-syntax-table nil "") + +(if wassr-mode-syntax-table + () + (setq wassr-mode-syntax-table (make-syntax-table)) + ;; (modify-syntax-entry ? "" wassr-mode-syntax-table) + (modify-syntax-entry ?\" "w" wassr-mode-syntax-table) + ) + +(defun wassr-mode-init-variables () + ;; (make-variable-buffer-local 'variable) + ;; (setq variable nil) + (font-lock-mode -1) + (defface wassr-username-face + `((t nil)) "" :group 'faces) + (copy-face 'font-lock-string-face 'wassr-username-face) + (set-face-attribute 'wassr-username-face nil :underline t) + (defface wassr-uri-face + `((t nil)) "" :group 'faces) + (set-face-attribute 'wassr-uri-face nil :underline t) + (add-to-list 'minor-mode-alist '(wassr-icon-mode " ws-icon")) + (add-to-list 'minor-mode-alist '(wassr-scroll-mode " ws-scroll")) + (add-to-list 'minor-mode-alist '(wassr-jojo-mode " ws-jojo")) + ) + +(defmacro case-string (str &rest clauses) + `(cond + ,@(mapcar + (lambda (clause) + (let ((keylist (car clause)) + (body (cdr clause))) + `(,(if (listp keylist) + `(or ,@(mapcar (lambda (key) `(string-equal ,str ,key)) keylist)) + 't) + ,@body))) + clauses))) + +;; If you use Emacs21, decode-char 'ucs will fail unless Mule-UCS is loaded. +;; TODO: Show error messages if Emacs 21 without Mule-UCS +(defmacro wassr-ucs-to-char (num) + (if (functionp 'ucs-to-char) + `(ucs-to-char ,num) + `(decode-char 'ucs ,num))) + +(defvar wassr-mode-string "Wassr mode") + +(defvar wassr-mode-hook nil + "Wassr-mode hook.") + +(defun wassr-mode () + "Major mode for Wassr" + (interactive) + (switch-to-buffer (wassr-buffer)) + (kill-all-local-variables) + (wassr-mode-init-variables) + (use-local-map wassr-mode-map) + (setq major-mode 'wassr-mode) + (setq mode-name wassr-mode-string) + (set-syntax-table wassr-mode-syntax-table) + (run-hooks 'wassr-mode-hook) + (font-lock-mode -1) + (wassr-start) + ) + +;;; +;;; Basic HTTP functions +;;; + +(defun wassr-http-get (method-class method &optional sentinel) + (if (null sentinel) (setq sentinel 'wassr-http-get-default-sentinel)) + + ;; clear the buffer + (save-excursion + (set-buffer (wassr-http-buffer)) + (erase-buffer)) + + (let (proc server port + (proxy-user wassr-proxy-user) + (proxy-password wassr-proxy-password)) + (condition-case nil + (progn + (if (and wassr-proxy-use wassr-proxy-server) + (setq server wassr-proxy-server + port (if (integerp wassr-proxy-port) + (int-to-string wassr-proxy-port) + wassr-proxy-port)) + (setq server "api.wassr.jp" + port "80")) + (setq proc + (open-network-stream + "network-connection-process" (wassr-http-buffer) + server (string-to-number port))) + (set-process-sentinel proc sentinel) + (process-send-string + proc + (let ((nl "\r\n") + request) + (setq request + (concat "GET http://api.wassr.jp/" method-class "/" method ".xml HTTP/1.1" nl + "Host: api.wassr.jp" nl + "User-Agent: " (wassr-user-agent) nl + "Authorization: Basic " + (base64-encode-string + (concat wassr-username ":" (wassr-get-password))) + nl + "Accept: text/xml" + ",application/xml" + ",application/xhtml+xml" + ",application/html;q=0.9" + ",text/plain;q=0.8" + ",image/png,*/*;q=0.5" nl + "Accept-Charset: utf-8;q=0.7,*;q=0.7" nl + (when wassr-proxy-use + "Proxy-Connection: Keep-Alive" nl + (when (and proxy-user proxy-password) + (concat + "Proxy-Authorization: Basic " + (base64-encode-string + (concat proxy-user ":" + proxy-password)) + nl))) + nl nl)) + (debug-print (concat "GET Request\n" request)) + request))) + (error + (message "Failure: HTTP GET") nil)))) + +(defun wassr-http-get-default-sentinel (proc stat &optional suc-msg) + (let ((header (wassr-get-response-header)) + (body (wassr-get-response-body)) + (status nil) + ) + (if (string-match "HTTP/1\.[01] \\([a-z0-9 ]+\\)\r?\n" header) + (progn + (setq status (match-string-no-properties 1 header)) + (case-string + status + (("200 OK") + (mapcar + #'wassr-cache-status-datum + (reverse (wassr-xmltree-to-status + body))) + (wassr-render-friends-timeline) + (message (if suc-msg suc-msg "Success: Get."))) + (t (message status)))) + (message "Failure: Bad http response."))) + ) + +(defun wassr-render-friends-timeline () + (with-current-buffer (wassr-buffer) + (let ((point (point)) + (end (point-max))) + (setq buffer-read-only nil) + (erase-buffer) + (mapc (lambda (status) + (insert (wassr-format-status + status wassr-status-format)) + (fill-region-as-paragraph + (save-excursion (beginning-of-line) (point)) (point)) + (insert "\n")) + wassr-friends-timeline-data) + (if wassr-image-stack + (clear-image-cache)) + (setq buffer-read-only t) + (debug-print (current-buffer)) + (goto-char (+ point (if wassr-scroll-mode (- (point-max) end) 0)))) + )) + +(defun wassr-format-status (status format-str) + (flet ((attr (key) + (assocref key status)) + (profile-image + () + (let ((profile-image-url (attr 'user-profile-image-url)) + (icon-string "\n ")) + (if (string-match "/\\([^/?]+\\)\\(?:\\?\\|$\\)" profile-image-url) + (let ((filename (match-string-no-properties 1 profile-image-url))) + ;; download icons if does not exist + (if (file-exists-p (concat wassr-tmp-dir + "/" filename)) + t + (add-to-list 'wassr-image-stack profile-image-url)) + + (when (and icon-string wassr-icon-mode) + (set-text-properties + 1 2 `(display + (image :type ,(wassr-image-type filename) + :file ,(concat wassr-tmp-dir + "/" + filename))) + icon-string) + icon-string) + ))))) + (let ((cursor 0) + (result ()) + c + found-at) + (setq cursor 0) + (setq result '()) + (while (setq found-at (string-match "%\\(C{\\([^}]+\\)}\\|[A-Za-z#@']\\)" format-str cursor)) + (setq c (string-to-char (match-string-no-properties 1 format-str))) + (if (> found-at cursor) + (list-push (substring format-str cursor found-at) result) + "|") + (setq cursor (match-end 1)) + + (case c + ((?s) ; %s - screen_name + (list-push (attr 'user-screen-name) result)) + ((?S) ; %S - name + (list-push (attr 'user-name) result)) + ((?i) ; %i - profile_image + (list-push (profile-image) result)) + ((?d) ; %d - description + (list-push (attr 'user-description) result)) + ((?l) ; %l - location + (list-push (attr 'user-location) result)) + ((?L) ; %L - " [location]" + (let ((location (attr 'user-location))) + (unless (or (null location) (string= "" location)) + (list-push (concat " [" location "]") result)) )) + ((?u) ; %u - url + (list-push (attr 'user-url) result)) + ((?j) ; %j - user.id + (list-push (format "%d" (attr 'user-id)) result)) + ((?p) ; %p - protected? + (let ((protected (attr 'user-protected))) + (when (string= "true" protected) + (list-push "[x]" result)))) + ((?c) ; %c - created_at (raw UTC string) + (list-push (attr 'created-at) result)) + ((?C) ; %C{time-format-str} - created_at (formatted with time-format-str) + (list-push (wassr-local-strftime + (or (match-string-no-properties 2 format-str) "%H:%M:%S") + (attr 'created-at)) + result)) + ((?@) ; %@ - X seconds ago + (let ((created-at + (apply + 'encode-time + (parse-time-string (attr 'created-at)))) + (now (current-time))) + (let ((secs (+ (* (- (car now) (car created-at)) 65536) + (- (cadr now) (cadr created-at)))) + time-string url) + (setq time-string + (cond ((< secs 5) "less than 5 seconds ago") + ((< secs 10) "less than 10 seconds ago") + ((< secs 20) "less than 20 seconds ago") + ((< secs 30) "half a minute ago") + ((< secs 60) "less than a minute ago") + ((< secs 150) "1 minute ago") + ((< secs 2400) (format "%d minutes ago" + (/ (+ secs 30) 60))) + ((< secs 5400) "about 1 hour ago") + ((< secs 84600) (format "about %d hours ago" + (/ (+ secs 1800) 3600))) + (t (format-time-string "%I:%M %p %B %d, %Y" created-at)))) + (setq url (wassr-get-status-url (attr 'user-screen-name) (attr 'id))) + ;; make status url clickable + (add-text-properties + 0 (length time-string) + `(mouse-face highlight + face wassr-uri-face + uri ,url) + time-string) + (list-push time-string result)))) + ((?t) ; %t - text + (list-push ;(clickable-text) + (attr 'text) + result)) + ((?') ; %' - truncated + (let ((truncated (attr 'truncated))) + (when (string= "true" truncated) + (list-push "..." result)))) + ((?f) ; %f - source + (list-push (attr 'source) result)) + ((?#) ; %# - id + (list-push (format "%d" (attr 'id)) result)) + (t + (list-push (char-to-string c) result))) + ) + (list-push (substring format-str cursor) result) + (let ((formatted-status (apply 'concat (nreverse result)))) + (add-text-properties 0 (length formatted-status) + `(username ,(attr 'user-screen-name)) + formatted-status) + formatted-status) + ))) + +(defun wassr-http-post + (method-class method &optional parameters contents sentinel) + "Send HTTP POST request to api.wassr.jp + +METHOD-CLASS must be one of Wassr API method classes(statuses, users or direct_messages). +METHOD must be one of Wassr API method which belongs to METHOD-CLASS. +PARAMETERS is alist of URI parameters. ex) ((\"mode\" . \"view\") (\"page\" . \"6\")) => ?mode=view&page=6" + (if (null sentinel) (setq sentinel 'wassr-http-post-default-sentinel)) + + ;; clear the buffer + (save-excursion + (set-buffer (wassr-http-buffer)) + (erase-buffer)) + + (let (proc server port + (proxy-user wassr-proxy-user) + (proxy-password wassr-proxy-password)) + (progn + (if (and wassr-proxy-use wassr-proxy-server) + (setq server wassr-proxy-server + port (if (integerp wassr-proxy-port) + (int-to-string wassr-proxy-port) + wassr-proxy-port)) + (setq server "api.wassr.jp" + port "80")) + (setq proc + (open-network-stream + "network-connection-process" (wassr-http-buffer) + server (string-to-number port))) + (set-process-sentinel proc sentinel) + (process-send-string + proc + (let ((nl "\r\n") + request) + (setq request + (concat "POST http://api.wassr.jp/" method-class "/" method ".xml?" + (if parameters + (mapconcat + (lambda (param-pair) + (format "%s=%s" + (wassr-percent-encode (car param-pair)) + (wassr-percent-encode (cdr param-pair)))) + parameters + "&")) + " HTTP/1.1" nl + "Host: api.wassr.jp" nl + "User-Agent: " (wassr-user-agent) nl + "Authorization: Basic " + (base64-encode-string + (concat wassr-username ":" (wassr-get-password))) + nl + "Content-Type: text/plain" nl + "Content-Length: 0" nl + (when wassr-proxy-use + "Proxy-Connection: Keep-Alive" nl + (when (and proxy-user proxy-password) + (concat + "Proxy-Authorization: Basic " + (base64-encode-string + (concat proxy-user ":" + proxy-password)) + nl))) + nl nl)) + (debug-print (concat "POST Request\n" request)) + request))))) + +(defun wassr-http-post-default-sentinel (proc stat &optional suc-msg) + + (condition-case err-signal + (let ((header (wassr-get-response-header)) + ;; (body (wassr-get-response-body)) not used now. + (status nil)) + (string-match "HTTP/1\.1 \\([a-z0-9 ]+\\)\r?\n" header) + (setq status (match-string-no-properties 1 header)) + (case-string status + (("200 OK") + (message (if suc-msg suc-msg "Success: Post"))) + (t (message status))) + ) + (error (message (prin1-to-string err-signal)))) + ) + +(defun wassr-get-response-header (&optional buffer) + "Exract HTTP response header from HTTP response. +`buffer' may be a buffer or the name of an existing buffer. + If `buffer' is omitted, the value of `wassr-http-buffer' is used as `buffer'." + (if (stringp buffer) (setq buffer (get-buffer buffer))) + (if (null buffer) (setq buffer (wassr-http-buffer))) + (save-excursion + (set-buffer buffer) + (let ((content (buffer-string))) + (substring content 0 (string-match "\r?\n\r?\n" content))))) + +(defun wassr-get-response-body (&optional buffer) + "Exract HTTP response body from HTTP response, parse it as XML, and return a XML tree as list. +`buffer' may be a buffer or the name of an existing buffer. + If `buffer' is omitted, the value of `wassr-http-buffer' is used as `buffer'." + (if (stringp buffer) (setq buffer (get-buffer buffer))) + (if (null buffer) (setq buffer (wassr-http-buffer))) + (save-excursion + (set-buffer buffer) + (let ((content (buffer-string))) + (let ((content (buffer-string))) + (xml-parse-region (+ (string-match "\r?\n\r?\n" content) + (length (match-string 0 content))) + (point-max))) + ))) + +(defun wassr-cache-status-datum (status-datum &optional data-var) + "Cache status datum into data-var(default wassr-friends-timeline-data) +If STATUS-DATUM is already in DATA-VAR, return nil. If not, return t." + (if (null data-var) + (setf data-var 'wassr-friends-timeline-data)) + (let ((id (cdr (assq 'id status-datum)))) + (if (or (null (symbol-value data-var)) + (not (find-if + (lambda (item) + (eql id (cdr (assq 'id item)))) + (symbol-value data-var)))) + (progn + (if wassr-jojo-mode + (wassr-update-jojo (cdr (assq 'user-screen-name status-datum)) + (cdr (assq 'text status-datum)))) + (set data-var (cons status-datum (symbol-value data-var))) + t) + nil))) + +(defun wassr-status-to-status-datum (status) + (flet ((assq-get (item seq) + (car (cddr (assq item seq))))) + (let* ((status-data (cddr status)) + id text source created-at truncated + (user-data (cddr (assq 'user status-data))) + user-id user-name + user-screen-name + user-location + user-description + user-profile-image-url + user-url + user-protected + regex-index) + + (setq id (string-to-number (assq-get 'id status-data))) + (setq text (wassr-decode-html-entities + (assq-get 'text status-data))) + (setq source (wassr-decode-html-entities + (assq-get 'source status-data))) + (setq created-at (assq-get 'created_at status-data)) + (setq truncated (assq-get 'truncated status-data)) + (setq user-id (string-to-number (assq-get 'id user-data))) + (setq user-name (wassr-decode-html-entities + (assq-get 'name user-data))) + (setq user-screen-name (wassr-decode-html-entities + (assq-get 'screen_name user-data))) + (setq user-location (wassr-decode-html-entities + (assq-get 'location user-data))) + (setq user-description (wassr-decode-html-entities + (assq-get 'description user-data))) + (setq user-profile-image-url (assq-get 'profile_image_url user-data)) + (setq user-url (assq-get 'url user-data)) + (setq user-protected (assq-get 'protected user-data)) + + ;; make username clickable + (add-text-properties + 0 (length user-name) + `(mouse-face highlight + uri ,(concat "http://api.wassr.jp/" user-screen-name) + face wassr-username-face) + user-name) + + ;; make screen-name clickable + (add-text-properties + 0 (length user-screen-name) + `(mouse-face highlight + face wassr-username-face + uri ,(concat "http://api.wassr.jp/" user-screen-name) + face wassr-username-face) + user-screen-name) + + ;; make URI clickable + (setq regex-index 0) + (while regex-index + (setq regex-index + (string-match "@\\([_a-zA-Z0-9]+\\)\\|\\(https?://[-_.!~*'()a-zA-Z0-9;/?:@&=+$,%#]+\\)" + text + regex-index)) + (when regex-index + (let* ((matched-string (match-string-no-properties 0 text)) + (screen-name (match-string-no-properties 1 text)) + (uri (match-string-no-properties 2 text))) + (add-text-properties + (if screen-name + (+ 1 (match-beginning 0)) + (match-beginning 0)) + (match-end 0) + (if screen-name + `(mouse-face + highlight + face wassr-uri-face + uri ,(concat "http://api.wassr.jp/" screen-name)) + `(mouse-face highlight + face wassr-uri-face + uri ,uri)) + text)) + (setq regex-index (match-end 0)) )) + + + ;; make source pretty and clickable + (if (string-match "\\(.*\\)" source) + (let ((uri (match-string-no-properties 1 source)) + (caption (match-string-no-properties 2 source))) + (setq source caption) + (add-text-properties + 0 (length source) + `(mouse-face highlight + uri ,uri + face wassr-uri-face + source ,source) + source) + )) + + (mapcar + (lambda (sym) + `(,sym . ,(symbol-value sym))) + '(id text source created-at truncated + user-id user-name user-screen-name user-location + user-description + user-profile-image-url + user-url + user-protected))))) + +(defun wassr-xmltree-to-status (xmltree) + (mapcar #'wassr-status-to-status-datum + ;; quirk to treat difference between xml.el in Emacs21 and Emacs22 + ;; On Emacs22, there may be blank strings + (let ((ret nil) (statuses (reverse (cddr (car xmltree))))) + (while statuses + (if (consp (car statuses)) + (setq ret (cons (car statuses) ret))) + (setq statuses (cdr statuses))) + ret))) + +(defun wassr-percent-encode (str &optional coding-system) + (if (or (null coding-system) + (not (coding-system-p coding-system))) + (setq coding-system 'utf-8)) + (mapconcat + (lambda (c) + (cond + ((wassr-url-reserved-p c) + (char-to-string c)) + ((eq c ? ) "+") + (t (format "%%%x" c)))) + (encode-coding-string str coding-system) + "")) + +(defun wassr-url-reserved-p (ch) + (or (and (<= ?A ch) (<= ch ?z)) + (and (<= ?0 ch) (<= ch ?9)) + (eq ?. ch) + (eq ?- ch) + (eq ?_ ch) + (eq ?~ ch))) + +(defun wassr-decode-html-entities (encoded-str) + (if encoded-str + (let ((cursor 0) + (found-at nil) + (result '())) + (while (setq found-at + (string-match "&\\(#\\([0-9]+\\)\\|\\([A-Za-z]+\\)\\);" + encoded-str cursor)) + (when (> found-at cursor) + (list-push (substring encoded-str cursor found-at) result)) + (let ((number-entity (match-string-no-properties 2 encoded-str)) + (letter-entity (match-string-no-properties 3 encoded-str))) + (cond (number-entity + (list-push + (char-to-string + (wassr-ucs-to-char + (string-to-number number-entity))) result)) + (letter-entity + (cond ((string= "gt" letter-entity) (list-push ">" result)) + ((string= "lt" letter-entity) (list-push "<" result)) + (t (list-push "?" result)))) + (t (list-push "?" result))) + (setq cursor (match-end 0)))) + (list-push (substring encoded-str cursor) result) + (apply 'concat (nreverse result))) + "")) + +(defun wassr-timer-action (func) + (let ((buf (get-buffer wassr-buffer))) + (if (null buf) + (wassr-stop) + (funcall func) + ))) + +(defun wassr-update-status-if-not-blank (status) + (if (string-match "^\\s-*\\(?:@[-_a-z0-9]+\\)?\\s-*$" status) + nil + (wassr-http-post "statuses" "update" + `(("status" . ,status) + ("source" . "ws-mode"))) + t)) + +(defun wassr-update-status-from-minibuffer (&optional init-str) + (if (null init-str) (setq init-str "")) + (let ((status init-str) (not-posted-p t)) + (while not-posted-p + (setq status (read-from-minibuffer "status: " status nil nil nil nil t)) + (setq not-posted-p + (not (wassr-update-status-if-not-blank status)))))) + +(defun wassr-update-lambda () + (interactive) + (wassr-http-post + "statuses" "update" + `(("status" . "\xd34b\xd22b\xd26f\xd224\xd224\xd268\xd34b") + ("source" . "ws-mode")))) + +(defun wassr-update-jojo (usr msg) + (if (string-match "\xde21\xd24b\\(\xd22a\xe0b0\\|\xdaae\xe6cd\\)\xd24f\xd0d6\\([^\xd0d7]+\\)\xd0d7\xd248\xdc40\xd226" + msg) + (wassr-http-post + "statuses" "update" + `(("status" . ,(concat + "@" usr " " + (match-string-no-properties 2 msg) + "\xd0a1\xd24f\xd243!?")) + ("source" . "ws-mode"))))) + +;;; +;;; Commands +;;; + +(defun wassr-start (&optional action) + (interactive) + (if (null action) + (setq action #'wassr-friends-timeline)) + (if wassr-timer + nil + (setq wassr-timer + (run-at-time "0 sec" + wassr-timer-interval + #'wassr-timer-action action)))) + +(defun wassr-stop () + (interactive) + (cancel-timer wassr-timer) + (setq wassr-timer nil)) + +(defun wassr-friends-timeline () + (interactive) + (let ((buf (get-buffer wassr-buffer))) + (if (not buf) + (wassr-stop) + (wassr-http-get "statuses" "friends_timeline") + )) + + (if wassr-icon-mode + (if wassr-image-stack + (let ((proc + (apply + #'start-process + "wget-images" + (wassr-wget-buffer) + "wget" + (format "--directory-prefix=%s" wassr-tmp-dir) + "--no-clobber" + "--quiet" + wassr-image-stack))) + (set-process-sentinel + proc + (lambda (proc stat) + (clear-image-cache) + (save-excursion + (set-buffer (wassr-wget-buffer)) + ))))))) + +(defun wassr-update-status-interactive () + (interactive) + (wassr-update-status-from-minibuffer)) + +(defun wassr-erase-old-statuses () + (interactive) + (setq wassr-friends-timeline-data nil) + (wassr-http-get "statuses" "friends_timeline")) + +(defun wassr-click () + (interactive) + (let ((uri (get-text-property (point) 'uri))) + (if uri + (browse-url uri)))) + +(defun wassr-enter () + (interactive) + (let ((username (get-text-property (point) 'username)) + (uri (get-text-property (point) 'uri))) + (if username + (wassr-update-status-from-minibuffer (concat "@" username " ")) + (if uri + (browse-url uri))))) + +(defun wassr-view-user-page () + (interactive) + (let ((uri (get-text-property (point) 'uri))) + (if uri + (browse-url uri)))) + +(defun wassr-reply-to-user () + (interactive) + (let ((username (get-text-property (point) 'username))) + (if username + (wassr-update-status-from-minibuffer (concat "@" username " "))))) + +(defun wassr-get-password () + (or wassr-password + (setq wassr-password (read-passwd "wassr-mode: ")))) + +(defun wassr-goto-next-status () + "Go to next status." + (interactive) + (let ((pos)) + (setq pos (wassr-get-next-username-face-pos (point))) + (if pos + (goto-char pos) + (message "End of status.")))) + +(defun wassr-get-next-username-face-pos (pos) + (interactive) + (let ((prop)) + (catch 'not-found + (while (and pos (not (eq prop wassr-username-face))) + (setq pos (next-single-property-change pos 'face)) + (when (eq pos nil) (throw 'not-found nil)) + (setq prop (get-text-property pos 'face))) + pos))) + +(defun wassr-goto-previous-status () + "Go to previous status." + (interactive) + (let ((pos)) + (setq pos (wassr-get-previous-username-face-pos (point))) + (if pos + (goto-char pos) + (message "Start of status.")))) + +(defun wassr-get-previous-username-face-pos (pos) + (interactive) + (let ((prop)) + (catch 'not-found + (while (and pos (not (eq prop wassr-username-face))) + (setq pos (previous-single-property-change pos 'face)) + (when (eq pos nil) (throw 'not-found nil)) + (setq prop (get-text-property pos 'face))) + pos))) + +(defun wassr-goto-next-status-of-user () + "Go to next status of user." + (interactive) + (let ((user-name (wassr-get-username-at-pos (point))) + (pos (wassr-get-next-username-face-pos (point)))) + (while (and (not (eq pos nil)) + (not (equal (wassr-get-username-at-pos pos) user-name))) + (setq pos (wassr-get-next-username-face-pos pos))) + (if pos + (goto-char pos) + (if user-name + (message "End of %s's status." user-name) + (message "Invalid user-name."))))) + +(defun wassr-goto-previous-status-of-user () + "Go to previous status of user." + (interactive) + (let ((user-name (wassr-get-username-at-pos (point))) + (pos (wassr-get-previous-username-face-pos (point)))) + (while (and (not (eq pos nil)) + (not (equal (wassr-get-username-at-pos pos) user-name))) + (setq pos (wassr-get-previous-username-face-pos pos))) + (if pos + (goto-char pos) + (if user-name + (message "Start of %s's status." user-name) + (message "Invalid user-name."))))) + +(defun wassr-get-username-at-pos (pos) + (let ((start-pos pos) + (end-pos)) + (catch 'not-found + (while (eq (get-text-property start-pos 'face) wassr-username-face) + (setq start-pos (1- start-pos)) + (when (or (eq start-pos nil) (eq start-pos 0)) (throw 'not-found nil))) + (setq start-pos (1+ start-pos)) + (setq end-pos (next-single-property-change pos 'face)) + (buffer-substring start-pos end-pos)))) + +(defun wassr-get-status-url (username id) + "Generate status URL." + (format "http://api.wassr.jp/%s/statuses/%d" username id)) + +;;;###autoload +(defun wassr () + "Start wassr-mode." + (interactive) + (wassr-mode)) + +(provide 'wassr-mode) +;;; wassr.el ends here Index: /ng/elisp/wassr-mode/trunk/twittering-mode.el =================================================================== --- /lang/elisp/wassr-mode/trunk/twittering-mode.el (revision 47) +++ (revision ) @@ -1,1056 +1,0 @@ -;;; twittering-mode.el --- Major mode for Twitter - -;; Copyright (C) 2007 Yuto Hayamizu. -;; 2008 Tsuyoshi CHO - -;; Author: Y. Hayamizu -;; Tsuyoshi CHO -;; Created: Sep 4, 2007 -;; Version: 0.4 -;; Keywords: twitter web -;; URL: http://lambdarepos.svnrepository.com/share/trac.cgi/browser/lang/elisp/twittering-mode - -;; This file is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; This file is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; twittering-mode.el is a major mode for Twitter. -;; You can check friends timeline, and update your status on Emacs. - -;;; Feature Request: - -;; URL : http://twitter.com/d00dle/statuses/577876082 -;; URL : http://twitter.com/d00dle/statuses/577879732 -;; * Status Input from Popup buffer and C-cC-c to POST. -;; * Mark fav(star) -;; URL : http://code.nanigac.com/source/view/419 -;; * update status for region - -;;; Code: - -(require 'cl) -(require 'xml) -(require 'parse-time) - -(defconst twittering-mode-version "0.5") - -(defun twittering-mode-version () - "Display a message for twittering-mode version." - (interactive) - (let ((version-string - (format "twittering-mode-v%s" twittering-mode-version))) - (if (interactive-p) - (message "%s" version-string) - version-string))) - -(defvar twittering-mode-map (make-sparse-keymap)) - -(defvar twittering-timer nil "Timer object for timeline refreshing will be stored here. DO NOT SET VALUE MANUALLY.") - -(defvar twittering-idle-time 20) - -(defvar twittering-timer-interval 90) - -(defvar twittering-username nil) - -(defvar twittering-password nil) - -(defvar twittering-scroll-mode nil) -(make-variable-buffer-local 'twittering-scroll-mode) - -(defvar twittering-jojo-mode nil) -(make-variable-buffer-local 'twittering-jojo-mode) - -(defvar twittering-status-format nil) -(setq twittering-status-format "%i %s, %@:\n %t // from %f%L") -;; %s - screen_name -;; %S - name -;; %i - profile_image -;; %d - description -;; %l - location -;; %L - " [location]" -;; %u - url -;; %j - user.id -;; %p - protected? -;; %c - created_at (raw UTC string) -;; %C{time-format-str} - created_at (formatted with time-format-str) -;; %@ - X seconds ago -;; %t - text -;; %' - truncated -;; %f - source -;; %# - id - -(defvar twittering-buffer "*twittering*") -(defun twittering-buffer () - (twittering-get-or-generate-buffer twittering-buffer)) - -(defvar twittering-http-buffer "*twittering-http-buffer*") -(defun twittering-http-buffer () - (twittering-get-or-generate-buffer twittering-http-buffer)) - -(defvar twittering-friends-timeline-data nil) - -(defvar twittering-username-face 'twittering-username-face) -(defvar twittering-uri-face 'twittering-uri-face) - -(defun twittering-get-or-generate-buffer (buffer) - (if (bufferp buffer) - (if (buffer-live-p buffer) - buffer - (generate-new-buffer (buffer-name buffer))) - (if (stringp buffer) - (or (get-buffer buffer) - (generate-new-buffer buffer))))) - -(defun assocref (item alist) - (cdr (assoc item alist))) -(defmacro list-push (value listvar) - `(setq ,listvar (cons ,value ,listvar))) - -;;; Proxy -(defvar twittering-proxy-use nil) -(defvar twittering-proxy-server nil) -(defvar twittering-proxy-port 8080) -(defvar twittering-proxy-user nil) -(defvar twittering-proxy-password nil) - -(defun twittering-toggle-proxy () "" - (interactive) - (setq twittering-proxy-use - (not twittering-proxy-use)) - (message "%s %s" - "Use Proxy:" - (if twittering-proxy-use - "on" "off"))) - -(defun twittering-user-agent-default-function () - "Twittering mode default User-Agent function." - (concat "Emacs/" - (int-to-string emacs-major-version) "." (int-to-string - emacs-minor-version) - " " - "Twittering-mode/" - twittering-mode-version)) - -(defvar twittering-user-agent-function 'twittering-user-agent-default-function) - -(defun twittering-user-agent () - "Return User-Agent header string." - (funcall twittering-user-agent-function)) - -;;; to show image files - -(defvar twittering-wget-buffer "*twittering-wget-buffer*") -(defun twittering-wget-buffer () - (twittering-get-or-generate-buffer twittering-wget-buffer)) - -(defvar twittering-tmp-dir - (expand-file-name (concat "twmode-images-" (user-login-name)) - temporary-file-directory)) - -(defvar twittering-icon-mode nil "You MUST NOT CHANGE this variable directory. You should change through function'twittering-icon-mode'") -(make-variable-buffer-local 'twittering-icon-mode) -(defun twittering-icon-mode (&optional arg) - (interactive) - (setq twittering-icon-mode - (if twittering-icon-mode - (if (null arg) - nil - (> (prefix-numeric-value arg) 0)) - (when (or (null arg) - (and arg (> (prefix-numeric-value arg) 0))) - (when (file-writable-p twittering-tmp-dir) - (progn - (if (not (file-directory-p twittering-tmp-dir)) - (make-directory twittering-tmp-dir)) - t))))) - (twittering-render-friends-timeline)) - -(defun twittering-scroll-mode (&optional arg) - (interactive) - (setq twittering-scroll-mode - (if (null arg) - (not twittering-scroll-mode) - (> (prefix-numeric-value arg) 0)))) - -(defun twittering-jojo-mode (&optional arg) - (interactive) - (setq twittering-jojo-mode - (if (null arg) - (not twittering-jojo-mode) - (> (prefix-numeric-value arg) 0)))) - -(defvar twittering-image-stack nil) - -(defun twittering-image-type (file-name) - (cond - ((string-match "\\.jpe?g" file-name) 'jpeg) - ((string-match "\\.png" file-name) 'png) - ((string-match "\\.gif" file-name) 'gif) - (t nil))) - -(defun twittering-local-strftime (fmt string) - (format-time-string fmt ; like "%Y-%m-%d %H:%M:%S", shown in localtime - (apply 'encode-time (parse-time-string string)))) - -(defvar twittering-debug-mode nil) -(defvar twittering-debug-buffer "*debug*") -(defun twittering-debug-buffer () - (twittering-get-or-generate-buffer twittering-debug-buffer)) -(defmacro debug-print (obj) - (let ((obsym (gensym))) - `(let ((,obsym ,obj)) - (if twittering-debug-mode - (with-current-buffer (twittering-debug-buffer) - (insert (prin1-to-string ,obsym)) - (newline) - ,obsym) - ,obsym)))) - -(defun twittering-debug-mode () - (interactive) - (setq twittering-debug-mode - (not twittering-debug-mode)) - (message (if twittering-debug-mode "debug mode:on" "debug mode:off"))) - -(if twittering-mode-map - (let ((km twittering-mode-map)) - (define-key km "\C-c\C-f" 'twittering-friends-timeline) - (define-key km "\C-c\C-s" 'twittering-update-status-interactive) - (define-key km "\C-c\C-e" 'twittering-erase-old-statuses) - (define-key km "\C-m" 'twittering-enter) - (define-key km "\C-c\C-l" 'twittering-update-lambda) - (define-key km [mouse-1] 'twittering-click) - (define-key km "\C-c\C-v" 'twittering-view-user-page) - ;; (define-key km "j" 'next-line) - ;; (define-key km "k" 'previous-line) - (define-key km "j" 'twittering-goto-next-status) - (define-key km "k" 'twittering-goto-previous-status) - (define-key km "l" 'forward-char) - (define-key km "h" 'backward-char) - (define-key km "0" 'beginning-of-line) - (define-key km "^" 'beginning-of-line-text) - (define-key km "$" 'end-of-line) - (define-key km "n" 'twittering-goto-next-status-of-user) - (define-key km "p" 'twittering-goto-previous-status-of-user) - (define-key km [backspace] 'backward-char) - (define-key km "G" 'end-of-buffer) - (define-key km "H" 'beginning-of-buffer) - (define-key km "i" 'twittering-icon-mode) - (define-key km "s" 'twittering-scroll-mode) - (define-key km "t" 'twittering-toggle-proxy) - (define-key km "\C-c\C-p" 'twittering-toggle-proxy) - nil)) - -(defvar twittering-mode-syntax-table nil "") - -(if twittering-mode-syntax-table - () - (setq twittering-mode-syntax-table (make-syntax-table)) - ;; (modify-syntax-entry ? "" twittering-mode-syntax-table) - (modify-syntax-entry ?\" "w" twittering-mode-syntax-table) - ) - -(defun twittering-mode-init-variables () - ;; (make-variable-buffer-local 'variable) - ;; (setq variable nil) - (font-lock-mode -1) - (defface twittering-username-face - `((t nil)) "" :group 'faces) - (copy-face 'font-lock-string-face 'twittering-username-face) - (set-face-attribute 'twittering-username-face nil :underline t) - (defface twittering-uri-face - `((t nil)) "" :group 'faces) - (set-face-attribute 'twittering-uri-face nil :underline t) - (add-to-list 'minor-mode-alist '(twittering-icon-mode " tw-icon")) - (add-to-list 'minor-mode-alist '(twittering-scroll-mode " tw-scroll")) - (add-to-list 'minor-mode-alist '(twittering-jojo-mode " tw-jojo")) - ) - -(defmacro case-string (str &rest clauses) - `(cond - ,@(mapcar - (lambda (clause) - (let ((keylist (car clause)) - (body (cdr clause))) - `(,(if (listp keylist) - `(or ,@(mapcar (lambda (key) `(string-equal ,str ,key)) keylist)) - 't) - ,@body))) - clauses))) - -;; If you use Emacs21, decode-char 'ucs will fail unless Mule-UCS is loaded. -;; TODO: Show error messages if Emacs 21 without Mule-UCS -(defmacro twittering-ucs-to-char (num) - (if (functionp 'ucs-to-char) - `(ucs-to-char ,num) - `(decode-char 'ucs ,num))) - -(defvar twittering-mode-string "Twittering mode") - -(defvar twittering-mode-hook nil - "Twittering-mode hook.") - -(defun twittering-mode () - "Major mode for Twitter" - (interactive) - (switch-to-buffer (twittering-buffer)) - (kill-all-local-variables) - (twittering-mode-init-variables) - (use-local-map twittering-mode-map) - (setq major-mode 'twittering-mode) - (setq mode-name twittering-mode-string) - (set-syntax-table twittering-mode-syntax-table) - (run-hooks 'twittering-mode-hook) - (font-lock-mode -1) - (twittering-start) - ) - -;;; -;;; Basic HTTP functions -;;; - -(defun twittering-http-get (method-class method &optional sentinel) - (if (null sentinel) (setq sentinel 'twittering-http-get-default-sentinel)) - - ;; clear the buffer - (save-excursion - (set-buffer (twittering-http-buffer)) - (erase-buffer)) - - (let (proc server port - (proxy-user twittering-proxy-user) - (proxy-password twittering-proxy-password)) - (condition-case nil - (progn - (if (and twittering-proxy-use twittering-proxy-server) - (setq server twittering-proxy-server - port (if (integerp twittering-proxy-port) - (int-to-string twittering-proxy-port) - twittering-proxy-port)) - (setq server "twitter.com" - port "80")) - (setq proc - (open-network-stream - "network-connection-process" (twittering-http-buffer) - server (string-to-number port))) - (set-process-sentinel proc sentinel) - (process-send-string - proc - (let ((nl "\r\n") - request) - (setq request - (concat "GET http://twitter.com/" method-class "/" method ".xml HTTP/1.1" nl - "Host: twitter.com" nl - "User-Agent: " (twittering-user-agent) nl - "Authorization: Basic " - (base64-encode-string - (concat twittering-username ":" (twittering-get-password))) - nl - "Accept: text/xml" - ",application/xml" - ",application/xhtml+xml" - ",application/html;q=0.9" - ",text/plain;q=0.8" - ",image/png,*/*;q=0.5" nl - "Accept-Charset: utf-8;q=0.7,*;q=0.7" nl - (when twittering-proxy-use - "Proxy-Connection: Keep-Alive" nl - (when (and proxy-user proxy-password) - (concat - "Proxy-Authorization: Basic " - (base64-encode-string - (concat proxy-user ":" - proxy-password)) - nl))) - nl nl)) - (debug-print (concat "GET Request\n" request)) - request))) - (error - (message "Failure: HTTP GET") nil)))) - -(defun twittering-http-get-default-sentinel (proc stat &optional suc-msg) - (let ((header (twittering-get-response-header)) - (body (twittering-get-response-body)) - (status nil) - ) - (if (string-match "HTTP/1\.[01] \\([a-z0-9 ]+\\)\r?\n" header) - (progn - (setq status (match-string-no-properties 1 header)) - (case-string - status - (("200 OK") - (mapcar - #'twittering-cache-status-datum - (reverse (twittering-xmltree-to-status - body))) - (twittering-render-friends-timeline) - (message (if suc-msg suc-msg "Success: Get."))) - (t (message status)))) - (message "Failure: Bad http response."))) - ) - -(defun twittering-render-friends-timeline () - (with-current-buffer (twittering-buffer) - (let ((point (point)) - (end (point-max))) - (setq buffer-read-only nil) - (erase-buffer) - (mapc (lambda (status) - (insert (twittering-format-status - status twittering-status-format)) - (fill-region-as-paragraph - (save-excursion (beginning-of-line) (point)) (point)) - (insert "\n")) - twittering-friends-timeline-data) - (if twittering-image-stack - (clear-image-cache)) - (setq buffer-read-only t) - (debug-print (current-buffer)) - (goto-char (+ point (if twittering-scroll-mode (- (point-max) end) 0)))) - )) - -(defun twittering-format-status (status format-str) - (flet ((attr (key) - (assocref key status)) - (profile-image - () - (let ((profile-image-url (attr 'user-profile-image-url)) - (icon-string "\n ")) - (if (string-match "/\\([^/?]+\\)\\(?:\\?\\|$\\)" profile-image-url) - (let ((filename (match-string-no-properties 1 profile-image-url))) - ;; download icons if does not exist - (if (file-exists-p (concat twittering-tmp-dir - "/" filename)) - t - (add-to-list 'twittering-image-stack profile-image-url)) - - (when (and icon-string twittering-icon-mode) - (set-text-properties - 1 2 `(display - (image :type ,(twittering-image-type filename) - :file ,(concat twittering-tmp-dir - "/" - filename))) - icon-string) - icon-string) - ))))) - (let ((cursor 0) - (result ()) - c - found-at) - (setq cursor 0) - (setq result '()) - (while (setq found-at (string-match "%\\(C{\\([^}]+\\)}\\|[A-Za-z#@']\\)" format-str cursor)) - (setq c (string-to-char (match-string-no-properties 1 format-str))) - (if (> found-at cursor) - (list-push (substring format-str cursor found-at) result) - "|") - (setq cursor (match-end 1)) - - (case c - ((?s) ; %s - screen_name - (list-push (attr 'user-screen-name) result)) - ((?S) ; %S - name - (list-push (attr 'user-name) result)) - ((?i) ; %i - profile_image - (list-push (profile-image) result)) - ((?d) ; %d - description - (list-push (attr 'user-description) result)) - ((?l) ; %l - location - (list-push (attr 'user-location) result)) - ((?L) ; %L - " [location]" - (let ((location (attr 'user-location))) - (unless (or (null location) (string= "" location)) - (list-push (concat " [" location "]") result)) )) - ((?u) ; %u - url - (list-push (attr 'user-url) result)) - ((?j) ; %j - user.id - (list-push (format "%d" (attr 'user-id)) result)) - ((?p) ; %p - protected? - (let ((protected (attr 'user-protected))) - (when (string= "true" protected) - (list-push "[x]" result)))) - ((?c) ; %c - created_at (raw UTC string) - (list-push (attr 'created-at) result)) - ((?C) ; %C{time-format-str} - created_at (formatted with time-format-str) - (list-push (twittering-local-strftime - (or (match-string-no-properties 2 format-str) "%H:%M:%S") - (attr 'created-at)) - result)) - ((?@) ; %@ - X seconds ago - (let ((created-at - (apply - 'encode-time - (parse-time-string (attr 'created-at)))) - (now (current-time))) - (let ((secs (+ (* (- (car now) (car created-at)) 65536) - (- (cadr now) (cadr created-at)))) - time-string url) - (setq time-string - (cond ((< secs 5) "less than 5 seconds ago") - ((< secs 10) "less than 10 seconds ago") - ((< secs 20) "less than 20 seconds ago") - ((< secs 30) "half a minute ago") - ((< secs 60) "less than a minute ago") - ((< secs 150) "1 minute ago") - ((< secs 2400) (format "%d minutes ago" - (/ (+ secs 30) 60))) - ((< secs 5400) "about 1 hour ago") - ((< secs 84600) (format "about %d hours ago" - (/ (+ secs 1800) 3600))) - (t (format-time-string "%I:%M %p %B %d, %Y" created-at)))) - (setq url (twittering-get-status-url (attr 'user-screen-name) (attr 'id))) - ;; make status url clickable - (add-text-properties - 0 (length time-string) - `(mouse-face highlight - face twittering-uri-face - uri ,url) - time-string) - (list-push time-string result)))) - ((?t) ; %t - text - (list-push ;(clickable-text) - (attr 'text) - result)) - ((?') ; %' - truncated - (let ((truncated (attr 'truncated))) - (when (string= "true" truncated) - (list-push "..." result)))) - ((?f) ; %f - source - (list-push (attr 'source) result)) - ((?#) ; %# - id - (list-push (format "%d" (attr 'id)) result)) - (t - (list-push (char-to-string c) result))) - ) - (list-push (substring format-str cursor) result) - (let ((formatted-status (apply 'concat (nreverse result)))) - (add-text-properties 0 (length formatted-status) - `(username ,(attr 'user-screen-name)) - formatted-status) - formatted-status) - ))) - -(defun twittering-http-post - (method-class method &optional parameters contents sentinel) - "Send HTTP POST request to twitter.com - -METHOD-CLASS must be one of Twitter API method classes(statuses, users or direct_messages). -METHOD must be one of Twitter API method which belongs to METHOD-CLASS. -PARAMETERS is alist of URI parameters. ex) ((\"mode\" . \"view\") (\"page\" . \"6\")) => ?mode=view&page=6" - (if (null sentinel) (setq sentinel 'twittering-http-post-default-sentinel)) - - ;; clear the buffer - (save-excursion - (set-buffer (twittering-http-buffer)) - (erase-buffer)) - - (let (proc server port - (proxy-user twittering-proxy-user) - (proxy-password twittering-proxy-password)) - (progn - (if (and twittering-proxy-use twittering-proxy-server) - (setq server twittering-proxy-server - port (if (integerp twittering-proxy-port) - (int-to-string twittering-proxy-port) - twittering-proxy-port)) - (setq server "twitter.com" - port "80")) - (setq proc - (open-network-stream - "network-connection-process" (twittering-http-buffer) - server (string-to-number port))) - (set-process-sentinel proc sentinel) - (process-send-string - proc - (let ((nl "\r\n") - request) - (setq request - (concat "POST http://twitter.com/" method-class "/" method ".xml?" - (if parameters - (mapconcat - (lambda (param-pair) - (format "%s=%s" - (twittering-percent-encode (car param-pair)) - (twittering-percent-encode (cdr param-pair)))) - parameters - "&")) - " HTTP/1.1" nl - "Host: twitter.com" nl - "User-Agent: " (twittering-user-agent) nl - "Authorization: Basic " - (base64-encode-string - (concat twittering-username ":" (twittering-get-password))) - nl - "Content-Type: text/plain" nl - "Content-Length: 0" nl - (when twittering-proxy-use - "Proxy-Connection: Keep-Alive" nl - (when (and proxy-user proxy-password) - (concat - "Proxy-Authorization: Basic " - (base64-encode-string - (concat proxy-user ":" - proxy-password)) - nl))) - nl nl)) - (debug-print (concat "POST Request\n" request)) - request))))) - -(defun twittering-http-post-default-sentinel (proc stat &optional suc-msg) - - (condition-case err-signal - (let ((header (twittering-get-response-header)) - ;; (body (twittering-get-response-body)) not used now. - (status nil)) - (string-match "HTTP/1\.1 \\([a-z0-9 ]+\\)\r?\n" header) - (setq status (match-string-no-properties 1 header)) - (case-string status - (("200 OK") - (message (if suc-msg suc-msg "Success: Post"))) - (t (message status))) - ) - (error (message (prin1-to-string err-signal)))) - ) - -(defun twittering-get-response-header (&optional buffer) - "Exract HTTP response header from HTTP response. -`buffer' may be a buffer or the name of an existing buffer. - If `buffer' is omitted, the value of `twittering-http-buffer' is used as `buffer'." - (if (stringp buffer) (setq buffer (get-buffer buffer))) - (if (null buffer) (setq buffer (twittering-http-buffer))) - (save-excursion - (set-buffer buffer) - (let ((content (buffer-string))) - (substring content 0 (string-match "\r?\n\r?\n" content))))) - -(defun twittering-get-response-body (&optional buffer) - "Exract HTTP response body from HTTP response, parse it as XML, and return a XML tree as list. -`buffer' may be a buffer or the name of an existing buffer. - If `buffer' is omitted, the value of `twittering-http-buffer' is used as `buffer'." - (if (stringp buffer) (setq buffer (get-buffer buffer))) - (if (null buffer) (setq buffer (twittering-http-buffer))) - (save-excursion - (set-buffer buffer) - (let ((content (buffer-string))) - (let ((content (buffer-string))) - (xml-parse-region (+ (string-match "\r?\n\r?\n" content) - (length (match-string 0 content))) - (point-max))) - ))) - -(defun twittering-cache-status-datum (status-datum &optional data-var) - "Cache status datum into data-var(default twittering-friends-timeline-data) -If STATUS-DATUM is already in DATA-VAR, return nil. If not, return t." - (if (null data-var) - (setf data-var 'twittering-friends-timeline-data)) - (let ((id (cdr (assq 'id status-datum)))) - (if (or (null (symbol-value data-var)) - (not (find-if - (lambda (item) - (eql id (cdr (assq 'id item)))) - (symbol-value data-var)))) - (progn - (if twittering-jojo-mode - (twittering-update-jojo (cdr (assq 'user-screen-name status-datum)) - (cdr (assq 'text status-datum)))) - (set data-var (cons status-datum (symbol-value data-var))) - t) - nil))) - -(defun twittering-status-to-status-datum (status) - (flet ((assq-get (item seq) - (car (cddr (assq item seq))))) - (let* ((status-data (cddr status)) - id text source created-at truncated - (user-data (cddr (assq 'user status-data))) - user-id user-name - user-screen-name - user-location - user-description - user-profile-image-url - user-url - user-protected - regex-index) - - (setq id (string-to-number (assq-get 'id status-data))) - (setq text (twittering-decode-html-entities - (assq-get 'text status-data))) - (setq source (twittering-decode-html-entities - (assq-get 'source status-data))) - (setq created-at (assq-get 'created_at status-data)) - (setq truncated (assq-get 'truncated status-data)) - (setq user-id (string-to-number (assq-get 'id user-data))) - (setq user-name (twittering-decode-html-entities - (assq-get 'name user-data))) - (setq user-screen-name (twittering-decode-html-entities - (assq-get 'screen_name user-data))) - (setq user-location (twittering-decode-html-entities - (assq-get 'location user-data))) - (setq user-description (twittering-decode-html-entities - (assq-get 'description user-data))) - (setq user-profile-image-url (assq-get 'profile_image_url user-data)) - (setq user-url (assq-get 'url user-data)) - (setq user-protected (assq-get 'protected user-data)) - - ;; make username clickable - (add-text-properties - 0 (length user-name) - `(mouse-face highlight - uri ,(concat "http://twitter.com/" user-screen-name) - face twittering-username-face) - user-name) - - ;; make screen-name clickable - (add-text-properties - 0 (length user-screen-name) - `(mouse-face highlight - face twittering-username-face - uri ,(concat "http://twitter.com/" user-screen-name) - face twittering-username-face) - user-screen-name) - - ;; make URI clickable - (setq regex-index 0) - (while regex-index - (setq regex-index - (string-match "@\\([_a-zA-Z0-9]+\\)\\|\\(https?://[-_.!~*'()a-zA-Z0-9;/?:@&=+$,%#]+\\)" - text - regex-index)) - (when regex-index - (let* ((matched-string (match-string-no-properties 0 text)) - (screen-name (match-string-no-properties 1 text)) - (uri (match-string-no-properties 2 text))) - (add-text-properties - (if screen-name - (+ 1 (match-beginning 0)) - (match-beginning 0)) - (match-end 0) - (if screen-name - `(mouse-face - highlight - face twittering-uri-face - uri ,(concat "http://twitter.com/" screen-name)) - `(mouse-face highlight - face twittering-uri-face - uri ,uri)) - text)) - (setq regex-index (match-end 0)) )) - - - ;; make source pretty and clickable - (if (string-match "\\(.*\\)" source) - (let ((uri (match-string-no-properties 1 source)) - (caption (match-string-no-properties 2 source))) - (setq source caption) - (add-text-properties - 0 (length source) - `(mouse-face highlight - uri ,uri - face twittering-uri-face - source ,source) - source) - )) - - (mapcar - (lambda (sym) - `(,sym . ,(symbol-value sym))) - '(id text source created-at truncated - user-id user-name user-screen-name user-location - user-description - user-profile-image-url - user-url - user-protected))))) - -(defun twittering-xmltree-to-status (xmltree) - (mapcar #'twittering-status-to-status-datum - ;; quirk to treat difference between xml.el in Emacs21 and Emacs22 - ;; On Emacs22, there may be blank strings - (let ((ret nil) (statuses (reverse (cddr (car xmltree))))) - (while statuses - (if (consp (car statuses)) - (setq ret (cons (car statuses) ret))) - (setq statuses (cdr statuses))) - ret))) - -(defun twittering-percent-encode (str &optional coding-system) - (if (or (null coding-system) - (not (coding-system-p coding-system))) - (setq coding-system 'utf-8)) - (mapconcat - (lambda (c) - (cond - ((twittering-url-reserved-p c) - (char-to-string c)) - ((eq c ? ) "+") - (t (format "%%%x" c)))) - (encode-coding-string str coding-system) - "")) - -(defun twittering-url-reserved-p (ch) - (or (and (<= ?A ch) (<= ch ?z)) - (and (<= ?0 ch) (<= ch ?9)) - (eq ?. ch) - (eq ?- ch) - (eq ?_ ch) - (eq ?~ ch))) - -(defun twittering-decode-html-entities (encoded-str) - (if encoded-str - (let ((cursor 0) - (found-at nil) - (result '())) - (while (setq found-at - (string-match "&\\(#\\([0-9]+\\)\\|\\([A-Za-z]+\\)\\);" - encoded-str cursor)) - (when (> found-at cursor) - (list-push (substring encoded-str cursor found-at) result)) - (let ((number-entity (match-string-no-properties 2 encoded-str)) - (letter-entity (match-string-no-properties 3 encoded-str))) - (cond (number-entity - (list-push - (char-to-string - (twittering-ucs-to-char - (string-to-number number-entity))) result)) - (letter-entity - (cond ((string= "gt" letter-entity) (list-push ">" result)) - ((string= "lt" letter-entity) (list-push "<" result)) - (t (list-push "?" result)))) - (t (list-push "?" result))) - (setq cursor (match-end 0)))) - (list-push (substring encoded-str cursor) result) - (apply 'concat (nreverse result))) - "")) - -(defun twittering-timer-action (func) - (let ((buf (get-buffer twittering-buffer))) - (if (null buf) - (twittering-stop) - (funcall func) - ))) - -(defun twittering-update-status-if-not-blank (status) - (if (string-match "^\\s-*\\(?:@[-_a-z0-9]+\\)?\\s-*$" status) - nil - (twittering-http-post "statuses" "update" - `(("status" . ,status) - ("source" . "twmode"))) - t)) - -(defun twittering-update-status-from-minibuffer (&optional init-str) - (if (null init-str) (setq init-str "")) - (let ((status init-str) (not-posted-p t)) - (while not-posted-p - (setq status (read-from-minibuffer "status: " status nil nil nil nil t)) - (setq not-posted-p - (not (twittering-update-status-if-not-blank status)))))) - -(defun twittering-update-lambda () - (interactive) - (twittering-http-post - "statuses" "update" - `(("status" . "\xd34b\xd22b\xd26f\xd224\xd224\xd268\xd34b") - ("source" . "twmode")))) - -(defun twittering-update-jojo (usr msg) - (if (string-match "\xde21\xd24b\\(\xd22a\xe0b0\\|\xdaae\xe6cd\\)\xd24f\xd0d6\\([^\xd0d7]+\\)\xd0d7\xd248\xdc40\xd226" - msg) - (twittering-http-post - "statuses" "update" - `(("status" . ,(concat - "@" usr " " - (match-string-no-properties 2 msg) - "\xd0a1\xd24f\xd243!?")) - ("source" . "twmode"))))) - -;;; -;;; Commands -;;; - -(defun twittering-start (&optional action) - (interactive) - (if (null action) - (setq action #'twittering-friends-timeline)) - (if twittering-timer - nil - (setq twittering-timer - (run-at-time "0 sec" - twittering-timer-interval - #'twittering-timer-action action)))) - -(defun twittering-stop () - (interactive) - (cancel-timer twittering-timer) - (setq twittering-timer nil)) - -(defun twittering-friends-timeline () - (interactive) - (let ((buf (get-buffer twittering-buffer))) - (if (not buf) - (twittering-stop) - (twittering-http-get "statuses" "friends_timeline") - )) - - (if twittering-icon-mode - (if twittering-image-stack - (let ((proc - (apply - #'start-process - "wget-images" - (twittering-wget-buffer) - "wget" - (format "--directory-prefix=%s" twittering-tmp-dir) - "--no-clobber" - "--quiet" - twittering-image-stack))) - (set-process-sentinel - proc - (lambda (proc stat) - (clear-image-cache) - (save-excursion - (set-buffer (twittering-wget-buffer)) - ))))))) - -(defun twittering-update-status-interactive () - (interactive) - (twittering-update-status-from-minibuffer)) - -(defun twittering-erase-old-statuses () - (interactive) - (setq twittering-friends-timeline-data nil) - (twittering-http-get "statuses" "friends_timeline")) - -(defun twittering-click () - (interactive) - (let ((uri (get-text-property (point) 'uri))) - (if uri - (browse-url uri)))) - -(defun twittering-enter () - (interactive) - (let ((username (get-text-property (point) 'username)) - (uri (get-text-property (point) 'uri))) - (if username - (twittering-update-status-from-minibuffer (concat "@" username " ")) - (if uri - (browse-url uri))))) - -(defun twittering-view-user-page () - (interactive) - (let ((uri (get-text-property (point) 'uri))) - (if uri - (browse-url uri)))) - -(defun twittering-reply-to-user () - (interactive) - (let ((username (get-text-property (point) 'username))) - (if username - (twittering-update-status-from-minibuffer (concat "@" username " "))))) - -(defun twittering-get-password () - (or twittering-password - (setq twittering-password (read-passwd "twittering-mode: ")))) - -(defun twittering-goto-next-status () - "Go to next status." - (interactive) - (let ((pos)) - (setq pos (twittering-get-next-username-face-pos (point))) - (if pos - (goto-char pos) - (message "End of status.")))) - -(defun twittering-get-next-username-face-pos (pos) - (interactive) - (let ((prop)) - (catch 'not-found - (while (and pos (not (eq prop twittering-username-face))) - (setq pos (next-single-property-change pos 'face)) - (when (eq pos nil) (throw 'not-found nil)) - (setq prop (get-text-property pos 'face))) - pos))) - -(defun twittering-goto-previous-status () - "Go to previous status." - (interactive) - (let ((pos)) - (setq pos (twittering-get-previous-username-face-pos (point))) - (if pos - (goto-char pos) - (message "Start of status.")))) - -(defun twittering-get-previous-username-face-pos (pos) - (interactive) - (let ((prop)) - (catch 'not-found - (while (and pos (not (eq prop twittering-username-face))) - (setq pos (previous-single-property-change pos 'face)) - (when (eq pos nil) (throw 'not-found nil)) - (setq prop (get-text-property pos 'face))) - pos))) - -(defun twittering-goto-next-status-of-user () - "Go to next status of user." - (interactive) - (let ((user-name (twittering-get-username-at-pos (point))) - (pos (twittering-get-next-username-face-pos (point)))) - (while (and (not (eq pos nil)) - (not (equal (twittering-get-username-at-pos pos) user-name))) - (setq pos (twittering-get-next-username-face-pos pos))) - (if pos - (goto-char pos) - (if user-name - (message "End of %s's status." user-name) - (message "Invalid user-name."))))) - -(defun twittering-goto-previous-status-of-user () - "Go to previous status of user." - (interactive) - (let ((user-name (twittering-get-username-at-pos (point))) - (pos (twittering-get-previous-username-face-pos (point)))) - (while (and (not (eq pos nil)) - (not (equal (twittering-get-username-at-pos pos) user-name))) - (setq pos (twittering-get-previous-username-face-pos pos))) - (if pos - (goto-char pos) - (if user-name - (message "Start of %s's status." user-name) - (message "Invalid user-name."))))) - -(defun twittering-get-username-at-pos (pos) - (let ((start-pos pos) - (end-pos)) - (catch 'not-found - (while (eq (get-text-property start-pos 'face) twittering-username-face) - (setq start-pos (1- start-pos)) - (when (or (eq start-pos nil) (eq start-pos 0)) (throw 'not-found nil))) - (setq start-pos (1+ start-pos)) - (setq end-pos (next-single-property-change pos 'face)) - (buffer-substring start-pos end-pos)))) - -(defun twittering-get-status-url (username id) - "Generate status URL." - (format "http://twitter.com/%s/statuses/%d" username id)) - -;;;###autoload -(defun twit () - "Start twittering-mode." - (interactive) - (twittering-mode)) - -(provide 'twittering-mode) -;;; twittering.el ends here