Index: lang/elisp/wassr-mode/trunk/twittering-mode.el =================================================================== --- lang/elisp/wassr-mode/trunk/twittering-mode.el (revision 47) +++ lang/elisp/wassr-mode/trunk/twittering-mode.el (revision 47) @@ -0,0 +1,1056 @@ +;;; 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 Index: lang/elisp/wassr-mode/trunk/ChangeLog =================================================================== --- lang/elisp/wassr-mode/trunk/ChangeLog (revision 47) +++ lang/elisp/wassr-mode/trunk/ChangeLog (revision 47) @@ -0,0 +1,173 @@ +2008-05-11 Tsuyoshi CHO + + * twittering-mode.el (twittering-format-status): id/user-idのフォー + マット整形。時間情報にuriを付与。Nicholasのパッチにより全体に + username情報を付与 + (twittering-status-to-status-datum): username/user-screen-nameにつ + いて整理 + (twittering-get-status-url): 新規関数(マクロでもいいんだけど...) + +2008-05-01 Tsuyoshi CHO + + * twittering-mode.el : 全体のコメント修正、以下の修正は大部分を + gan2さんが実施した + (twittering-mode-version): 新規関数 + (twittering-timer): コメント追加 + (twittering-scroll-mode, twittering-jojo-mode) + (twittering-icon-mode): Nicholas Riley さんのパッ + チ採用、バッファローカル化 + (list-push): 新規マクロ + (twittering-mode-map): キーバインド変更 + (twittering-mode-hook): フック変数新規作成(以前から利用してたけど + 定義がなかった) + (twittering-render-friends-timeline): Nicholas Riley + さんのパッチ採用、ステータスの挿入正常化 + (twittering-goto-next-status) + (twittering-get-next-username-face-pos) + (twittering-goto-previous-status) + (twittering-get-previous-username-face-pos) + (twittering-goto-next-status-of-user) + (twittering-goto-previous-status-of-user) + (twittering-get-username-at-pos, twit): 新規関数 + +2008-02-08 Tsuyoshi CHO + + * twittering-mode.el : 全体的に整形、Proxy、Safe Password、 + User-Agent、Major mode stringを対応。Version 0.3 + (twittering-mode-version): 暫定のバージョン定数を定義 + (twittering-proxy-use): プロキシ関係設定を導入 from + (twittering-proxy-server): 同上 + (twittering-proxy-port, twittering-proxy-user): 同上 + (twittering-proxy-password): 同上 + (twittering-toggle-proxy): 同上 + (twittering-user-agent-default-function): 同上 + (twittering-user-agent-default-function): デフォルトUser-Agent生成関数 + (twittering-user-agent-function): User-Agent生成関数指定変数を導入 + (twittering-user-agent): 内部でのUser-Agent生成関数 + (twittering-tmp-dir): ユーザー固有のImageTmpDirを生成 from + (twittering-mode-map): プロキシの有効無効のキーバインド定義 + (twittering-mode-string): メジャーモード文字列を変数定義 + (twittering-mode): メジャーモード開始時に文字列を設定 + (twittering-http-get): プロキシ、User-Agentによる処理を追加 + (twittering-http-post): 同上 + (twittering-get-password): パスワードを動的に確認する関数を定義 + +2007-10-14 Y. Hayamizu + + * twittering-mode.el : Naoya T. , masa_edw のパッチをとりこむ + (twittering-url-encode): 使わないので削除 + (twittering-decode-html-entities): patched: 数値エンティティだけでなく,asciiエンティティにも対応. + (twittering-font-lock-keywords): font-lock-keywordsを削除.text propertyによって設定する. + (twittering-format-status): patched: statusとformat-strからstatusの表示用文字列を生成. + (twittering-scroll-mode): patched: 新しいtwitがあったときに,カーソルもスクロールするか固定するかを設定するマイナモード, masa_edwのパッチ + (twittering-status-format): twitの表示方法をきめるテンプレート文字列 + (twittering-icon-mode): patched: ifをwhenにおかえた.nilを渡されたときはマイナモードのスイッチに振舞を変更 + (twittering-local-strftime): patched: 時間をフォーマット文字列に従い文字列化 + (twittering-mode-init-variables): font-lock-modeは,Emacs21系ではautoloadするために一度呼ぶ必要がある. icon-mode, scroll-modeをマイナモードに登録. + (twittering-inspect-object): 使わないので削除 + (twittering-http-get-default-sentinel): エラーを追いやすくするため,condition-caseを廃止 + (twittering-status-to-status-datum): 全てのデータを抽出するようコード追加.ユーザ名,URIリンク表示などの処理もここで. + +2007-10-13 Y. Hayamizu + + * twittering-mode.el (twittering-font-lock-keywords): ユーザー名のフェイスを適用する規則を修正.アイコン画像を表示したときに,下線が画像にかからないようにした. + (twittering-render-friends-timeline): ポイントが特定のtwitに対して固定されるようにした(patch from masa_edw) + +2007-10-12 Y. Hayamizu + + * twittering-mode.el (twittering-idle-time): つかわないので削除 + (twittering-get-or-generate-buffer): バッファ取得のための関数.存在しないバッファだったら,新たに生成して返す. + (twittering-buffer): Variable:twittering-bufferを名前に持つバッファを返す関数.このバッファを使う場合は,(twittering-buffer)によって取得する. + (twittering-http-buffer): twittering-bufferと同じ + (twittering-wget-buffer): twittering-bufferと同じ + + +2007-10-11 Y. Hayamizu + + * twittering-mode.el (twittering-icon-mode): アイコンを表示するか否かのフラグ + (twittering-wget-buffer): アイコン画像をwgetで取得するプロセスのバッファ + (twittering-icon-mode): アイコンの表示/非表示を切り換えるコマンド + (twittering-tmp-dir): アイコンの画像を保存するディレクトリ + (twittering-image-stack): ダウンロードすべきアイコン画像のリスト + (twittering-image-type): 画像の種類を判別する関数 + (twittering-render-friends-timeline): friends timelineを表示する部分を切り出した + +2007-10-10 Y. Hayamizu + + * twittering-mode.el: バージョン番号をつけた 0.1.0 + +2007-10-07 Y. Hayamizu + + * twittering-mode.el (twittering-http-get-default-sentinel): http-bufferを毎回生成-削除するのをやめて,内容をeraseして使い回すようにした. + (twittering-http-get-default-sentinel):HTTPレスポンスのステータスコードが上手く拾えなかったときの処理を追加 + (twittering-http-get-default-sentinel): カレントバッファか*twittering*のときは,friends-timelineを更新してもポイントの位置が変わらないように修正. + +2007-09-24 Y. Hayamizu + + * twittering-mode.el (twittering-status-to-status-datum): URIをクリック可能にする処理を追加 + +2007-09-23 Y. Hayamizu + + * twittering-mode.el (twittering-uri-face): URI用のフェイス + (twittering-click): クリック時に実行されるコマンド + (twittering-enter): EnterかC-mが押されたときに実行されるコマンド + +2007-09-19 Y. Hayamizu + + * twittering-mode.el (twittering-mode-syntax-table): "(double quote)を,文字列クオートと認識しないようにsytax-tableを変更. + (twittering-friends-timeline): friends timelineの取得したデータを保存しておく変数.twittering modeが起動している限り,この変数に取得したstatusを随時追加してゆく. + (cl): assocrefをinnner defunして,バイトコンパイル時にWarningが出ていた.clパッケージのfletを使うことでWarningが出ないように解決した. + (twittering-status-to-status-datum): twittering-status-to-lineから名前変更 + (twittering-friends-timeline-data): twittering-friends-timelineから名前変更 + (twittering-status-to-status-datum): idもstatus datumに含めるようにした. + (twittering-cache-status-datum): status datumをdata-var(デフォルトはtwittering-friends-timeline-data)にキャッシュする関数.すでにあるstatus datumを渡すとnil,新しいstatus datumを渡すとtを返してdata-varに追加する. + (twittering-http-get-default-sentinel):過去のstatus datumをキャッシュして,バッファに過去のstatusも表示されるようにした. + (twittering-erase-old-statuses): 21件目以降の古いstatusを消す関数.実際はキャッシュを全部消して,twittering-http-getを呼んでいるだけ.C-c C-eにバインド. + (twittering-username-face): ユーザ名用のface.(defface )の後に(defvar )で使用可能になった.なぜ？ + (twittering-status-to-status-datum): ユーザ名のテキストにmouse-face属性と,uri属性(ユーザのページのURI)を付加するようにした. + (twittering-click-username): ユーザ名をクリックするか,C-mを押したときに起動するコマンド. + (twittering-mode-map): vimライクなキーバインドを追加 + (twittering-mode): twittering-mode-hookでfont-lock-defaultsが設定された後に,font-lock-mode を2回呼んで変更を反映させるようにした. + (twittering-mode-init-variables): twittering-username-faceの定義をこの関数の中にうつした. + (twittering-browse-user-page): twittering-click-usernameから名前変更. + (twittering-update-status-interactive): twittering-update-statusから名前変更. + (twittering-reply-to-user): ユーザ名上でEnterを押すとこの関数が呼びだされるようにキーバインド変更.ミニバッファに @<ユーザ名> が自動挿入される. + (twittering-view-user-page): twittering-browse-user-pageから名前変更.C-c C-vにバインド. + (twittering-update-status-if-not-blank): 引数statusが,空白文字のみか, @<ユーザ名> のみの場合には nil を返し,他の文字も含む場合には POSTしてtを返す関数. + (twittering-update-status-from-minibuffer): ミニバッファからstatusを更新するための関数.無効な文字(twittering-update-status-if-not-blankで判定)が入力された場合は,有効な文字列が入力されるまでループする. + +2007-09-12 Y. Hayamizu + + * twittering-mode.el (twittering-ucs-to-char): Emacs21系では,Mule-UCSがロードされていないと,(decode-char 'ucs HOGE)がnilになり,文字コードを取得できないことがある.そこで,ucs-to-charが使える環境ではucs-to-charを,使えない環境(Emacs22など)ではdecode-charを使うように自動で切り替えるマクロを書いた. + +2007-09-10 Y. Hayamizu + + * twittering-mode.el (twittering-refresh-buffer): 使わないので削除 + (twittering-http-post-default-sentinel): condition-case でエラーハンドリングするようにした. + (twittering-http-get-default-sentinel): *twittering*バッファをread-onlyにした + (twittering-http-post-default-sentinel): condition-case でエラーハンドリングするコードを追加. + (twittering-start): 複数のタイマが走らないように,twittering-timerがnilでない=既存のタイマが走っている場合は一旦twittering-stopを呼び出してからタイマをスタートするようにした. + +2007-09-09 Y. Hayamizu + + * twittering-mode.el: リリース + (case-string): CarbonEmacs (Emacs22)で,case-stringを呼びだすコードよりも前にdefmacroを持ってきたら,警告が出ないという報告. + (twittering-decode-html-entities): ucs-to-charの使用をやめ,(decode-char 'ucs ...)を使うことに. (reported by masa_edw) + (twittering-update-status): read-from-minibufferの7番目の引数にtを指定し,input methodをカレントバッファから継承するようにした. + (twittering-decode-html-entities): string-to-intはobsoleteなので,string-to-numberに変更 (reported by masa_edw) + (twittering-get-response-header): (setq (get-buffer ...)) となっていたので,(setq buffer (get-buffer ...))に修正. twittering-get-response-bodyも同様 + (twittering-timer-action): twittering-refresh-triggerは既に使っていない変数だったので削除した + (debug-print): マクロが最初にコンパイルされる時点では,debug-modeが変数として宣言されていないので,debug-modeの判断まで含めたコードを吐くようにした. + (twittering-http-post-default-sentinel): xml-parse.elのかわりに,xml.el(Emacs標準？)を使うように変更したことに伴い書き換えた + (twittering-get-response-body): xml-parse.elのかわりに,xml.el(Emacs標準？)を使うように変更したことに伴い書き換えた + (twittering-xmltree-to-status): xml-parse.elのかわりに,xml.el(Emacs標準？)を使うように変更したことに伴い書き換えた + (twittering-status-lines): xml-parse.elのかわりに,xml.el(Emacs標準？)を使うように変更したことに伴い書き換えた + (twittering-status-to-line): xml-parse.elのかわりに,xml.el(Emacs標準？)を使うように変更したことに伴い書き換えた + (twittering-get-timeline): xml-parse.elのかわりに,xml.el(Emacs標準？)を使うように変更したことに削除 + (twittering-status-lines): xml-parse.elのかわりに,xml.el(Emacs標準？)を使うように変更したことに削除 + (twittering-parse-xml): xml-parse.elのかわりに,xml.el(Emacs標準？)を使うように変更したことに削除 + (twittering-timer-interval): twittering-refresh-intervalから名前変更 + (twittering-inspect-object): 任意のLispオブジェクトを文字列で表現できるユーティリティ関数 + (twittering-timer-action): xml.elにより処理が軽くなったので,一定時間間隔での更新に変更. + (twittering-xmltree-to-status): Emacs21とEmacs22のxml.elの差異を吸収するコードを追加.Emacs22では,ノードのリストに空の文字列が混入することがあるため,文字列を除去するようにした. + Index: lang/elisp/wassr-mode/trunk/makefile =================================================================== --- lang/elisp/wassr-mode/trunk/makefile (revision 10) +++ lang/elisp/wassr-mode/trunk/makefile (revision 10) @@ -0,0 +1,17 @@ + +EMACS21 = /home/haya/usr/bin/emacs-21.4 +EMACS22 = /home/haya/usr/bin/emacs-22.1 + +batchtest : twittering-mode.el + $(EMACS21) --no-init-file --batch -f batch-byte-compile twittering-mode.el + rm twittering-mode.elc + $(EMACS22) --no-init-file --batch -f batch-byte-compile twittering-mode.el + rm twittering-mode.elc + +test : twittering-mode.el + $(EMACS21) -q -l local.test-emacs21.el & + $(EMACS22) -q -l local.test-emacs22.el & + +clean : + rm twittering-mode.elc +