From: Andreas Gerler Date: Thu, 23 Nov 2023 18:55:20 +0000 (+0100) Subject: remove twitter X-Git-Url: http://git.bundesbrandschatzamt.de/?a=commitdiff_plain;h=f08c15b81d67a5973847bd7ea49d0de1a244095b;p=emacsconfig.git remove twitter Signed-off-by: Andreas Gerler --- diff --git a/bba.org b/bba.org index 7bd74211..6cb97232 100644 --- a/bba.org +++ b/bba.org @@ -225,7 +225,6 @@ Keep track of your important stuff! (shell-command "git --work-tree ~/workorg/ --git-dir ~/workorg/.git commit -a -m 'autocommit'") (shell-command "git --work-tree ~/workorg/ --git-dir ~/workorg/.git push origin") )) - (setq twittering-cert-file nil) (kill-emacs) ) @@ -904,25 +903,6 @@ Use our default socket files :render (gts-buffer-render))) #+end_src -* [[http://www.twmode.sourceforge.net/][twitter]] - -#+BEGIN_SRC emacs-lisp - (add-to-list 'load-path "~/.emacs.d/elpa/twittering-mode-20181121.1402") - (require 'twittering-mode) - (cond - ((string-equal system-type "gnu/linux") - (progn - (setq twittering-cert-file "/etc/ssl/certs/ca-bundle.crt") ) - ) - ) - - (setq twittering-use-master-password t) - - (if (getenv "http_proxy") - (twittering-toggle-proxy)) - -#+END_SRC - * [[http://www.mew.org][mew]] email #+BEGIN_SRC emacs-lisp :eval no :tangle no @@ -2599,7 +2579,6 @@ function to convert groups of spaces to hard tabs. (define-key bba/launcher "S" 'synonyms) (define-key bba/launcher "\C-s" 'helm-swoop) (define-key bba/launcher "t" 'git-timemachine) - (define-key bba/launcher "T" 'twittering-mode) (define-key bba/launcher "v" 'vterm) (define-prefix-command 'bba/keyboard-maestro) diff --git a/elpa/twittering-mode-20181121.1402/twittering-mode-autoloads.el b/elpa/twittering-mode-20181121.1402/twittering-mode-autoloads.el deleted file mode 100644 index 5b966231..00000000 --- a/elpa/twittering-mode-20181121.1402/twittering-mode-autoloads.el +++ /dev/null @@ -1,28 +0,0 @@ -;;; twittering-mode-autoloads.el --- automatically extracted autoloads -;; -;;; Code: - -(add-to-list 'load-path (directory-file-name - (or (file-name-directory #$) (car load-path)))) - - -;;;### (autoloads nil "twittering-mode" "twittering-mode.el" (0 0 -;;;;;; 0 0)) -;;; Generated autoloads from twittering-mode.el - -(autoload 'twit "twittering-mode" "\ -Start twittering-mode. - -\(fn)" t nil) - -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "twittering-mode" '("twittering-" "debug-print" "case-string" "list-push" "assocref"))) - -;;;*** - -;; Local Variables: -;; version-control: never -;; no-byte-compile: t -;; no-update-autoloads: t -;; coding: utf-8 -;; End: -;;; twittering-mode-autoloads.el ends here diff --git a/elpa/twittering-mode-20181121.1402/twittering-mode-pkg.el b/elpa/twittering-mode-20181121.1402/twittering-mode-pkg.el deleted file mode 100644 index 63a35f9f..00000000 --- a/elpa/twittering-mode-20181121.1402/twittering-mode-pkg.el +++ /dev/null @@ -1,2 +0,0 @@ -;;; -*- no-byte-compile: t -*- -(define-package "twittering-mode" "20181121.1402" "Major mode for Twitter" 'nil :commit "114891e8fdb4f06b1326a6cf795e49c205cf9e29" :keywords '("twitter" "web") :authors '(("Tadashi MATSUO" . "tad@mymail.twin.ne.jp") ("Y. Hayamizu" . "y.hayamizu@gmail.com") ("Tsuyoshi CHO" . "Tsuyoshi.CHO+develop@Gmail.com") ("Alberto Garcia" . "agarcia@igalia.com") ("Xavier Maillard" . "xavier@maillard.im")) :maintainer '("Tadashi MATSUO" . "tad@mymail.twin.ne.jp") :url "http://twmode.sf.net/") diff --git a/elpa/twittering-mode-20181121.1402/twittering-mode.el b/elpa/twittering-mode-20181121.1402/twittering-mode.el deleted file mode 100644 index aa90cdaf..00000000 --- a/elpa/twittering-mode-20181121.1402/twittering-mode.el +++ /dev/null @@ -1,13231 +0,0 @@ -;;; twittering-mode.el --- Major mode for Twitter - -;; Copyright (C) 2009-2015 Tadashi MATSUO -;; 2007, 2009-2011 Yuto Hayamizu. -;; 2008 Tsuyoshi CHO -;; 2014, 2015 Xavier Maillard - -;; Author: Tadashi MATSUO -;; Y. Hayamizu -;; Tsuyoshi CHO -;; Alberto Garcia -;; Xavier Maillard -;; Created: Sep 4, 2007 -;; Version: HEAD -;; Package-Version: 20181121.1402 -;; Identity: $Id: fb19946d706684ccd33bcd810e98638d7374964c $ -;; Keywords: twitter web -;; URL: http://twmode.sf.net/ - -;; 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 -;; * Status Input from Popup buffer and C-cC-c to POST. -;; URL : http://code.nanigac.com/source/view/419 -;; * update status for region - -;;; Code: - -(eval-when-compile (require 'cl) - (require 'easymenu)) -(require 'xml) - -(eval-and-compile - ;; On byte-compilation, Emacs21 requires loading the libraries - ;; distributed with twittering-mode.el for macros defined in them. - (when (> 22 emacs-major-version) - (setq load-path - (append (mapcar (lambda (dir) - (expand-file-name - dir - (if load-file-name - (or (file-name-directory load-file-name) - ".") - "."))) - '("url-emacs21" "emacs21")) - load-path)))) - -(when (> 22 emacs-major-version) - (and (require 'un-define nil t) - ;; the explicitly require 'unicode to update a workaround with - ;; navi2ch. see a comment of `twittering-ucs-to-char' for more - ;; details. - (require 'unicode nil t)) - (defadvice url-scheme-register-proxy (around twittering-fix-process-env (scheme) activate) - (let ((process-environment - (apply 'append - (let ((env-var (concat scheme "_proxy"))) - (mapcar - (lambda (str) - (if (string-match - (concat "^\\(" - (regexp-opt (list (upcase env-var) - (downcase env-var))) - "\\)=$") - str) - nil - (list str))) - process-environment))))) - ad-do-it))) -(require 'url) - -(defgroup twittering-mode nil - "Settings for twittering-mode." - :link '(url-link "https://github.com/hayamiz/twittering-mode") - :prefix "twittering-" - :group 'hypermedia) - -(defconst twittering-mode-version "HEAD") -(defconst twittering-mode-identity "$Id: fb19946d706684ccd33bcd810e98638d7374964c $") -(defvar twittering-api-host "api.twitter.com") -(defvar twittering-api-search-host "search.twitter.com") -(defvar twittering-web-host "twitter.com") -(defvar twittering-oauth-request-token-url-without-scheme - "://api.twitter.com/oauth/request_token") -(defvar twittering-oauth-authorization-url-base-without-scheme - "://api.twitter.com/oauth/authorize?oauth_token=") -(defvar twittering-oauth-access-token-url-without-scheme - "://api.twitter.com/oauth/access_token") - -(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))) - -(defcustom twittering-auth-method 'oauth - "*Authentication method to use with `twittering-mode'. - -Choose between symbols `oauth' (default), `basic' or `xauth'. - -OAuth Authentication requires `twittering-oauth-consumer-key' and -`twittering-oauth-consumer-secret'. - -Additionally, it requires an external command `curl' or another -command included in `tls-program', which may be `openssl' or -`gnutls-cli', for SSL." - :group 'twittering-mode - :type '(choice :tag "Twitter authentication method" - (const :tag "Basic authentication" :value basic) - (const :tag "OAuth authentication" :value oauth) - (const :tag "xAuth authentication" :value xauth))) - -(defvar twittering-account-authorization nil - "State of account authorization for `twittering-username' and -`twittering-password'. The value is one of the following symbols: -nil -- The account have not been authorized yet. -queried -- The authorization has been queried, but not finished yet. -authorized -- The account has been authorized.") - -(defcustom twittering-oauth-use-ssl t - "*If non-nil, use SSL authentication for OAuth. - -Twitter requires SSL on authorization via OAuth." - :group 'twittering-mode - :type 'boolean) - -(defcustom twittering-oauth-invoke-browser nil - "*If non-nil, invoke a browser on authorization of access key automatically." - :type 'boolean - :group 'twittering-mode) - -(defvar twittering-oauth-consumer-key nil) -(defvar twittering-oauth-consumer-secret nil) -(defvar twittering-oauth-access-token-alist nil) - -(defconst twittering-max-number-of-tweets-on-retrieval 200 - "The maximum number of `twittering-number-of-tweets-on-retrieval'.") - -(defcustom twittering-number-of-tweets-on-retrieval 20 - "*Number of tweets which will be retrieved in one request. - -The upper limit is `twittering-max-number-of-tweets-on-retrieval'." - :type 'integer - :group 'twittering-mode) - -(defcustom twittering-tinyurl-service 'tinyurl - "*Shorten URI service to use. - -This must be one of key symbols of `twittering-tinyurl-services-map'. - -To use bit.ly or j.mp services, you have to configure -`twittering-bitly-login' and `twittering-bitly-api-key'." - :type '(radio (symbol :tag "bit.ly" - :value bit.ly) - (symbol :tag "goo.gl" - :value goo.gl) - (symbol :tag "is.gd" - :value is.gd) - (symbol :tag "j.mp" - :value j.mp) - (symbol :tag "migre.me" - :value migre.me) - (symbol :tag "tinyurl" - :value tinyurl) - (symbol :tag "toly" - :value toly)) - :group 'twittering-mode) - -(defcustom twittering-tinyurl-services-map - '((bit.ly twittering-make-http-request-for-bitly - (lambda (service reply) - (if (string-match "\n\\'" reply) - (substring reply 0 (match-beginning 0)) - reply))) - (goo.gl - (lambda (service longurl) - (twittering-make-http-request-from-uri - "POST" '(("Content-Type" . "application/json")) - "https://www.googleapis.com/urlshortener/v1/url" - (concat "{\"longUrl\": \"" longurl "\"}"))) - (lambda (service reply) - (when (string-match "\"id\"[[:space:]]*:[[:space:]]*\"\\([^\"]*\\)\"" - reply) - (match-string 1 reply)))) - (is.gd . "http://is.gd/create.php?format=simple&url=") - (j.mp twittering-make-http-request-for-bitly - (lambda (service reply) - (if (string-match "\n\\'" reply) - (substring reply 0 (match-beginning 0)) - reply))) - (migre.me . "http://migre.me/api.txt?url=") - (tinyurl . "http://tinyurl.com/api-create.php?url=") - (toly - (lambda (service longurl) - (twittering-make-http-request-from-uri - "POST" nil - "http://to.ly/api.php" - (concat "longurl=" (twittering-percent-encode longurl)))))) - "Alist of URL shortening services. -The key is a symbol specifying the service. -The value is a string or a list consisting of two elements at most. - -If the value is a string, `(concat THE-FIRST-ELEMENT longurl)' is used as the -URL invoking the service. -If the value is a list, it is interpreted as follows. -The first element specifies how to make a HTTP request for shortening a URL. -If the first element is a string, `(concat THE-FIRST-ELEMENT longurl)' is -used as the URL invoking the service. -If the first element is a function, it is called as `(funcall THE-FIRST-ELEMENT -service-symbol longurl)' to obtain a HTTP request alist for invoking the -service, which must be generated by `twittering-make-http-request'. - -The second element specifies how to post-process a HTTP reply by the HTTP -request. -If the second element is nil, the reply is directly used as a shortened URL. -If the second element is a function, it is called as `(funcall -THE-SECOND-ELEMENT service-symbol HTTP-reply-string)' and its result is used -as a shortened URL." - :type 'alist - :group 'twittering-mode) - -(defcustom twittering-bitly-login nil - "*The login name for URL shortening service bit.ly and j.mp." - :type '(choice (const nil) - string) - :group 'twittering-mode) - -(defcustom twittering-bitly-api-key nil - "*API key for `bit.ly' and `j.mp' URL shortening services." - :type '(choice (const nil) - string) - :group 'twittering-mode) - -(defvar twittering-mode-map (make-sparse-keymap)) -(defvar twittering-mode-menu-on-uri-map (make-sparse-keymap "Twittering Mode")) -(defvar twittering-mode-on-uri-map (make-sparse-keymap)) - -(defvar twittering-tweet-history nil) -(defvar twittering-user-history nil) -(defvar twittering-timeline-history nil) -(defvar twittering-hashtag-history nil) -(defvar twittering-search-history nil) - -(defvar twittering-current-hashtag nil - "A hash tag string currently set. You can set it by calling -`twittering-set-current-hashtag'.") - -(defvar twittering-timer nil - "Timer object for timeline refreshing will be stored here. -DO NOT SET VALUE MANUALLY.") - -(defcustom twittering-timer-interval 90 - "Number of seconds to wait before an auto-reload occurs. - -Number of API calls per hour is limited so this value should be 60 or more." - :type 'integer - :group 'twittering-mode) - -(defvar twittering-timer-for-redisplaying nil - "Timer object for timeline redisplay statuses will be stored here. -DO NOT SET VALUE MANUALLY.") - -(defvar twittering-timer-interval-for-redisplaying 5.0 - "The interval of auto redisplaying statuses. -Each time Emacs remains idle for the interval, twittering-mode updates parts -requiring to be redrawn.") - -(defcustom twittering-username nil - "*A username of your Twitter account." - :type '(choice (const nil) - string) - :group 'twittering-mode) - -(defcustom twittering-password nil - "*A password of your Twitter account. Leave it blank is the -recommended way because writing a password in .emacs file is so -dangerous." - :type '(choice (const nil) - string) - :group 'twittering-mode) - -(defcustom twittering-initial-timeline-spec-string ":home" - "*An initial timeline spec string or a list of timeline spec strings. -This specifies one or more initial timeline spec strings, which are -automatically visited when invoking `twittering-mode' or `twit'. - -If it is a string, it specifies a timeline spec string. -If it is a list of strings, it specifies multiple timeline spec strings." - :type '(choice (const nil) - string - (repeat string)) - :group 'twittering-mode) - -(defvar twittering-timeline-spec nil - "The timeline spec for the current buffer.") -(defvar twittering-timeline-spec-string "" - "The timeline spec string for the current buffer.") - -(defcustom twittering-timeline-spec-alias nil - "*Alist for aliases of timeline spec. -Each element is (NAME . SPEC-STRING), where NAME is a string and -SPEC-STRING is a string or a function that returns a timeline spec string. - -The alias can be referred as \"$NAME\" or \"$NAME(ARG)\" in timeline spec -string. If SPEC-STRING is a string, ARG is simply ignored. -If SPEC-STRING is a function, it is called with a string argument. -For the style \"$NAME\", the function is called with nil. -For the style \"$NAME(ARG)\", the function is called with a string ARG. - -For example, if you specify - `((\"FRIENDS\" . \"my-account/friends-list\") - (\"related-to\" . - ,(lambda (username) - (if username - (format \":search/to:%s OR from:%s OR @%s/\" - username username username) - \":home\")))), -then you can use \"$FRIENDS\" and \"$related-to(USER)\" as -\"my-account/friends-list\" and \":search/to:USER OR from:USER OR @USER/\", -respectively." - :type 'alist - :group 'twittering-mode) - -(defvar twittering-current-timeline-spec-string nil - "The current timeline spec string. This variable should not be referred -directly. Use `twittering-current-timeline-spec-string' or -`twittering-current-timeline-spec'.") -(defvar twittering-list-index-retrieved nil) - -(defvar twittering-process-info-alist nil - "Alist of active process and timeline spec retrieved by the process.") - -(defvar twittering-server-info-alist nil - "Alist of server information.") - -(defvar twittering-api-limit-info-alist '() - "Alist of an API identifier and an alist representing rate limit for the API.") - -(defvar twittering-timeline-spec-to-api-table '() - "Alist of a timeline spec and an API identifier for retrieving the timeline.") - -(defcustom twittering-mode-init-hook nil - "*Hook run after initializing global variables for `twittering-mode'." - :type 'hook - :group 'twittering-mode) - -(defcustom twittering-mode-hook nil - "*Hook run every time a buffer is initialized as a `twittering-mode' buffer." - :type 'hook - :group 'twittering-mode) - -(defvar twittering-cookie-alist nil - "Alist for stroing cookies for each account. -This variable stores an alist. -A key of the alist is a string that is a screen name of an account. -A value of the alist is a cookie alist which corresponds to a list of -a pair of a cookie name and value.") - -(defvar twittering-new-tweets-count 0 - "Number of new tweets when `twittering-new-tweets-hook' is run.") -(defvar twittering-new-tweets-spec nil - "Timeline spec, which new tweets belong to, when -`twittering-new-tweets-hook' is run.") -(defvar twittering-new-tweets-statuses nil - "New tweet status messages, when -`twittering-new-tweets-hook' is run.") - -(defcustom twittering-new-tweets-hook nil - "*Hook run when new tweets are received. - -You can read `twittering-new-tweets-count' or `twittering-new-tweets-spec' -to get the number of new tweets received when this hook is run." - :type 'hook - :group 'twittering-mode) - -(defvar twittering-rendered-new-tweets-spec nil - "A timeline spec of newly rendered tweets. -This variable is bound when invoking hooks registered with -`twittering-new-tweets-rendered-hook'.") - -(defvar twittering-rendered-new-tweets-spec-string nil - "A timeline spec string of newly rendered tweets. -This variable is bound when invoking hooks registered with -`twittering-new-tweets-rendered-hook'.") - -(defvar twittering-rendered-new-tweets nil - "A list of newly rendered tweets. -Hooks registered with `twittering-new-tweets-rendered-hook' can use this -variable as a list of rendered tweets. Each tweet is represented as an alist. -You can refer to a property of a tweet alist as - (cdr (assq PROPERTY-SYMBOL TWEET-ALIST)). -Valid symbols are following; id, text, user-name, user-screen-name, user-id, - source, source-uri. -In the list, tweets are placed in order of time. The car of the list is the -latest one, and the last is the oldest one.") - -(defcustom twittering-new-tweets-rendered-hook nil - "*Hook run when new tweets are rendered. -When the registered functions are called, the current buffer is the buffer -that the new tweets are just rendered on. -The functions can refer to the timeline spec and timeline spec string as -`twittering-rendered-new-tweets-spec' and -`twittering-rendered-new-tweets-spec-string', repectively. -Hooks can also use the local variable `twittering-rendered-new-tweets' as a -list of rendered tweets. -For the detail of the representation of tweets, see the variable -`twittering-rendered-new-tweets'." - :type 'hook - :group 'twittering-mode) - -(defvar twittering-active-mode nil - "Non-nil if new statuses should be retrieved periodically. -Do not modify this variable directly. Use `twittering-activate-buffer', -`twittering-deactivate-buffer', `twittering-toggle-activate-buffer' or -`twittering-set-active-flag-for-buffer'.") - -(defvar twittering-jojo-mode nil) -(defcustom twittering-reverse-mode nil - "*Non-nil means tweets are aligned in reverse order of `http://twitter.com/'." - :type 'boolean - :group 'twittering-mode) - -(defcustom twittering-display-remaining nil - "*If non-nil, display remaining of rate limit on the mode-line." - :type 'boolean - :group 'twittering-mode) - -(defcustom twittering-display-connection-method t - "*If non-nil, display the current connection method on the mode-line." - :type 'boolean - :group 'twittering-mode) - -(defcustom twittering-status-format "%RT{%FACE[bold]{RT}}%i %s, %@:\n%FOLD[ ]{%T // from %f%L%r%R%QT{\n+----\n%FOLD[|]{%i %s, %@:\n%FOLD[ ]{%T // from %f%L%r%R}}\n+----}}\n " - "Format string for rendering statuses. -Ex. \"%i %s, %@:\\n%FILL{ %T // from %f%L%r%R}\n \" - -Items: - %s - screen_name - %S - name - %i - profile_image - %d - description - %l - location - %L - \" [location]\" - %r - \" sent to user\" (use on direct_messages{,_sent}) - %r - \" in reply to user\" (use on other standard timeline) - %R - \" (retweeted by user)\" - %RT{...} - strings rendered only when the tweet is a retweet. - The braced strings are rendered with the information of the - retweet itself instead of that of the retweeted original tweet. - For example, %s for a retweet means who posted the original - tweet, but %RT{%s} means who retweeted it. - %QT{...} - strings rendered only when the tweet quotes a tweet. - The braced strings are rendered with the information of the - quoted tweet. For example, %QT{%s} means the author of the - quoted tweet. - %u - url - %j - user.id - %p - protected? - %c - created_at (raw UTC string) - %C{time-format-str} - created_at (formatted with time-format-str) - %@{time-format-str} - X seconds ago (formatted with time-format-str) - %T - raw text - %t - text filled as one paragraph - %' - truncated - %FACE[face-name]{...} - strings decorated with the specified face. - %FIELD[format-str]{field-name} - - a value of the given field of a tweet formatted with format-str. - The format-str is optional. As a field-name, you can use - \"retweet_count\", \"favorite_count\" and so on. - %FIELD-IF-NONZERO[format-str]{field-name} - - similar to %FIELD[...]{...} except that this makes an empty string - if the field value is zero. - %FILL[prefix]{...} - strings filled as a paragraph. The prefix is optional. - You can use any other specifiers in braces. - %FOLD[prefix]{...} - strings folded within the frame width. - The prefix is optional. This keeps newlines and does not - squeeze a series of white spaces. - You can use any other specifiers in braces. - %f - source - %# - id" - :type 'string - :group 'twittering-mode) - -(defcustom twittering-retweet-format '(nil _ " RT: %t (via @%s)") - "*A format string or a skeleton for retweet. -If the value is a string, it means a format string for generating an initial -string of a retweet. The format string is converted with the below replacement -table. And then, the cursor is placed on the next of the initial string. -It is equivalent to the skeleton '(nil STRING _). -Note that this string is inserted before the edit skeleton specified by -`twittering-edit-skeleton' is performed. - -If the value is a list, it is treated as a skeleton used with -`skeleton-insert'. The strings included in the list are converted with the -following replacement table. And then, the list with converted strings is -inserted by `skeleton-insert'. -Note that this skeleton is performed before the edit skeleton specified by -`twittering-edit-skeleton' is performed. - -Replacement table: - %s - The screen-name of the cited tweet. - %t - The text of the cited tweet. - %u - The URL of the cited tweet. - %# - The ID of the cited tweet. - %% - % itself." - :type 'sexp - :group 'twittering-mode) - -(defcustom twittering-fill-column nil - "*The `fill-column' used for \"%FILL{...}\" in `twittering-status-format'. -If nil, the fill-column is automatically calculated." - :type '(choice (const nil) - integer) - :group 'twittering-mode) - -(defcustom twittering-show-replied-tweets t - "*The number of replied tweets which will be showed in one tweet. - -If the value is not a number and is non-nil, show all replied tweets -which is already fetched. -If the value is nil, doesn't show replied tweets." - - :type '(choice (const :tag "Do not show replied tweets" - :value nil) - (const :tag "Show all replied tweets" - :value t) - (integer :tag "Number of replied tweet")) - :group 'twittering-mode) - -(defcustom twittering-default-show-replied-tweets nil - "*The number of default replied tweets which will be shown in one tweet. -This value will be used only when showing new tweets. - -See `twittering-show-replied-tweets' for more details." - :type '(choice (const nil) - integer) - :group 'twittering-mode) - -(defcustom twittering-disable-overlay-on-too-long-string nil - "*If non-nil, disable overlay on too long string on edit buffer. - -If nil, `twittering-edit-mode' puts an overlay `twittering-warning-overlay' on -characters exceeding the maximum length. - -On some environments, some input methods seem to interfere the update of the -overlay. In such case, you may avoid the problems by setting this variable to -non-nil." - :type 'boolean - :group 'twittering-mode) - -(defcustom twittering-use-show-minibuffer-length t - "*Show current length of minibuffer if this variable is non-nil. - -We suggest that you should set to nil to disable the showing function -when it conflict with your input method (such as AquaSKK, etc.)" - :type 'boolean - :group 'twittering-mode) - -(defvar twittering-notify-successful-http-get t) - -(defcustom twittering-use-ssl t - "*Use SSL connection if this variable is non-nil. - -SSL connections use an external command as a backend." - :type 'boolean - :group 'twittering-mode) - -(defcustom twittering-allow-insecure-server-cert nil - "*If non-nil, `twittering-mode' allows insecure server certificates." - :type 'boolean - :group 'twittering-mode) - -(defvar twittering-curl-program nil - "Cache a result of `twittering-find-curl-program'. -DO NOT SET VALUE MANUALLY.") -(defvar twittering-curl-program-https-capability nil - "Cache a result of `twittering-start-http-session-curl-https-p'. -DO NOT SET VALUE MANUALLY.") -(defvar twittering-curl-program-http2-capability nil - "Cache a result of `twittering-start-http-session-curl-http2-p'. -DO NOT SET VALUE MANUALLY.") - -(defvar twittering-wget-program nil - "Cache a result of `twittering-find-wget-program'. -DO NOT SET VALUE MANUALLY.") - -(defcustom twittering-tls-program nil - "*List of strings containing commands to start TLS stream to a host. -Each entry in the list is tried until a connection is successful. -%h is replaced with server hostname, %p with port to connect to. -Also see `tls-program'. -If nil, this is initialized with a list of valied entries extracted from -`tls-program'." - :type '(repeat string) - :group 'twittering-mode) - -(defcustom twittering-connection-type-order - '(curl wget urllib-http native urllib-https) - "*A list of connection methods in the preferred order." - :type 'list - :group 'twittering-mode) - -(defun twittering-connection-build-customize-option () - "Generate a valid `defcustom' entry to build `twittering-connection-type-table' variable." - (list 'repeat - (list - 'cons :tag "Connection" - '(symbol :tag "Name" :value "") - '(repeat - :tag "Connection method definition" - (choice - (cons :tag "Check test method" - (const :format "" check) - (choice :value t (const :tag "Do not check" t) - (function :tag "Check function"))) - (cons :tag "Display name" - (const :format "" display-name) - string) - (cons :tag "HTTPS connection method" - (const :format "" https) - (choice :value nil (const :tag "None" nil) - (const :tag "True" t) - (function :tag "HTTPS test function"))) - (cons :tag "Send HTTP request function" - (const :format "" send-http-request) - function) - (cons :tag "Pre process buffer" - (const :format "" pre-process-buffer) - function)))))) - -(defcustom twittering-connection-type-table - '((native - (check . t) - (send-http-request . twittering-send-http-request-native) - (pre-process-buffer . twittering-pre-process-buffer-native)) - (curl - (check . twittering-start-http-session-curl-p) - (https . twittering-start-http-session-curl-https-p) - (send-http-request . twittering-send-http-request-curl) - (pre-process-buffer . twittering-pre-process-buffer-curl)) - (wget - (check . twittering-start-http-session-wget-p) - (https . ignore) - (send-http-request . twittering-send-http-request-wget) - (pre-process-buffer . twittering-pre-process-buffer-wget)) - (urllib-http - (display-name . "urllib") - (check . twittering-start-http-session-urllib-p) - (https . nil) - (send-http-request . twittering-send-http-request-urllib) - (pre-process-buffer . twittering-pre-process-buffer-urllib)) - (urllib-https - (display-name . "urllib") - (check . twittering-start-http-session-urllib-p) - (https . twittering-start-http-session-urllib-https-p) - (send-http-request . twittering-send-http-request-urllib) - (pre-process-buffer . twittering-pre-process-buffer-urllib))) - "A list of alist of connection methods." - :group 'twittering-mode - :type (twittering-connection-build-customize-option)) - -(defvar twittering-format-status-function-source "" - "The status format string that has generated the current -`twittering-format-status-function'.") -(defvar twittering-format-status-function nil - "The formating function generated from `twittering-format-status-function-source'.") -(defvar twittering-format-status-function-without-compile nil - "The formating function generated from `twittering-format-status-function-source', -which is a lambda expression without being compiled.") - -(defvar twittering-timeline-data-table (make-hash-table :test 'equal)) - -(defcustom twittering-username-face 'twittering-username-face - "*Face used to display USERNAME." - :type 'face - :group 'twittering-mode) - -(defcustom twittering-uri-face 'twittering-uri-face - "*Face used to display URIs." - :type 'face - :group 'twittering-mode) - -(defcustom twittering-use-native-retweet nil - "*If non-nil, post retweet using native retweets." - :type 'boolean - :group 'twittering-mode) - -(defcustom twittering-update-status-function - 'twittering-update-status-from-pop-up-buffer - "*The function which is used to post a tweet. - -It takes the following 5 arguments, INIT-STR, REPLY-TO-ID, USERNAME, -TWEET-TYPE and CURRENT-SPEC. -The first argument INIT-STR is nil or an initial text to be edited. -REPLY-TO-ID and USERNAME are an ID and a user-screen-name of a tweet to -which you are going to reply. If the tweet is not a reply, they are nil. -TWEET-TYPE is a symbol specifying a type of a tweet being edited. It must -be one of 'direct-message, 'normal, 'organic-retweet and 'reply. -CURRENT-SPEC means on which timeline the function is called. - -Twittering-mode provides two functions for updating status: -* `twittering-update-status-from-minibuffer': edit tweets in minibuffer -* `twittering-update-status-from-pop-up-buffer': edit tweets in pop-up buffer" - :type '(choice (const :tag "built-in: from minibuffer" - twittering-update-status-from-minibuffer) - (const :tag "built-in: from a popup buffer" - twittering-update-status-from-pop-up-buffer) - (function :tag "Your own function")) - :group 'twittering-mode) - -(defcustom twittering-request-confirmation-on-posting nil - "*If non-nil, confirmation will be requested on posting a tweet edited in -pop-up buffer." - :type 'boolean - :group 'twittering-mode) - -(defcustom twittering-use-master-password nil - "*If non-nil, store private information encrypted with a master password." - :type 'boolean - :group 'twittering-mode) - -(defcustom twittering-private-info-file (expand-file-name "~/.twittering-mode.gpg") - "*File for storing encrypted private information. - - Only used when `twittering-use-master-password' is non-nil." - :group 'twittering-mode - :type 'file) - -(defvar twittering-private-info-file-loaded nil - "Whether the private info file has been loaded or not.") -(defvar twittering-variables-stored-with-encryption - '(twittering-oauth-access-token-alist)) - -(defvar twittering-api-prefix "1/") -(defvar twittering-search-api-method "search") -(defvar twittering-web-path-prefix "") - -(defconst twittering-service-method-table - '((twitter (status-url . twittering-get-status-url-twitter) - (search-url . twittering-get-search-url-twitter)) - (twitter-api-v1.1 - (status-url . twittering-get-status-url-twitter) - (search-url . twittering-get-search-url-twitter)) - (statusnet (status-url . twittering-get-status-url-statusnet) - (search-url . twittering-get-search-url-statusnet))) - "A list of alist of service methods.") - -(defcustom twittering-service-method 'twitter-api-v1.1 - "*Service method for `twittering-mode'. - -The symbol `twitter' means Twitter Service. -The symbol `statusnet' means StatusNet Service. - -Default to `twitter-api-v1.1' which is an alias for `twitter'. - -See also `twittering-service-method-table'." - :type (if (> (length (mapcar #'car twittering-service-method-table)) 0) - `(choice ,@(mapcar (lambda (entry) `(const ,(car entry))) - twittering-service-method-table)) - 'symbol) - :group 'twittering-mode) - -(defcustom twittering-timeline-header-face 'twittering-timeline-header-face - "*Face for the header on `twittering-mode'. - -The face is used for rendering `twittering-timeline-header'." - :type 'face - :group 'twittering-mode) - -(defcustom twittering-timeline-footer-face 'twittering-timeline-footer-face - "*Face for the footer on `twittering-mode'. - -The face is used for rendering `twittering-timeline-footer'." - :type 'face - :group 'twittering-mode) - -(defcustom twittering-timeline-header "-- Press Enter here to update --\n" - "*Timeline header string on `twittering-mode'. - -The string is rendered on the beginning of a `twittering-mode' buffer. -Its face is specified by `twittering-timeline-header-face'." - :type 'string - :group 'twittering-mode) - -(defcustom twittering-timeline-footer "-- Press Enter here to update --" - "*Timeline footer string on `twittering-mode'. - -The string is rendered on the end of a `twittering-mode' buffer. -Its face is specified by `twittering-timeline-footer-face'." - :type 'string - :group 'twittering-mode) - -(defcustom twittering-pop-to-buffer-function - 'twittering-pop-to-buffer-in-bottom-largest-window - "*Function being invoked by `twittering-pop-to-buffer'. - -It will receive an argument, the buffer being selected. -For example, the following functions can be used; `pop-to-buffer', -`twittering-pop-to-buffer-simple', -`twittering-pop-to-buffer-in-current-window', -`twittering-pop-to-buffer-in-largest-window', and -`twittering-pop-to-buffer-in-bottom-largest-window'." - :type 'function - :group 'twittering-mode) - -;; FIXME: change to something better than alist -(defcustom twittering-relative-retrieval-interval-alist - '(("\\`:direct.*\\'" 4) - (":home" ":mentions" 1) - (t 1)) - "*An alist of relative intervals of retrieving timelines. -Each element looks like (TIMELINE-SPEC-REGEXP RELATIVE-INTERVAL). - -TIMELINE-SPEC-REGEXP must be t or a regexp string specifying primary -timeline specs. -If TIMELINE-SPEC-REGEXP is t, it matches all timelines. -RELATIVE-INTERVAL must be zero or a positive integer specifying relative -interval of retrieving timelines that match TIMELINE-SPEC-REGEXP. - -An interval for a timeline is determined as follows; -1. Find the first element where TIMELINE-SPEC-REGEXP matches the - timeline or TIMELINE-SPEC-REGEXP is t. - If no elements are found, the interval is `twittering-timer-interval'. -2. Check the RELATIVE-INTERVAL of the element. - If RELATIVE-INTERVAL is a positive integer, the interval is - RELATIVE-INTERVAL times as long as `twittering-timer-interval'. - - If RELATIVE-INTERVAL is zero, the interval is infinity. - The timeline is not retrieved automatically." - :type 'alist - :group 'twittering-mode) - -(defvar twittering-relative-retrieval-count-alist '() - "An alist for counting retrieval of primary timelines.") - -(defvar twittering-filter-alist '() - "*An alist of hidden tweet patterns for each primary timeline. -Each element looks like: - (TIMELINE-SPECIFIER (SYM1 . REGEXP1) (SYM2 . REGEXP2) ...). - -TIMELINE-SPECIFIER must be a string or a list of strings. -Each string is a regexp for specifying primary timelines. -Note that you cannot specify composite timelines such as \":merge\", -\":exclude-if\" or \":exclude-re\". -Following regexps (REGEXP1, REGEXP2, ...) specify which tweet should -be hidden in a certain timeline. - -In a timeline that matches TIMELINE-SPECIFIER, a tweet is hidden if -its elements specified by SYM1, SYM2, ... match corresponding REGEXP1, REGEXP2, -... respectively. - -If a timeline matches multiple specifiers, all regexps of matched elements -are effective. - -For example, if you specify - '(((\":home\" \":mentions\") (text . \"http://\")) - (\"^[^:]\" (text . \"sample\") (user-screen-name . \"\\`FOO\\'\")) - (\"twitter/.*\" (text . \"^aa\"))), -the following tweets are hidden. - -- tweets including \"http://\" in the home timeline and the mentions timeline, -- tweets that are posted by the user FOO and include \"sample\" - in user timelines and list timelines, -- tweets including \"aa\" at a beginning of a line in list timelines of - twitter, such as \"twitter/media\" or \"twitter/support\".") - - -;;;; -;;;; Macro and small utility function -;;;; - -(defun assocref (item alist) - (cdr (assoc item alist))) - -(defmacro list-push (value listvar) - `(setq ,listvar (cons ,value ,listvar))) - -(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))) - -(defmacro twittering-wait-while (timeout interval condition &optional form &rest timeout-forms) - "Wait while CONDITION returns non-nil until TIMEOUT seconds passes. - -The form CONDITION is repeatedly evaluated for every INTERVAL seconds -until CONDITION returns nil or TIMEOUT seconds passes unless TIMEOUT is nil. -If TIMEOUT is nil, there is no time limit. - -If CONDITION returns nil, evaluate the form FORM and return its value. -If TIMEOUT seconds passes, evaluate the forms TIMEOUT-FORMS and return -the value of the last form in TIMEOUT-FORMS." - `(lexical-let (,@(when timeout `((timeout ,timeout))) - (interval ,interval) - (current 0.0)) - (while (and ,@(when timeout '((< current timeout))) - ,condition) - (sleep-for interval) - (setq current (+ current interval))) - ,(when (or form timeout-forms) - (if (null timeout) - form - `(if (< current timeout) - ,form - ,@timeout-forms))))) - - -(defun twittering-extract-matched-substring-all (regexp str) - (let ((pos 0) - (result nil)) - (while (string-match regexp str pos) - (setq result (cons (match-string 1 str) result)) - (setq pos (match-end 0))) - (reverse result))) - -(defun twittering-process-alive-p (proc) - "Return non-nil if PROC is alive." - (not (memq (process-status proc) '(nil closed exit failed signal)))) - -(defun twittering-start-process-with-sentinel (name buffer program args sentinel) - "Start a program in a subprocess with a sentinel. - -This function is the same as `start-process' except that SENTINEL must -be invoked when the process is successfully started." - (let* (;; By binding `process-connection-type' to nil, - ;; ensure that the new process communicates with Emacs - ;; via a pipe instead of a pty. - (process-connection-type nil) - (proc (apply 'start-process name buffer program args))) - (when (and proc (functionp sentinel)) - (if (twittering-process-alive-p proc) - (set-process-sentinel proc sentinel) - ;; Ensure that the sentinel is invoked if a subprocess is - ;; successfully started. - (funcall sentinel proc "finished"))) - proc)) - -(defun twittering-parse-time-string (str &optional round-up) - "Parse the time-string STR into (SEC MIN HOUR DAY MON YEAR DOW DST TZ). -This function is the same as `parse-time-string' except to complement the -lacked parameters with the current time. -If ROUND-UP is nil, complement the lacked parameters with the oldest ones. -If ROUND-UP is non-nil, complement the lacked parameters with the latest ones. -For example, (twittering-parse-time-string \"2012-04-20\") -returns (0 0 0 20 4 2012 nil nil 32400). -And (twittering-parse-time-string \"2012-04-20\" t) -returns (59 59 23 20 4 2012 nil nil 32400). -The values are identical to those of `decode-time', but any values that are -unknown are returned as nil." - (let* ((parsed (parse-time-string str)) - (current (decode-time (current-time))) - (replacement-alist - `((SEC . ,(if round-up - 59 - 0)) - (MIN . ,(if round-up - 59 - 0)) - (HOUR . ,(if round-up - 23 - 0)) - (DAY . nil) - (MON . nil) - (YEAR . nil) - (DOW . nil) - (DST . nil) - (TZ . nil))) - (sym-list (mapcar 'car replacement-alist)) - (result nil)) - (while (and parsed current sym-list) - (let* ((sym (car sym-list)) - (v (or (car parsed) - (cdr (assq sym replacement-alist)) - ;; If `sym' is not 'DOW and it is bound to nil - ;; in `replacement-alist', use `current'. - (unless (eq sym 'DOW) - (car current))))) - (setq result (cons v result))) - (setq parsed (cdr parsed)) - (setq current (cdr current)) - (setq sym-list (cdr sym-list))) - (reverse result))) - -(defun twittering-normalize-string (str) - (if (require 'ucs-normalize nil t) - (ucs-normalize-NFC-string str) - str)) - -;;;; -;;;; Utility for portability -;;;; - -(defun twittering-remove-duplicates (list) - "Return a copy of LIST with all duplicate elements removed. -This is non-destructive version of `delete-dups' which is not -defined in Emacs21." - (if (fboundp 'delete-dups) - (delete-dups (copy-sequence list)) - (let ((rest list) - (result nil)) - (while rest - (unless (member (car rest) result) - (setq result (cons (car rest) result))) - (setq rest (cdr rest))) - (nreverse result)))) - -(defun twittering-completing-read (prompt collection &optional predicate require-match initial-input hist def inherit-input-method) - "Read a string in the minibuffer, with completion. -This is a modified version of `completing-read' and accepts candidates -as a list of a string on Emacs21." - ;; completing-read() of Emacs21 does not accepts candidates as - ;; a list. Candidates must be given as an alist. - (let* ((collection (twittering-remove-duplicates collection)) - (collection - (if (and (> 22 emacs-major-version) - (listp collection) - (stringp (car collection))) - (mapcar (lambda (x) (cons x nil)) collection) - collection))) - (completing-read prompt collection predicate require-match - initial-input hist def inherit-input-method))) - -(defun twittering-add-to-history (history-var elt &optional maxelt keep-all) - (if (functionp 'add-to-history) - (add-to-history history-var elt maxelt keep-all) - (let* ((added (cons elt - (if (and (not keep-all) - (boundp 'history-delete-duplicates) - history-delete-duplicates) - (delete elt (symbol-value history-var)) - (symbol-value history-var)))) - (maxelt (or maxelt history-length)) - (len (length added))) - (set history-var - (if (<= len maxelt) - added - (butlast added (- len maxelt))))))) - -(if (fboundp 'assoc-string) - (defalias 'twittering-assoc-string 'assoc-string) - (defun twittering-assoc-string (key list &optional case-fold) - "Like `assoc' but specifically for strings (and symbols). -This returns the first element of LIST whose car matches the string or -symbol KEY, or nil if no match exists. When performing the -comparison, symbols are first converted to strings, and unibyte -strings to multibyte. If the optional arg CASE-FOLD is non-nil, case -is ignored. - -Unlike `assoc', KEY can also match an entry in LIST consisting of a -single string, rather than a cons cell whose car is a string. - -This is reimplemented version of `assoc-string' which is not -defined in Emacs21." - (let* ((key (if (stringp key) - key - (symbol-name key))) - (regexp (concat "\\`" key "\\'")) - (rest list) - (result nil) - (case-fold-search case-fold)) - (while (not (null rest)) - (let* ((current (car rest)) - (current-key - (if (listp current) - (car current) - current)) - (current-key - (if (stringp current-key) - current-key - (symbol-name current-key)))) - (if (string-match key current-key) - (setq result current - rest nil) - (setq rest (cdr rest))))) - result))) - -;;;; -;;;; Debug mode -;;;; - -(defvar twittering-debug-mode nil) -(defvar twittering-debug-buffer "*debug*") - -(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 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 "[debug] " (prin1-to-string ,obsym)) - (newline) - ,obsym) - ,obsym)))) - -(defun debug-printf (fmt &rest args) - (when twittering-debug-mode - (with-current-buffer (twittering-debug-buffer) - (insert "[debug] " (apply 'format fmt args)) - (newline)))) - -(defun twittering-debug-mode () - (interactive) - (setq twittering-debug-mode - (not twittering-debug-mode)) - (message (if twittering-debug-mode "debug mode:on" "debug mode:off"))) - -;;;; -;;;; Proxy setting / functions -;;;; - -(defgroup twittering-proxy nil - "Subgroup handling `twittering-mode' proxy setup." - :group 'twittering-mode) - -(defcustom twittering-proxy-use nil - "*If non-nil, use PROXY. - -See also `twittering-proxy-server' for documentation." - :type 'boolean - :group 'twittering-mode) - -(defcustom twittering-proxy-server nil - "*Proxy server for `twittering-mode'. - -If both `twittering-proxy-server' and `twittering-proxy-port' are -non-nil, the variables `twittering-proxy-*' have priority over other -variables `twittering-http-proxy-*' or `twittering-https-proxy-*' -regardless of HTTP or HTTPS. - -To use individual proxies for HTTP and HTTPS, both `twittering-proxy-server' -and `twittering-proxy-port' must be nil." - :group 'twittering-proxy - :type '(choice (const nil) string)) - -(defcustom twittering-proxy-port nil - "*Port number for `twittering-mode'. - -If both `twittering-proxy-server' and `twittering-proxy-port' are -non-nil, the variables `twittering-proxy-*' have priority over other -variables `twittering-http-proxy-*' or `twittering-https-proxy-*' -regardless of HTTP or HTTPS. - -To use individual proxies for HTTP and HTTPS, both `twittering-proxy-server' -and `twittering-proxy-port' must be nil." - :group 'twittering-proxy - :type '(choice (const nil) - integer)) - -(defvar twittering-proxy-keep-alive nil) -(defcustom twittering-proxy-user nil - "*Username for `twittering-proxy-server'. - -NOTE: If both `twittering-proxy-server' and `twittering-proxy-port' are -non-nil, the variables `twittering-proxy-*' have priority over other -variables `twittering-http-proxy-*' or `twittering-https-proxy-*' -regardless of HTTP or HTTPS.") - -(defcustom twittering-proxy-password nil - "*Password for `twittering-proxy-server'. - -NOTE: If both `twittering-proxy-server' and `twittering-proxy-port' are -non-nil, the variables `twittering-proxy-*' have priority over other -variables `twittering-http-proxy-*' or `twittering-https-proxy-*' -regardless of HTTP or HTTPS." - :group 'twittering-proxy - :type '(choice (const nil) - string)) - -(defcustom twittering-http-proxy-server nil - "*HTTP proxy server for `twittering-mode'. -If nil, it is initialized on entering `twittering-mode'. -The port number is specified by `twittering-http-proxy-port'. -For HTTPS connection, the proxy specified by `twittering-https-proxy-server' -and `twittering-https-proxy-port' is used. - -NOTE: If both `twittering-proxy-server' and `twittering-proxy-port' are -non-nil, the variables `twittering-proxy-*' have priority over other -variables `twittering-http-proxy-*' or `twittering-https-proxy-*' -regardless of HTTP or HTTPS." - :group 'twittering-proxy - :type '(choice (const nil) - string)) - -(defcustom twittering-http-proxy-port nil - "*Port number of a HTTP proxy server for `twittering-mode'. -If nil, it is initialized on entering `twittering-mode'. -The server is specified by `twittering-http-proxy-server'. -For HTTPS connection, the proxy specified by `twittering-https-proxy-server' -and `twittering-https-proxy-port' is used. - -NOTE: If both `twittering-proxy-server' and `twittering-proxy-port' are -non-nil, the variables `twittering-proxy-*' have priority over other -variables `twittering-http-proxy-*' or `twittering-https-proxy-*' -regardless of HTTP or HTTPS." - :group 'twittering-proxy - :type '(choice (const nil) - integer)) - -(defcustom twittering-http-proxy-keep-alive nil - "*If non-nil, the Keep-alive is enabled. This is experimental." - :group 'twittering-proxy - :type 'boolean) - -(defcustom twittering-http-proxy-user nil - "*Username for `twittering-http-proxy-server'. - -NOTE: If both `twittering-proxy-server' and `twittering-proxy-port' are -non-nil, the variables `twittering-proxy-*' have priority over other -variables `twittering-http-proxy-*' or `twittering-https-proxy-*' -regardless of HTTP or HTTPS." - :group 'twittering-proxy - :type '(choice (const nil) - string)) - -(defcustom twittering-http-proxy-password nil - "*Password for `twittering-http-proxy-server'. - -NOTE: If both `twittering-proxy-server' and `twittering-proxy-port' are -non-nil, the variables `twittering-proxy-*' have priority over other -variables `twittering-http-proxy-*' or `twittering-https-proxy-*' -regardless of HTTP or HTTPS." - :group 'twittering-proxy - :type '(choice (const nil) - string)) - -(defcustom twittering-https-proxy-server nil - "*HTTPS proxy server for `twittering-mode'. -If nil, it is initialized on entering `twittering-mode'. -The port number is specified by `twittering-https-proxy-port'. -For HTTP connection, the proxy specified by `twittering-http-proxy-server' -and `twittering-http-proxy-port' is used. - -NOTE: If both `twittering-proxy-server' and `twittering-proxy-port' are -non-nil, the variables `twittering-proxy-*' have priority over other -variables `twittering-http-proxy-*' or `twittering-https-proxy-*' -regardless of HTTP or HTTPS." - :group 'twittering-proxy - :type '(choice (const nil) - string)) - -(defcustom twittering-https-proxy-port nil - "*Port number of a HTTPS proxy server for `twittering-mode'. -If nil, it is initialized on entering `twittering-mode'. -The server is specified by `twittering-https-proxy-server'. -For HTTP connection, the proxy specified by `twittering-http-proxy-server' -and `twittering-http-proxy-port' is used. - -NOTE: If both `twittering-proxy-server' and `twittering-proxy-port' are -non-nil, the variables `twittering-proxy-*' have priority over other -variables `twittering-http-proxy-*' or `twittering-https-proxy-*' -regardless of HTTP or HTTPS." - :group 'twittering-proxy - :type '(choice (const nil) - integer)) - -(defcustom twittering-https-proxy-keep-alive nil - "*If non-nil, the Keep-alive is enabled. This is experimental." - :group 'twittering-proxy - :type 'boolean) - -(defcustom twittering-https-proxy-user nil - "*Username for `twittering-https-proxy-server'. - -NOTE: If both `twittering-proxy-server' and `twittering-proxy-port' are -non-nil, the variables `twittering-proxy-*' have priority over other -variables `twittering-http-proxy-*' or `twittering-https-proxy-*' -regardless of HTTP or HTTPS." - :group 'twittering-proxy - :type '(choice (const nil) - string)) - -(defcustom twittering-https-proxy-password nil - "*Password for `twittering-https-proxy-server'. - -NOTE: If both `twittering-proxy-server' and `twittering-proxy-port' are -non-nil, the variables `twittering-proxy-*' have priority over other -variables `twittering-http-proxy-*' or `twittering-https-proxy-*' -regardless of HTTP or HTTPS." - :group 'twittering-proxy - :type '(choice (const nil) - string)) - -(defun twittering-normalize-proxy-vars () - "Normalize the type of `twittering-http-proxy-port' and -`twittering-https-proxy-port'." - (mapc (lambda (sym) - (let ((value (symbol-value sym))) - (cond - ((null value) - nil) - ((integerp value) - nil) - ((stringp value) - (set sym (string-to-number value))) - (t - (set sym nil))))) - '(twittering-proxy-port - twittering-http-proxy-port - twittering-https-proxy-port))) - -(defun twittering-proxy-info (scheme &optional item) - "Return an alist for proxy configuration registered for SCHEME. -SCHEME must be a string \"http\", \"https\" or a symbol 'http or 'https. -The server name is a string and the port number is an integer." - (twittering-normalize-proxy-vars) - (let ((scheme (if (symbolp scheme) - (symbol-name scheme) - scheme)) - (info-list - `((("http" "https") - . ((server . ,twittering-proxy-server) - (port . ,twittering-proxy-port) - (keep-alive . ,twittering-proxy-keep-alive) - (user . ,twittering-proxy-user) - (password . ,twittering-proxy-password))) - (("http") - . ((server . ,twittering-http-proxy-server) - (port . ,twittering-http-proxy-port) - (keep-alive . ,twittering-http-proxy-keep-alive) - (user . ,twittering-http-proxy-user) - (password . ,twittering-http-proxy-password))) - (("https") - . ((server . ,twittering-https-proxy-server) - (port . ,twittering-https-proxy-port) - (keep-alive . ,twittering-https-proxy-keep-alive) - (user . ,twittering-https-proxy-user) - (password . ,twittering-https-proxy-password)))))) - (let ((info - (car (remove nil - (mapcar - (lambda (entry) - (when (member scheme (car entry)) - (let ((info (cdr entry))) - (when (and (cdr (assq 'server info)) - (cdr (assq 'port info))) - info)))) - info-list))))) - (if item - (cdr (assq item info)) - info)))) - -(defun twittering-url-proxy-services () - "Return the current proxy configuration for `twittering-mode' in the format -of `url-proxy-services'." - (remove nil (mapcar - (lambda (scheme) - (let ((server (twittering-proxy-info scheme 'server)) - (port (twittering-proxy-info scheme 'port))) - (when (and server port) - `(,scheme . ,(format "%s:%s" server port))))) - '("http" "https")))) - -(defun twittering-find-proxy (scheme) - "Find proxy server and its port from the environmental variables and return -a cons pair of them. -SCHEME must be \"http\" or \"https\"." - (cond - ((require 'url-methods nil t) - (url-scheme-register-proxy scheme) - (let* ((proxy-service (assoc scheme url-proxy-services)) - (proxy (if proxy-service (cdr proxy-service) nil))) - (if (and proxy - (string-match "^\\([^:]+\\):\\([0-9]+\\)$" proxy)) - (let ((host (match-string 1 proxy)) - (port (string-to-number (match-string 2 proxy)))) - (cons host port)) - nil))) - (t - (let* ((env-var (concat scheme "_proxy")) - (env-proxy (or (getenv (upcase env-var)) - (getenv (downcase env-var)))) - (default-port (if (string= "https" scheme) "443" "80"))) - (if (and env-proxy - (string-match - "^\\(https?://\\)?\\([^:/]+\\)\\(:\\([0-9]+\\)\\)?/?$" - env-proxy)) - (let* ((host (match-string 2 env-proxy)) - (port-str (or (match-string 4 env-proxy) default-port)) - (port (string-to-number port-str))) - (cons host port)) - nil))))) - -(defun twittering-setup-proxy () - (when (require 'url-methods nil t) - ;; If `url-scheme-registry' is not initialized, - ;; `url-proxy-services' will be reset by calling - ;; `url-insert-file-contents' or `url-retrieve-synchronously', etc. - ;; To avoid it, initialize `url-scheme-registry' by calling - ;; `url-scheme-get-property' before calling such functions. - (url-scheme-get-property "http" 'name) - (url-scheme-get-property "https" 'name)) - (unless (and twittering-http-proxy-server - twittering-http-proxy-port) - (let ((info (twittering-find-proxy "http"))) - (setq twittering-http-proxy-server (car-safe info)) - (setq twittering-http-proxy-port (cdr-safe info)))) - (unless (and twittering-https-proxy-server - twittering-https-proxy-port) - (let ((info (twittering-find-proxy "https"))) - (setq twittering-https-proxy-server (car-safe info)) - (setq twittering-https-proxy-port (cdr-safe info)))) - (if (and twittering-proxy-use - (null (twittering-proxy-info "http")) - (null (twittering-proxy-info "https"))) - (progn - (message "Disabling proxy due to lack of configuration.") - (setq twittering-proxy-use nil)) - t)) - -(defun twittering-toggle-proxy () - (interactive) - (setq twittering-proxy-use - (not twittering-proxy-use)) - (if (twittering-setup-proxy) - (message (if twittering-proxy-use "Use Proxy:on" "Use Proxy:off"))) - (twittering-update-mode-line)) - -;;;; -;;;; Functions for URL library -;;;; - -(defcustom twittering-url-show-status nil - "*If non-nil, show a running total of bytes transferred by urllib. - -This has effect only if either \"urllib-httpp\" or \"urllib-https\" is used -as the connection method." - :group 'twittering-mode - :type 'boolean) - -;;;; -;;;; CA certificate -;;;; - -(defvar twittering-cert-file nil - "The full-path of the file including the certificates authorizing -servers on SSL.") - -(defconst twittering-ca-cert-list - '( -;; #BEGIN-CERTIFICATE -;; Verisign Class 3 Public Primary Certification Authority - G3 -;; issuer= /C=US/O=VeriSign, Inc./OU=VeriSign Trust Network/OU=(c) 1999 VeriSign, Inc. - For authorized use only/CN=VeriSign Class 3 Public Primary Certification Authority - G3 -;; subject= /C=US/O=VeriSign, Inc./OU=VeriSign Trust Network/OU=(c) 1999 VeriSign, Inc. - For authorized use only/CN=VeriSign Class 3 Public Primary Certification Authority - G3 -;; serial=9B7E0649A33E62B9D5EE90487129EF57 -;; SHA1 Fingerprint=13:2D:0D:45:53:4B:69:97:CD:B2:D5:C3:39:E2:55:76:60:9B:5C:C6 -;; notBefore=Oct 1 00:00:00 1999 GMT -;; notAfter=Jul 16 23:59:59 2036 GMT -"-----BEGIN CERTIFICATE----- -MIIEGjCCAwICEQCbfgZJoz5iudXukEhxKe9XMA0GCSqGSIb3DQEBBQUAMIHKMQsw -CQYDVQQGEwJVUzEXMBUGA1UEChMOVmVyaVNpZ24sIEluYy4xHzAdBgNVBAsTFlZl -cmlTaWduIFRydXN0IE5ldHdvcmsxOjA4BgNVBAsTMShjKSAxOTk5IFZlcmlTaWdu -LCBJbmMuIC0gRm9yIGF1dGhvcml6ZWQgdXNlIG9ubHkxRTBDBgNVBAMTPFZlcmlT -aWduIENsYXNzIDMgUHVibGljIFByaW1hcnkgQ2VydGlmaWNhdGlvbiBBdXRob3Jp -dHkgLSBHMzAeFw05OTEwMDEwMDAwMDBaFw0zNjA3MTYyMzU5NTlaMIHKMQswCQYD -VQQGEwJVUzEXMBUGA1UEChMOVmVyaVNpZ24sIEluYy4xHzAdBgNVBAsTFlZlcmlT -aWduIFRydXN0IE5ldHdvcmsxOjA4BgNVBAsTMShjKSAxOTk5IFZlcmlTaWduLCBJ -bmMuIC0gRm9yIGF1dGhvcml6ZWQgdXNlIG9ubHkxRTBDBgNVBAMTPFZlcmlTaWdu -IENsYXNzIDMgUHVibGljIFByaW1hcnkgQ2VydGlmaWNhdGlvbiBBdXRob3JpdHkg -LSBHMzCCASIwDQYJKoZIhvcNAQEBBQADggEPADCCAQoCggEBAMu6nFL8eB8aHm8b -N3O9+MlrlBIwT/A2R/XQkQr1F8ilYcEWQE37imGQ5XYgwREGfassbqb1EUGO+i2t -KmFZpGcmTNDovFJbcCAEWNF6yaRpvIMXZK0Fi7zQWM6NjPXr8EJJC52XJ2cybuGu -kxUccLwgTS8Y3pKI6GyFVxEa6X7jJhFUokWWVYPKMIno3Nij7SqAP395ZVc+FSBm -CC+Vk7+qRy+oRpfwEuL+wgorUeZ25rdGt+INpsyow0xZVYnm6FNcHOqd8GIWC6fJ -Xwzw3sJ2zq/3avL6QaaiMxTJ5Xpj055iN9WFZZ4O5lMkdBteHRJTW8cs54NJOxWu -imi5V5cCAwEAATANBgkqhkiG9w0BAQUFAAOCAQEAERSWwauSCPc/L8my/uRan2Te -2yFPhpk0djZX3dAVL8WtfxUfN2JzPtTnX84XA9s1+ivbrmAJXx5fj267Cz3qWhMe -DGBvtcC1IyIuBwvLqXTLR7sdwdela8wv0kL9Sd2nic9TutoAWii/gt/4uhMdUIaC -/Y4wjylGsB49Ndo4YhYYSq3mtlFs3q9i6wHQHiT+eo8SGhJouPtmmRQURVyu565p -F4ErWjfJXir0xuKhXFSbplQAz/DxwceYMBo7Nhbbo27q/a2ywtrvAkcTisDxszGt -TxzhT5yvDwyd93gN2PQ1VoDat20Xj50egWTh/sVFuq1ruQp6Tk9LhO5L8X3dEQ== ------END CERTIFICATE----- -" -;; GeoTrust Global CA -;; issuer= /C=US/O=GeoTrust Inc./CN=GeoTrust Global CA -;; subject= /C=US/O=GeoTrust Inc./CN=GeoTrust Global CA -;; serial=023456 -;; SHA1 Fingerprint=DE:28:F4:A4:FF:E5:B9:2F:A3:C5:03:D1:A3:49:A7:F9:96:2A:82:12 -;; notBefore=May 21 04:00:00 2002 GMT -;; notAfter=May 21 04:00:00 2022 GMT -"-----BEGIN CERTIFICATE----- -MIIDVDCCAjygAwIBAgIDAjRWMA0GCSqGSIb3DQEBBQUAMEIxCzAJBgNVBAYTAlVT -MRYwFAYDVQQKEw1HZW9UcnVzdCBJbmMuMRswGQYDVQQDExJHZW9UcnVzdCBHbG9i -YWwgQ0EwHhcNMDIwNTIxMDQwMDAwWhcNMjIwNTIxMDQwMDAwWjBCMQswCQYDVQQG -EwJVUzEWMBQGA1UEChMNR2VvVHJ1c3QgSW5jLjEbMBkGA1UEAxMSR2VvVHJ1c3Qg -R2xvYmFsIENBMIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEA2swYYzD9 -9BcjGlZ+W988bDjkcbd4kdS8odhM+KhDtgPpTSEHCIjaWC9mOSm9BXiLnTjoBbdq -fnGk5sRgprDvgOSJKA+eJdbtg/OtppHHmMlCGDUUna2YRpIuT8rxh0PBFpVXLVDv -iS2Aelet8u5fa9IAjbkU+BQVNdnARqN7csiRv8lVK83Qlz6cJmTM386DGXHKTubU -1XupGc1V3sjs0l44U+VcT4wt/lAjNvxm5suOpDkZALeVAjmRCw7+OC7RHQWa9k0+ -bw8HHa8sHo9gOeL6NlMTOdReJivbPagUvTLrGAMoUgRx5aszPeE4uwc2hGKceeoW -MPRfwCvocWvk+QIDAQABo1MwUTAPBgNVHRMBAf8EBTADAQH/MB0GA1UdDgQWBBTA -ephojYn7qwVkDBF9qn1luMrMTjAfBgNVHSMEGDAWgBTAephojYn7qwVkDBF9qn1l -uMrMTjANBgkqhkiG9w0BAQUFAAOCAQEANeMpauUvXVSOKVCUn5kaFOSPeCpilKIn -Z57QzxpeR+nBsqTP3UEaBU6bS+5Kb1VSsyShNwrrZHYqLizz/Tt1kL/6cdjHPTfS -tQWVYrmm3ok9Nns4d0iXrKYgjy6myQzCsplFAMfOEVEiIuCl6rYVSAlk6l5PdPcF -PseKUgzbFbS9bZvlxrFUaKnjaZC2mqUPuLk/IH2uSrW4nOQdtqvmlKXBx4Ot2/Un -hw4EbNX/3aBd7YdStysVAq45pmp06drE57xNNB6pXE0zX5IJL4hmXXeXxx12E6nV -5fEWCRE11azbJHFwLJhWC9kXtNHjUStedejV0NxPNO3CBWaAocvmMw== ------END CERTIFICATE----- -" -;; DigiCert High Assurance EV Root CA -;; issuer= /C=US/O=DigiCert Inc/OU=www.digicert.com/CN=DigiCert High Assurance EV Root CA -;; subject= /C=US/O=DigiCert Inc/OU=www.digicert.com/CN=DigiCert High Assurance EV Root CA -;; serial=02AC5C266A0B409B8F0B79F2AE462577 -;; SHA1 Fingerprint=5F:B7:EE:06:33:E2:59:DB:AD:0C:4C:9A:E6:D3:8F:1A:61:C7:DC:25 -;; notBefore=Nov 10 00:00:00 2006 GMT -;; notAfter=Nov 10 00:00:00 2031 GMT -"-----BEGIN CERTIFICATE----- -MIIDxTCCAq2gAwIBAgIQAqxcJmoLQJuPC3nyrkYldzANBgkqhkiG9w0BAQUFADBs -MQswCQYDVQQGEwJVUzEVMBMGA1UEChMMRGlnaUNlcnQgSW5jMRkwFwYDVQQLExB3 -d3cuZGlnaWNlcnQuY29tMSswKQYDVQQDEyJEaWdpQ2VydCBIaWdoIEFzc3VyYW5j -ZSBFViBSb290IENBMB4XDTA2MTExMDAwMDAwMFoXDTMxMTExMDAwMDAwMFowbDEL -MAkGA1UEBhMCVVMxFTATBgNVBAoTDERpZ2lDZXJ0IEluYzEZMBcGA1UECxMQd3d3 -LmRpZ2ljZXJ0LmNvbTErMCkGA1UEAxMiRGlnaUNlcnQgSGlnaCBBc3N1cmFuY2Ug -RVYgUm9vdCBDQTCCASIwDQYJKoZIhvcNAQEBBQADggEPADCCAQoCggEBAMbM5XPm -+9S75S0tMqbf5YE/yc0lSbZxKsPVlDRnogocsF9ppkCxxLeyj9CYpKlBWTrT3JTW -PNt0OKRKzE0lgvdKpVMSOO7zSW1xkX5jtqumX8OkhPhPYlG++MXs2ziS4wblCJEM -xChBVfvLWokVfnHoNb9Ncgk9vjo4UFt3MRuNs8ckRZqnrG0AFFoEt7oT61EKmEFB -Ik5lYYeBQVCmeVyJ3hlKV9Uu5l0cUyx+mM0aBhakaHPQNAQTXKFx01p8VdteZOE3 -hzBWBOURtCmAEvF5OYiiAhF8J2a3iLd48soKqDirCmTCv2ZdlYTBoSUeh10aUAsg -EsxBu24LUTi4S8sCAwEAAaNjMGEwDgYDVR0PAQH/BAQDAgGGMA8GA1UdEwEB/wQF -MAMBAf8wHQYDVR0OBBYEFLE+w2kD+L9HAdSYJhoIAu9jZCvDMB8GA1UdIwQYMBaA -FLE+w2kD+L9HAdSYJhoIAu9jZCvDMA0GCSqGSIb3DQEBBQUAA4IBAQAcGgaX3Nec -nzyIZgYIVyHbIUf4KmeqvxgydkAQV8GK83rZEWWONfqe/EW1ntlMMUu4kehDLI6z -eM7b41N5cdblIZQB2lWHmiRk9opmzN6cN82oNLFpmyPInngiK3BD41VHMWEZ71jF -hS9OMPagMRYjyOfiZRYzy78aG6A9+MpeizGLYAiJLQwGXFK3xPkKmNEVX58Svnw2 -Yzi9RKR/5CYrCsSXaQ3pjOLAEFe4yHYSkVXySGnYvCoCWw9E1CAx2/S6cCZdkGCe -vEsXCS+0yx5DaMkHJ8HSXPfqIbloEpw8nL+e/IBcm2PN7EeqJSdnoDfzAIJ9VNep -+OkuE6N36B9K ------END CERTIFICATE----- -" -;; VeriSign Class 3 Public Primary Certification Authority - G5 -;; issuer= /C=US/O=VeriSign, Inc./OU=VeriSign Trust Network/OU=(c) 2006 VeriSign, Inc. - For authorized use only/CN=VeriSign Class 3 Public Primary Certification Authority - G5 -;; subject= /C=US/O=VeriSign, Inc./OU=VeriSign Trust Network/OU=(c) 2006 VeriSign, Inc. - For authorized use only/CN=VeriSign Class 3 Public Primary Certification Authority - G5 -;; serial=18DAD19E267DE8BB4A2158CDCC6B3B4A -;; SHA1 Fingerprint=4E:B6:D5:78:49:9B:1C:CF:5F:58:1E:AD:56:BE:3D:9B:67:44:A5:E5 -;; notBefore=Nov 8 00:00:00 2006 GMT -;; notAfter=Jul 16 23:59:59 2036 GMT -"-----BEGIN CERTIFICATE----- -MIIE0zCCA7ugAwIBAgIQGNrRniZ96LtKIVjNzGs7SjANBgkqhkiG9w0BAQUFADCB -yjELMAkGA1UEBhMCVVMxFzAVBgNVBAoTDlZlcmlTaWduLCBJbmMuMR8wHQYDVQQL -ExZWZXJpU2lnbiBUcnVzdCBOZXR3b3JrMTowOAYDVQQLEzEoYykgMjAwNiBWZXJp -U2lnbiwgSW5jLiAtIEZvciBhdXRob3JpemVkIHVzZSBvbmx5MUUwQwYDVQQDEzxW -ZXJpU2lnbiBDbGFzcyAzIFB1YmxpYyBQcmltYXJ5IENlcnRpZmljYXRpb24gQXV0 -aG9yaXR5IC0gRzUwHhcNMDYxMTA4MDAwMDAwWhcNMzYwNzE2MjM1OTU5WjCByjEL -MAkGA1UEBhMCVVMxFzAVBgNVBAoTDlZlcmlTaWduLCBJbmMuMR8wHQYDVQQLExZW -ZXJpU2lnbiBUcnVzdCBOZXR3b3JrMTowOAYDVQQLEzEoYykgMjAwNiBWZXJpU2ln -biwgSW5jLiAtIEZvciBhdXRob3JpemVkIHVzZSBvbmx5MUUwQwYDVQQDEzxWZXJp -U2lnbiBDbGFzcyAzIFB1YmxpYyBQcmltYXJ5IENlcnRpZmljYXRpb24gQXV0aG9y -aXR5IC0gRzUwggEiMA0GCSqGSIb3DQEBAQUAA4IBDwAwggEKAoIBAQCvJAgIKXo1 -nmAMqudLO07cfLw8RRy7K+D+KQL5VwijZIUVJ/XxrcgxiV0i6CqqpkKzj/i5Vbex -t0uz/o9+B1fs70PbZmIVYc9gDaTY3vjgw2IIPVQT60nKWVSFJuUrjxuf6/WhkcIz -SdhDY2pSS9KP6HBRTdGJaXvHcPaz3BJ023tdS1bTlr8Vd6Gw9KIl8q8ckmcY5fQG -BO+QueQA5N06tRn/Arr0PO7gi+s3i+z016zy9vA9r911kTMZHRxAy3QkGSGT2RT+ -rCpSx4/VBEnkjWNHiDxpg8v+R70rfk/Fla4OndTRQ8Bnc+MUCH7lP59zuDMKz10/ -NIeWiu5T6CUVAgMBAAGjgbIwga8wDwYDVR0TAQH/BAUwAwEB/zAOBgNVHQ8BAf8E -BAMCAQYwbQYIKwYBBQUHAQwEYTBfoV2gWzBZMFcwVRYJaW1hZ2UvZ2lmMCEwHzAH -BgUrDgMCGgQUj+XTGoasjY5rw8+AatRIGCx7GS4wJRYjaHR0cDovL2xvZ28udmVy -aXNpZ24uY29tL3ZzbG9nby5naWYwHQYDVR0OBBYEFH/TZafC3ey78DAJ80M5+gKv -MzEzMA0GCSqGSIb3DQEBBQUAA4IBAQCTJEowX2LP2BqYLz3q3JktvXf2pXkiOOzE -p6B4Eq1iDkVwZMXnl2YtmAl+X6/WzChl8gGqCBpH3vn5fJJaCGkgDdk+bW48DW7Y -5gaRQBi5+MHt39tBquCWIMnNZBU4gcmU7qKEKQsTb47bDN0lAtukixlE0kF6BWlK -WE9gyn6CagsCqiUXObXbf+eEZSqVir2G3l6BFoMtEMze/aiCKm0oHw0LxOXnGiYZ -4fQRbxC1lfznQgUy286dUV4otp6F01vvpX1FQHKOtw5rDgb7MzVIcbidJ4vEZV8N -hnacRHr2lVz2XTIIM6RUthg/aFzyQkqFOFSDX9HoLPKsEdao7WNq ------END CERTIFICATE----- -" -;; VeriSign Universal Root Certification Authority -;; issuer= /C=US/O=VeriSign, Inc./OU=VeriSign Trust Network/OU=(c) 2008 VeriSign, Inc. - For authorized use only/CN=VeriSign Universal Root Certification Authority -;; subject= /C=US/O=VeriSign, Inc./OU=VeriSign Trust Network/OU=(c) 2008 VeriSign, Inc. - For authorized use only/CN=VeriSign Universal Root Certification Authority -;; serial=401AC46421B31321030EBBE4121AC51D -;; SHA1 Fingerprint=36:79:CA:35:66:87:72:30:4D:30:A5:FB:87:3B:0F:A7:7B:B7:0D:54 -;; notBefore=Apr 2 00:00:00 2008 GMT -;; notAfter=Dec 1 23:59:59 2037 GMT -"-----BEGIN CERTIFICATE----- -MIIEuTCCA6GgAwIBAgIQQBrEZCGzEyEDDrvkEhrFHTANBgkqhkiG9w0BAQsFADCB -vTELMAkGA1UEBhMCVVMxFzAVBgNVBAoTDlZlcmlTaWduLCBJbmMuMR8wHQYDVQQL -ExZWZXJpU2lnbiBUcnVzdCBOZXR3b3JrMTowOAYDVQQLEzEoYykgMjAwOCBWZXJp -U2lnbiwgSW5jLiAtIEZvciBhdXRob3JpemVkIHVzZSBvbmx5MTgwNgYDVQQDEy9W -ZXJpU2lnbiBVbml2ZXJzYWwgUm9vdCBDZXJ0aWZpY2F0aW9uIEF1dGhvcml0eTAe -Fw0wODA0MDIwMDAwMDBaFw0zNzEyMDEyMzU5NTlaMIG9MQswCQYDVQQGEwJVUzEX -MBUGA1UEChMOVmVyaVNpZ24sIEluYy4xHzAdBgNVBAsTFlZlcmlTaWduIFRydXN0 -IE5ldHdvcmsxOjA4BgNVBAsTMShjKSAyMDA4IFZlcmlTaWduLCBJbmMuIC0gRm9y -IGF1dGhvcml6ZWQgdXNlIG9ubHkxODA2BgNVBAMTL1ZlcmlTaWduIFVuaXZlcnNh -bCBSb290IENlcnRpZmljYXRpb24gQXV0aG9yaXR5MIIBIjANBgkqhkiG9w0BAQEF -AAOCAQ8AMIIBCgKCAQEAx2E3XrEBNNti1xWb/1hajCMj1mCOkdeQmIN65lgZOIzF -9uVkhbSicfvtvbnazU0AtMgtc6XHaXGVHzk8skQHnOgO+k1KxCHfKWGPMiJhgsWH -H26MfF8WIFFE0XBPV+rjHOPMee5Y2A7Cs0WTwCznmhcrewA3ekEzeOEz4vMQGn+H -LL729fdC4uW/h2KJXwBL38Xd5HVEMkE6HnFuacsLdUYI0crSK5XQz/u5QGtkjFdN -/BMReYTtXlT2NJ8IAfMQJQYXStrxHXpma5hgZqTZ79IugvHw7wnqRMkVauIDbjPT -rJ9VAMf2CGqUuV/c4DPxhGD5WycRtPwW8rtWaoAljQIDAQABo4GyMIGvMA8GA1Ud -EwEB/wQFMAMBAf8wDgYDVR0PAQH/BAQDAgEGMG0GCCsGAQUFBwEMBGEwX6FdoFsw -WTBXMFUWCWltYWdlL2dpZjAhMB8wBwYFKw4DAhoEFI/l0xqGrI2Oa8PPgGrUSBgs -exkuMCUWI2h0dHA6Ly9sb2dvLnZlcmlzaWduLmNvbS92c2xvZ28uZ2lmMB0GA1Ud -DgQWBBS2d/ppSEefUxLVwuoHMnYH0ZcHGTANBgkqhkiG9w0BAQsFAAOCAQEASvj4 -sAPmLGd75JR3Y8xuTPl9Dg3cyLk1uXBPY/ok+myDjEedO2Pzmvl2MpWRsXe8rJq+ -seQxIcaBlVZaDrHC1LGmWazxY8u4TB1ZkErvkBYoH1quEPuBUDgMbMzxPcP1Y+Oz -4yHJJDnp/RVmRvQbEdBNc6N9Rvk97ahfYtTxP/jgdFcrGJ2BtMQo2pSXpXDrrB2+ -BxHw1dvd5Yzw1TKwg+ZX4o+/vqGqvz0dtdQ46tewXDpPaj+PwGZsY6rp2aQW9IHR -lRQOfc2VNNnSj3BzgXucfr2YYdhFh5iQxeuGMMY1v/D/w1WIg0vvBZIGcfK4mJO3 -7M2CYfE45k+XmCpajQ== ------END CERTIFICATE----- -" -;; VeriSign Class 3 Public Primary Certification Authority - G4 -;; issuer= /C=US/O=VeriSign, Inc./OU=VeriSign Trust Network/OU=(c) 2007 VeriSign, Inc. - For authorized use only/CN=VeriSign Class 3 Public Primary Certification Authority - G4 -;; subject= /C=US/O=VeriSign, Inc./OU=VeriSign Trust Network/OU=(c) 2007 VeriSign, Inc. - For authorized use only/CN=VeriSign Class 3 Public Primary Certification Authority - G4 -;; serial=2F80FE238C0E220F486712289187ACB3 -;; SHA1 Fingerprint=22:D5:D8:DF:8F:02:31:D1:8D:F7:9D:B7:CF:8A:2D:64:C9:3F:6C:3A -;; notBefore=Nov 5 00:00:00 2007 GMT -;; notAfter=Jan 18 23:59:59 2038 GMT -"-----BEGIN CERTIFICATE----- -MIIDhDCCAwqgAwIBAgIQL4D+I4wOIg9IZxIokYesszAKBggqhkjOPQQDAzCByjEL -MAkGA1UEBhMCVVMxFzAVBgNVBAoTDlZlcmlTaWduLCBJbmMuMR8wHQYDVQQLExZW -ZXJpU2lnbiBUcnVzdCBOZXR3b3JrMTowOAYDVQQLEzEoYykgMjAwNyBWZXJpU2ln -biwgSW5jLiAtIEZvciBhdXRob3JpemVkIHVzZSBvbmx5MUUwQwYDVQQDEzxWZXJp -U2lnbiBDbGFzcyAzIFB1YmxpYyBQcmltYXJ5IENlcnRpZmljYXRpb24gQXV0aG9y -aXR5IC0gRzQwHhcNMDcxMTA1MDAwMDAwWhcNMzgwMTE4MjM1OTU5WjCByjELMAkG -A1UEBhMCVVMxFzAVBgNVBAoTDlZlcmlTaWduLCBJbmMuMR8wHQYDVQQLExZWZXJp -U2lnbiBUcnVzdCBOZXR3b3JrMTowOAYDVQQLEzEoYykgMjAwNyBWZXJpU2lnbiwg -SW5jLiAtIEZvciBhdXRob3JpemVkIHVzZSBvbmx5MUUwQwYDVQQDEzxWZXJpU2ln -biBDbGFzcyAzIFB1YmxpYyBQcmltYXJ5IENlcnRpZmljYXRpb24gQXV0aG9yaXR5 -IC0gRzQwdjAQBgcqhkjOPQIBBgUrgQQAIgNiAASnVnp8Utpkmw4tXNherJI9/gHm -GUo9FANL+mAnINmDiWn6VMaaGF5VKmTeBvaNSjutEDxlPZCIBIngMGGzrl0Bp3ve -fLK+ymVhAIau2o970ImtTR1ZmkGxvEeA3J5iw/mjgbIwga8wDwYDVR0TAQH/BAUw -AwEB/zAOBgNVHQ8BAf8EBAMCAQYwbQYIKwYBBQUHAQwEYTBfoV2gWzBZMFcwVRYJ -aW1hZ2UvZ2lmMCEwHzAHBgUrDgMCGgQUj+XTGoasjY5rw8+AatRIGCx7GS4wJRYj -aHR0cDovL2xvZ28udmVyaXNpZ24uY29tL3ZzbG9nby5naWYwHQYDVR0OBBYEFLMW -kf3upm7ktS5Jj4d4gYDs5bG1MAoGCCqGSM49BAMDA2gAMGUCMGYhDBgmYFo4e1ZC -4Kf8NoRRkSAsdk1DPcQdhCPQrNZ8NQbOzWm9kA3bbEhCHQ6qQgIxAJw9SDkjOVga -FRJZap7v1VmyHVIsmXHNxynfGyphe3HR3vPA5Q06Sqotp9iGKt0uEA== ------END CERTIFICATE----- -" -;; #END-CERTIFICATE -)) - -(defun twittering-delete-ca-cert () - (when (and twittering-cert-file - (file-exists-p twittering-cert-file)) - (delete-file twittering-cert-file)) - (setq twittering-cert-file nil)) - -(defun twittering-ensure-ca-cert () - "Return a full-path of the file including CA certificates. - -If it does not exist, create it. The directory includes root certificates -in \"hash format\". In detail, see verify(1SSL)." - (unless twittering-cert-file - (let ((coding-system-for-write 'iso-safe) - (file (make-temp-file "twmode-cacert"))) - (with-temp-file file - (apply 'insert twittering-ca-cert-list)) - (setq twittering-cert-file file) - (add-hook 'kill-emacs-hook 'twittering-delete-ca-cert))) - twittering-cert-file) - -;;;; -;;;; User agent -;;;; - -(defvar twittering-user-agent-function 'twittering-user-agent-default-function) - -(defun twittering-user-agent-default-function () - "Twittering mode default User-Agent function." - (format "Emacs/%d.%d Twittering-mode/%s" - emacs-major-version emacs-minor-version - twittering-mode-version)) - -(defun twittering-user-agent () - "Return User-Agent header string." - (funcall twittering-user-agent-function)) - -;;;; -;;;; Basic HTTP functions (general) -;;;; - -(defun twittering-percent-encode (str &optional coding-system) - "Encode STR according to Percent-Encoding defined in RFC 3986." - (twittering-oauth-url-encode str coding-system)) - -(defun twittering-lookup-connection-type (use-ssl &optional order table) - "Return available entry extracted fron connection type table. -TABLE is connection type table, which is an alist of type symbol and its -item alist, such as - '((native (check . t) - (https . twittering-start-http-session-native-tls-p) - (start . twittering-start-http-session-native)) - (curl (check . twittering-start-http-session-curl-p) - (https . twittering-start-http-session-curl-https-p) - (start . twittering-start-http-session-curl))) . -ORDER means the priority order of type symbols. -If USE-SSL is nil, the item `https' is ignored. -When the type `curl' has priority and is available for the above table, -the function returns - '((check . twittering-start-http-session-curl-p) - (https . twittering-start-http-session-curl-https-p) - (start . twittering-start-http-session-curl)) ." - (let ((rest (or order twittering-connection-type-order)) - (table (or table twittering-connection-type-table)) - (result nil)) - (while (and rest (null result)) - (let* ((candidate (car rest)) - (entry (cons `(symbol . ,candidate) - (cdr (assq candidate table)))) - (entry (if (assq 'display-name entry) - entry - (cons `(display-name . ,(symbol-name candidate)) - entry))) - (validate (lambda (item) - (let ((v (cdr (assq item entry)))) - (or (null v) (eq t v) (functionp v))))) - (confirm (lambda (item) - (let ((v (cdr (assq item entry)))) - (cond - ((null v) nil) - ((eq t v) t) - ((functionp v) (funcall v))))))) - (if (and (funcall validate 'check) - (or (not use-ssl) (funcall validate 'https))) - (cond - ((and (funcall confirm 'check) - (or (not use-ssl) (funcall confirm 'https))) - (setq rest nil) - (setq result entry)) - (t - (setq rest (cdr rest)))) - (message "The configuration for conncetion type `%s' is invalid." - candidate) - (setq rest nil)))) - result)) - -(defun twittering-get-connection-method-name (use-ssl) - "Return a name of the preferred connection method. -If USE-SSL is non-nil, return a connection method for HTTPS. -If USE-SSL is nil, return a connection method for HTTP." - (cdr (assq 'display-name (twittering-lookup-connection-type use-ssl)))) - -(defun twittering-lookup-http-start-function (&optional order table) - "Decide a connection method from currently available methods." - (let ((entry - (twittering-lookup-connection-type twittering-use-ssl order table))) - (cdr (assq 'send-http-request entry)))) - -(defun twittering-ensure-connection-method (&optional order table) - "Ensure a connection method with a compromise. -Return nil if no connection methods are available with a compromise." - (let* ((use-ssl (or twittering-use-ssl twittering-oauth-use-ssl)) - (entry (twittering-lookup-connection-type use-ssl order table))) - (cond - (entry - t) - ((and (null entry) use-ssl - (yes-or-no-p "HTTPS(SSL) is unavailable. Use HTTP instead? ")) - ;; Fall back on connection without SSL. - (setq twittering-use-ssl nil) - (setq twittering-oauth-use-ssl nil) - (twittering-update-mode-line) - (twittering-ensure-connection-method order table)) - (t - (message "No connection methods are available.") - nil)))) - -(defun twittering-make-http-request (method header-list host port path query-parameters post-body use-ssl) - "Returns an alist specifying a HTTP request. -METHOD specifies HTTP method. It must be \"GET\" or \"POST\". -HEADER-LIST is a list of (field-name . field-value) specifying HTTP header -fields. The fields \"Host\", \"User-Agent\" and \"Content-Length\" are -automatically filled if necessary. -HOST specifies the host. -PORT specifies the port. This must be an integer. -PATH specifies the absolute path in URI (without query string). -QUERY-PARAMTERS is a string or an alist. -If QUERY-PARAMTERS is a string, it is treated as an encoded query string. -If QUERY-PARAMTERS is an alist, it represents a list of cons pairs of -string, (query-key . query-value). -POST-BODY specifies the post body sent when METHOD equals to \"POST\". -If POST-BODY is nil, no body is posted. -If USE-SSL is non-nil, the request is performed with SSL. - -The result alist includes the following keys, where a key is a symbol. - method: HTTP method such as \"GET\" or \"POST\". - scheme: the scheme name. \"http\" or \"https\". - host: the host to which the request is sent. - port: the port to which the request is sent (integer). - path: the absolute path string. Note that it does not include query string. - query-string: the query string. - encoded-query-alist: the alist consisting of pairs of encoded query-name and - encoded query-value. - uri: the URI. It includes the query string. - uri-without-query: the URI without the query string. - header-list: an alist specifying pairs of a parameter and its value in HTTP - header field. - post-body: the entity that will be posted." - (let* ((scheme (if use-ssl "https" "http")) - (default-port (if use-ssl 443 80)) - (port (if port port default-port)) - (query-string - (cond - ((stringp query-parameters) - query-parameters) - ((consp query-parameters) - (mapconcat (lambda (pair) - (cond - ((stringp pair) - (twittering-percent-encode pair)) - ((consp pair) - (format - "%s=%s" - (twittering-percent-encode (car pair)) - (twittering-percent-encode (cdr pair)))) - (t - nil))) - query-parameters - "&")) - (t - nil))) - (encoded-query-alist - (cond - ((stringp query-parameters) - ;; Query name and its value must be already encoded. - (mapcar (lambda (str) - (if (string-match "=" str) - (let ((key (substring str 0 (match-beginning 0))) - (value (substring str (match-end 0)))) - `(,key . ,value)) - `(,str . nil))) - (split-string query-parameters "&"))) - ((consp query-parameters) - (mapcar (lambda (pair) - (cond - ((stringp pair) - (cons (twittering-percent-encode pair) nil)) - ((consp pair) - (cons (twittering-percent-encode (car pair)) - (twittering-percent-encode (cdr pair)))) - (t - nil))) - query-parameters)) - (t - nil))) - (uri-without-query - (concat scheme "://" - host - (when (and port (not (= port default-port))) - (format ":%d" port)) - path)) - (uri - (if query-string - (concat uri-without-query "?" query-string) - uri-without-query)) - (header-list - `(,@(when (and (string= method "POST") - (not (assoc "Content-Length" header-list))) - `(("Content-Length" . ,(format "%d" (length post-body))))) - ,@(unless (assoc "Host" header-list) - `(("Host" . ,host))) - ,@(unless (assoc "User-Agent" header-list) - `(("User-Agent" . ,(twittering-user-agent)))) - ,@header-list))) - (cond - ((not (member method '("POST" "GET"))) - (error "Unknown HTTP method: %s" method) - nil) - ((not (string-match "^/" path)) - (error "Invalid HTTP path: %s" path) - nil) - (t - `((method . ,method) - (scheme . ,scheme) - (host . ,host) - (port . ,port) - (path . ,path) - (query-string . ,query-string) - (encoded-query-alist . ,encoded-query-alist) - (uri . ,uri) - (uri-without-query . ,uri-without-query) - (header-list . ,header-list) - (post-body . ,post-body)))))) - -(defun twittering-make-http-request-from-uri (method header-list uri &optional post-body) - "Returns an alist specifying a HTTP request. -The result alist has the same form as an alist generated by -`twittering-make-http-request'. - -METHOD specifies HTTP method. It must be \"GET\" or \"POST\". -HEADER-LIST is a list of (field-name . field-value) specifying HTTP header -fields. The fields \"Host\" and \"User-Agent\" are automatically filled -if necessary. -URI specifies the URI including query string. -POST-BODY specifies the post body sent when METHOD equals to \"POST\". -If POST-BODY is nil, no body is posted." - (let* ((parts-alist - (let ((parsed-url (url-generic-parse-url uri))) - ;; This is required for the difference of url library - ;; distributed with Emacs 22 and 23. - (cond - ((and (fboundp 'url-p) (url-p parsed-url)) - ;; Emacs 23 and later. - `((scheme . ,(url-type parsed-url)) - (host . ,(url-host parsed-url)) - (port . ,(url-portspec parsed-url)) - (path . ,(url-filename parsed-url)))) - ((vectorp parsed-url) - ;; Emacs 22. - `((scheme . ,(aref parsed-url 0)) - (host . ,(aref parsed-url 3)) - (port . ,(aref parsed-url 4)) - (path . ,(aref parsed-url 5)))) - (t - nil)))) - (path (let ((path (cdr (assq 'path parts-alist)))) - (if (string-match "\\`\\(.*\\)\\?" path) - (match-string 1 path) - path))) - (query-string (let ((path (cdr (assq 'path parts-alist)))) - (if (string-match "\\?\\(.*\\)\\'" path) - (match-string 1 path) - nil)))) - (twittering-make-http-request method header-list - (cdr (assq 'host parts-alist)) - (cdr (assq 'port parts-alist)) - path - query-string - post-body - (string= "https" - (cdr (assq 'scheme parts-alist)))))) - -(defun twittering-make-connection-info (request &optional additional order table) - "Make an alist specifying the information of connection for REQUEST. -REQUEST must be an alist that has the same keys as that generated by -`twittering-make-http-request'. - -ADDITIONAL is appended to the tail of the result alist. -Following ADDITIONAL, an entry in TABLE is also appended to the result alist, -where `twittering-lookup-connection-type' determines the entry according to -the priority order ORDER. -If ORDER is nil, `twittering-connection-type-order' is used in place of ORDER. -If TABLE is nil, `twittering-connection-type-table' is used in place of TABLE. - -The parameter symbols are following: - use-ssl: whether SSL is enabled or not. - allow-insecure-server-cert: non-nil if an insecure server certificate is - allowed on SSL. - cacert-file-fullpath: the full-path of a file including the certificates - authorizing a server certificate on SSL. The file must be in PEM format. - use-proxy: non-nil if using a proxy. - proxy-server: a proxy server or nil. - proxy-port: a port for connecting the proxy (integer) or nil. - proxy-user: a username for connecting the proxy or nil. - proxy-password: a password for connecting the proxy or nil. - request: an alist specifying a HTTP request." - (let* ((order (or order twittering-connection-type-order)) - (table (or table twittering-connection-type-table)) - (scheme (cdr (assq 'scheme request))) - (use-ssl (string= "https" scheme)) - (entry (twittering-lookup-connection-type use-ssl order table))) - `((use-ssl . ,use-ssl) - (allow-insecure-server-cert - . ,twittering-allow-insecure-server-cert) - (cacert-file-fullpath - . ,(when use-ssl (twittering-ensure-ca-cert))) - (use-proxy . ,twittering-proxy-use) - ,@(when twittering-proxy-use - `((proxy-server . ,(twittering-proxy-info scheme 'server)) - (proxy-port . ,(twittering-proxy-info scheme 'port)) - (proxy-user . ,(twittering-proxy-info scheme 'user)) - (proxy-password . ,(twittering-proxy-info scheme 'password)))) - (request . ,request) - ,@additional - ,@entry))) - -(defun twittering-get-response-header (buffer) - "Extract HTTP response header from HTTP response. -BUFFER may be a buffer or the name of an existing buffer which contains the HTTP response." - (with-current-buffer buffer - (save-excursion - (goto-char (point-min)) - (if (search-forward-regexp "\r?\n\r?\n" nil t) - (prog1 - (buffer-substring (point-min) (match-end 0)) - (when twittering-debug-mode - (debug-printf "connection-info=%s\n" connection-info) - (debug-print "HTTP response header:\n--BEGIN\n") - (debug-print (buffer-substring (point-min) (match-end 0))) - (debug-print "--END\n"))) - nil)))) - -(defun twittering-make-header-info-alist (header-str) - "Make HTTP header alist from HEADER-STR. -The alist consists of pairs of field-name and field-value, such as -'((\"Content-Type\" . \"application/xml\; charset=utf-8\") - (\"Content-Length\" . \"2075\"))." - (let* ((lines (split-string header-str "\r?\n")) - (status-line (car lines)) - (header-lines (cdr lines))) - (when (string-match - "^\\(HTTP/1\\.[01]\\|HTTP/2\\(?:\\.0\\)?\\) \\([0-9][0-9][0-9]\\)\\(.*\\)$" - status-line) - (append `((status-line . ,status-line) - (http-version . ,(match-string 1 status-line)) - (status-code . ,(match-string 2 status-line)) - (reason-phrase . ,(match-string 3 status-line))) - (remove nil - (mapcar - (lambda (line) - (when (string-match "^\\([^: ]*\\): *\\(.*\\)$" line) - (cons (match-string 1 line) (match-string 2 line)))) - header-lines)))))) - -(defun twittering-get-content-subtype-symbol-from-header-info (header-info) - "Return a symbol corresponding to the subtype of content-type." - (let* ((content-type - ;; According to RFC2616, field name of a HTTP header is - ;; case-insensitive. - (car - (remove - nil - (mapcar (lambda (entry) - (when (and (stringp (car entry)) - (let ((case-fold-search t)) - (string-match "\\`content-type\\'" - (car entry)))) - (cdr entry))) - header-info)))) - (subtype (when (and (stringp content-type) - (string-match "\\` *[^/]*/\\([^ ;]*\\)" - content-type)) - (downcase (match-string 1 content-type)))) - (symbol-alist - '(("json" . json) - ("atom+xml" . atom) - ("plain" . plain) - ("xml" . xml)))) - (cdr (assoc subtype symbol-alist)))) - -(defun twittering-decode-response-body (header-info) - "Decode the current buffer according to the content-type in HEADER-INFO." - (let* ((content-type - ;; According to RFC2616, field name of a HTTP header is - ;; case-insensitive. - (car - (remove - nil - (mapcar (lambda (entry) - (when (and (stringp (car entry)) - (let ((case-fold-search t)) - (string-match "\\`content-type\\'" - (car entry)))) - (cdr entry))) - header-info)))) - (parameters (when (stringp content-type) - (cdr (split-string content-type ";")))) - (regexp "^[[:space:]]*charset=utf-8[[:space:]]*$") - (encoded-with-utf-8 - (let ((case-fold-search t)) - (remove nil - (mapcar (lambda (entry) - (string-match regexp entry)) - parameters))))) - (when encoded-with-utf-8 - (decode-coding-region (point-min) (point-max) 'utf-8)))) - -(defun twittering-send-http-request-internal (request additional-info sentinel &optional order table) - "Open a connection and return a subprocess object for the connection. -REQUEST must be an alist that has the same keys as that generated by -`twittering-make-http-request'. -SENTINEL is called as a function when the process changes state. -It gets three arguments: the process, a string describing the change, and -the connection-info, which is generated by `twittering-make-connection-info' -and also includes an alist ADDITIONAL-INFO. - -How to perform the request is selected from TABLE according to the priority -order ORDER. ORDER and TABLE are directly sent to -`twittering-make-connection-info'. -If ORDER is nil, `twittering-connection-type-order' is used in place of ORDER. -If TABLE is nil, `twittering-connection-type-table' is used in place of TABLE. -" - (let* ((order (or order twittering-connection-type-order)) - (table (or table twittering-connection-type-table)) - (connection-info - (twittering-make-connection-info request additional-info - order table)) - (func (cdr (assq 'send-http-request connection-info))) - (temp-buffer (generate-new-buffer "*twmode-http-buffer*")) - ;; Bind `default-directory' to the temporary directory - ;; because it is possible that the directory pointed by - ;; `default-directory' has been already removed. - (default-directory temporary-file-directory)) - (cond - ((and func (functionp func)) - (funcall func "*twmode-generic*" temp-buffer - connection-info - (when (and sentinel (functionp sentinel)) - (lexical-let ((sentinel sentinel) - (connection-info connection-info)) - (lambda (proc status) - (apply sentinel proc status connection-info nil)))))) - (t - (error "No valid connection method is found") - nil)))) - -(defun twittering-send-http-request (request additional-info func &optional clean-up-func) - "Send a HTTP request and return a subprocess object for the connection. -REQUEST must be an alist that has the same keys as that generated by -`twittering-make-http-request'. - -FUNC is called when a HTTP response has been received without errors. -It is called with the current buffer containing the HTTP response (without -HTTP headers). FUNC is called with four arguments: the process, a symbol -describing the status of the process, a connection-info generated by -`twittering-make-connection-info', and a header-info generated by -`twittering-get-response-header' and `twittering-make-header-info-alist'. -The connection-info also includes an alist ADDITIONAL-INFO. -If FUNC returns non-nil and `twittering-buffer-related-p' is non-nil, the -returned value is displayed as a message. -And also, if FUNC returns a string and it matches the regular expression -\"^\\\\(Failuare\\\\|Response\\\\): \", the returned value is displayed -as a message. - -CLEAN-UP-FUNC is called whenever the sentinel of the subprocess for the -connection is called (as `set-process-sentinel'). -It is called with three arguments: the process, a symbol describing the status -of the proess, and a connection-info generated by -`twittering-make-connection-info'. -They are the same as arguments for FUNC. -When a HTTP response has been received, FUNC is called in advance of -CLEAN-UP-FUNC. CLEAN-UP-FUNC can overwrite the message displayed by FUNC. - -If the subprocess has exited, the buffer bound to it is automatically killed -after calling CLEAN-UP-FUNC. - -The method to perform the request is determined from -`twittering-connection-type-table' according to the priority order -`twittering-connection-type-order'." - (lexical-let ((func func) - (clean-up-func clean-up-func)) - (twittering-send-http-request-internal - request additional-info - (lambda (proc status-str connection-info) - (let ((status (cond - ((string= status-str "urllib-finished") 'exit) - ((processp proc) (process-status proc)) - (t nil))) - (buffer (process-buffer proc)) - (exit-status (cond - ((string= status-str "urllib-finished") 0) - ((processp proc) (process-exit-status proc)) - (t 1))) - (command (process-command proc)) - (pre-process-func - (cdr (assq 'pre-process-buffer connection-info))) - (mes nil)) - (unwind-protect - (setq mes - (cond - ((null status) - (format "Failure: process %s does not exist" proc)) - ((or (memq status '(run stop open listen connect)) - (not (memq status '(exit signal closed failed)))) - ;; If the process is running, FUNC is not called. - nil) - ((and command - (not (= 0 exit-status))) - ;; If the process abnormally exited, - (format "Failure: %s exited abnormally (exit-status=%s)" - (car command) exit-status)) - ((not (buffer-live-p buffer)) - (format "Failure: the buffer for %s is already killed" - proc)) - (t - (when (functionp pre-process-func) - ;; Pre-process buffer. - (funcall pre-process-func proc buffer connection-info)) - (let* ((header (twittering-get-response-header buffer)) - (header-info - (and header - (twittering-make-header-info-alist header)))) - (with-current-buffer buffer - (goto-char (point-min)) - (when (search-forward-regexp "\r?\n\r?\n" nil t) - ;; delete HTTP headers. - (delete-region (point-min) (match-end 0))) - ;; It may be necessary to decode the contents of - ;; the buffer by UTF-8 because - ;; `twittering-http-application-headers' specifies - ;; utf-8 as one of acceptable charset. - ;; For the present, only UTF-8 is taken into account. - (twittering-decode-response-body header-info) - (apply func proc status connection-info - header-info nil)))))) - ;; unwind-forms - (setq mes - (cond - ((null mes) - nil) - ((string-match "^\\(Failure\\|Response\\): " mes) - (let* ((request (cdr (assq 'request connection-info))) - (method (cdr (assq 'method request))) - (uri (cdr (assq 'uri request)))) - (concat mes " for " method " " uri))) - ((twittering-buffer-related-p) - mes))) - (when mes - ;; CLEAN-UP-FUNC can overwrite a message from the return value - ;; of FUNC. - (message "%s" mes)) - (when (functionp clean-up-func) - (funcall clean-up-func proc status connection-info)) - (when (and (memq status '(exit signal closed failed)) - (buffer-live-p buffer) - (not twittering-debug-mode)) - (kill-buffer buffer)))))))) - -;;;; -;;;; Basic HTTP functions with tls and Emacs builtins. -;;;; - -(eval-when-compile (require 'tls nil t)) -(defun twittering-start-http-session-native-tls-p () - (when (and (not twittering-proxy-use) - (require 'tls nil t)) - (unless twittering-tls-program - (let ((programs - (remove nil - (mapcar (lambda (cmd) - (when (string-match "\\`\\([^ ]+\\) " cmd) - (when (executable-find (match-string 1 cmd)) - cmd))) - tls-program)))) - (setq twittering-tls-program - (if twittering-allow-insecure-server-cert - (mapcar - (lambda (str) - (cond - ((string-match "^\\([^ ]*/\\)?openssl s_client " str) - (concat (match-string 0 str) "-verify 0 " - (substring str (match-end 0)))) - ((string-match "^\\([^ ]*/\\)?gnutls-cli " str) - (concat (match-string 0 str) "--insecure " - (substring str (match-end 0)))) - (t - str))) - programs) - programs)))) - (not (null twittering-tls-program)))) - -;; TODO: proxy -(defun twittering-send-http-request-native (name buffer connection-info sentinel) - (let* ((request (cdr (assq 'request connection-info))) - (uri (cdr (assq 'uri connection-info))) - (method (cdr (assq 'method request))) - (scheme (cdr (assq 'scheme request))) - (host (cdr (assq 'host request))) - (port (cdr (assq 'port request))) - (path (cdr (assq 'path request))) - (query-string (cdr (assq 'query-string request))) - (post-body (cdr (assq 'post-body request))) - (use-proxy (cdr (assq 'use-proxy connection-info))) - (proxy-server (cdr (assq 'proxy-server connection-info))) - (proxy-port (cdr (assq 'proxy-port connection-info))) - (proxy-user (cdr (assq 'proxy-user connection-info))) - (proxy-password (cdr (assq 'proxy-password connection-info))) - (proxy-credentials - (when (and proxy-user proxy-password) - (concat "Basic " - (base64-encode-string - (concat proxy-user ":" proxy-password))))) - (header-list - (let ((original-header-list (cdr (assq 'header-list request)))) - (if proxy-credentials - (cons - `("Proxy-Authorization" ,proxy-credentials) - original-header-list) - original-header-list))) - (use-ssl (cdr (assq 'use-ssl connection-info))) - (allow-insecure-server-cert - (cdr (assq 'allow-insecure-server-cert connection-info))) - (connect-host (or proxy-server host)) - (connect-port (or proxy-port port)) - (request-str - (format "%s %s HTTP/1.1\r\n%s\r\n\r\n%s\r\n" - method - (if use-proxy - ;; As described in 5.1.2 of RFC2616, the - ;; absolute URI is required here if the connection - ;; uses a proxy. - uri - (concat path - (when query-string - (concat "?" query-string)))) - (mapconcat (lambda (pair) - (format "%s: %s" (car pair) (cdr pair))) - header-list "\r\n") - (or post-body ""))) - (coding-system-for-read 'binary) - (coding-system-for-write 'binary) - (tls-program twittering-tls-program) - (proc - (funcall (if use-ssl - 'open-tls-stream - 'open-network-stream) - "network-connection-process" - nil connect-host connect-port))) - (when proc - (set-process-buffer proc buffer) - (when (functionp sentinel) - (if (twittering-process-alive-p proc) - (set-process-sentinel proc sentinel) - (funcall sentinel proc "finished"))) - (process-send-string proc request-str) - proc))) - -(defun twittering-pre-process-buffer-native (proc buffer connection-info) - (let ((use-ssl (cdr (assq 'use-ssl connection-info))) - (args (process-command proc))) - (cond - ((and use-ssl args - (car - (remove nil - (mapcar (lambda (cmd) - (string-match "^\\(.*/\\)?gnutls-cli\\b" cmd)) - args)))) - (with-current-buffer buffer - (save-excursion - (goto-char (point-max)) - (when (search-backward-regexp - "- Peer has closed the GNUTLS connection\r?\n\\'") - (let ((beg (match-beginning 0)) - (end (match-end 0))) - (delete-region beg end)))))) - ((and use-ssl args - (car - (remove nil - (mapcar - (lambda (cmd) - (string-match "^\\(.*/\\)?openssl s_client\\b" cmd)) - args)))) - (with-current-buffer buffer - (save-excursion - (goto-char (point-max)) - (when (search-backward-regexp "closed\r?\n\\'") - (let ((beg (match-beginning 0)) - (end (match-end 0))) - (delete-region beg end)))))) - (t - nil)))) - -;;;; -;;;; Basic HTTP functions with curl -;;;; - -(defun twittering-find-curl-program () - "Returns an appropriate `curl' program pathname or nil if not found." - (or (executable-find "curl") - (let ((windows-p (memq system-type '(windows-nt cygwin))) - (curl.exe - (expand-file-name - "curl.exe" - (expand-file-name - "win-curl" - (file-name-directory (symbol-file 'twit)))))) - (and windows-p - (file-exists-p curl.exe) curl.exe)))) - -(defun twittering-start-http-session-curl-p () - "Return t if curl was installed, otherwise nil." - (unless twittering-curl-program - (setq twittering-curl-program (twittering-find-curl-program))) - (not (null twittering-curl-program))) - -(defun twittering-start-http-session-curl-https-p () - "Return t if curl was installed and the curl support HTTPS, otherwise nil." - (when (twittering-start-http-session-curl-p) - (unless twittering-curl-program-https-capability - (with-temp-buffer - (let ((coding-system-for-read 'iso-safe) - (coding-system-for-write 'iso-safe) - ;; Bind `default-directory' to the temporary directory - ;; because it is possible that the directory pointed by - ;; `default-directory' has been already removed. - (default-directory temporary-file-directory)) - (call-process twittering-curl-program - nil (current-buffer) nil - "--version") - (goto-char (point-min)) - (setq twittering-curl-program-https-capability - (if (search-forward-regexp "^Protocols: .*https" nil t) - 'capable - 'incapable))))) - (eq twittering-curl-program-https-capability 'capable))) - -(defun twittering-start-http-session-curl-http2-p () - "Return t if the curl support HTTP2, otherwise nil." - (when (twittering-start-http-session-curl-p) - (unless twittering-curl-program-http2-capability - (with-temp-buffer - (let ((coding-system-for-read 'iso-safe) - (coding-system-for-write 'iso-safe) - ;; Bind `default-directory' to the temporary directory - ;; because it is possible that the directory pointed by - ;; `default-directory' has been already removed. - (default-directory temporary-file-directory)) - (call-process twittering-curl-program - nil (current-buffer) nil - "--version") - (goto-char (point-min)) - (setq twittering-curl-program-http2-capability - (if (search-forward-regexp "^Features:.* HTTP2" nil t) - 'capable - 'incapable))))) - (eq twittering-curl-program-http2-capability 'capable))) - -(defun twittering-send-http-request-curl (name buffer connection-info sentinel) - (let* ((request (cdr (assq 'request connection-info))) - (method (cdr (assq 'method request))) - (uri (cdr (assq 'uri request))) - (header-list (cdr (assq 'header-list request))) - (post-body (cdr (assq 'post-body request))) - (use-proxy (cdr (assq 'use-proxy connection-info))) - (proxy-server (cdr (assq 'proxy-server connection-info))) - (proxy-port (cdr (assq 'proxy-port connection-info))) - (proxy-user (cdr (assq 'proxy-user connection-info))) - (proxy-password (cdr (assq 'proxy-password connection-info))) - (use-ssl (cdr (assq 'use-ssl connection-info))) - (use-http2 (twittering-start-http-session-curl-http2-p)) - (allow-insecure-server-cert - (cdr (assq 'allow-insecure-server-cert connection-info))) - (cacert-file-fullpath - (cdr (assq 'cacert-file-fullpath connection-info))) - (cacert-file-base-directory - (when cacert-file-fullpath - (file-name-directory cacert-file-fullpath))) - (cacert-file-body - (when cacert-file-fullpath - (file-name-nondirectory cacert-file-fullpath))) - (header-list - `(,@header-list - ;; Make `curl' remove the HTTP header field "Expect" for - ;; avoiding '417 Expectation Failed' HTTP response error. - ;; The header field is automatically added for a HTTP request - ;; exceeding 1024 byte. See - ;; http://d.hatena.ne.jp/imait/20091228/1262004813 and - ;; http://www.escafrace.co.jp/blog/09/10/16/1008 - ("Expect" . ""))) - (curl-args - `("--include" "--silent" "--compressed" "--output" "-" - ,@(when use-http2 `("--http2")) - ,@(apply 'append - (mapcar - (lambda (pair) - ;; Do not overwrite internal headers `curl' would use. - ;; Thanks to William Xu. - ;; "cURL - How To Use" - ;; http://curl.haxx.se/docs/manpage.html - (unless (string= (car pair) "Host") - `("-H" ,(format "%s: %s" (car pair) (cdr pair))))) - header-list)) - ,@(when use-ssl `("--cacert" ,cacert-file-body)) - ,@(when (and use-ssl allow-insecure-server-cert) - `("--insecure")) - ,@(when (and use-proxy proxy-server proxy-port) - (append - `("-x" ,(format "%s:%s" proxy-server proxy-port)) - (when (and proxy-user proxy-password) - `("-U" ,(format "%s:%s" proxy-user proxy-password))))) - ,@(when (string= "POST" method) - `("-d" ,(or post-body ""))) - ,uri)) - (coding-system-for-read 'binary) - (coding-system-for-write 'binary) - (default-directory - ;; If `use-ssl' is non-nil, the `curl' process - ;; is executed at the same directory as the temporary cert file. - ;; Without changing directory, `curl' misses the cert file if - ;; you use Emacs on Cygwin because the path on Emacs differs - ;; from Windows. - ;; With changing directory, `curl' on Windows can find the cert - ;; file if you use Emacs on Cygwin. - (if use-ssl - cacert-file-base-directory - default-directory))) - (twittering-start-process-with-sentinel name buffer - twittering-curl-program - curl-args sentinel))) - -(defun twittering-pre-process-buffer-curl (proc buffer connection-info) - (let ((use-ssl (cdr (assq 'use-ssl connection-info))) - (use-proxy (cdr (assq 'use-proxy connection-info)))) - (when (and use-ssl use-proxy) - ;; When using SSL via a proxy with CONNECT method, - ;; omit a successful HTTP response and headers if they seem to be - ;; sent from the proxy. - (with-current-buffer buffer - (save-excursion - (goto-char (point-min)) - (let ((first-regexp - ;; successful HTTP response - "\\`HTTP/\\(1\\.[01]\\|2\\(\\.0\\)?\\) 2[0-9][0-9].*?\r?\n") - (next-regexp - ;; following HTTP response - "^\\(\r?\n\\)HTTP/\\(1\\.[01]\\|2\\(\\.0\\)?\\) [0-9][0-9][0-9].*?\r?\n")) - (when (and (search-forward-regexp first-regexp nil t) - (search-forward-regexp next-regexp nil t)) - (let ((beg (point-min)) - (end (match-end 1))) - (delete-region beg end))))))))) - -;;;; -;;;; Basic HTTP functions with wget -;;;; - -(defun twittering-find-wget-program () - "Returns an appropriate `wget' program pathname or nil if not found." - (executable-find "wget")) - -(defun twittering-start-http-session-wget-p () - "Return t if `wget' was installed, otherwise nil." - (unless twittering-wget-program - (setq twittering-wget-program (twittering-find-wget-program))) - (not (null twittering-wget-program))) - -(defun twittering-send-http-request-wget (name buffer connection-info sentinel) - (let* ((request (cdr (assq 'request connection-info))) - (method (cdr (assq 'method request))) - (scheme (cdr (assq 'scheme request))) - (uri (cdr (assq 'uri request))) - (header-list (cdr (assq 'header-list request))) - (post-body (cdr (assq 'post-body request))) - (use-proxy (cdr (assq 'use-proxy connection-info))) - (proxy-server (cdr (assq 'proxy-server connection-info))) - (proxy-port (cdr (assq 'proxy-port connection-info))) - (proxy-user (cdr (assq 'proxy-user connection-info))) - (proxy-password (cdr (assq 'proxy-password connection-info))) - (use-ssl (cdr (assq 'use-ssl connection-info))) - (allow-insecure-server-cert - (cdr (assq 'allow-insecure-server-cert connection-info))) - (cacert-file-fullpath - (cdr (assq 'cacert-file-fullpath connection-info))) - (cacert-file-base-directory - (when cacert-file-fullpath - (file-name-directory cacert-file-fullpath))) - (cacert-file-body - (when cacert-file-fullpath - (file-name-nondirectory cacert-file-fullpath))) - (args - `("--save-headers" - "--quiet" - "--output-document=-" - ,@(remove nil - (mapcar - (lambda (pair) - (unless (string= (car pair) "Host") - (format "--header=%s: %s" (car pair) (cdr pair)))) - header-list)) - ,@(when use-ssl - `(,(format "--ca-certificate=%s" cacert-file-body))) - ,@(when (and use-ssl allow-insecure-server-cert) - `("--no-check-certificate")) - ,@(cond - ((not use-proxy) - '("--no-proxy")) - ((and use-proxy proxy-server proxy-port - proxy-user proxy-password) - `(,(format "--proxy-user=%s" proxy-user) - ,(format "--proxy-password=%s" proxy-password))) - (t - nil)) - ,@(when (string= "POST" method) - `(,(concat "--post-data=" (or post-body "")))) - ,uri)) - (coding-system-for-read 'binary) - (coding-system-for-write 'binary) - (default-directory - ;; If `use-ssl' is non-nil, the `wget' process - ;; is executed at the same directory as the temporary cert file. - ;; Without changing directory, `wget' misses the cert file if - ;; you use Emacs on Cygwin because the path on Emacs differs - ;; from Windows. - ;; With changing directory, `wget' on Windows can find the cert - ;; file if you use Emacs on Cygwin. - (if use-ssl - cacert-file-base-directory - default-directory)) - (process-environment - `(,@(when (and use-proxy proxy-server proxy-port) - `(,(format "%s_proxy=%s://%s:%s/" scheme - scheme proxy-server proxy-port))) - ,@process-environment))) - (twittering-start-process-with-sentinel name buffer - twittering-wget-program args - sentinel))) - -(defun twittering-pre-process-buffer-wget (proc buffer connection-info) - (with-current-buffer buffer - (save-excursion - (goto-char (point-min)) - (when (search-forward-regexp "\\`[^\n]*?\r\r\n" (point-max) t) - ;; When `wget.exe' writes HTTP response in text mode, - ;; CRLF may be converted into CRCRLF. - (goto-char (point-min)) - (while (search-forward "\r\n" nil t) - (replace-match "\n" nil t))) - (goto-char (point-max)) - (when (search-backward-regexp "\nProcess [^\n]* finished\n\\'" - (point-min) t) - (replace-match "" nil t)) - ))) - -;;;; -;;;; Basic HTTP functions with url library -;;;; - -(defun twittering-start-http-session-urllib-p () - "Return t if url library is available, otherwise nil." - (require 'url nil t)) - -(defun twittering-start-http-session-urllib-https-p () - "Return t if url library can be used for HTTPS, otherwise nil." - (and (not twittering-proxy-use) - (require 'url nil t) - (cond - ((<= 22 emacs-major-version) - ;; On Emacs22 and later, `url' requires `tls'. - (twittering-start-http-session-native-tls-p)) - ((require 'ssl nil t) - ;; On Emacs21, `url' requires `ssl'. - t) - ((or (and (fboundp 'open-ssl-stream) - ;; Since `url-gw' (required by `url') defines autoload of - ;; `open-ssl-stream' from "ssl", - ;; (fboundp 'open-ssl-stream) will be non-nil even if - ;; "ssl" cannot be loaded and `open-ssl-stream' is - ;; unavailable. - ;; Here, the availability is confirmed by `documentation'. - (documentation 'open-ssl-stream)) - ;; On Emacs21, `url' requires `ssl' in order to use - ;; `open-ssl-stream', which is included in `ssl.el'. - ;; Even if `ssl' cannot be loaded, `open-tls-stream' can be - ;; used as an alternative of the function. - (and (twittering-start-http-session-native-tls-p) - (defalias 'open-ssl-stream 'open-tls-stream))) - (provide 'ssl) - t) - (t - nil)))) - -(defun twittering-send-http-request-urllib (name buffer connection-info sentinel) - (let* ((request (cdr (assq 'request connection-info))) - (method (cdr (assq 'method request))) - (scheme (cdr (assq 'scheme request))) - (uri (cdr (assq 'uri request))) - (header-list (cdr (assq 'header-list request))) - (post-body (cdr (assq 'post-body request))) - (use-proxy (cdr (assq 'use-proxy connection-info))) - (proxy-server (cdr (assq 'proxy-server connection-info))) - (proxy-port (cdr (assq 'proxy-port connection-info))) - (proxy-user (cdr (assq 'proxy-user connection-info))) - (proxy-password (cdr (assq 'proxy-password connection-info))) - (proxy-credentials - (when (and proxy-user proxy-password) - (concat "Basic " - (base64-encode-string - (concat proxy-user ":" proxy-password))))) - (coding-system-for-read 'binary) - (coding-system-for-write 'binary) - (url-proxy-services - (when use-proxy - `((,scheme . ,(format "%s:%s" proxy-server proxy-port))))) - (url-request-method method) - (url-request-extra-headers - ;; Remove some headers that should be configured by url library. - ;; They may break redirections by url library because - ;; `url-request-extra-headers' overwrites the new headers - ;; that are adapted to redirected connection. - (apply 'append - (mapcar (lambda (pair) - (if (member (car pair) - '("Host" "Content-Length")) - nil - `(,pair))) - (if proxy-credentials - (cons - `("Proxy-Authorization" ,proxy-credentials) - header-list) - header-list)))) - (url-request-data post-body) - (url-show-status twittering-url-show-status) - (url-http-attempt-keepalives nil) - (tls-program twittering-tls-program) - (coding-system-for-read 'binary) - (coding-system-for-write 'binary)) - (lexical-let ((sentinel sentinel) - (buffer buffer)) - (let ((result-buffer - (url-retrieve - uri - (lambda (&rest args) - (let ((proc url-http-process) - (url-buffer (current-buffer)) - (status-str - (if (and (< emacs-major-version 22) - (boundp 'url-http-end-of-headers) - url-http-end-of-headers) - "urllib-finished" - "finished"))) - ;; Callback may be called multiple times. - ;; (as filter and sentinel?) - (unless (local-variable-if-set-p 'twittering-retrieved) - (set (make-local-variable 'twittering-retrieved) - 'not-completed) - (with-current-buffer buffer - (set-buffer-multibyte nil) - (insert-buffer-substring url-buffer)) - (set-process-buffer proc buffer) - (unwind-protect - (apply sentinel proc status-str nil) - (set-process-buffer proc url-buffer) - (if (eq twittering-retrieved 'exited) - (url-mark-buffer-as-dead url-buffer) - (setq twittering-retrieved 'completed)))) - (when (memq (process-status proc) - '(nil closed exit failed signal)) - ;; Mark `url-buffer' as dead when the process exited - ;; and `sentinel' is completed. - ;; If this `lambda' is evaluated via a filter, the - ;; process may exit before it is finished to evaluate - ;; `(apply sentinel ...)'. In the case, `buffer' should - ;; not be killed. It should be killed after the - ;; evaluation of `sentinel'. - (if (eq twittering-retrieved 'completed) - (url-mark-buffer-as-dead url-buffer) - (setq twittering-retrieved 'exited)))))))) - (when (buffer-live-p result-buffer) - (with-current-buffer result-buffer - (set (make-local-variable 'url-show-status) - twittering-url-show-status) - ;; Make `url-http-attempt-keepalives' buffer-local - ;; in order to send the current value of the variable - ;; to the sentinel invoked for HTTP redirection, - (make-local-variable 'url-http-attempt-keepalives)) - (get-buffer-process result-buffer)))))) - -(defun twittering-pre-process-buffer-urllib (proc buffer connection-info) - (with-current-buffer buffer - (save-excursion - (goto-char (point-max)) - (cond - ((search-backward-regexp - "- Peer has closed the GNUTLS connection\r?\n\\'" - nil t) - (let ((beg (match-beginning 0)) - (end (match-end 0))) - (delete-region beg end))) - ((search-backward-regexp "closed\r?\n\\'" nil t) - (let ((beg (match-beginning 0)) - (end (match-end 0))) - (delete-region beg end))) - (t nil))))) - -;;;; -;;;; HTTP functions for twitter-like serivce -;;;; - -(defun twittering-http-application-headers (&optional method headers) - "Return an assoc list of HTTP headers for twittering-mode." - (unless method - (setq method "GET")) - - (let ((headers headers)) - (push (cons "User-Agent" (twittering-user-agent)) headers) - (when (string= "GET" method) - (push (cons "Accept" - (concat - "text/xml" - ",application/xml" - ",application/xhtml+xml" - ",application/html;q=0.9" - ",text/plain;q=0.8" - ",image/png,*/*;q=0.5")) - headers) - (push (cons "Accept-Charset" "utf-8;q=0.7,*;q=0.7") - headers)) - (when (string= "POST" method) - (push (cons "Content-Type" "text/plain") headers)) - headers - )) - -(defun twittering-add-application-header-to-http-request (request account-info) - "Make a new HTTP request based on REQUEST with the authorization header. -The authorization header is generated from ACCOUNT-INFO. -ACCOUNT-INFO must be an alist that includes the following keys; - \"screen_name\" and \"password\" if `twittering-auth-method' is 'basic, - \"screen_name\", \"oauth_token\" and \"oauth_token_secret\" if - `twittering-auth-method' is 'oauth or 'xauth." - (let* ((method (cdr (assq 'method request))) - (auth-str - (cond - ((eq twittering-auth-method 'basic) - (twittering-make-basic-authentication-string account-info)) - ((memq twittering-auth-method '(oauth xauth)) - (twittering-make-oauth-authentication-string account-info request)) - (t - nil))) - (cookie-str (twittering-make-cookie-string request account-info)) - (application-headers - `(,@(twittering-http-application-headers method) - ("Authorization" . ,auth-str) - ,@(when cookie-str - `(("Cookie" . ,cookie-str)))))) - (mapcar (lambda (entry) - (if (eq (car entry) 'header-list) - `(header-list - . ,(append (cdr entry) application-headers)) - entry)) - request))) - -(defun twittering-get-error-message (header-info connection-info &optional buffer) - "Return an error message generated from the arguments. -HEADER-INFO must be an alist generated by `twittering-get-response-header'. -CONNECTION-INFO must be an alist generated by -`twittering-make-connection-info'. It may include some additional information -which is added by `twittering-send-http-request'. -BUFFER must be nil or a HTTP response body, which includes error messages from -the server when the HTTP status code equals to 400 or 403. -If BUFFER is nil, the current buffer is used instead." - (let ((buffer (or buffer (current-buffer))) - (status-line (cdr (assq 'status-line header-info))) - (status-code (cdr (assq 'status-code header-info))) - (format - (twittering-get-content-subtype-symbol-from-header-info header-info))) - (cond - ((and (buffer-live-p buffer) - (member status-code '("400" "401" "403" "404"))) - ;; Twitter returns an error message as a HTTP response body if - ;; HTTP status is "400 Bad Request" or "403 Forbidden". - ;; See "HTTP Response Codes and Errors | dev.twitter.com" - ;; http://dev.twitter.com/pages/responses_errors . - ;; - ;; However, Twitter seems to return an error message even when - ;; the HTTP status is "401 Unauthorized" or "404 Not Found". - (let* ((error-mes - (cond - ((eq format 'xml) - (let ((xmltree - (with-current-buffer buffer - (twittering-xml-parse-region (point-min) - (point-max))))) - (car (cddr (assq 'error (or (assq 'errors xmltree) - (assq 'hash xmltree))))))) - ((eq format 'json) - (let ((json-object (with-current-buffer buffer - (twittering-json-read)))) - (cdr (assq 'error json-object)))) - (t - ;; ATOM is not supported. - nil)))) - (if error-mes - (format "%s (%s)" status-line error-mes) - status-line))) - (t - status-line)))) - -(defun twittering-http-get (account-info-alist host method &optional parameters format additional-info sentinel clean-up-sentinel) - "Send a HTTP GET request with application headers. -ACCOUNT-INFO-ALIST is an alist used by -`twittering-add-application-header-to-http-request'. -The alist made by `((account-info . ,ACCOUNT-INFO-ALIST) ,@ADDITIONAL-INFO)' -is used as the argument `additional-info' of `twittering-send-http-request'. -HOST is hostname of remote side, api.twitter.com (or search.twitter.com). -METHOD must be one of Twitter API method classes - (statuses, users or direct_messages). -PARAMETERS is alist of URI parameters. - ex) ((\"mode\" . \"view\") (\"page\" . \"6\")) => ?mode=view&page=6 -FORMAT is a response data format (\"xml\", \"atom\", \"json\")" - (let* ((format (or format "xml")) - (sentinel - (lexical-let ((sentinel (or sentinel - 'twittering-http-get-default-sentinel))) - (lambda (proc status connection-info header-info) - (twittering-update-server-info connection-info header-info) - (apply sentinel proc status connection-info header-info nil)))) - (path (concat "/" method "." format)) - (headers nil) - (port nil) - (post-body "") - (request - (twittering-add-application-header-to-http-request - (twittering-make-http-request "GET" headers host port path - parameters post-body - twittering-use-ssl) - account-info-alist)) - (additional-info - `((account-info . ,account-info-alist) - ,@additional-info))) - (twittering-send-http-request request additional-info - sentinel clean-up-sentinel))) - -(defun twittering-http-get-default-sentinel (proc status connection-info header-info) - (let ((status-line (cdr (assq 'status-line header-info))) - (status-code (cdr (assq 'status-code header-info))) - (format - (twittering-get-content-subtype-symbol-from-header-info header-info))) - (case-string - status-code - (("200") - (debug-printf "connection-info=%s" connection-info) - (let* ((spec (cdr (assq 'timeline-spec connection-info))) - (spec-string (cdr (assq 'timeline-spec-string connection-info))) - (service-method (cdr (assq 'service-method connection-info))) - (statuses - (cond - ((eq format 'json) - (let ((json-array (twittering-json-read))) - (cond - ((null json-array) - nil) - ((eq (car spec) 'search) - (cond - ((memq service-method '(twitter statusnet)) - (mapcar 'twittering-json-object-to-a-status-on-search - (cdr (assq 'results json-array)))) - ((eq service-method 'twitter-api-v1.1) - (mapcar 'twittering-json-object-to-a-status - (cdr (assq 'statuses json-array)))))) - ((twittering-timeline-spec-is-direct-message-events-p spec) - (twittering-json-object-to-statuses-on-direct-message-events json-array) - ) - ((twittering-timeline-spec-is-direct-messages-p spec) - (mapcar - 'twittering-json-object-to-a-status-on-direct-messages - json-array)) - (t - (mapcar 'twittering-json-object-to-a-status - json-array))))) - ((eq format 'xml) - (let ((xmltree - (twittering-xml-parse-region (point-min) (point-max)))) - (when xmltree - (twittering-xmltree-to-status xmltree)))) - ((eq format 'atom) - (let ((xmltree - (twittering-xml-parse-region (point-min) (point-max)))) - (when xmltree - (twittering-atom-xmltree-to-status xmltree)))) - (t - nil))) - (rendered-tweets nil)) - (let ((updated-timeline-info - (twittering-add-statuses-to-timeline-data statuses spec)) - (buffer (twittering-get-buffer-from-spec spec))) - ;; FIXME: We should retrieve un-retrieved statuses until - ;; statuses is nil. twitter server returns nil as - ;; xmltree with HTTP status-code is "200" when we - ;; retrieved all un-retrieved statuses. - (if twittering-notify-successful-http-get - (if updated-timeline-info - (concat - (format "Fetching %s. Success. " spec-string) - (mapconcat - (lambda (info) - (let ((spec-string (nth 0 info)) - (num (nth 1 info))) - (format "%s: +%d" spec-string num))) - updated-timeline-info - ", ")) - (format "Fetching %s. Success. (No new tweets)" - spec-string)) - nil)))) - (("404") - ;; The requested resource does not exist. - (let ((spec (cdr (assq 'timeline-spec connection-info))) - (spec-string (cdr (assq 'timeline-spec-string connection-info)))) - ;; Remove specs related to the invalid spec from history. - (mapc - (lambda (buffer) - (let ((other-spec (twittering-get-timeline-spec-for-buffer buffer)) - (other-spec-string - (twittering-get-timeline-spec-string-for-buffer buffer))) - (when (twittering-timeline-spec-depending-on-p other-spec spec) - (twittering-remove-timeline-spec-string-from-history - other-spec-string)))) - (twittering-get-buffer-list))) - (format "Response: %s" - (twittering-get-error-message header-info connection-info))) - (t - (format "Response: %s" - (twittering-get-error-message header-info connection-info)))))) - -(defun twittering-retrieve-single-tweet-sentinel (proc status connection-info header-info) - (let ((status-line (cdr (assq 'status-line header-info))) - (status-code (cdr (assq 'status-code header-info))) - (format - (twittering-get-content-subtype-symbol-from-header-info header-info))) - (case-string - status-code - (("200" "403" "404") - (debug-printf "connection-info=%s" connection-info) - (let* ((id (cdr (assq 'id connection-info))) - (user-screen-name (cdr (assq 'user-screen-name connection-info))) - (status - (cond - ((string= status-code "403") - ;; Forbidden. Maybe a protected tweet? - (twittering-make-alist-of-forbidden-tweet id - user-screen-name)) - ((string= status-code "404") - ;; The requested resource does not exist. - (twittering-make-alist-of-non-existent-tweet id - user-screen-name)) - ((eq format 'json) - (let ((json-object (twittering-json-read))) - (twittering-json-object-to-a-status json-object))) - ((eq format 'xml) - (let ((xmltree - (twittering-xml-parse-region (point-min) (point-max)))) - (when xmltree - (car - (twittering-xmltree-to-status - `((statuses nil ,@xmltree))))))) - (t - nil)))) - (when status - (twittering-add-statuses-to-timeline-data `(,status) '(:single)) - (let ((buffer (cdr (assq 'buffer connection-info))) - (spec (cdr (assq 'timeline-spec connection-info))) - (prop - (cdr (assq 'property-to-be-redisplayed connection-info)))) - (cond - ((null prop) - ;; The process has been invoked via `twittering-call-api' with - ;; the command `retrieve-timeline', not the command - ;; `retrieve-single-tweet' for rendering a replied tweet. - ;; No special property that specifies regions being re-rendered - ;; is given. - (let ((new-statuses `(,status)) - (buffer (twittering-get-buffer-from-spec spec))) - (when (and new-statuses buffer) - (twittering-render-timeline buffer new-statuses t)))) - ((and buffer prop (buffer-live-p buffer)) - (twittering-redisplay-status-on-each-buffer buffer prop) - (with-current-buffer buffer - (save-excursion - (let ((buffer-read-only nil)) - (lexical-let ((prop prop)) - (twittering-for-each-property-region - prop - (lambda (beg end value) - ;; Remove the property required no longer. - (remove-text-properties beg end `(,prop nil)) - (goto-char beg) - (twittering-render-replied-statuses))))))))))) - (cond - ((string= status-code "403") - (format "You are not authorized to see this tweet (ID %s)." id)) - ((string= status-code "404") - (format "The tweet with ID %s does not exist." id)) - (twittering-notify-successful-http-get - (format "Fetching %s. Success." id)) - (t - nil)))) - (t - (format "Response: %s" - (twittering-get-error-message header-info connection-info)))))) - -(defmacro twittering-http-get-list-sentinel-base (what) - `(let ((status-line (cdr (assq 'status-line header-info))) - (status-code (cdr (assq 'status-code header-info))) - (format - (twittering-get-content-subtype-symbol-from-header-info header-info)) - (indexes nil) - (mes nil)) - (case-string - status-code - (("200") - (cond - ((eq format 'xml) - (let ((xmltree (twittering-xml-parse-region (point-min) (point-max)))) - (when xmltree - (setq indexes - (mapcar - (lambda (c-node) - (caddr (assq ,what c-node))) - (remove nil - (mapcar - (lambda (node) - (and (consp node) (eq 'list (car node)) - node)) - (cdr-safe - (assq 'lists (assq 'lists_list xmltree)))) - )) - )))) - ((eq format 'json) - (let* ((json-object (twittering-json-read)) - (json-list - (cond - ((arrayp json-object) - ;; GET lists/list in the Twitter REST API v1.1 returns - ;; an array. - json-object) - (t - ;; GET lists/subscriptions in the Twitter REST API v1.1 - ;; returns an alist. - (cdr (assq 'lists json-object)))))) - (when json-object - (setq indexes - (mapcar (lambda (entry) - (cdr (assq ,what entry))) - json-list))))) - (t - (error "Format \"%s\" is not supported" format) - nil))) - (t - (setq mes (format "Response: %s" - (twittering-get-error-message header-info - connection-info))))) - (setq twittering-list-index-retrieved - (or indexes - mes - "")) ;; set "" explicitly if user does not have a list. - mes)) - -(defun twittering-http-get-list-index-sentinel (proc status connection-info header-info) - (twittering-http-get-list-sentinel-base 'slug)) - -(defun twittering-http-get-list-subscriptions-sentinel (proc status connection-info header-info) - (let ((result (twittering-http-get-list-sentinel-base 'full_name))) - (when (listp twittering-list-index-retrieved) - (setq twittering-list-index-retrieved - (mapcar (lambda (str) - (and (string-match "\\`@\\(.*\\)\\'" str) - (match-string 1 str))) - twittering-list-index-retrieved))) - result)) - -(defun twittering-http-post (account-info-alist host method &optional parameters format additional-info sentinel clean-up-sentinel post-body) - "Send HTTP POST request to api.twitter.com (or search.twitter.com) -ACCOUNT-INFO-ALIST is an alist used by -`twittering-add-application-header-to-http-request'. -The alist made by `((account-info . ,ACCOUNT-INFO-ALIST) ,@ADDITIONAL-INFO)' -is used as the argument `additional-info' of `twittering-send-http-request'. -HOST is hostname of remote side, api.twitter.com (or search.twitter.com). -METHOD must be one of Twitter API method classes - (statuses, users or direct_messages). -PARAMETERS is alist of URI parameters. - ex) ((\"mode\" . \"view\") (\"page\" . \"6\")) => ?mode=view&page=6 -FORMAT is a response data format (\"xml\", \"atom\", \"json\")" - (let* ((format (or format "xml")) - (sentinel - (lexical-let ((sentinel (or sentinel - 'twittering-http-post-default-sentinel))) - (lambda (proc status connection-info header-info) - (twittering-update-server-info connection-info header-info) - (apply sentinel proc status connection-info header-info nil)))) - (path (concat "/" method "." format)) - (headers nil) - (port nil) - (post-body (or post-body "")) - (request - (twittering-add-application-header-to-http-request - (twittering-make-http-request "POST" headers host port path - parameters post-body - twittering-use-ssl) - account-info-alist)) - (additional-info `((account-info . ,account-info-alist) - ,@additional-info))) - (twittering-send-http-request request additional-info - sentinel clean-up-sentinel))) - -(defun twittering-http-post-default-sentinel (proc status connection-info header-info) - (let ((status-line (cdr (assq 'status-line header-info))) - (status-code (cdr (assq 'status-code header-info)))) - (case-string - status-code - (("200") - "Success: Post.") - (t - (format "Response: %s" - (twittering-get-error-message header-info connection-info)))))) - -(defun twittering-http-post-destroy-status-sentinel (proc status connection-info header-info) - "A sentinel for deleting a status invoked via `twittering-call-api'." - (let ((status-line (cdr (assq 'status-line header-info))) - (status-code (cdr (assq 'status-code header-info))) - (format - (twittering-get-content-subtype-symbol-from-header-info header-info))) - (case-string - status-code - (("200") - (let* ((params - (cond - ((eq format 'xml) - (let ((xml - (twittering-xml-parse-region (point-min) (point-max)))) - `((id . ,(elt (assq 'id (assq 'status xml)) 2)) - (text . ,(elt (assq 'text (assq 'status xml)) 2))))) - ((eq format 'json) - (let ((json-object (twittering-json-read))) - `((id . ,(cdr (assq 'id_str json-object))) - (text . ,(cdr (assq 'text json-object)))))) - (t - (error "Format \"%s\" is not supported" format) - nil))) - (id (cdr (assq 'id params))) - (text (cdr (assq 'text params)))) - (cond - (id - (twittering-delete-status-from-data-table id) - (format "Deleting \"%s\". Success." text)) - (t - "Failure: the response for deletion could not be parsed.")))) - (t - (format "Response: %s" - (twittering-get-error-message header-info connection-info)))))) - -;;;; -;;;; OAuth -;;;; - -(defun twittering-oauth-url-encode (str &optional coding-system) - "Encode string according to Percent-Encoding defined in RFC 3986." - (let ((coding-system (or (when (and coding-system - (coding-system-p coding-system)) - coding-system) - 'utf-8))) - (mapconcat - (lambda (c) - (cond - ((or (and (<= ?A c) (<= c ?Z)) - (and (<= ?a c) (<= c ?z)) - (and (<= ?0 c) (<= c ?9)) - (eq ?. c) - (eq ?- c) - (eq ?_ c) - (eq ?~ c)) - (char-to-string c)) - (t (format "%%%02X" c)))) - (encode-coding-string str coding-system) - ""))) - -(defun twittering-oauth-unhex (c) - (cond - ((and (<= ?0 c) (<= c ?9)) - (- c ?0)) - ((and (<= ?A c) (<= c ?F)) - (+ 10 (- c ?A))) - ((and (<= ?a c) (<= c ?f)) - (+ 10 (- c ?a))) - )) - -(defun twittering-oauth-url-decode (str &optional coding-system) - (let* ((coding-system (or (when (and coding-system - (coding-system-p coding-system)) - coding-system) - 'utf-8)) - (substr-list (split-string str "%")) - (head (car substr-list)) - (tail (cdr substr-list))) - (decode-coding-string - (concat - head - (mapconcat - (lambda (substr) - (if (string-match "\\`\\([0-9a-fA-F]\\)\\([0-9a-fA-F]\\)\\(.*\\)\\'" - substr) - (let* ((c1 (string-to-char (match-string 1 substr))) - (c0 (string-to-char (match-string 2 substr))) - (tail (match-string 3 substr)) - (ch (+ (* 16 (twittering-oauth-unhex c1)) - (twittering-oauth-unhex c0)))) - (concat (char-to-string ch) tail)) - substr)) - tail - "")) - coding-system))) - -(defun twittering-oauth-make-signature-base-string (method base-url parameters) - ;; "OAuth Core 1.0a" - ;; http://oauth.net/core/1.0a/#anchor13 - (let* ((sorted-parameters (copy-sequence parameters)) - (sorted-parameters - (sort sorted-parameters - (lambda (entry1 entry2) - (string< (car entry1) (car entry2)))))) - (concat - method - "&" - (twittering-oauth-url-encode base-url) - "&" - (mapconcat - (lambda (entry) - (let ((key (car entry)) - (value (cdr entry))) - (concat (twittering-oauth-url-encode key) - "%3D" - (twittering-oauth-url-encode value)))) - sorted-parameters - "%26")))) - -(defun twittering-oauth-make-random-string (len) - (let* ((table - (concat - "0123456789" - "ABCDEFGHIJKLMNOPQRSTUVWXYZ" - "abcdefghijklmnopqrstuvwxyz")) - (n (length table)) - (l 0) - (result (make-string len ?0))) - (while (< l len) - (aset result l (aref table (random n))) - (setq l (1+ l))) - result)) - -(defun twittering-sha1 (&rest args) - "Return the SHA1 (Secure Hash Algorithm) of an object. - -This is equivalent to the function `sha1' except that -`coding-system-for-read' and `coding-system-for-write' are bound to the -symbol `binary'. - -The function `sha1' uses an external program for large object. However, -the coding system for transferring data from/to the program is not fixed, -at least in the implementation distributed with GNU Emacs 21.4.1, 22.2.1 -and 23.2.1. -Therefore, the result from the function `sha1' may depend on the current -coding system. - -This function avoid the dependency by binding `coding-system-for-read' and -`coding-system-for-write' to the symbol `binary'." - (require 'sha1) - (let ((coding-system-for-read 'binary) - (coding-system-for-write 'binary) - ;; Bind `default-directory' to the temporary directory - ;; because it is possible that the directory pointed by - ;; `default-directory' has been already removed. - (default-directory temporary-file-directory)) - (apply 'sha1 args))) - -;;; -;;; The below function is derived from `hmac-sha1' retrieved -;;; from http://www.emacswiki.org/emacs/HmacShaOne. -;;; -(defun twittering-hmac-sha1 (key message) - "Return an HMAC-SHA1 authentication code for KEY and MESSAGE. - -KEY and MESSAGE must be unibyte strings. The result is a unibyte -string. Use the function `encode-hex-string' or the function -`base64-encode-string' to produce human-readable output. - -See URL: for more information -on the HMAC-SHA1 algorithm. - -The Emacs multibyte representation actually uses a series of -8-bit values under the hood, so we could have allowed multibyte -strings as arguments. However, internal 8-bit values don't -correspond to any external representation \(at least for major -version 22). This makes multibyte strings useless for generating -hashes. - -Instead, callers must explicitly pick and use an encoding for -their multibyte data. Most callers will want to use UTF-8 -encoding, which we can generate as follows: - - (let ((unibyte-key (encode-coding-string key 'utf-8 t)) - (unibyte-value (encode-coding-string value 'utf-8 t))) - (twittering-hmac-sha1 unibyte-key unibyte-value)) - -For keys and values that are already unibyte, the -`encode-coding-string' calls just return the same string." -;;; Return an HMAC-SHA1 authentication code for KEY and MESSAGE. -;;; -;;; KEY and MESSAGE must be unibyte strings. The result is a unibyte -;;; string. Use the function `encode-hex-string' or the function -;;; `base64-encode-string' to produce human-readable output. -;;; -;;; See URL: for more information -;;; on the HMAC-SHA1 algorithm. -;;; -;;; The Emacs multibyte representation actually uses a series of -;;; 8-bit values under the hood, so we could have allowed multibyte -;;; strings as arguments. However, internal 8-bit values don't -;;; correspond to any external representation \(at least for major -;;; version 22). This makes multibyte strings useless for generating -;;; hashes. -;;; -;;; Instead, callers must explicitly pick and use an encoding for -;;; their multibyte data. Most callers will want to use UTF-8 -;;; encoding, which we can generate as follows: -;;; -;;; (let ((unibyte-key (encode-coding-string key 'utf-8 t)) -;;; (unibyte-value (encode-coding-string value 'utf-8 t))) -;;; (hmac-sha1 unibyte-key unibyte-value)) -;;; -;;; For keys and values that are already unibyte, the -;;; `encode-coding-string' calls just return the same string. -;;; -;;; Author: Derek Upham - sand (at) blarg.net -;;; -;;; Copyright: This code is in the public domain. - (require 'sha1) - (when (multibyte-string-p key) - (error "key must be unibyte")) - (when (multibyte-string-p message) - (error "message must be unibyte")) - - ;; The key block is always exactly the block size of the hash - ;; algorithm. If the key is too small, we pad it with zeroes (or - ;; instead, we initialize the key block with zeroes and copy the - ;; key onto the nulls). If the key is too large, we run it - ;; through the hash algorithm and use the hashed value (strange - ;; but true). - - (let ((+hmac-sha1-block-size-bytes+ 64)) ; SHA-1 uses 512-bit blocks - (when (< +hmac-sha1-block-size-bytes+ (length key)) - (setq key (twittering-sha1 key nil nil t))) - - (let ((key-block (make-vector +hmac-sha1-block-size-bytes+ 0))) - (dotimes (i (length key)) - (aset key-block i (aref key i))) - - (let ((opad (make-vector +hmac-sha1-block-size-bytes+ #x5c)) - (ipad (make-vector +hmac-sha1-block-size-bytes+ #x36))) - - (dotimes (i +hmac-sha1-block-size-bytes+) - (aset ipad i (logxor (aref ipad i) (aref key-block i))) - (aset opad i (logxor (aref opad i) (aref key-block i)))) - - (when (fboundp 'unibyte-string) - ;; `concat' of Emacs23 (and later?) generates a multi-byte - ;; string from a vector of characters with eight bit. - ;; Since `opad' and `ipad' must be unibyte, we have to - ;; convert them by using `unibyte-string'. - ;; We cannot use `string-as-unibyte' here because it encodes - ;; bytes with the manner of UTF-8. - (setq opad (apply 'unibyte-string (mapcar 'identity opad))) - (setq ipad (apply 'unibyte-string (mapcar 'identity ipad)))) - - (twittering-sha1 (concat opad - (twittering-sha1 (concat ipad message) - nil nil t)) - nil nil t))))) - -(defun twittering-oauth-auth-str (method base-url query-parameters oauth-parameters key) - "Generate the value for HTTP Authorization header on OAuth. -QUERY-PARAMETERS is an alist for query parameters, where name and value -must be encoded into the same as they will be sent." - (let* ((parameters (append query-parameters oauth-parameters)) - (base-string - (twittering-oauth-make-signature-base-string method base-url parameters)) - (key (if (multibyte-string-p key) - (string-make-unibyte key) - key)) - (base-string (if (multibyte-string-p base-string) - (string-make-unibyte base-string) - base-string)) - (signature - (base64-encode-string (twittering-hmac-sha1 key base-string)))) - (concat - "OAuth " - (mapconcat - (lambda (entry) - (concat (car entry) "=\"" (cdr entry) "\"")) - oauth-parameters - ",") - ",oauth_signature=\"" (twittering-oauth-url-encode signature) "\""))) - -(defun twittering-oauth-auth-str-request-token (url query-parameters consumer-key consumer-secret &optional oauth-parameters) - (let ((key (concat consumer-secret "&")) - (oauth-params - (or oauth-parameters - `(("oauth_nonce" . ,(twittering-oauth-make-random-string 43)) - ("oauth_callback" . "oob") - ("oauth_signature_method" . "HMAC-SHA1") - ("oauth_timestamp" . ,(format-time-string "%s")) - ("oauth_consumer_key" . ,consumer-key) - ("oauth_version" . "1.0"))))) - (twittering-oauth-auth-str "POST" url query-parameters oauth-params key))) - -(defun twittering-oauth-auth-str-exchange-token (url query-parameters consumer-key consumer-secret request-token request-token-secret verifier &optional oauth-parameters) - (let ((key (concat consumer-secret "&" request-token-secret)) - (oauth-params - (or oauth-parameters - `(("oauth_consumer_key" . ,consumer-key) - ("oauth_nonce" . ,(twittering-oauth-make-random-string 43)) - ("oauth_signature_method" . "HMAC-SHA1") - ("oauth_timestamp" . ,(format-time-string "%s")) - ("oauth_version" . "1.0") - ("oauth_token" . ,request-token) - ("oauth_verifier" . ,verifier))))) - (twittering-oauth-auth-str "POST" url query-parameters oauth-params key))) - -(defun twittering-oauth-auth-str-access (method url query-parameters consumer-key consumer-secret access-token access-token-secret &optional oauth-parameters) - "Generate a string for Authorization in HTTP header on OAuth. -METHOD means HTTP method such as \"GET\", \"POST\", etc. URL means a simple -URL without port number and query parameters. -QUERY-PARAMETERS means an alist of query parameters such as -'((\"status\" . \"test%20tweet\") - (\"in_reply_to_status_id\" . \"12345678\")), -where name and value must be encoded into the same as they will be sent. -CONSUMER-KEY and CONSUMER-SECRET specifies the consumer. -ACCESS-TOKEN and ACCESS-TOKEN-SECRET must be authorized before calling this -function." - (let ((key (concat consumer-secret "&" access-token-secret)) - (oauth-params - (or oauth-parameters - `(("oauth_consumer_key" . ,consumer-key) - ("oauth_nonce" . ,(twittering-oauth-make-random-string 43)) - ("oauth_signature_method" . "HMAC-SHA1") - ("oauth_timestamp" . ,(format-time-string "%s")) - ("oauth_version" . "1.0") - ("oauth_token" . ,access-token))))) - (twittering-oauth-auth-str method url query-parameters oauth-params key))) - -;; "Using xAuth | dev.twitter.com" -;; http://dev.twitter.com/pages/xauth -(defun twittering-xauth-auth-str-access-token (url query-parameters consumer-key consumer-secret username password &optional oauth-parameters) - (let ((key (concat consumer-secret "&")) - (oauth-params - (or oauth-parameters - `(("oauth_nonce" . ,(twittering-oauth-make-random-string 43)) - ("oauth_signature_method" . "HMAC-SHA1") - ("oauth_timestamp" . ,(format-time-string "%s")) - ("oauth_consumer_key" . ,consumer-key) - ("oauth_version" . "1.0")))) - (query-params - (append query-parameters - `(("x_auth_mode" . "client_auth") - ("x_auth_password" - . ,(twittering-oauth-url-encode password)) - ("x_auth_username" - . ,(twittering-oauth-url-encode username)))))) - (twittering-oauth-auth-str "POST" url query-params oauth-params key))) - -;; "OAuth Core 1.0a" -;; http://oauth.net/core/1.0a/#response_parameters -(defun twittering-oauth-make-response-alist (str) - (mapcar - (lambda (entry) - (let* ((pair (split-string entry "=")) - (name-entry (car pair)) - (value-entry (cadr pair)) - (name (and name-entry (twittering-oauth-url-decode name-entry))) - (value (and value-entry - (twittering-oauth-url-decode value-entry)))) - `(,name . ,value))) - (split-string str "&"))) - -(defun twittering-oauth-get-response-alist (buffer) - (with-current-buffer buffer - (goto-char (point-min)) - (when (search-forward-regexp - "\\`\\(\\(HTTP/1\\.[01]\\|HTTP/2\\(?:\\.0\\)?\\) \\([0-9][0-9][0-9]\\)\\(.*?\\)\\)\r?\n" - nil t) - (let ((status-line (match-string 1)) - (http-version (match-string 2)) - (status-code (match-string 3)) - (reason-phrase (match-string 4))) - (cond - ((not (string-match "2[0-9][0-9]" status-code)) - (message "Response: %s" status-line) - nil) - ((search-forward-regexp "\r?\n\r?\n" nil t) - (let ((beg (match-end 0)) - (end (point-max))) - (twittering-oauth-make-response-alist (buffer-substring beg end)))) - (t - (message "Response: %s" status-line) - nil)))))) - -(defun twittering-oauth-get-token-alist-url (url auth-str post-body) - (let* ((url-request-method "POST") - (url-request-extra-headers - `(("Authorization" . ,auth-str) - ("Accept-Charset" . "us-ascii") - ("Content-Type" . "application/x-www-form-urlencoded") - ("Content-Length" . ,(format "%d" (length post-body))))) - (url-request-data post-body) - (coding-system-for-read 'utf-8-unix)) - (lexical-let ((result 'queried)) - (let ((buffer - (url-retrieve - url - (lambda (&rest args) - (let* ((status (if (< 21 emacs-major-version) - (car args) - nil)) - (callback-args (if (< 21 emacs-major-version) - (cdr args) - args)) - (response-buffer (current-buffer))) - (setq result - (twittering-oauth-get-response-alist response-buffer)) - ))))) - (while (eq result 'queried) - (sleep-for 0.1)) - (unless twittering-debug-mode - (kill-buffer buffer)) - result)))) - -(defun twittering-oauth-get-token-alist (url auth-str &optional post-body) - (let ((request - (twittering-make-http-request-from-uri - "POST" - `(("Authorization" . ,auth-str) - ("Accept-Charset" . "us-ascii") - ("Content-Type" . "application/x-www-form-urlencoded")) - url post-body))) - (lexical-let ((result 'queried)) - (let ((proc - (twittering-send-http-request - request nil - (lambda (proc status connection-info header-info) - (let ((status-line (cdr (assq 'status-line header-info))) - (status-code (cdr (assq 'status-code header-info)))) - (case-string - status-code - (("200") - (when twittering-debug-mode - (let ((buffer (current-buffer))) - (with-current-buffer (twittering-debug-buffer) - (insert-buffer-substring buffer)))) - (setq result - (twittering-oauth-make-response-alist - (buffer-string))) - nil) - (t - (setq result nil) - (format "Response: %s" status-line))))) - (lambda (proc status connection-info) - (when (and (not (twittering-process-alive-p proc)) - (eq result 'queried)) - (setq result nil)))))) - (twittering-wait-while nil 0.1 - (and (eq result 'queried) - (twittering-process-alive-p proc))) - (when (and (eq result 'queried) - (not (twittering-process-alive-p proc))) - ;; If the process has been dead, wait a moment because - ;; Emacs may be in the middle of evaluating the sentinel. - (twittering-wait-while 10 0.1 - (eq result 'queried) - nil - (setq result nil))) - result)))) - -(defun twittering-oauth-get-request-token (url consumer-key consumer-secret) - (let ((auth-str - (twittering-oauth-auth-str-request-token - url nil consumer-key consumer-secret))) - (twittering-oauth-get-token-alist url auth-str))) - -(defun twittering-oauth-exchange-request-token (url consumer-key consumer-secret request-token request-token-secret verifier) - (let ((auth-str - (twittering-oauth-auth-str-exchange-token - url nil - consumer-key consumer-secret - request-token request-token-secret verifier))) - (twittering-oauth-get-token-alist url auth-str))) - -(defun twittering-oauth-get-access-token (request-token-url authorize-url-func access-token-url consumer-key consumer-secret consumer-name) - "Return an alist of authorized access token. -The function retrieves a request token from the site specified by -REQUEST-TOKEN-URL. Then, The function asks a WWW browser to authorize the -token by calling `browse-url'. The URL for authorization is calculated by -calling AUTHORIZE-URL-FUNC with the request token as an argument. -AUTHORIZE-URL-FUNC is called as `(funcal AUTHORIZE-URL-FUNC request-token)', -where the request-token is a string. -After calling `browse-url', the function waits for user to input the PIN code -that is displayed in the browser. The request token is authorized by the -PIN code, and then it is exchanged for the access token on the site -specified by ACCESS-TOKEN-URL. -CONSUMER-KEY and CONSUMER-SECRET specify the consumer. -CONSUMER-NAME is displayed at the guide of authorization. - -The access token is returned as a list of a cons pair of name and value -like following: - ((\"oauth_token\" - . \"819797-Jxq8aYUDRmykzVKrgoLhXSq67TEa5ruc4GJC2rWimw\") - (\"oauth_token_secret\" - . \"J6zix3FfA9LofH0awS24M3HcBYXO5nI1iYe8EfBA\") - (\"user_id\" . \"819797\") - (\"screen_name\" . \"episod\")) -." - (let* ((request-token-alist - (twittering-oauth-get-request-token - request-token-url consumer-key consumer-secret)) - (request-token (cdr (assoc "oauth_token" request-token-alist))) - (request-token-secret - (cdr (assoc "oauth_token_secret" request-token-alist))) - (authorize-url (funcall authorize-url-func request-token)) - (str - (concat - (propertize "Authorization via OAuth\n" 'face 'bold) - "\n" - "1.Allow access by " consumer-name " on the below site.\n" - "\n " - (propertize authorize-url 'url authorize-url 'face 'bold) - "\n" - "\n" - (when twittering-oauth-invoke-browser - (concat - " Emacs invokes your browser by the function `browse-url'.\n" - " If the site is not opened automatically, you have to open\n" - " the site manually.\n" - "\n")) - "2.After allowing access, the site will display the PIN code." - "\n" - " Input the PIN code " - (propertize "at the below minibuffer." 'face 'bold)))) - (cond - (request-token-alist - (with-temp-buffer - (switch-to-buffer (current-buffer)) - (let* ((str-height (length (split-string str "\n"))) - (height (max 0 (- (/ (- (window-text-height) 1) 2) - (/ str-height 2))))) - (insert (make-string height ?\n) str) - (if twittering-oauth-invoke-browser - (browse-url authorize-url) - (when (y-or-n-p "Open authorization URL with browser? (using `browse-url')") - (browse-url authorize-url))) - (let* ((pin - (block pin-input-block - (while t - (let ((pin-input (read-string "Input PIN code: "))) - (when (string-match "^\\s-*\\([0-9]+\\)\\s-*$" pin-input) - (return-from pin-input-block - (match-string 1 pin-input))))))) - (verifier pin)) - (twittering-oauth-exchange-request-token - access-token-url - consumer-key consumer-secret - request-token request-token-secret verifier))))) - (t - (error "Failed to retrieve a request token") - nil)))) - -(defun twittering-xauth-get-access-token (access-token-url consumer-key consumer-secret username password) - (let ((auth-str - (twittering-xauth-auth-str-access-token - access-token-url nil consumer-key consumer-secret - username password)) - (post-body - (mapconcat (lambda (pair) - (format "%s=%s" (car pair) - (twittering-oauth-url-encode (cdr pair)))) - `(("x_auth_mode" . "client_auth") - ("x_auth_password" . ,password) - ("x_auth_username" . ,username)) - "&"))) - (twittering-oauth-get-token-alist access-token-url auth-str post-body))) - -;;;; -;;;; Private storage -;;;; - -(defun twittering-private-info-loaded-p () - twittering-private-info-file-loaded) - -(defun twittering-load-private-info () - (let* ((file twittering-private-info-file) - (decrypted-str (twittering-read-from-encrypted-file file)) - (loaded-alist - (when decrypted-str - (condition-case nil - (read decrypted-str) - (error - nil))))) - (when loaded-alist - (remove - nil - (mapcar - (lambda (pair) - (when (consp pair) - (let ((sym (car pair)) - (value (cdr pair))) - (cond - ((memq sym twittering-variables-stored-with-encryption) - (set sym value) - sym) - (t - nil))))) - loaded-alist))))) - -(defun twittering-load-private-info-with-guide () - (let ((str (concat - "Loading authorized access token for OAuth from\n" - (format "%s.\n" twittering-private-info-file) - "\n" - (propertize "Please input the master password.\n" 'face 'bold) - "\n" - "To cancel it, you may need to press C-g multiple times.\n" - ))) - (with-temp-buffer - (switch-to-buffer (current-buffer)) - (let* ((str-height (length (split-string str "\n"))) - (height (max 0 (- (/ (- (window-text-height) 1) 2) - (/ str-height 2))))) - (insert (make-string height ?\n) str) - (set-buffer-modified-p nil) - (twittering-load-private-info))))) - -(defun twittering-save-private-info () - (let* ((obj (mapcar (lambda (sym) - `(,sym . ,(symbol-value sym))) - twittering-variables-stored-with-encryption)) - (str (with-output-to-string (pp obj))) - (file twittering-private-info-file)) - (when (twittering-write-and-encrypt file str) - (set-file-modes file #o600) - (setq twittering-private-info-file-loaded t)))) - -(defun twittering-save-private-info-with-guide () - (let ((str (concat - "Saving authorized access token for OAuth to " - (format "%s.\n" twittering-private-info-file) - "\n" - (propertize "Please input a master password twice." - 'face 'bold)))) - (with-temp-buffer - (switch-to-buffer (current-buffer)) - (let* ((str-height (length (split-string str "\n"))) - (height (max 0 (- (/ (- (window-text-height) 1) 2) - (/ str-height 2))))) - (insert (make-string height ?\n) str) - (set-buffer-modified-p nil) - (twittering-save-private-info))))) - -(defun twittering-capable-of-encryption-p () - (and (or (require 'epa nil t) (require 'alpaca nil t)) - (or (executable-find "gpg") (executable-find "gpg2")))) - -(eval-when-compile - (require 'epa nil t) - (require 'alpaca nil t)) -(defun twittering-read-from-encrypted-file (file) - "Decrypt contents from FILE and return them. -Read encrypted contents from FILE and return the decrypted contents. -This function requires `epa' or `alpaca' library." - (cond - ((not (file-readable-p file)) - (error "Failed to read %s" file) - nil) - ((require 'epa nil t) - (let ((context (epg-make-context epa-protocol)) - ;; Bind `default-directory' to the temporary directory - ;; because it is possible that the directory pointed by - ;; `default-directory' has been already removed. - (default-directory temporary-file-directory) - (decrypted-result nil)) - (epg-context-set-passphrase-callback - context #'epa-passphrase-callback-function) - (epg-context-set-progress-callback - context - (cons #'epa-progress-callback-function - (format "Decrypting %s..." (file-name-nondirectory file)))) - (when (fboundp 'epg-context-pinentry-mode) - (setf (epg-context-pinentry-mode context) epa-pinentry-mode)) - (message "Decrypting %s..." (file-name-nondirectory file)) - (condition-case err - (let ((full-path (expand-file-name file))) - ;; `epg-decrypt-file' included in EasyPG 1.0.0, which is - ;; distributed with Emacs 23.2, requires the expanded full path - ;; as the argument CIPHER. This is because CIPHER is directly - ;; used as an argument of the command `gpg'. - (setq decrypted-result (epg-decrypt-file context full-path nil))) - (error - (if (fboundp 'epa-display-error) - (epa-display-error context) - (message "%s" (cdr err))) - nil)) - (when decrypted-result - (setq decrypted-result - (epa--decode-coding-string - decrypted-result - (or coding-system-for-read 'undecided)))) - (if (epg-context-result-for context 'verify) - (epa-display-info (epg-verify-result-to-string - (epg-context-result-for context 'verify)))) - decrypted-result)) - ((require 'alpaca nil t) - (with-temp-buffer - (let ((buffer-file-name (expand-file-name file)) - (alpaca-regex-suffix ".*") - (coding-system-for-read 'binary) - (coding-system-for-write 'binary) - (temp-buffer (current-buffer)) - ;; Bind `default-directory' to the temporary directory - ;; because it is possible that the directory pointed by - ;; `default-directory' has been already removed. - (default-directory temporary-file-directory)) - (insert-file-contents-literally file) - (set-buffer-modified-p nil) - (condition-case nil - (progn - (alpaca-after-find-file) - (if (eq temp-buffer (current-buffer)) - (buffer-string) - ;; `alpaca-after-find-file' kills the current buffer - ;; if the decryption is failed. - nil)) - (error - (when (eq temp-buffer (current-buffer)) - (delete-region (point-min) (point-max))) - nil))))) - (t - nil))) - -(defun twittering-write-and-encrypt (file str) - (cond - ((require 'epg nil t) - (let ((context (epg-make-context epa-protocol)) - ;; Bind `default-directory' to the temporary directory - ;; because it is possible that the directory pointed by - ;; `default-directory' has been already removed. - (default-directory temporary-file-directory)) - (cond - ((version< emacs-version "25.1") - (epg-context-set-armor context t) - (epg-context-set-textmode context t)) - (nil - (setf (epg-context-armor context) t) - (setf (epg-context-textmode context) t))) - (epg-context-set-passphrase-callback - context #'epa-passphrase-callback-function) - (epg-context-set-progress-callback - context (cons #'epa-progress-callback-function "Encrypting...")) - (when (fboundp 'epg-context-pinentry-mode) - (setf (epg-context-pinentry-mode context) epa-pinentry-mode)) - (message "Encrypting...") - (condition-case err - (unwind-protect - ;; In order to prevent `epa-file' to encrypt the file double, - ;; `epa-file-name-regexp' is temorarily changed into the null - ;; regexp that never matches any string. - (let ((epa-file-name-regexp "\\`\\'") - (coding-system-for-read 'binary) - (coding-system-for-write 'binary)) - (when (fboundp 'epa-file-name-regexp-update) - (epa-file-name-regexp-update)) - (with-temp-file file - (set-buffer-multibyte nil) - (delete-region (point-min) (point-max)) - (insert (epg-encrypt-string context str nil)) - (message "Encrypting...wrote %s" file) - t)) - (when (fboundp 'epa-file-name-regexp-update) - (epa-file-name-regexp-update))) - (error - (message "%s" (cdr err)) - nil)))) - ((require 'alpaca nil t) - ;; Create the file. - ;; This is required because `alpaca-save-buffer' checks its timestamp. - (with-temp-file file) - (with-temp-buffer - (let ((buffer-file-name file) - (coding-system-for-read 'binary) - (coding-system-for-write 'binary) - ;; Bind `default-directory' to the temporary directory - ;; because it is possible that the directory pointed by - ;; `default-directory' has been already removed. - (default-directory temporary-file-directory)) - (insert str) - (condition-case nil - (if (alpaca-save-buffer) - t - (delete-file file) - nil) - (error - (when (file-exists-p file) - (delete-file file)) - nil))))) - (t - nil))) - -(defun twittering-ensure-private-info () - "Ensure that private information is loaded if necessary. -Return non-nil if `twittering-use-master-password' is nil or private -information has been already loaded. Also, return non-nil -if `twittering-use-master-password' is non-nil and this function succeeded -in loading private information. -Return nil if private information cannot be loaded." - (if (or (not twittering-use-master-password) - (twittering-private-info-loaded-p)) - ;; The private information is unnecessary or already loaded. - t - (cond - ((not (twittering-capable-of-encryption-p)) - (message "You need GnuPG and (EasyPG or alpaca.el) for master password!") - nil) - ((and (memq twittering-auth-method '(oauth xauth)) - (file-exists-p twittering-private-info-file)) - (cond - ((twittering-load-private-info-with-guide) - (setq twittering-private-info-file-loaded t) - (message "The authorized token is loaded.") - t) - (t - (message "Failed to load an authorized token from \"%s\"." - twittering-private-info-file) - nil))) - (t - ;; The file for private infomation does not exist now. - t)))) - -;;;; -;;;; Asynchronous retrieval -;;;; - -(defvar twittering-url-data-hash (make-hash-table :test 'equal)) -(defvar twittering-url-request-list nil) -(defvar twittering-url-request-sentinel-hash (make-hash-table :test 'equal)) -(defvar twittering-internal-url-queue nil) -(defvar twittering-url-request-resolving-p nil) -(defvar twittering-url-request-retry-limit 3) -(defvar twittering-url-request-sentinel-delay 1.0 - "*Delay from completing retrieval to invoking associated sentinels. -Sentinels registered by `twittering-url-retrieve-async' will be invoked -after retrieval is completed and Emacs remains idle a certain time, which -this variable specifies. The unit is second.") - -(defun twittering-remove-redundant-queries (queue) - (remove nil - (mapcar - (lambda (url) - (let ((current (gethash url twittering-url-data-hash))) - (when (or (null current) - (and (integerp current) - (< current twittering-url-request-retry-limit))) - url))) - (twittering-remove-duplicates queue)))) - -(defun twittering-resolve-url-request () - "Resolve requests of asynchronous URL retrieval." - (when (null twittering-url-request-resolving-p) - (setq twittering-url-request-resolving-p t) - ;; It is assumed that the following part is not processed - ;; in parallel. - (setq twittering-internal-url-queue - (append twittering-internal-url-queue twittering-url-request-list)) - (setq twittering-url-request-list nil) - (setq twittering-internal-url-queue - (twittering-remove-redundant-queries twittering-internal-url-queue)) - (if (null twittering-internal-url-queue) - (setq twittering-url-request-resolving-p nil) - (let* ((url (car twittering-internal-url-queue)) - (request (twittering-make-http-request-from-uri "GET" nil url)) - (additional-info `((uri . ,url)))) - (twittering-send-http-request - request additional-info - 'twittering-url-retrieve-async-sentinel - 'twittering-url-retrieve-async-clean-up-sentinel))))) - -(defun twittering-url-retrieve-async-sentinel (proc status connection-info header-info) - (let ((status-line (cdr (assq 'status-line header-info))) - (status-code (cdr (assq 'status-code header-info))) - (uri (cdr (assq 'uri (assq 'request connection-info))))) - (when (string= status-code "200") - (let ((body (string-as-unibyte (buffer-string)))) - (puthash uri body twittering-url-data-hash) - (setq twittering-internal-url-queue - (remove uri twittering-internal-url-queue)) - (let ((sentinels (gethash uri twittering-url-request-sentinel-hash))) - (when sentinels - (remhash uri twittering-url-request-sentinel-hash)) - (twittering-run-on-idle twittering-url-request-sentinel-delay - (lambda (sentinels uri body) - (mapc (lambda (func) - (funcall func uri body)) - sentinels) - ;; Resolve the rest of requests. - (setq twittering-url-request-resolving-p - nil) - (twittering-resolve-url-request)) - sentinels uri body) - ;; Without the following nil, it seems that the value of - ;; `sentinels' is displayed. - nil))))) - -(defun twittering-url-retrieve-async-clean-up-sentinel (proc status connection-info) - (when (memq status '(exit signal closed failed)) - (let* ((uri (cdr (assq 'uri connection-info))) - (current (gethash uri twittering-url-data-hash))) - (when (or (null current) (integerp current)) - ;; Increment the counter on failure and then retry retrieval. - (puthash uri (1+ (or current 0)) twittering-url-data-hash) - (setq twittering-url-request-resolving-p nil) - (twittering-resolve-url-request))))) - -(defun twittering-url-retrieve-async (url &optional sentinel) - "Retrieve URL asynchronously and call SENTINEL with the retrieved data. -The request is placed at the last of queries queue. When the data has been -retrieved and Emacs remains idle a certain time specified by -`twittering-url-request-sentinel-delay', SENTINEL will be called as - (funcall SENTINEL URL url-data). -The retrieved data can be referred as (gethash URL twittering-url-data-hash)." - (let ((data (gethash url twittering-url-data-hash))) - (cond - ((or (null data) (integerp data)) - (add-to-list 'twittering-url-request-list url t) - (when sentinel - (let ((current (gethash url twittering-url-request-sentinel-hash))) - (unless (member sentinel current) - (puthash url (cons sentinel current) - twittering-url-request-sentinel-hash)))) - (twittering-resolve-url-request) - nil) - (t - ;; URL has been already retrieved. - (twittering-run-on-idle twittering-url-request-sentinel-delay - sentinel url data) - data)))) - -;;;; -;;;; XML parser -;;;; - -(defun twittering-ucs-to-char-internal (code-point) - ;; Check (featurep 'unicode) is a workaround with navi2ch to avoid - ;; error "error in process sentinel: Cannot open load file: - ;; unicode". - ;; - ;; Details: navi2ch prior to 1.8.3 (which is currently last release - ;; version as of 2010-01-18) always define `ucs-to-char' as autoload - ;; file "unicode(.el)" (which came from Mule-UCS), hence it breaks - ;; `ucs-to-char' under non Mule-UCS environment. The problem is - ;; fixed in navi2ch dated 2010-01-16 or later, but not released yet. - (if (and (featurep 'unicode) (functionp 'ucs-to-char)) - (ucs-to-char code-point) - ;; Emacs21 have a partial support for UTF-8 text, so it can decode - ;; only parts of a text with Japanese. - (decode-char 'ucs code-point))) - -(defvar twittering-unicode-replacement-char - ;; "Unicode Character 'REPLACEMENT CHARACTER' (U+FFFD)" - (or (twittering-ucs-to-char-internal #xFFFD) - ??) - "*Replacement character returned by `twittering-ucs-to-char' when it fails -to decode a code.") - -(defun twittering-ucs-to-char (code-point) - "Return a character specified by CODE-POINT in Unicode. -If it fails to decode the code, return `twittering-unicode-replacement-char'." - (or (twittering-ucs-to-char-internal code-point) - twittering-unicode-replacement-char)) - -(defadvice decode-char (after twittering-add-fail-over-to-decode-char) - (when (null ad-return-value) - (setq ad-return-value twittering-unicode-replacement-char))) - -(defun twittering-xml-parse-region (&rest args) - "Wrapped `xml-parse-region' in order to avoid decoding errors. -After activating the advice `twittering-add-fail-over-to-decode-char', -`xml-parse-region' is called. This prevents `xml-parse-region' from -exiting abnormally by decoding unknown numeric character reference." - (let ((activated (ad-is-active 'decode-char))) - (ad-enable-advice - 'decode-char 'after 'twittering-add-fail-over-to-decode-char) - (ad-activate 'decode-char) - (unwind-protect - (condition-case err - (apply 'xml-parse-region args) - (error - (message "Failed to parse the retrieved XML.") - nil)) - (ad-disable-advice 'decode-char 'after - 'twittering-add-fail-over-to-decode-char) - (if activated - (ad-activate 'decode-char) - (ad-deactivate 'decode-char))))) - -;;;; -;;;; JSON parser with a fallback character -;;;; - -(defconst twittering-surrogate-pair-regexp - (if (<= 23 emacs-major-version) - ;; Literal strings such as "\uXXXX" is not allowed in Emacs 21 - ;; and earlier. A character of invalid code point such as U+D800 - ;; is not allowed in Emacs 22. - ;; To avoid errors caused by literal strings invalid in Emacs 22 - ;; and earlier, the regexp is generated indirectly. - (format "[%c-%c][%c-%c]" - (decode-char 'ucs #xd800) - (decode-char 'ucs #xdbff) - (decode-char 'ucs #xdc00) - (decode-char 'ucs #xdfff)) - ;; A regexp that never matches any strings. - "\\'\\`") - "Regexp to match a surrogate pair for CESU-8. -In Emacs 22 and earlier, this variable is initialized by a regexp -that never matches any string because code points for a surrogate pair, -from U+D800 to U+DFFF, are invalid.") - -(defun twittering-decode-surrogate-pairs-as-cesu-8 (str) - "Decode surrogate pairs in STR similarly to CESU-8. -If STR includes surrogate pairs represented by code points from U+D800 to -U+DFFF, decode them with CESU-8 and return the result. - -A character not in the Basic Multilingual Plane is represented by a surrogate -pair in JSON (RFC4627). This is similar to CESU-8. But the function -`json-read' in `json.el' does not correctly decode surrogate pairs. Therefore, -`json-read' may return a string including invalid code points from U+D800 to -U+DFFF. This function decodes such invalid code points." - (let ((str str) - (prev 0) - (current 0) - (result "")) - (while (setq current - (string-match twittering-surrogate-pair-regexp str prev)) - (let* ((next (match-end 0)) - (decoded-str - (decode-coding-string - (mapconcat - (lambda (c) - (let* ((code-point (encode-char c 'ucs)) - (b1 (/ code-point #x100)) - (b2 (% code-point #x100))) - (unibyte-string b1 b2))) - (match-string 0 str) - "") - 'utf-16))) - (setq result - (concat result - (substring str prev current) - decoded-str)) - (setq prev next))) - (setq result (concat result (substring str prev))) - result)) - -(defadvice json-read-string (after twittering-decode-surrogate-pairs-as-cesu-8) - (when (<= 23 emacs-major-version) - (setq ad-return-value - (twittering-decode-surrogate-pairs-as-cesu-8 ad-return-value)))) - -(defun twittering-json-read (&rest args) - "Wrapped `json-read' in order to avoid decoding errors. -`json-read' is called after activating the advice -`twittering-add-fail-over-to-decode-char'. -This prevents `json-read' from exiting abnormally by decoding an unknown -numeric character reference." - (let ((activated (ad-is-active 'decode-char)) - (json-activated (ad-is-active 'json-read-string))) - (ad-enable-advice - 'decode-char 'after 'twittering-add-fail-over-to-decode-char) - (ad-activate 'decode-char) - (ad-enable-advice 'json-read-string 'after - 'twittering-decode-surrogate-pairs-as-cesu-8) - (ad-activate 'json-read-string) - (unwind-protect - (condition-case err - (apply 'json-read args) - (error - (message "Failed to parse the retrieved JSON.") - nil)) - (ad-disable-advice 'decode-char 'after - 'twittering-add-fail-over-to-decode-char) - (ad-disable-advice 'json-read-string 'after - 'twittering-decode-surrogate-pairs-as-cesu-8) - (if activated - (ad-activate 'decode-char) - (ad-deactivate 'decode-char)) - (if json-activated - (ad-activate 'json-read-string) - (ad-deactivate 'json-read-string)) - ))) - -;;;; -;;;; Window configuration -;;;; - -(defun twittering-set-window-end (window pos) - (let* ((height (window-text-height window)) - (n (- (- height 1)))) - (while (progn (setq n (1+ n)) - (set-window-start - window - (with-current-buffer (window-buffer window) - (save-excursion - (goto-char pos) - (line-beginning-position n)))) - (not (pos-visible-in-window-p pos window)))))) - -(defun twittering-current-window-config (window-list) - "Return window parameters of WINDOW-LIST." - (mapcar (lambda (win) - (let ((start (window-start win)) - (point (window-point win))) - `(,win ,start ,point))) - window-list)) - -(defun twittering-restore-window-config-after-modification (config beg end) - "Restore window parameters changed by modification on given region. -CONFIG is window parameters made by `twittering-current-window-config'. -BEG and END mean a region that had been modified." - (mapc (lambda (entry) - (let ((win (elt entry 0)) - (start (elt entry 1)) - (point (elt entry 2))) - (when (and (< beg start) (< start end)) - (set-window-start win start)) - (when (and (< beg point) (< point end)) - (set-window-point win point)))) - config)) - -(defun twittering-pop-to-buffer (buf) - "Select the buffer BUF in some window. -The behavior is determined by the function specified by -`twittering-pop-to-buffer-function'." - (funcall twittering-pop-to-buffer-function buf)) - -(defun twittering-pop-to-buffer-simple (buf) - "Select the buffer BUF by using `pop-to-buffer'." - (let ((win (selected-window))) - (pop-to-buffer buf) - ;; This is required because the new window generated by `pop-to-buffer' - ;; may hide the region following the current position. - (twittering-ensure-whole-of-status-is-visible win))) - -(defun twittering-pop-to-buffer-in-current-window (buf &optional win) - "Select the buffer BUF in the window WIN by splitting it. -If WIN is nil, the selected window is splitted." - (let* ((win (or win (selected-window))) - (size - (let ((rest (- (window-height win) 15))) - (if (<= rest 3) - ;; To avoid an error due to a too small window. - nil - rest))) - (new-win (split-window win size))) - (select-window new-win) - (switch-to-buffer buf))) - -(defun twittering-pop-to-buffer-in-largest-window (buf) - "Select the buffer BUF in the largest window by splitting it." - (let ((win - (lexical-let ((max-area 0) - (largest-win nil)) - (walk-windows - (lambda (win) - (let ((area (* (window-height win) (window-width win)))) - (when (< max-area area) - (setq max-area area) - (setq largest-win win))))) - largest-win))) - (twittering-pop-to-buffer-in-current-window buf win))) - -(defun twittering-pop-to-buffer-in-bottom-largest-window (buf) - "Select the buffer BUF in the window largest on bottom by splitting it." - (let* ((bottom-win-list - (lexical-let ((win-list '()) - (max-bottom 0)) - (walk-windows - (lambda (win) - (let ((bottom (nth 3 (window-edges win)))) - (cond - ((< max-bottom bottom) - (setq max-bottom bottom) - (setq win-list `(,win))) - ((= max-bottom bottom) - (setq win-list (cons win win-list))) - (t - nil))))) - win-list)) - (win - (lexical-let ((max-area 0) - (largest-win nil)) - (mapc (lambda (win) - (let ((area (* (window-height win) (window-width win)))) - (when (< max-area area) - (setq largest-win win) - (setq max-area area)))) - bottom-win-list) - largest-win))) - (twittering-pop-to-buffer-in-current-window buf win))) - -;;;; -;;;; URI shortening -;;;; - -(defun twittering-tinyurl-get (longurl &optional service) - "Shorten LONGURL with the service specified by `twittering-tinyurl-service'." - (let* ((service (or service twittering-tinyurl-service)) - (api (cdr (assq service twittering-tinyurl-services-map))) - (request-generator (when (listp api) (elt api 0))) - (post-process (when (listp api) (elt api 1))) - (encoded-url (twittering-percent-encode longurl)) - (request - (cond - ((stringp api) - (twittering-make-http-request-from-uri - "GET" nil (concat api encoded-url))) - ((stringp request-generator) - (twittering-make-http-request-from-uri - "GET" nil (concat request-generator encoded-url))) - ((functionp request-generator) - (funcall request-generator service longurl)) - (t - (error "%s is invalid. try one of %s" - (symbol-name service) - (mapconcat (lambda (x) (symbol-name (car x))) - twittering-tinyurl-services-map ", ")) - nil))) - (additional-info `((longurl . ,longurl)))) - (cond - ((null request) - (error "Failed to generate a HTTP request for shortening %s with %s" - longurl (symbol-name service)) - nil) - (t - (lexical-let ((result 'queried)) - (let ((proc - (twittering-send-http-request - request additional-info - (lambda (proc status connection-info header-info) - (let ((status-line (cdr (assq 'status-line header-info))) - (status-code (cdr (assq 'status-code header-info)))) - (case-string - status-code - (("200") - (setq result (buffer-string)) - nil) - (t - (setq result nil) - (format "Response: %s" status-line))))) - (lambda (proc status connection-info) - (when (and (not (twittering-process-alive-p proc)) - (eq result 'queried)) - (setq result nil)))))) - (twittering-wait-while nil 0.1 - (and (eq result 'queried) - (twittering-process-alive-p proc))) - (when (and (eq result 'queried) - (not (twittering-process-alive-p proc))) - ;; If the process has been dead, wait a moment because - ;; Emacs may be in the middle of evaluating the sentinel. - (twittering-wait-while 10 0.1 - (eq result 'queried) - nil - ;; Reset `result' on timeout. - (setq result nil)))) - (let ((processed-result (if (and result (functionp post-process)) - (funcall post-process service result) - result))) - (if processed-result - processed-result - (error "Failed to shorten a URL %s with %s" - longurl (symbol-name service)) - nil))))))) - -(defun twittering-tinyurl-replace-at-point () - "Replace the url at point with a tiny version." - (interactive) - (let ((url-bounds (bounds-of-thing-at-point 'url))) - (when url-bounds - (let ((url (twittering-tinyurl-get (thing-at-point 'url)))) - (when url - (save-restriction - (narrow-to-region (car url-bounds) (cdr url-bounds)) - (delete-region (point-min) (point-max)) - (insert url))))))) - -(defun twittering-make-http-request-for-bitly (service longurl) - "Make a HTTP request for URL shortening service bit.ly or j.mp. -Before calling this, you have to configure `twittering-bitly-login' and -`twittering-bitly-api-key'." - (let* ((query-string - (mapconcat - (lambda (entry) - (concat (car entry) "=" (cdr entry))) - `(("login" . ,twittering-bitly-login) - ("apiKey" . ,twittering-bitly-api-key) - ("format" . "txt") - ("longUrl" . ,(twittering-percent-encode longurl))) - "&")) - (prefix - (cdr (assq service '((bit.ly . "http://api.bit.ly/v3/shorten?") - (j.mp . "http://api.j.mp/v3/shorten?"))))) - (uri (concat prefix query-string))) - (twittering-make-http-request-from-uri "GET" nil uri))) - -;;;; -;;;; Timeline spec -;;;; - -;;; Timeline spec as S-expression -;;; - (user USER): timeline of the user whose name is USER. USER is a string. -;;; - (list USER LIST): -;;; the list LIST of the user USER. LIST and USER are strings. -;;; -;;; - (direct_message_events): received direct messages. -;;; - (direct_messages): received direct messages. -;;; - (direct_messages_sent): sent direct messages. -;;; - (favorites): favorites timeline for the current user. -;;; - (favorites USER): favorites timeline for the specified user. -;;; - (friends): friends timeline. -;;; - (home): home timeline. -;;; - (mentions): mentions timeline. -;;; mentions (status containing @username) for the authenticating user. -;;; - (public): public timeline. -;;; - (replies): replies. -;;; - (retweeted_by_me): retweets posted by the authenticating user. -;;; - (retweeted_by_user USER): retweets posted by the user. -;;; - (retweeted_to_me): retweets posted by the authenticating user's friends. -;;; - (retweeted_to_user USER): retweets posted to the user. -;;; - (retweets_of_me): -;;; tweets of the authenticated user that have been retweeted by others. -;;; - (single ID): the single tweet specified by ID. -;;; -;;; - (search STRING): the result of searching with query STRING. -;;; -;;; - (exclude-if FUNC SPEC): -;;; the same timeline as SPEC, except that it does not include tweets -;;; that FUNC returns non-nil for. -;;; - (exclude-re REGEXP-STRING SPEC): -;;; the same timeline as SPEC, except that it does not include tweets -;;; that matches the regular expression specified by REGEXP-STRING. -;;; -;;; - (merge SPEC1 SPEC2 ...): result of merging timelines SPEC1 SPEC2 ... -;;; - -;;; Timeline spec string -;;; -;;; SPEC ::= PRIMARY | COMPOSITE -;;; PRIMARY ::= USER | LIST | DIRECT_MESSSAGES | DIRECT_MESSSAGES_SENT -;;; | FRIENDS | HOME | MENTIONS | PUBLIC | REPLIES -;;; | RETWEETED_BY_ME | RETWEETED_BY_USER -;;; | RETWEETED_TO_ME | RETWEETED_TO_USER | RETWEETS_OF_ME -;;; | SEARCH -;;; COMPOSITE ::= EXCLUDE-IF | EXCLUDE-RE | MERGE -;;; -;;; USER ::= /[a-zA-Z0-9_-]+/ -;;; LIST ::= USER "/" LISTNAME -;;; LISTNAME ::= /[a-zA-Z0-9_-]+/ -;;; DIRECT_MESSSAGE_EVENTS ::= ":direct_message_events" -;;; DIRECT_MESSSAGES ::= ":direct_messages" -;;; DIRECT_MESSSAGES_SENT ::= ":direct_messages_sent" -;;; FAVORITES ::= ":favorites" | ":favorites/" USER -;;; FRIENDS ::= ":friends" -;;; HOME ::= ":home" | "~" -;;; MENTIONS ::= ":mentions" -;;; PUBLIC ::= ":public" -;;; REPLIES ::= ":replies" | "@" -;;; RETWEETED_BY_ME ::= ":retweeted_by_me" -;;; RETWEETED_BY_USER ::= ":retweeted_by_user/" USER -;;; RETWEETED_TO_ME ::= ":retweeted_to_me" -;;; RETWEETED_TO_USER ::= ":retweeted_to_user/" USER -;;; RETWEETS_OF_ME ::= ":retweets_of_me" -;;; SINGLE ::= ":single/" ID -;;; ID ::= /[0-9]+/ -;;; -;;; SEARCH ::= ":search/" QUERY_STRING "/" -;;; QUERY_STRING ::= any string, where "/" is escaped by a backslash. -;;; -;;; EXCLUDE-IF ::= ":exclude-if/" FUNC "/" SPEC -;;; FUNC ::= LAMBDA EXPRESSION | SYMBOL -;;; EXCLUDE-RE ::= ":exclude-re/" REGEXP "/" SPEC -;;; -;;; MERGE ::= "(" MERGED_SPECS ")" -;;; MERGED_SPECS ::= SPEC | SPEC "+" MERGED_SPECS -;;; - -(defvar twittering-regexp-hash - (let ((full-width-number-sign (twittering-ucs-to-char #xff03))) - ;; Unicode Character 'FULLWIDTH NUMBER SIGN' (U+FF03) - (concat "\\(?:#\\|" (char-to-string full-width-number-sign) "\\)"))) - -(defvar twittering-regexp-atmark - (let ((full-width-commercial-at (twittering-ucs-to-char #xff20))) - ;; Unicode Character 'FULLWIDTH COMMERCIAL AT' (U+FF20) - (concat "\\(?:@\\|" (char-to-string full-width-commercial-at) "\\)"))) - -(defun twittering-timeline-spec-to-string (timeline-spec &optional shorten) - "Convert TIMELINE-SPEC into a string. -If SHORTEN is non-nil, the abbreviated expression will be used." - (let ((type (car timeline-spec)) - (value (cdr timeline-spec))) - (cond - ;; user - ((eq type 'user) (car value)) - ;; list - ((eq type 'list) (concat (car value) "/" (cadr value))) - ;; simple - ((eq type 'direct_message_events) ":direct_message_events") - ((eq type 'direct_messages) ":direct_messages") - ((eq type 'direct_messages_sent) ":direct_messages_sent") - ((eq type 'favorites) - (if value - (concat ":favorites/" (car value)) - ":favorites")) - ((eq type 'friends) ":friends") - ((eq type 'home) (if shorten "~" ":home")) - ((eq type 'mentions) (if shorten "@" ":mentions")) - ((eq type 'public) ":public") - ((eq type 'replies) ":replies") - ((eq type 'retweeted_by_me) ":retweeted_by_me") - ((eq type 'retweeted_by_user) (concat ":retweeted_by_user/" (car value))) - ((eq type 'retweeted_to_me) ":retweeted_to_me") - ((eq type 'retweeted_to_user) (concat ":retweeted_to_user/" (car value))) - ((eq type 'retweets_of_me) ":retweets_of_me") - ((eq type 'single) (concat ":single/" (car value))) - ((eq type 'search) - (let ((query (car value))) - (concat ":search/" - (replace-regexp-in-string "\\(\\\\\\|/\\)" "\\\\\\1" query) - "/"))) - ;; composite - ((eq type 'exclude-if) - (let ((func (car value)) - (spec (cadr value)) - (print-level nil)) - (concat ":exclude-if/" (prin1-to-string func) "/" - (twittering-timeline-spec-to-string spec)))) - ((eq type 'exclude-re) - (let ((regexp-str (car value)) - (spec (cadr value)) - (print-level nil)) - (concat ":exclude-re/" - (replace-regexp-in-string "/" "\\\\\/" regexp-str) - "/" - (twittering-timeline-spec-to-string spec)))) - ((eq type 'merge) - (concat "(" - (mapconcat 'twittering-timeline-spec-to-string value "+") - ")")) - (t - nil)))) - -(eval-and-compile - (defmacro twittering-make-user-timeline-spec-direct (user) - `(list 'user ,user)) - (defmacro twittering-make-list-timeline-spec-direct (owner listname) - `(list 'list ,owner ,listname)) - (defmacro twittering-make-hashtag-timeline-spec-direct (tag) - `(list 'search (concat "#" ,tag))) - (defmacro twittering-make-hashtag-timeline-spec-string-direct (tag) - `(concat "#" ,tag))) - -(defun twittering-extract-timeline-spec (str &optional unresolved-aliases) - "Extract one timeline spec from STR. -Return cons of the spec and the rest string." - (cond - ((null str) - (error "STR is nil") - nil) - ((string-match "^\\([a-zA-Z0-9_-]+\\)/\\([[:word:]_-]+\\)" str) - (let ((user (match-string 1 str)) - (listname (match-string 2 str)) - (rest (substring str (match-end 0)))) - `(,(twittering-make-list-timeline-spec-direct user listname) . ,rest))) - ((string-match "^\\([a-zA-Z0-9_-]+\\)" str) - (let ((user (match-string 1 str)) - (rest (substring str (match-end 0)))) - `(,(twittering-make-user-timeline-spec-direct user) . ,rest))) - ((string-match "^~" str) - `((home) . ,(substring str (match-end 0)))) - ((string-match (concat "^" twittering-regexp-atmark) str) - `((mentions) . ,(substring str (match-end 0)))) - ((string-match (concat "^" twittering-regexp-hash "\\([[:alpha:]0-9_-]+\\)") - str) - (let* ((tag (match-string 1 str)) - (rest (substring str (match-end 0)))) - `(,(twittering-make-hashtag-timeline-spec-direct tag) . ,rest))) - ((string-match "^:\\([a-z_-]+\\)" str) - (let ((type (match-string 1 str)) - (following (substring str (match-end 0))) - (alist '(("direct_message_events" . direct_message_events) - ("direct_messages" . direct_messages) - ("direct_messages_sent" . direct_messages_sent) - ("friends" . friends) - ("home" . home) - ("mentions" . mentions) - ("public" . public) - ("replies" . replies) - ("retweeted_by_me" . retweeted_by_me) - ("retweeted_to_me" . retweeted_to_me) - ("retweets_of_me" . retweets_of_me)))) - (cond - ((assoc type alist) - (let ((first-spec (list (cdr (assoc type alist))))) - (cons first-spec following))) - ((string= type "favorites") - (if (string-match "^:favorites/\\([a-zA-Z0-9_-]+\\)" str) - (let ((rest (substring str (match-end 0)))) - `((favorites ,(match-string 1 str)) . ,rest)) - `((favorites) . ,following))) - ((string-match "^:retweeted_by_user/\\([a-zA-Z0-9_-]+\\)" str) - (let ((user (match-string 1 str)) - (rest (substring str (match-end 0)))) - `((retweeted_by_user ,user) . ,rest))) - ((string-match "^:retweeted_to_user/\\([a-zA-Z0-9_-]+\\)" str) - (let ((user (match-string 1 str)) - (rest (substring str (match-end 0)))) - `((retweeted_to_user ,user) . ,rest))) - ((string-match "^:single/\\([0-9]+\\)" str) - (let ((id (match-string 1 str)) - (rest (substring str (match-end 0)))) - `((single ,id) . ,rest))) - ((string= type "search") - (if (string-match "^:search/\\(\\(.*?[^\\]\\)??\\(\\\\\\\\\\)*\\)??/" - str) - (let* ((escaped-query (or (match-string 1 str) "")) - (query (replace-regexp-in-string "\\\\\\(\\\\\\|/\\)" "\\1" - escaped-query)) - (rest (substring str (match-end 0)))) - (if (not (string= "" escaped-query)) - `((search ,query) . ,rest) - (error "\"%s\" has no valid regexp" str) - nil)))) - ((string= type "exclude-if") - (let ((result-pair - (cond - ((string-match "^:exclude-if/\\([^(/]+\\)/" str) - `(,(intern (match-string 1 str)) . ,(match-end 1))) - ((string-match "^:exclude-if/" str) - (condition-case err - (read-from-string str (match-end 0)) - (error - nil)))))) - (if result-pair - (let ((func (car result-pair)) - (pos (cdr result-pair))) - (cond - ((not (functionp func)) - (error "\"%s\" has an invalid function" str) - nil) - ((<= (length str) (1+ pos)) - (error "\"%s\" has no timeline spec" str) - nil) - ((not (char-equal ?/ (aref str pos))) - (error "\"%s\" has no delimiter" str) - nil) - (t - (let* ((pair (twittering-extract-timeline-spec - (substring str (1+ pos)) unresolved-aliases)) - (spec (car pair)) - (rest (cdr pair))) - `((exclude-if ,func ,spec) . ,rest))))) - (error "\"%s\" has an invalid function" str) - nil))) - ((string= type "exclude-re") - (cond - ((string-match "^:exclude-re/\\(\\(.*?[^\\]\\)??\\(\\\\\\\\\\)*\\)??/" - str) - (let* ((escaped-regexp (or (match-string 1 str) "")) - (regexp - (replace-regexp-in-string "\\\\/" "/" escaped-regexp nil t)) - (following (substring str (match-end 0)))) - (cond - ((string= "" escaped-regexp) - (error "\"%s\" has no valid regexp" str) - nil) - (t - (let* ((pair (twittering-extract-timeline-spec - following unresolved-aliases)) - (spec (car pair)) - (rest (cdr pair))) - `((exclude-re ,regexp ,spec) . ,rest)))))) - (t - (error "\"%s\" has no valid regexp" str) - nil))) - (t - (error "\"%s\" is invalid as a timeline spec" str) - nil)))) - ((string-match "^\\$\\([a-zA-Z0-9_-]+\\)\\(?:(\\([^)]*\\))\\)?" str) - (let* ((name (match-string 1 str)) - (rest (substring str (match-end 0))) - (value (cdr-safe (assoc name twittering-timeline-spec-alias))) - (arg (match-string 2 str))) - (if (member name unresolved-aliases) - (error "Alias \"%s\" includes a recursive reference" name) - (cond - ((stringp value) - (twittering-extract-timeline-spec - (concat value rest) - (cons name unresolved-aliases))) - ((functionp value) - (twittering-extract-timeline-spec - (funcall value arg) - (cons name unresolved-aliases))) - (t - (error "Alias \"%s\" is undefined" name)))))) - ((string-match "^(" str) - (let ((rest (concat "+" (substring str (match-end 0)))) - (result '())) - (while (and rest (string-match "^\\+" rest)) - (let* ((spec-string (substring rest (match-end 0))) - (pair (twittering-extract-timeline-spec - spec-string unresolved-aliases)) - (spec (car pair)) - (next-rest (cdr pair))) - (setq result (cons spec result)) - (setq rest next-rest))) - (if (and rest (string-match "^)" rest)) - (let ((spec-list - (twittering-remove-duplicates - (apply 'append - (mapcar (lambda (x) (if (eq 'merge (car x)) - (cdr x) - (list x))) - (reverse result)))))) - (if (= 1 (length spec-list)) - `(,(car spec-list) . ,(substring rest 1)) - `((merge ,@spec-list) . ,(substring rest 1)))) - (if rest - ;; The string following the opening parenthesis `(' - ;; can be interpreted without errors, - ;; but there is no corresponding closing parenthesis. - (error "\"%s\" lacks a closing parenthesis" str)) - ;; Does not display additional error messages if an error - ;; occurred on interpreting the string following - ;; the opening parenthesis `('. - nil))) - (t - (error "\"%s\" is invalid as a timeline spec" str) - nil) - )) - -(defun twittering-string-to-timeline-spec (spec-str &optional noerror) - "Convert SPEC-STR into a timeline spec. -If SPEC-STR is invalid as a timeline spec string, raise an error or return -nil if NOERROR is non-nil." - (let ((result-pair - (condition-case err - (twittering-extract-timeline-spec spec-str) - (error - (if noerror - nil - (signal (car err) (cdr err)) - nil))))) - (if (and result-pair (string= "" (cdr result-pair))) - (car result-pair) - nil))) - -(defun twittering-timeline-spec-primary-p (spec) - "Return non-nil if SPEC is a primary timeline spec. -`primary' means that the spec is not a composite timeline spec such as -`merge'." - (let ((primary-spec-types - '(user list - direct_message_events direct_messages direct_messages_sent - favorites friends home mentions public replies - search - retweeted_by_me retweeted_by_user - retweeted_to_me retweeted_to_user - retweets_of_me - single)) - (type (car spec))) - (memq type primary-spec-types))) - -(defun twittering-timeline-spec-composite-p (spec) - "Return non-nil if SPEC is a composite timeline spec. -`composite' means that the spec depends on other timelines." - (let ((composite-spec-types - '(exclude-if exclude-re merge)) - (type (car spec))) - (memq type composite-spec-types))) - -(defun twittering-timeline-spec-depending-on-p (spec base-spec) - "Return non-nil if SPEC depends on BASE-SPEC." - (cond - ((twittering-timeline-spec-primary-p spec) - (equal spec base-spec)) - ((equal spec base-spec) - t) - (t - (remove - nil - (mapcar - (lambda (direct-base-spec) - (twittering-timeline-spec-depending-on-p direct-base-spec base-spec)) - (twittering-get-base-timeline-specs spec)))))) - -(defun twittering-timeline-spec-is-user-p (spec) - "Return non-nil if SPEC is a user timeline." - (and (consp spec) (eq 'user (car spec)))) - -(defun twittering-timeline-spec-is-direct-message-events-p (spec) - "Return non-nil if SPEC is a timeline spec which is related of -direct_message_events." - (and spec - (memq (car spec) '(direct_message_events)))) - -(defun twittering-timeline-spec-is-direct-messages-p (spec) - "Return non-nil if SPEC is a timeline spec which is related of -direct_messages." - (and spec - (memq (car spec) '(direct_messages direct_messages_sent)))) - -(defun twittering-timeline-spec-is-search-p (spec) - "Return non-nil if SPEC is a search timeline spec." - (and (consp spec) - (eq 'search (car spec)))) - -(defun twittering-extract-query-string-from-search-timeline-spec (spec) - "Return the query string if SPEC is a search timeline spec. -If SPEC is not a search timeline spec, return nil." - (and (eq 'search (car spec)) - (cadr spec))) - -(defun twittering-equal-string-as-timeline (spec-str1 spec-str2) - "Return non-nil if SPEC-STR1 equals SPEC-STR2 as a timeline spec. -If either SPEC-STR1 or SPEC-STR2 is invalid as a timeline spec string, -return nil." - (if (and (stringp spec-str1) (stringp spec-str2)) - (let ((spec1 (twittering-string-to-timeline-spec spec-str1 t)) - (spec2 (twittering-string-to-timeline-spec spec-str2 t))) - (equal spec1 spec2)) - nil)) - -(defun twittering-get-base-timeline-specs (spec) - "Return the timeline specs on which the timeline SPEC depends. -If SPEC is primary, returns a list consisting of itself. -The result timelines may be a composite timeline." - (let ((type (car spec))) - (cond - ((twittering-timeline-spec-primary-p spec) - `(,spec)) - ((memq type '(exclude-if exclude-re)) - `(,(elt spec 2))) - ((eq type 'merge) - (cdr spec)) - (t - nil)))) - -(defun twittering-get-primary-base-timeline-specs (spec) - "Return the primary timeline specs on which the timeline SPEC depends. -If SPEC is primary, returns a list consisting of itself. -The result timelines are primary." - (if (twittering-timeline-spec-primary-p spec) - `(,spec) - (twittering-remove-duplicates - (apply 'append - (mapcar 'twittering-get-primary-base-timeline-specs - (twittering-get-base-timeline-specs spec)))))) - -(defun twittering-get-dependent-timeline-specs (base-spec) - "Return a list of timeline specs that depend on BASE-SPEC. -If BASE-SPEC is a primary timeline spec, the return value consists of -BASE-SPEC and composite timeline specs that depend on BASE-SPEC and are -bound to a live buffer. -If BASE-SPEC is a composite timeline spec, the return value consists of -composite timeline specs that depend on BASE-SPEC and are bound to a live -buffer." - (twittering-remove-duplicates - `(;; BASE-SPEC may not be bound to a live buffer. - ,@(when (twittering-timeline-spec-primary-p base-spec) - `(,base-spec)) - ,@(remove - nil - (mapcar - (lambda (spec) - (when (twittering-timeline-spec-depending-on-p spec base-spec) - spec)) - (mapcar 'twittering-get-timeline-spec-for-buffer - (twittering-get-buffer-list))))))) - -(defun twittering-generate-composite-timeline (spec base-spec base-statuses) - "Generate statuses for the timeline SPEC from BASE-STATUSES. -BASE-STATUSES must originate from the BASE-SPEC timeline. -If SPEC is a primary timeline and equals BASE-SPEC, just return BASE-STATUSES. -If SPEC is a primary timeline and does not equal BASE-SPEC, return nil." - (let ((type (car spec))) - (cond - ((twittering-timeline-spec-primary-p spec) - (if (equal spec base-spec) - (let ((pattern-list - (twittering-get-filter-list-for-timeline-spec - spec))) - (if pattern-list - (remove - nil - (mapcar - (lambda (status) - (if (twittering-match-pattern-list status pattern-list) - (progn - (debug-printf "Exclude the status: %s" status) - nil) - status)) - base-statuses)) - base-statuses)) - nil)) - ((eq type 'exclude-if) - (let* ((direct-base (car (twittering-get-base-timeline-specs spec))) - (direct-base-statuses - (twittering-generate-composite-timeline direct-base - base-spec base-statuses)) - (func (elt spec 1))) - (remove nil - (mapcar (lambda (status) - (unless (funcall func status) - status)) - direct-base-statuses)))) - ((eq type 'exclude-re) - (let* ((direct-base (car (twittering-get-base-timeline-specs spec))) - (direct-base-statuses - (twittering-generate-composite-timeline direct-base - base-spec base-statuses)) - (regexp (elt spec 1))) - (remove nil - (mapcar - (lambda (status) - (unless (string-match regexp (cdr (assq 'text status))) - status)) - direct-base-statuses)))) - ((eq type 'merge) - (sort - (apply 'append - (mapcar (lambda (direct-base-spec) - ;; `copy-sequence' is required because `sort' - ;; modifies the appended list that may include - ;; `base-statuses' as a tail. - ;; `base-statuses' may refer to the original list - ;; which already retrieved tweets are registered - ;; with. It must not be modified. - (copy-sequence - (twittering-generate-composite-timeline - direct-base-spec base-spec base-statuses))) - (twittering-get-base-timeline-specs spec))) - (lambda (status1 status2) - (let ((id1 (cdr (assq 'id status1))) - (id2 (cdr (assq 'id status2)))) - (twittering-status-id< id2 id1))))) - (t - nil)))) - -;;;; -;;;; Filter -;;;; - -(defun twittering-get-filter-list-for-timeline-spec-string (spec-string) - (let ((entry-list twittering-filter-alist)) - (remove - nil - (mapcar - (lambda (entry) - (let ((spec-regexp - (if (listp (car entry)) - (concat "\\(?:" - (mapconcat 'identity (car entry) "\\|") - "\\)") - (car entry))) - (pattern-list (cdr entry))) - (when (string-match spec-regexp spec-string) - pattern-list))) - entry-list)))) - -(defun twittering-get-filter-list-for-timeline-spec (spec) - (when twittering-filter-alist - (let* ((spec-string (twittering-timeline-spec-to-string spec)) - (short-spec-string (twittering-timeline-spec-to-string spec t)) - (regexp-list - (twittering-get-filter-list-for-timeline-spec-string - spec-string))) - (if (string= spec-string short-spec-string) - regexp-list - (append regexp-list - (twittering-get-filter-list-for-timeline-spec-string - short-spec-string)))))) - -(defun twittering-match-pattern (status pattern) - (let* ((rest pattern) - (matched t)) - (while (and rest matched) - (let* ((current (car rest)) - (sym (car current)) - (regexp (cdr current)) - (value (cdr (assq sym status))) - (value - (if (eq sym 'text) - (twittering-make-fontified-tweet-text-with-entity status) - value))) - (unless (and (stringp value) - (string-match regexp value)) - (setq matched nil)) - (setq rest (cdr rest)))) - matched)) - -(defun twittering-match-pattern-list (status pattern-list) - (let* ((rest pattern-list) - (matched nil)) - (while (and rest (not matched)) - (let ((current (car rest))) - (when (twittering-match-pattern status current) - (setq matched t)) - (setq rest (cdr rest)))) - matched)) - -;;;; -;;;; Retrieved statuses (timeline data) -;;;; - -(defun twittering-current-timeline-id-table (&optional spec) - (let ((spec (or spec (twittering-current-timeline-spec)))) - (if spec - (elt (gethash spec twittering-timeline-data-table) 0) - nil))) - -(defun twittering-current-timeline-referring-id-table (&optional spec) - "Return the hash from a ID to the ID of the first observed status -referring the former ID." - (let* ((spec (or spec (twittering-current-timeline-spec))) - (type (car spec))) - (cond - ((null spec) - nil) - ((memq type '(exclude-if exclude-re merge)) - ;; Use the first non-nil table instead of merging the all tables - ;; because it may take a long time to merge them. - (car - (remove - nil - (mapcar (lambda (base-spec) - (elt (gethash base-spec twittering-timeline-data-table) 1)) - (twittering-get-primary-base-timeline-specs spec))))) - ((eq type 'single) - ;; Single tweet timelines are registered in a special way. - ;; See `twittering-retrieve-single-tweet-sentinel'. - (elt (gethash '(:single) twittering-timeline-data-table) 1)) - (t - (elt (gethash spec twittering-timeline-data-table) 1))))) - -(defun twittering-current-timeline-data (&optional spec) - (let* ((spec (or spec (twittering-current-timeline-spec))) - (type (car spec))) - (cond - ((null spec) - nil) - ((eq type 'single) - (let* ((id (cadr spec)) - (status (twittering-find-status id))) - (if status - `(,status) - nil))) - ((memq type '(exclude-if exclude-re merge)) - (let ((primary-base-specs - (twittering-get-primary-base-timeline-specs spec))) - (sort - (apply - 'append - (mapcar - (lambda (primary-spec) - ;; `copy-sequence' is required to prevent `sort' - ;; from modifying lists of statuses in the database - ;; `twittering-timeline-data-table'. - ;; The result of `twittering-generate-composite-timeline' - ;; may include a list in the database. If so, the simply - ;; appended list include it as a tail. - (copy-sequence - (twittering-generate-composite-timeline - spec - primary-spec (twittering-current-timeline-data primary-spec)))) - primary-base-specs)) - (lambda (status1 status2) - (let ((id1 (cdr (assq 'id status1))) - (id2 (cdr (assq 'id status2)))) - (twittering-status-id< id2 id1)))))) - ((eq type :single) - ;; The timeline spec '(:single) does not correspond to an ordinary - ;; timeline. It means an unordered set of tweets retrieved by the - ;; 'retrieve-single-tweet command of `twittering-call-api'. - ;; If this function is used with the spec '(:single), a specific tweet - ;; will be required with the user's intention. - ;; In this case, exclusion by patterns does not required. - (elt (gethash spec twittering-timeline-data-table) 2)) - (t - (let ((statuses (elt (gethash spec twittering-timeline-data-table) 2)) - (pattern-list - (twittering-get-filter-list-for-timeline-spec spec))) - (if pattern-list - (remove - nil - (mapcar - (lambda (status) - (if (twittering-match-pattern-list status pattern-list) - (progn - (debug-printf "Exclude the status: %s" status) - nil) - status)) - statuses)) - statuses)))))) - -(defun twittering-remove-timeline-data (&optional spec) - (let ((spec (or spec (twittering-current-timeline-spec)))) - (remhash spec twittering-timeline-data-table))) - -(defun twittering-find-status (id) - (let ((result nil)) - (maphash - (lambda (spec pair) - (let* ((id-table (car pair)) - (entry (gethash id id-table))) - ;; Take the most detailed status. - (when (and entry - (or (null result) (< (length result) (length entry)))) - (setq result entry)))) - twittering-timeline-data-table) - result)) - -(defun twittering-delete-status-from-data-table (id) - (let ((modified-spec nil)) - (maphash - (lambda (spec data) - (let* ((id-table (elt data 0)) - (referring-id-table (elt data 1)) - (timeline-data (elt data 2)) - (status (gethash id id-table))) - (when status - (remhash id id-table) - ;; Here, `referring-id-table' is not modified. - ;; Therefore, the retweet observed secondly will not appear even - ;; if the retweet observed first for the same tweet is deleted. - (setq modified-spec - (cons `(,spec - ,id-table - ,referring-id-table - ,(remove status timeline-data)) - modified-spec))))) - twittering-timeline-data-table) - (mapc - (lambda (spec) - (let ((buffer (twittering-get-buffer-from-spec spec))) - (when (buffer-live-p buffer) - (with-current-buffer buffer - (save-excursion - (twittering-for-each-property-region - 'id - (lambda (beg end value) - (when (twittering-status-id= id value) - (let ((buffer-read-only nil) - (separator-pos (min (point-max) (1+ end)))) - (delete-region beg separator-pos) - (goto-char beg)))) - buffer)))))) - (twittering-remove-duplicates - (apply 'append - (mapcar - (lambda (data) - (let ((spec (car data))) - ;; Update the entry for `spec' in - ;; `twittering-timeline-data-table' with the new - ;; timeline-data that does not include `status'. - (puthash spec (cdr data) twittering-timeline-data-table) - (twittering-get-dependent-timeline-specs spec))) - modified-spec)))))) - -(defun twittering-get-replied-statuses (id &optional count) - "Return a list of replied statuses starting from the status specified by ID. -Statuses are stored in ascending-order with respect to their IDs." - (let ((result nil) - (status (twittering-find-status id))) - (while - (and (if (numberp count) - (<= 0 (setq count (1- count))) - t) - (let ((replied-id (or (cdr (assq 'in-reply-to-status-id status)) - ""))) - (unless (string= "" replied-id) - (let ((replied-status (twittering-find-status replied-id))) - (when replied-status - (setq result (cons replied-status result)) - (setq status replied-status) - t)))))) - result)) - -(defun twittering-have-replied-statuses-p (id) - (let ((status (twittering-find-status id))) - (when status - (let ((replied-id (cdr (assq 'in-reply-to-status-id status)))) - (and replied-id (not (string= "" replied-id))))))) - -(defun twittering-add-statuses-to-timeline-data (statuses &optional spec) - "Add STATUSES as new statuses for SPEC and update derived timelines. -The function returns a list of lists including an updated timeline spec -string and the number of new statuses for the timeline." - (let* ((spec (or spec (twittering-current-timeline-spec))) - (id-table - (or (twittering-current-timeline-id-table spec) - (make-hash-table :test 'equal))) - (referring-id-table - (or (twittering-current-timeline-referring-id-table spec) - (make-hash-table :test 'equal))) - (timeline-data (twittering-current-timeline-data spec))) - (let* ((new-statuses - (remove nil - (mapcar - (lambda (status) - (let ((id (cdr (assq 'id status))) - (retweeted-id (cdr (assq 'retweeted-id status)))) - (unless (or (not retweeted-id) - (gethash retweeted-id referring-id-table)) - ;; Store the id of the first observed tweet - ;; that refers `retweeted-id'. - (puthash retweeted-id id referring-id-table)) - (if (gethash id id-table) - nil - (puthash id status id-table) - (puthash id id referring-id-table) - `((source-spec . ,spec) - ,@status)))) - statuses))) - (new-statuses - ;; Sort tweets by ID. - ;; This is necessary because `twittering-render-timeline' assumes - ;; that given tweets are ordered. - (sort new-statuses - (lambda (status1 status2) - (let ((id1 (cdr (assq 'id status1))) - (id2 (cdr (assq 'id status2)))) - (twittering-status-id< id2 id1)))))) - (when new-statuses - ;; Register user IDs found in new statuses. - (when (and (not (twittering-timeline-spec-is-direct-messages-p spec))) - (mapc #'twittering-register-user-id-from-status new-statuses)) - (let ((new-timeline-data - (sort (append new-statuses timeline-data) - (lambda (status1 status2) - (let ((id1 (cdr (assq 'id status1))) - (id2 (cdr (assq 'id status2)))) - (twittering-status-id< id2 id1)))))) - (puthash spec `(,id-table ,referring-id-table ,new-timeline-data) - twittering-timeline-data-table)) - (let ((twittering-new-tweets-spec spec) - (twittering-new-tweets-statuses new-statuses) - (twittering-new-tweets-count (length new-statuses))) - (run-hooks 'twittering-new-tweets-hook))) - ;; Update timelines derived from SPEC and return the number of - ;; new tweets for each updated timeline. - (remove - nil - (mapcar - (lambda (buffer) - (let ((other-spec (twittering-get-timeline-spec-for-buffer buffer)) - (other-spec-string - (twittering-get-timeline-spec-string-for-buffer buffer))) - (when (twittering-timeline-spec-depending-on-p other-spec spec) - (let* ((twittering-new-tweets-spec other-spec) - (twittering-new-tweets-statuses - (twittering-generate-composite-timeline - other-spec spec new-statuses)) - (twittering-new-tweets-count - (length twittering-new-tweets-statuses)) - (rendered-tweets - (twittering-render-timeline - buffer twittering-new-tweets-statuses t))) - (when rendered-tweets - (when (not (equal spec other-spec)) - ;; The hook has been alreadly invoked for `spec'. - (run-hooks 'twittering-new-tweets-hook)) - `(,other-spec-string ,(length rendered-tweets))))))) - (twittering-get-buffer-list)))))) - -;;;; -;;;; User IDs -;;;; - -(defvar twittering-user-id-db (make-hash-table :test 'equal)) -(defvar twittering-user-screen-name-db (make-hash-table :test 'equal)) -(defvar twittering-user-screen-name-history '() - "Recently registered user screen names. - -It is updated by `twittering-register-user-id'.") -(defvar twittering-user-screen-name-history-length 1000 - "Maximum length of `twittering-user-screen-name-history'.") -(defcustom twittering-user-id-db-file - (expand-file-name "~/.twittering-mode-user-info.gz") - "*The file to which user IDs are stored. - -The file is loaded with `with-auto-compression-mode'." - :group 'twittering-mode - :type 'file) -(defcustom twittering-user-id-db-expiration-date 7 - "*How many days a user ID without update will be saved to the file. - -If nil, all user IDs are saved without regard to dates when they are updated. -The file is specified by `twittering-user-id-db-file'." - :group 'twittering-mode - :type '(choice (const nil) - integer)) - -(defun twittering-registered-user-screen-names () - twittering-user-screen-name-history) - -(defun twittering-find-user (user-id) - (gethash user-id twittering-user-id-db)) - -(defun twittering-find-user-screen-name (user-screen-name) - (gethash user-screen-name twittering-user-screen-name-db)) - -(defun twittering-register-user-id (user-id properties) - (let* ((screen-name (cdr (assq 'screen-name properties))) - (current-properties (twittering-find-user user-id)) - (now-timestamp (current-time)) - (properties - (if (null current-properties) - (if (null (assq 'timestamp properties)) - `(,@properties - (timestamp . ,now-timestamp)) - properties) - `(,@properties - ,@(remove nil - (mapcar (lambda (entry) - (when (and - (not (assq (car entry) properties)) - (not (eq (car entry) 'timestamp))) - entry)) - current-properties)) - (timestamp . ,now-timestamp))))) - (puthash user-id properties twittering-user-id-db) - (add-to-history 'twittering-user-screen-name-history screen-name - twittering-user-screen-name-history-length) - (when screen-name - (puthash screen-name properties twittering-user-screen-name-db)))) - -(defun twittering-register-user-id-from-status (status) - (let* ((id (cdr (assq 'user-id status))) - (symbols '((user-id . id) - (user-name . name) - (user-screen-name . screen-name) - (user-profile-image-url . profile-image-url) - ;; (user-description . description) - ;; (user-location . location) - )) - (info (mapcar (lambda (pair) - (let ((source-sym (car pair)) - (dest-sym (cdr pair))) - `(,dest-sym . ,(cdr (assq source-sym status))))) - symbols))) - (twittering-register-user-id id info) - (when (assq 'quoted-status status) - (twittering-register-user-id-from-status - (cdr (assq 'quoted-status status)))) - (when (assq 'retweeting-id status) - ;; Register a user ID from a retweeting tweet. - (let* ((id-of-retweet (cdr (assq 'retweeting-user-id status))) - (info-of-retweet - (mapcar (lambda (pair) - (let* ((raw-source-sym (car pair)) - (source-sym - (intern - (concat "retweeting-" - (symbol-name raw-source-sym)))) - (dest-sym (cdr pair))) - `(,dest-sym . ,(cdr (assq source-sym status))))) - symbols))) - (twittering-register-user-id id-of-retweet info-of-retweet))) - )) - -(defun twittering-save-user-id-db (&optional filename) - (let ((filename (or filename twittering-user-id-db-file)) - (stored-data - (let* ((result nil) - (current (current-time)) - (limit - (when twittering-user-id-db-expiration-date - (time-subtract - (current-time) - (seconds-to-time - (* twittering-user-id-db-expiration-date 24 60 60)))))) - (maphash - (lambda (user-id properties) - (let ((timestamp (cdr (assq 'timestamp properties)))) - (when (or (null twittering-user-id-db-expiration-date) - (time-less-p limit timestamp)) - (setq result (cons `(,user-id ,@properties) result))))) - twittering-user-id-db) - result)) - ;; Bind `default-directory' to the temporary directory - ;; because it is possible that the directory pointed by - ;; `default-directory' has been already removed. - (default-directory temporary-file-directory)) - (message "Saving %d user IDs." (length stored-data)) - (when (require 'jka-compr nil t) - (with-auto-compression-mode - (let ((coding-system-for-write 'utf-8)) - (with-temp-file filename - (insert "( 1 ") - (prin1 (cons 'emacs-version emacs-version) (current-buffer)) - (insert "(user-id-list ") - (mapc (lambda (entry) (prin1 entry (current-buffer))) stored-data) - (insert "))"))))))) - -(defun twittering-load-user-id-db (&optional filename) - (let* ((filename (or filename twittering-user-id-db-file)) - ;; Bind `default-directory' to the temporary directory - ;; because it is possible that the directory pointed by - ;; `default-directory' has been already removed. - (default-directory temporary-file-directory) - (data - (with-temp-buffer - (condition-case err - (cond - ((and (require 'jka-compr) - (file-exists-p filename)) - (with-auto-compression-mode - (let ((coding-system-for-read 'utf-8)) - (insert-file-contents filename))) - (read (current-buffer))) - (t - nil)) - (error - (message "Failed to load user IDs. %s" (cdr err)) - nil)))) - (format-version (car data))) - (cond - ((equal 1 format-version) - (let ((generator-version (cdr (assq 'emacs-version data)))) - (cond - ((or (equal generator-version emacs-version) - (y-or-n-p - (format "%s is generated by Emacs %s! Continue?" - filename generator-version))) - (mapc (lambda (entry) - (let ((id (car entry)) - (properties (cdr entry))) - (twittering-register-user-id id properties))) - (cdr (assq 'user-id-list data))) - t) - (t - (message "Stopped loading user IDs"))))) - (t - nil)))) - -;;;; -;;;; URIs related to a tweet -;;;; - -(defun twittering-get-status-url (username &optional id) - "Generate a URL of a user or a specific status." - (let ((func - (cdr (assq - 'status-url - (assq twittering-service-method - twittering-service-method-table))))) - (funcall func username id))) - -(defun twittering-get-status-url-from-alist (status) - "Generate a URL of a tweet specified by an alist STATUS." - (let ((username (cdr (or (assq 'retweeted-user-screen-name status) - (assq 'user-screen-name status)))) - (id (cdr (or (assq 'retweeted-id status) - (assq 'id status)))) - (func - (cdr (assq - 'status-url - (assq twittering-service-method - twittering-service-method-table))))) - (funcall func username id))) - -(defun twittering-get-list-url (username listname) - "Generate a URL of a specific list." - (let ((func - (cdr (assq - 'status-url - (assq twittering-service-method - twittering-service-method-table)))) - (str (concat username "/" listname))) - (funcall func str nil))) - -(defun twittering-get-status-url-twitter (username &optional id) - "Generate status URL for Twitter." - (if id - (format "http://%s/%s/status/%s" twittering-web-host username id) - (format "http://%s/%s" twittering-web-host username))) - -(defun twittering-get-status-url-statusnet (username &optional id) - "Generate status URL for StatusNet." - (if id - (format "http://%s/%s/notice/%s" twittering-web-host twittering-web-path-prefix id) - (format "http://%s/%s/%s" twittering-web-host twittering-web-path-prefix username))) - -(defun twittering-get-search-url (query-string) - "Generate a URL for searching QUERY-STRING." - (let ((func (cdr (assq - 'search-url (assq twittering-service-method - twittering-service-method-table))))) - (funcall func query-string))) - -(defun twittering-get-search-url-twitter (query-string) - (format "http://%s/search?q=%s" - twittering-web-host (twittering-percent-encode query-string))) - -(defun twittering-get-search-url-statusnet (query-string) - (if (string-match "^#\\(.+\\)" query-string) - (format "http://%s/%s/tag/%s" - twittering-web-host - twittering-web-path-prefix - (twittering-percent-encode (match-string 1 query-string))) - (format "http://%s/search?q=%s" - twittering-web-host (twittering-percent-encode query-string)))) - -(defun twittering-extract-id-from-url (url-string) - "Extract the ID from URL-STRING. -Return nil if URL-STRING cannot be interpreted as a URL pointing a tweet." - (when (string-match - "\\`https?://twitter.com/\\(?:#!/\\)?[^/]+/status\\(?:es\\)?/\\([0-9]+\\)/?\\'" - url-string) - (match-string 1 url-string))) - -;;;; -;;;; Utility of status IDs -;;;; - -(defun twittering-status-id< (id1 id2) - (let ((len1 (length id1)) - (len2 (length id2))) - (cond - ((= len1 len2) (string< id1 id2)) - ((< len1 len2) t) - (t nil)))) - -(defun twittering-status-id= (id1 id2) - (equal id1 id2)) - -(defun twittering-epoch-timestamp-to-time (timestamp-str) - "Return a time object corresponding to the given epoch timestamp in msec. -TIMESTAMP-STR must be a decimal string representing a time elapsed since -the UNIX epoch (1970-01-01 00:00:00+00:00) in milliseconds." - (require 'calc) - (let* ((str (calc-eval `(,(concat "floor(10#" timestamp-str "/10#1000)") - calc-word-size 64 calc-number-radix 16))) - (hex-str (substring str 3)) - (len (length hex-str)) - (hex-str (if (< len 8) - (concat (make-string (- 8 len) ?0) hex-str) - hex-str)) - (high (substring hex-str 0 4)) - (low (substring hex-str 4)) - (milisec-str - (calc-eval `(,(concat "10#" timestamp-str "%10#1000") - calc-word-size 64 calc-number-radix 10)))) - (mapcar (lambda (s) (string-to-number s 16)) - `(,high ,low ,milisec-str)))) - -(defun twittering-snowflake-epoch-time () - "Return the epoch time of Snowflake." - (let ((epoch-str - ;; This corresponds to 2010-11-04 01:42:54+00:00 in RFC3339. - ;; The value comes from the following page. - ;; https://github.com/twitter/snowflake/blob/6d4634aa490de26e22425538291fe0a03071a170/src/main/scala/com/twitter/service/snowflake/IdWorker.scala#L22 - ;; 22 val twepoch = 1288834974657L - "1288834974657")) - (twittering-epoch-timestamp-to-time epoch-str))) - -(defun twittering-id-to-time (id) - "Return the time corresonding to ID generated by Snowflake. -If ID is a string consisting of 12 or more digits, return the corresponding -time in Emacs internal representation the same as `encode-time'. -Otherwise, return nil. - -This is because ID consisting of 11 or less digits may not be generated -by Snowflake." - (require 'calc) - (cond - ((not (stringp id)) - nil) - ((< (length id) 12) - ;; The given ID may not be generated by Snowflake. - ;; - ;; The first tweet in the example response of - ;; https://dev.twitter.com/docs/api/1/get/statuses/home_timeline - ;; has "18700887835" as the ID. - ;; Assuming that it is generated by Snowflake, it corresponds to - ;; "2010-11-04 01:42:58+00:00". - ;; However, the created_at is "Fri Jul 16 16:58:46 +0000 2010". - ;; It can be confirmed at http://twitter.com/cindyli/status/18700887835 . - ;; - ;; Therefore we can not suppose that an ID is generated by Snowflake - ;; if the ID consists of 11-digits. - ;; Assuming that an ID reaches 10^11 before Snowflake is turned on at - ;; Nov 04 2010, the average number of tweets per day will exceed - ;; 533 million. - ;; ( 10^11 - 18,700,887,835 > 80,000,000,000 - ;; 80 billion / 5 month (from Jul 16 to Nov 4) > 533 million / day ) - ;; - ;; It is impossible. - ;; So, I assume that an ID is generated by Snowflake if the ID consists of - ;; 12 or more digits. - ;; The first ID with 12-digits, 100,000,000,000 (10^11), corresponds to - ;; 2010-11-04 01:43:17+00:00. - nil) - (t - (let* ((epoch (twittering-snowflake-epoch-time)) - (str (calc-eval - `(,(format "floor(rsh(10#%s,22)/1000)" id) - calc-word-size 64 calc-number-radix 16))) - (milisec - (string-to-number - (calc-eval - `(,(format "rsh(10#%s,22)%%1000" id) - calc-word-size 64 calc-number-radix 10)) - 10))) - (when (string-match "^16#\\([[:xdigit:]]+\\)" str) - (let* ((hex-str (match-string 1 str)) - (hex-str - (if (< (length hex-str) 4) - (concat "0000" hex-str) - hex-str))) - (time-add epoch - `(,(string-to-number - (substring hex-str 0 (- (length hex-str) 4)) 16) - ,(string-to-number - (substring hex-str (- (length hex-str) 4)) 16) - ,(* milisec 1000) - )))))))) - -(defun twittering-time-to-id (time) - "Return the ID corresponding to TIME by Snowflake. -Bits other than timestamp are zero. The least significant 22 bits are zero. -TIME must be an Emacs internal representation as a return value of -`current-time'." - (require 'calc) - (let* ((epoch-time (twittering-snowflake-epoch-time)) - (dt (if (time-less-p epoch-time time) - (time-subtract time epoch-time) - nil)) - (sec-high (nth 0 dt)) - (sec-low (nth 1 dt)) - (microsec (or (nth 2 dt) "0"))) - (when dt - (calc-eval - `(,(format "lsh((16#%04x%04x) * 1000 + floor(%d/1000), 22)" - sec-high sec-low microsec) - calc-word-size 64 calc-number-radix 10))))) - -;;;; -;;;; Process info -;;;; - -(defun twittering-register-process (proc spec &optional str) - (let ((str (or str (twittering-timeline-spec-to-string spec)))) - (add-to-list 'twittering-process-info-alist `(,proc ,spec ,str)))) - -(defun twittering-release-process (proc) - (let ((pair (assoc proc twittering-process-info-alist))) - (when pair - (setq twittering-process-info-alist - (delq pair twittering-process-info-alist))))) - -(defun twittering-get-timeline-spec-from-process (proc) - (let ((entry (assoc proc twittering-process-info-alist))) - (if entry - (elt entry 1) - nil))) - -(defun twittering-get-timeline-spec-string-from-process (proc) - (let ((entry (assoc proc twittering-process-info-alist))) - (if entry - (elt entry 2) - nil))) - -(defun twittering-find-processes-for-timeline-spec (spec) - (apply 'append - (mapcar - (lambda (pair) - (let ((proc (car pair)) - (spec-info (cadr pair))) - (if (equal spec-info spec) - `(,proc) - nil))) - twittering-process-info-alist))) - -(defun twittering-remove-inactive-processes () - (let ((inactive-statuses '(nil closed exit failed signal))) - (setq twittering-process-info-alist - (apply 'append - (mapcar - (lambda (pair) - (let* ((proc (car pair)) - (info (cdr pair)) - (status (process-status proc))) - (if (memq status inactive-statuses) - nil - `((,proc ,@info))))) - twittering-process-info-alist))))) - -(defun twittering-process-active-p (&optional spec) - (twittering-remove-inactive-processes) - (if spec - (twittering-find-processes-for-timeline-spec spec) - twittering-process-info-alist)) - -;;;; -;;;; Server info -;;;; - -(defun twittering-update-api-table (spec api-string) - "Register a pair of a timeline spec and an API for retrieving the timeline. -SPEC is a timeline spec. API-STRING is an identifier of an API for retrieving -the timeline." - (let ((current (assoc spec twittering-timeline-spec-to-api-table))) - (if (null current) - (add-to-list 'twittering-timeline-spec-to-api-table - `(,spec . ,api-string)) - (setcdr current api-string)))) - -(defun twittering-make-rate-limit-alist (header-info) - "Make a rate-limit information alist from HEADER-INFO. -Key symbols of a returned alist are following; limit, remaining, reset-time. -Values bound to limit and remaining is a positive integer and -one bound to reset-time is an Emacs time (result of `seconds-to-time')." - (let ((symbol-table - '(("X-Rate-Limit-Limit" . limit) - ("X-Rate-Limit-Remaining" . remaining) - ("X-Rate-Limit-Reset" . reset-time) - ;; For Twitter API v1.0. - ("X-RateLimit-Limit" . limit) - ("X-RateLimit-Remaining" . remaining) - ("X-RateLimit-Reset" . reset-time)))) - (remove - nil - (mapcar (lambda (entry) - (let ((sym - (cdr - (twittering-assoc-string (car entry) symbol-table t)))) - (cond - ((memq sym '(limit remaining)) - `(,sym . ,(string-to-number (cdr entry)))) - ((eq sym 'reset-time) - `(,sym - . ,(seconds-to-time (string-to-number (cdr entry))))) - (t - nil)))) - header-info)))) - -(defun twittering-update-rate-limit-info (api-string spec header-info) - "Register rate-limit information. -API-STRING is an identifier of an API. SPEC is a timeline spec that had been -retrieved by the API. HEADER-INFO is an alist generated from the HTTP response -header of the API." - (let* ((api-string - (if (eq twittering-service-method 'twitter) - ;; The key for Twitter API v1.0 is nil. - nil - api-string)) - (current (assoc api-string twittering-api-limit-info-alist)) - (rate-limit-alist (twittering-make-rate-limit-alist header-info))) - (twittering-update-api-table spec api-string) - (if (null current) - (add-to-list 'twittering-api-limit-info-alist - `(,api-string . ,rate-limit-alist)) - (setcdr current rate-limit-alist)))) - -(defun twittering-update-server-info (connection-info header-info) - (let* ((new-entry-list (mapcar 'car header-info)) - (account-info (cdr (assq 'account-info connection-info))) - (account - (twittering-get-from-account-info "screen_name" account-info)) - (spec (cdr (assq 'timeline-spec connection-info))) - (api-string - (cdr (assq 'uri-without-query (assq 'request connection-info))))) - (twittering-update-rate-limit-info api-string spec header-info) - (when (remove t (mapcar - (lambda (entry) - (equal (assoc entry header-info) - (assoc entry twittering-server-info-alist))) - new-entry-list)) - (setq twittering-server-info-alist - (append header-info - (remove nil (mapcar - (lambda (entry) - (if (member (car entry) new-entry-list) - nil - entry)) - twittering-server-info-alist)))) - (when twittering-display-remaining - (mapc (lambda (buffer) - (with-current-buffer buffer - (twittering-update-mode-line))) - (twittering-get-buffer-list)))) - ;; cookie - (let* ((new-cookies - (twittering-extract-cookie connection-info header-info)) - (old-cookies (cdr (assoc account twittering-cookie-alist))) - (updated-cookies - (append new-cookies - (remove nil - (mapcar (lambda (cookie) - (unless (assoc (car cookie) new-cookies) - cookie)) - old-cookies))))) - (setq twittering-cookie-alist - (cons (cons account updated-cookies) - (remove nil - (mapcar (lambda (entry) - (unless (equal account (car entry)) - entry)) - twittering-cookie-alist))))) - header-info)) - -(defun twittering-extract-cookie (connection-info header-info) - (remove - nil - (mapcar - (lambda (entry) - (let ((header-item (car entry)) - (header-value (cdr entry))) - (when (and (string= header-item "Set-Cookie") - (string-match "\\([^= ]*\\) *= *\\([^; ]*\\) *;? *" - header-value)) - ;; For ease of implementation, the followings are assumed. - ;; 1. Each response header includes only one cookie. - ;; 2. `value' of cookie is a token, not a quoted string. - ;; 3. Attributes except `domain', `expires' and `path' are ignored. - (let* ((name (downcase (match-string 1 header-value))) - (value (match-string 2 header-value)) - (attributes - (mapcar - (lambda (str) - (when (string-match "\\` *\\([^ ]*\\) *= *\\(.*\\)\\'" - str) - (let ((attr (downcase (match-string 1 str))) - (value (match-string 2 str))) - (cond - ((string= attr "domain") - `(domain . ,value)) - ((string= attr "expires") - `(expires - . ,(apply 'encode-time - (parse-time-string - (replace-regexp-in-string - "-" " " value))))) - ((string= attr "path") - `(path . ,value)) - (t - nil))))) - (split-string (substring header-value (match-end 0)) - " *; *"))) - (additional-attributes - `(,@(let* ((domain (cdr (assq 'domain attributes))) - (request (cdr (assq 'request connection-info))) - (host (cdr (assq 'host request))) - (prefix - (if domain - (regexp-quote domain) - (concat "\\`" (regexp-quote host))))) - `((domain-regexp . ,(concat prefix "\\'"))))))) - `(,name - (value . ,value) - ,@attributes - ,@additional-attributes))))) - header-info))) - -(defun twittering-make-cookie-string (request account-info) - (let ((account - (twittering-get-from-account-info "screen_name" account-info)) - (current-time (current-time)) - (host (cdr (assq 'host request)))) - (when account - (mapconcat - 'identity - (remove nil - (mapcar - (lambda (entry) - (let* ((expires (cdr (assq 'expires entry))) - (not-expired (or (null expires) - (time-less-p current-time expires))) - (domain-regexp (cdr (assq 'domain-regexp entry)))) - (when (and not-expired - (string-match domain-regexp host)) - (format "%s=%s" (car entry) (cdr (assq 'value entry)))))) - (cdr (assoc account twittering-cookie-alist)))) - ";")))) - -(defun twittering-get-ratelimit-alist (&optional spec) - (let ((api-string - (cdr (assoc spec twittering-timeline-spec-to-api-table)))) - (cdr (assoc api-string twittering-api-limit-info-alist)))) - -(defun twittering-get-ratelimit-remaining (&optional spec) - (or (cdr (assq 'remaining (twittering-get-ratelimit-alist spec))) - 0)) - -(defun twittering-get-ratelimit-limit (&optional spec) - (or (cdr (assq 'limit (twittering-get-ratelimit-alist spec))) - 0)) - -(defun twittering-get-ratelimit-indicator-string (&optional spec) - "Make an indicator string of rate-limit information of SPEC." - (cond - ((eq twittering-service-method 'twitter) - ;; Twitter API v1.0. - (format "%d/%d" - (twittering-get-ratelimit-remaining) - (twittering-get-ratelimit-limit))) - (t - (mapconcat - (lambda (api-string) - (let* ((alist (cdr (assoc api-string twittering-api-limit-info-alist))) - (remaining (cdr (assq 'remaining alist))) - (limit (cdr (assq 'limit alist)))) - (format "%s/%s" - (if remaining (number-to-string remaining) "?") - (if limit (number-to-string limit) "?")))) - (twittering-remove-duplicates - (mapcar (lambda (spec) - (cdr (assoc spec twittering-timeline-spec-to-api-table))) - (twittering-get-primary-base-timeline-specs spec))) - "+")))) - -;;;; -;;;; Abstract layer for Twitter API -;;;; - -(defun twittering-api-path (&rest params) - (mapconcat 'identity `(,twittering-api-prefix ,@params) "")) - -(defun twittering-call-api (command args-alist &optional additional-info) - "Call Twitter API and return the process object for the request. -Invoke `twittering-call-api-with-account' with the main account specified -by `twittering-get-main-account-info'. -For details of arguments, see `twittering-call-api-with-account'." - (let ((account-info-alist (twittering-get-main-account-info))) - (twittering-call-api-with-account account-info-alist command args-alist - additional-info))) - -(defun twittering-call-api-with-account (account-info-alist command args-alist &optional additional-info) - "Call Twitter API and return the process object for the request. -COMMAND is a symbol specifying API. ARGS-ALIST is an alist specifying -arguments for the API corresponding to COMMAND. Each key of ARGS-ALIST is a -symbol. -ACCOUNT-INFO-ALIST is an alist storing account information, which has -the following key; -\"screen_name\", \"oauth_token\" and \"oauth_token_secret\" for OAuth/xAuth, -\"screen_name\" and \"password\" for basic authentication. -ADDITIONAL-INFO is used as an argument ADDITIONAL-INFO of -`twittering-send-http-request'. Sentinels associated to the returned process -receives it as the fourth argument. See also the function -`twittering-send-http-request'. - -The valid symbols as COMMAND follows: -retrieve-timeline -- Retrieve a timeline. - Valid key symbols in ARGS-ALIST: - timeline-spec -- the timeline spec to be retrieved. - timeline-spec-string -- the string representation of the timeline spec. - format -- (optional) the symbol specifying the format. - number -- (optional) how many tweets are retrieved. It must be an integer. - If nil, `twittering-number-of-tweets-on-retrieval' is used instead. - The maximum for search timeline is 100, and that for other timelines is - `twittering-max-number-of-tweets-on-retrieval'. - If the given number exceeds the maximum, the maximum is used instead. - max_id -- (optional) the maximum ID of retrieved tweets. - since_id -- (optional) the minimum ID of retrieved tweets. - sentinel -- (optional) the sentinel that processes the buffer consisting - of retrieved data.. This is used as an argument SENTINEL of - `twittering-send-http-request' via `twittering-http-get'. - If nil, `twittering-http-get-default-sentinel' is used. - clean-up-sentinel -- (optional) the clean-up sentinel that post-processes - the buffer associated to the process. This is used as an argument - CLEAN-UP-SENTINEL of `twittering-send-http-request' via - `twittering-http-get'. - page -- (optional and valid only for favorites timeline) which page will - be retrieved. -retrieve-single-tweet -- Retrieve a single tweet. - Valid key symbols in ARGS-ALIST: - id -- the ID of the tweet to be retrieved. - username -- (optional) the screen name of the author of the tweet. - format -- (optional) the symbol specifying the format. - sentinel -- (optional) the sentinel that processes the buffer consisting - of retrieved data.. This is used as an argument SENTINEL of - `twittering-send-http-request' via `twittering-http-get'. - If nil, `twittering-http-get-default-sentinel' is used. - clean-up-sentinel -- (optional) the clean-up sentinel that post-processes - the buffer associated to the process. This is used as an argument - CLEAN-UP-SENTINEL of `twittering-send-http-request' via - `twittering-http-get'. -get-list-index -- Retrieve list names owned by a user. - Valid key symbols in ARGS-ALIST: - username -- the username. - sentinel -- the sentinel that processes retrieved strings. This is used - as an argument SENTINEL of `twittering-send-http-request' - via `twittering-http-get'. - clean-up-sentinel -- (optional) the clean-up sentinel that post-processes - the buffer associated to the process. This is used as an argument - CLEAN-UP-SENTINEL of `twittering-send-http-request' via - `twittering-http-get'. -get-list-subscriptions -- Retrieve list names followed by a user. - Valid key symbols in ARGS-ALIST: - username -- the username. - sentinel -- the sentinel that processes retrieved strings. This is used - as an argument SENTINEL of `twittering-send-http-request' - via `twittering-http-get'. - clean-up-sentinel -- (optional) the clean-up sentinel that post-processes - the buffer associated to the process. This is used as an argument - CLEAN-UP-SENTINEL of `twittering-send-http-request' via - `twittering-http-get'. -create-friendships -- Follow a user. - Valid key symbols in ARGS-ALIST: - username -- the username which will be followed. -destroy-friendships -- Unfollow a user. - Valid key symbols in ARGS-ALIST: - username -- the username which will be unfollowed. -create-favorites -- Mark a tweet as a favorite. - Valid key symbols in ARGS-ALIST: - id -- the ID of the target tweet. -destroy-favorites -- Remove a mark of a tweet as a favorite. - Valid key symbols in ARGS-ALIST: - id -- the ID of the target tweet. -update-status -- Post a tweet. - Valid key symbols in ARGS-ALIST: - status -- the string to be posted. - in-reply-to-status-id -- (optional) the ID of a status that this post is - in reply to. -destroy-status -- Destroy a tweet posted by the authenticated user itself. - Valid key symbols in ARGS-ALIST: - id -- the ID of the target tweet. -retweet -- Retweet a tweet. - Valid key symbols in ARGS-ALIST: - id -- the ID of the target tweet. -verify-credentials -- Verify the current credentials. - Valid key symbols in ARGS-ALIST: - sentinel -- the sentinel that processes returned information. This is used - as an argument SENTINEL of `twittering-send-http-request' - via `twittering-http-get'. - clean-up-sentinel -- the clean-up sentinel that post-processes the buffer - associated to the process. This is used as an argument CLEAN-UP-SENTINEL - of `twittering-send-http-request' via `twittering-http-get'. -send-direct-message -- Send a direct message. - Valid key symbols in ARGS-ALIST: - recipient-id -- the user ID who the message is sent to. - text -- the sent message. -mute -- Mute a user. - Valid key symbols in ARGS-ALIST: - user-id -- the user-id that will be muted. - username -- the username who will be muted. - This command requires either of the above key. If both are given, `user-id' - will be used in REST API. -unmute -- Un-mute a user. - Valid key symbols in ARGS-ALIST: - user-id -- the user-id that will be un-muted. - username -- the username who will be un-muted. - This command requires either of the above key. If both are given, `user-id' - will be used in REST API. -block -- Block a user. - Valid key symbols in ARGS-ALIST: - user-id -- the user-id that will be blocked. - username -- the username who will be blocked. - This command requires either of the above key. If both are given, `user-id' - will be used in REST API. -block-and-report-as-spammer -- Block a user and report him or her as a spammer. - Valid key symbols in ARGS-ALIST: - user-id -- the user-id that will be blocked. - username -- the username who will be blocked. - This command requires either of the above key. If both are given, `user-id' - will be used in REST API. -get-service-configuration -- Get the configuration of the server. - Valid key symbols in ARGS-ALIST: - sentinel -- the sentinel that processes retrieved strings. This is used - as an argument SENTINEL of `twittering-send-http-request'. - clean-up-sentinel -- (optional) the clean-up sentinel that post-processes - the buffer associated to the process. This is used as an argument - CLEAN-UP-SENTINEL of `twittering-send-http-request'." - (let* ((additional-info - `(,@additional-info - (service-method . ,twittering-service-method)))) - (cond - ((memq twittering-service-method '(twitter statusnet)) - (twittering-call-api-with-account-in-api1.0 - account-info-alist command args-alist additional-info)) - ((eq twittering-service-method 'twitter-api-v1.1) - (cond - ((not (require 'json nil t)) - (error "`json.el' is required to use the Twitter REST API v1.1") - nil) - ((not twittering-use-ssl) - (error "SSL is required to use the Twitter REST API v1.1") - nil) - (t - (twittering-call-api-with-account-in-api1.1 - account-info-alist command args-alist additional-info)))) - (t - (error "`twittering-service-method' is an invalid service method") - )))) - -(defun twittering-call-api-with-account-in-api1.0 (account-info-alist command args-alist &optional additional-info) - "Call the Twitter REST API v1.0 and return the process object for the request." - (cond - ((eq command 'retrieve-timeline) - ;; Retrieve a timeline. - (let* ((spec (cdr (assq 'timeline-spec args-alist))) - (spec-string (cdr (assq 'timeline-spec-string args-alist))) - (spec-type (car-safe spec)) - (max-number (if (eq 'search spec-type) - 100 ;; FIXME: refer to defconst. - twittering-max-number-of-tweets-on-retrieval)) - (number - (let ((number - (or (cdr (assq 'number args-alist)) - (let* ((default-number 20) - (n twittering-number-of-tweets-on-retrieval)) - (cond - ((integerp n) n) - ((string-match "^[0-9]+$" n) (string-to-number n 10)) - (t default-number)))))) - (min (max 1 number) max-number))) - (number-str (number-to-string number)) - (max_id (cdr (assq 'max_id args-alist))) - (page (cdr (assq 'page args-alist))) - (since_id (cdr (assq 'since_id args-alist))) - (word (when (eq 'search spec-type) - (cadr spec))) - (parameters - (cond - ((eq spec-type 'favorites) - `(("include_entities" . "true") - ,@(when max_id `(("max_id" . ,max_id))) - ,@(when page `(("page" . ,page))))) - ((eq spec-type 'retweeted_by_user) - (let ((username (elt spec 1))) - `(("count" . ,number-str) - ,@(when max_id `(("max_id" . ,max_id))) - ("include_entities" . "true") - ("screen_name" . ,username) - ,@(when since_id `(("since_id" . ,since_id)))))) - ((eq spec-type 'retweeted_to_user) - (let ((username (elt spec 1))) - `(("count" . ,number-str) - ("include_entities" . "true") - ,@(when max_id `(("max_id" . ,max_id))) - ("screen_name" . ,username) - ,@(when since_id `(("since_id" . ,since_id)))))) - (t - `(,@(when max_id `(("max_id" . ,max_id))) - ,@(when since_id `(("since_id" . ,since_id))) - ,@(cond - ((eq spec-type 'search) - `(("include_entities" . "true") - ("q" . ,word) - ("rpp" . ,number-str) - ("with_twitter_user_id". "true"))) - ((eq spec-type 'list) - (let ((username (elt spec 1)) - (list-name (elt spec 2))) - `(("include_entities" . "true") - ("include_rts" . "true") - ("owner_screen_name" . ,username) - ("per_page" . ,number-str) - ("slug" . ,list-name)))) - ((eq spec-type 'user) - (let ((username (elt spec 1))) - `(("count" . ,number-str) - ("include_entities" . "true") - ("include_rts" . "true") - ("screen_name" . ,username)))) - ((memq spec-type '(friends mentions public)) - `(("include_entities" . "true") - ("count" . ,number-str) - ("include_rts" . "true"))) - (t - ;; direct_messages - ;; direct_messages_sent - ;; home - ;; replies - ;; retweeted_by_me - ;; retweeted_to_me - ;; retweets_of_me - `(("include_entities" . "true") - ("count" . ,number-str)))))))) - (format - (let ((format (cdr (assq 'format args-alist)))) - (cond - ((and format (symbolp format)) - format) - ((eq spec-type 'search) - 'atom) - (t - 'xml)))) - (format-str (symbol-name format)) - (simple-spec-list - '((direct_messages . "direct_messages") - (direct_messages_sent . "direct_messages/sent") - (friends . "statuses/friends_timeline") - (home . "statuses/home_timeline") - (mentions . "statuses/mentions") - (public . "statuses/public_timeline") - (replies . "statuses/replies") - (retweeted_by_me . "statuses/retweeted_by_me") - (retweeted_to_me . "statuses/retweeted_to_me") - (retweets_of_me . "statuses/retweets_of_me") - (user . "statuses/user_timeline"))) - (host (cond ((eq spec-type 'search) twittering-api-search-host) - (t twittering-api-host))) - (method - (cond - ((eq spec-type 'list) - (twittering-api-path "lists/statuses")) - ((eq spec-type 'favorites) - (let ((user (elt spec 1))) - (if user - (twittering-api-path "favorites/" user) - (twittering-api-path "favorites")))) - ((eq spec-type 'retweeted_by_user) - (twittering-api-path "statuses/retweeted_by_user")) - ((eq spec-type 'retweeted_to_user) - (twittering-api-path "statuses/retweeted_to_user")) - ((eq spec-type 'search) - twittering-search-api-method) - ((assq spec-type simple-spec-list) - (twittering-api-path (cdr (assq spec-type simple-spec-list)))) - (t nil))) - (sentinel (cdr (assq 'sentinel args-alist))) - (clean-up-sentinel (cdr (assq 'clean-up-sentinel args-alist))) - (additional-info `(,@additional-info (format . ,format)))) - (cond - ((eq spec-type 'single) - (let ((id (cadr spec)) - (sentinel (or sentinel - 'twittering-retrieve-single-tweet-sentinel))) - (if (twittering-find-status id) - ;; If the status has already retrieved, do nothing. - nil - (twittering-call-api 'retrieve-single-tweet - `((id . ,id) - (format . ,format) - (sentinel . ,sentinel) - (clean-up-sentinel . ,clean-up-sentinel)) - additional-info)))) - ((and host method) - (twittering-http-get account-info-alist host method parameters - format-str - additional-info sentinel clean-up-sentinel)) - (t - (error "Invalid timeline spec"))))) - ((eq command 'retrieve-single-tweet) - (let* ((id (cdr (assq 'id args-alist))) - (user-screen-name (cdr (assq 'username args-alist))) - (format - (let ((format (cdr (assq 'format args-alist)))) - (cond - ((and format (symbolp format)) - format) - (t - 'xml)))) - (format-str (symbol-name format)) - (parameters '(("include_entities" . "true"))) - (sentinel (cdr (assq 'sentinel args-alist))) - (clean-up-sentinel (cdr (assq 'clean-up-sentinel args-alist))) - (additional-info `(,@additional-info - (id . ,id) - (user-screen-name . ,user-screen-name) - (format . ,format)))) - (twittering-http-get account-info-alist twittering-api-host - (twittering-api-path "statuses/show/" id) - parameters format-str additional-info - sentinel clean-up-sentinel))) - ((eq command 'get-list-index) - ;; Get list names. - (let* ((username (cdr (assq 'username args-alist))) - (sentinel (cdr (assq 'sentinel args-alist))) - (format (if (require 'json nil t) 'json 'xml)) - (format-str (symbol-name format)) - (clean-up-sentinel (cdr (assq 'clean-up-sentinel args-alist)))) - (twittering-http-get account-info-alist twittering-api-host - (twittering-api-path username "/lists") - nil format-str additional-info - sentinel clean-up-sentinel))) - ((eq command 'get-list-subscriptions) - (let* ((username (cdr (assq 'username args-alist))) - (sentinel (cdr (assq 'sentinel args-alist))) - (format (if (require 'json nil t) 'json 'xml)) - (format-str (symbol-name format)) - (clean-up-sentinel (cdr (assq 'clean-up-sentinel args-alist)))) - (twittering-http-get account-info-alist twittering-api-host - (twittering-api-path username "/lists/subscriptions") - nil format-str additional-info - sentinel clean-up-sentinel))) - ((eq command 'create-friendships) - ;; Create a friendship. - (let ((username (cdr (assq 'username args-alist)))) - (twittering-http-post account-info-alist twittering-api-host - (twittering-api-path "friendships/create") - `(("screen_name" . ,username)) - nil additional-info))) - ((eq command 'destroy-friendships) - ;; Destroy a friendship - (let ((username (cdr (assq 'username args-alist)))) - (twittering-http-post account-info-alist twittering-api-host - (twittering-api-path "friendships/destroy") - `(("screen_name" . ,username)) - nil additional-info))) - ((eq command 'create-favorites) - ;; Create a favorite. - (let ((id (cdr (assq 'id args-alist)))) - (twittering-http-post account-info-alist twittering-api-host - (twittering-api-path "favorites/create/" id) - nil nil additional-info))) - ((eq command 'destroy-favorites) - ;; Destroy a favorite. - (let ((id (cdr (assq 'id args-alist)))) - (twittering-http-post account-info-alist twittering-api-host - (twittering-api-path "favorites/destroy/" id) - nil nil additional-info))) - ((eq command 'update-status) - ;; Post a tweet. - (let* ((status (cdr (assq 'status args-alist))) - (id (cdr (assq 'in-reply-to-status-id args-alist))) - (parameters - `(("status" . ,status) - ,@(when (eq twittering-auth-method 'basic) - '(("source" . "twmode"))) - ,@(when id `(("in_reply_to_status_id" . ,id)))))) - (twittering-http-post account-info-alist twittering-api-host - (twittering-api-path "statuses/update") - parameters nil additional-info))) - ((eq command 'destroy-status) - ;; Destroy a status. - (let* ((id (cdr (assq 'id args-alist))) - (format (if (require 'json nil t) 'json 'xml)) - (format-str (symbol-name format))) - (twittering-http-post account-info-alist twittering-api-host - (twittering-api-path "statuses/destroy/" id) - nil format-str additional-info - 'twittering-http-post-destroy-status-sentinel))) - ((eq command 'retweet) - ;; Post a retweet. - (let ((id (cdr (assq 'id args-alist)))) - (twittering-http-post account-info-alist twittering-api-host - (twittering-api-path "statuses/retweet/" id) - nil nil additional-info))) - ((eq command 'verify-credentials) - ;; Verify the account. - (let ((sentinel (cdr (assq 'sentinel args-alist))) - (clean-up-sentinel (cdr (assq 'clean-up-sentinel args-alist)))) - (twittering-http-get account-info-alist twittering-api-host - (twittering-api-path "account/verify_credentials") - nil nil additional-info - sentinel clean-up-sentinel))) - ((eq command 'send-direct-message) - ;; Send a direct message. - (let ((parameters - `(("user_id" . ,(cdr (assq 'id args-alist))) - ("text" . ,(cdr (assq 'text args-alist)))))) - (twittering-http-post account-info-alist twittering-api-host - (twittering-api-path "direct_messages/new") - parameters nil additional-info))) - ((eq command 'block) - ;; Block a user. - (let* ((user-id (cdr (assq 'user-id args-alist))) - (username (cdr (assq 'username args-alist))) - (parameters (if user-id - `(("user_id" . ,user-id)) - `(("screen_name" . ,username))))) - (twittering-http-post account-info-alist twittering-api-host - (twittering-api-path "blocks/create") - parameters nil additional-info))) - ((eq command 'block-and-report-as-spammer) - ;; Report a user as a spammer and block him or her. - (let* ((user-id (cdr (assq 'user-id args-alist))) - (username (cdr (assq 'username args-alist))) - (parameters (if user-id - `(("user_id" . ,user-id)) - `(("screen_name" . ,username))))) - (twittering-http-post account-info-alist twittering-api-host - (twittering-api-path "report_spam") - parameters nil additional-info))) - ((eq command 'get-service-configuration) - (let* ((format (if (require 'json nil t) 'json 'xml)) - (format-str (symbol-name format)) - (request - (twittering-make-http-request-from-uri - "GET" nil - (concat (if twittering-use-ssl - "https" - "http") - "://" twittering-api-host - "/" - (twittering-api-path "help/configuration." format-str)))) - (additional-info nil) - (sentinel (cdr (assq 'sentinel args-alist))) - (clean-up-sentinel (cdr (assq 'clean-up-sentinel args-alist)))) - (twittering-send-http-request request additional-info - sentinel clean-up-sentinel))) - (t - nil))) - -(defun twittering-call-api-with-account-in-api1.1 (account-info-alist command args-alist &optional additional-info) - "Call the Twitter REST API v1.1 and return the process object for the request." - (cond - ((eq command 'retrieve-timeline) - ;; Retrieve a timeline. - (let* ((args-alist - (let* ((spec (cdr (assq 'timeline-spec args-alist))) - (spec-type (car-safe spec)) - (table '((friends . (home)) - (replies . (mentions))))) - (cond - ((memq spec-type '(friends replies)) - (let* ((alternative (cdr (assq spec-type table))) - (alternative-str - (twittering-timeline-spec-to-string alternative))) - (message - "Timeline spec %s is not supported in the Twitter REST API v1.1" - spec) - `((timeline-spec . ,alternative) - (timeline-spec-string . ,alternative-str) - ,@args-alist))) - (t - args-alist)))) - (spec (cdr (assq 'timeline-spec args-alist))) - (spec-string (cdr (assq 'timeline-spec-string args-alist))) - (spec-type (car-safe spec)) - (max-number (if (eq 'search spec-type) - 100 ;; FIXME: refer to defconst. - twittering-max-number-of-tweets-on-retrieval)) - (number - (let ((number - (or (cdr (assq 'number args-alist)) - (let* ((default-number 20) - (n twittering-number-of-tweets-on-retrieval)) - (cond - ((integerp n) n) - ((string-match "^[0-9]+$" n) (string-to-number n 10)) - (t default-number)))))) - (min (max 1 number) max-number))) - (number-str (number-to-string number)) - (max_id (cdr (assq 'max_id args-alist))) - (since_id (cdr (assq 'since_id args-alist))) - (word (when (eq 'search spec-type) - (cadr spec))) - (parameters - (cond - ((eq spec-type 'user) - (let ((username (elt spec 1))) - `(,twittering-api-host - "1.1/statuses/user_timeline" - ("count" . ,number-str) - ("include_entities" . "true") - ("include_rts" . "true") - ,@(when max_id `(("max_id" . ,max_id))) - ("screen_name" . ,username) - ,@(when since_id `(("since_id" . ,since_id))) - ("tweet_mode" . "extended") - ))) - ((eq spec-type 'list) - (let ((username (elt spec 1)) - (list-name (elt spec 2))) - `(,twittering-api-host - "1.1/lists/statuses" - ("count" . ,number-str) - ("include_entities" . "true") - ("include_rts" . "true") - ,@(when max_id `(("max_id" . ,max_id))) - ("owner_screen_name" . ,username) - ,@(when since_id `(("since_id" . ,since_id))) - ("slug" . ,list-name) - ("tweet_mode" . "extended") - ))) - ((eq spec-type 'direct_message_events) - `(,twittering-api-host - "1.1/direct_messages/events/list" - ("count" . "50") - )) - ((eq spec-type 'direct_messages) - `(,twittering-api-host - "1.1/direct_messages" - ("count" . ,number-str) - ("include_entities" . "true") - ,@(when max_id `(("max_id" . ,max_id))) - ,@(when since_id `(("since_id" . ,since_id))) - ("full_text" . "true"))) - ((eq spec-type 'direct_messages_sent) - `(,twittering-api-host - "1.1/direct_messages/sent" - ("count" . ,number-str) - ("include_entities" . "true") - ,@(when max_id `(("max_id" . ,max_id))) - ,@(when since_id `(("since_id" . ,since_id))) - ("full_text" . "true") - )) - ((eq spec-type 'favorites) - (let ((user (elt spec 1))) - `(,twittering-api-host - "1.1/favorites/list" - ("count" . ,number-str) - ("include_entities" . "true") - ,@(when max_id `(("max_id" . ,max_id))) - ,@(when user `(("screen_name" . ,user))) - ,@(when since_id `(("since_id" . ,since_id))) - ("tweet_mode" . "extended") - ))) - ((eq spec-type 'home) - `(,twittering-api-host - "1.1/statuses/home_timeline" - ("count" . ,number-str) - ("include_entities" . "true") - ,@(when max_id `(("max_id" . ,max_id))) - ,@(when since_id `(("since_id" . ,since_id))) - ("tweet_mode" . "extended") - )) - ((eq spec-type 'mentions) - `(,twittering-api-host - "1.1/statuses/mentions_timeline" - ("count" . ,number-str) - ("include_entities" . "true") - ,@(when max_id `(("max_id" . ,max_id))) - ,@(when since_id `(("since_id" . ,since_id))) - ("tweet_mode" . "extended") - )) - ((eq spec-type 'public) - (error - "Timeline spec %s is not supported in the Twitter REST API v1.1" - spec) - nil) - ((memq spec-type '(retweeted_by_me - retweeted_by_user - retweeted_to_me - retweeted_to_user)) - (error - "Timeline spec %s is not supported in the Twitter REST API v1.1" - spec) - nil) - ((eq spec-type 'retweets_of_me) - `(,twittering-api-host - "1.1/statuses/retweets_of_me" - ("count" . ,number-str) - ("include_entities" . "true") - ,@(when max_id `(("max_id" . ,max_id))) - ,@(when since_id `(("since_id" . ,since_id))) - ("tweet_mode" . "extended") - )) - ((eq spec-type 'single) - (let ((id (elt spec 1))) - `(,twittering-api-host - "1.1/statuses/show" - ("id" . ,id) - ("include_entities" . "true") - ("tweet_mode" . "extended") - ))) - ((eq spec-type 'search) - (let ((word (elt spec 1))) - `(,twittering-api-host - "1.1/search/tweets" - ("count" . ,number-str) - ("include_entities" . "true") - ,@(when max_id `(("max_id" . ,max_id))) - ("q" . ,word) - ("result_type" . "recent") - ,@(when since_id `(("since_id" . ,since_id))) - ("tweet_mode" . "extended") - ))) - (t - (error - "Timeline spec %s is unknown" - spec-string) - nil))) - (format 'json) - (format-str (symbol-name format)) - (host (elt parameters 0)) - (method (elt parameters 1)) - (http-parameters (nthcdr 2 parameters)) - (sentinel (cdr (assq 'sentinel args-alist))) - (clean-up-sentinel (cdr (assq 'clean-up-sentinel args-alist))) - (additional-info `(,@additional-info (format . ,format))) - ;; special treatment for single timeline. - (id (cdr (assoc "id" http-parameters))) - (sentinel (or sentinel - (when (eq spec-type 'single) - 'twittering-retrieve-single-tweet-sentinel)))) - (cond - ((null parameters) - nil) - ((not (and (string= format-str "json") - (require 'json nil t))) - (error "The Twitter REST API v1.1 supports only JSON") - nil) - ((and (eq spec-type 'single) - (twittering-find-status id)) - ;; If the status has already retrieved, do nothing. - nil) - ((and host method) - (twittering-http-get account-info-alist host method http-parameters - format-str - additional-info sentinel clean-up-sentinel)) - (t - (error "Invalid timeline spec") - nil)))) - ((eq command 'retrieve-single-tweet) - (let* ((id (cdr (assq 'id args-alist))) - (user-screen-name (cdr (assq 'username args-alist))) - (format - (let ((format (cdr (assq 'format args-alist)))) - (cond - ((and format (symbolp format)) - format) - (t - 'json)))) - (format-str (symbol-name format)) - (sentinel (cdr (assq 'sentinel args-alist))) - (clean-up-sentinel (cdr (assq 'clean-up-sentinel args-alist))) - (additional-info `(,@additional-info - (id . ,id) - (user-screen-name . ,user-screen-name) - (format . ,format)))) - (twittering-call-api-with-account-in-api1.1 - account-info-alist 'retrieve-timeline - `((timeline-spec . (single ,id)) - (format . ,format) - (sentinel . ,sentinel) - (clean-up-sentinel . ,clean-up-sentinel)) - additional-info))) - ((eq command 'get-list-index) - ;; Get list names. - (let* ((username (cdr (assq 'username args-alist))) - (sentinel (cdr (assq 'sentinel args-alist))) - (host twittering-api-host) - (method "1.1/lists/list") - (http-parameters `(("screen_name" . ,username))) - (format-str "json") - (clean-up-sentinel (cdr (assq 'clean-up-sentinel args-alist)))) - (twittering-http-get account-info-alist host method http-parameters - format-str additional-info - sentinel clean-up-sentinel))) - ((eq command 'get-list-subscriptions) - (let* ((username (cdr (assq 'username args-alist))) - (sentinel (cdr (assq 'sentinel args-alist))) - (host twittering-api-host) - (method "1.1/lists/subscriptions") - (http-parameters - `(("count" . "20") - ("screen_name" . ,username))) - (format-str "json") - (clean-up-sentinel (cdr (assq 'clean-up-sentinel args-alist)))) - (twittering-http-get account-info-alist host method http-parameters - format-str additional-info - sentinel clean-up-sentinel))) - ((eq command 'create-friendships) - ;; Create a friendship. - (let* ((username (cdr (assq 'username args-alist))) - (host twittering-api-host) - (method "1.1/friendships/create") - (http-parameters - `(("screen_name" . ,username))) - (format-str "json")) - (twittering-http-post account-info-alist host method http-parameters - format-str additional-info))) - ((eq command 'destroy-friendships) - ;; Destroy a friendship - (let* ((username (cdr (assq 'username args-alist))) - (host twittering-api-host) - (method "1.1/friendships/destroy") - (http-parameters - `(("screen_name" . ,username))) - (format-str "json")) - (twittering-http-post account-info-alist host method http-parameters - format-str additional-info))) - ((eq command 'create-favorites) - ;; Create a favorite. - (let* ((id (cdr (assq 'id args-alist))) - (host twittering-api-host) - (method "1.1/favorites/create") - (http-parameters `(("id" . ,id))) - (format-str "json")) - (twittering-http-post account-info-alist host method http-parameters - format-str additional-info))) - ((eq command 'destroy-favorites) - ;; Destroy a favorite. - (let* ((id (cdr (assq 'id args-alist))) - (host twittering-api-host) - (method "1.1/favorites/destroy") - (http-parameters `(("id" . ,id))) - (format-str "json")) - (twittering-http-post account-info-alist host method http-parameters - format-str additional-info))) - ((eq command 'update-status) - ;; Post a tweet. - (let* ((status (cdr (assq 'status args-alist))) - (id (cdr (assq 'in-reply-to-status-id args-alist))) - (host twittering-api-host) - (method "1.1/statuses/update") - (http-parameters - `(("status" . ,status) - ,@(when id `(("in_reply_to_status_id" . ,id))))) - (format-str "json")) - (twittering-http-post account-info-alist host method http-parameters - format-str additional-info))) - ((eq command 'destroy-status) - ;; Destroy a status. - (let* ((id (cdr (assq 'id args-alist))) - (host twittering-api-host) - (method (format "1.1/statuses/destroy/%s" id)) - (http-parameters nil) - (format-str "json")) - (twittering-http-post account-info-alist host method http-parameters - format-str additional-info - 'twittering-http-post-destroy-status-sentinel))) - ((eq command 'retweet) - ;; Post a retweet. - (let* ((id (cdr (assq 'id args-alist))) - (host twittering-api-host) - (method (format "1.1/statuses/retweet/%s" id)) - (http-parameters nil) - (format-str "json")) - (twittering-http-post account-info-alist host method http-parameters - format-str additional-info))) - ((eq command 'verify-credentials) - ;; Verify the account. - (let* ((host twittering-api-host) - (method "1.1/account/verify_credentials") - (http-parameters nil) - (format-str "json") - (sentinel (cdr (assq 'sentinel args-alist))) - (clean-up-sentinel (cdr (assq 'clean-up-sentinel args-alist)))) - (twittering-http-get account-info-alist host method http-parameters - format-str additional-info - sentinel clean-up-sentinel))) - ((eq command 'send-direct-message) - ;; Send a direct message. - (let* ((host twittering-api-host) - (method "1.1/direct_messages/events/new") - (http-parameters nil) - (format-str "json") - (additional-info nil) - (recipient-id (cdr (assq 'recipient-id args-alist))) - (text (cdr (assq 'text args-alist))) - (obj - `((event - . - ((type . "message_create") - (message_create - . - ((target . ((recipient_id . ,recipient-id))) - (message_data . ((text . ,text))))))))) - (post-body (json-encode obj)) - ) - (twittering-http-post account-info-alist host method http-parameters - format-str additional-info nil nil post-body))) - ((memq command '(mute unmute)) - ;; Mute a user. - (let* ((user-id (cdr (assq 'user-id args-alist))) - (username (cdr (assq 'username args-alist))) - (host twittering-api-host) - (method - (cdr (assq command '((mute . "1.1/mutes/users/create") - (unmute . "1.1/mutes/users/destroy"))))) - (http-parameters (if user-id - `(("user_id" . ,user-id)) - `(("screen_name" . ,username)))) - (format-str "json")) - (twittering-http-post account-info-alist host method http-parameters - format-str additional-info))) - ((eq command 'block) - ;; Block a user. - (let* ((user-id (cdr (assq 'user-id args-alist))) - (username (cdr (assq 'username args-alist))) - (host twittering-api-host) - (method "1.1/blocks/create") - (http-parameters (if user-id - `(("user_id" . ,user-id)) - `(("screen_name" . ,username)))) - (format-str "json")) - (twittering-http-post account-info-alist host method http-parameters - format-str additional-info))) - ((eq command 'block-and-report-as-spammer) - ;; Report a user as a spammer and block him or her. - (let* ((user-id (cdr (assq 'user-id args-alist))) - (username (cdr (assq 'username args-alist))) - (host twittering-api-host) - (method "1.1/users/report_spam") - (http-parameters (if user-id - `(("user_id" . ,user-id)) - `(("screen_name" . ,username)))) - (format-str "json")) - (twittering-http-post account-info-alist host method http-parameters - format-str additional-info))) - ((eq command 'get-service-configuration) - (let* ((host twittering-api-host) - (method "1.1/help/configuration") - (http-parameters nil) - (format-str "json") - (additional-info nil) - (sentinel (cdr (assq 'sentinel args-alist))) - (clean-up-sentinel (cdr (assq 'clean-up-sentinel args-alist)))) - (twittering-http-get account-info-alist host method http-parameters - format-str additional-info - sentinel clean-up-sentinel))) - (t - nil))) - -;;;; -;;;; Service configuration -;;;; - -(defconst twittering-service-configuration-default - '((dm_text_character_limit . 10000) - (short_url_length . 23) - (short_url_length_https . 23)) - "Default value of `twittering-service-configuration'.") -(defconst twittering-text-configuration-default - '((ranges . - [((weight . 100) (end . 4351) (start . 0)) - ((weight . 100) (end . 8205) (start . 8192)) - ((weight . 100) (end . 8223) (start . 8208)) - ((weight . 100) (end . 8247) (start . 8242))]) - (transformedURLLength . 23) - (defaultWeight . 200) - (scale . 100) - (maxWeightedTweetLength . 280) - (version . 2)) - "Default value of `twittering-text-configuration'.") -(defconst twittering-text-configuration-url - "https://raw.githubusercontent.com/twitter/twitter-text/master/config/v2.json") - -(defvar twittering-service-configuration nil - "Current server configuration.") -(defvar twittering-text-configuration nil - "Current text configuration. - -It is retrieved from the URL defined in `twittering-text-configuration-url'.") -(defvar twittering-service-configuration-queried nil) -(defvar twittering-text-configuration-queried nil) - -(defvar twittering-service-configuration-update-interval 86400 - "*Interval of updating `twittering-service-configuration' and `twittering-text-configuration'.") - -(defun twittering-prepare-text-configuration (config) - (let* ((ranges (cdr (assq 'ranges config))) - (default-weight (cdr (assq 'defaultWeight config))) - (range-weights - (sort - (twittering-remove-duplicates - (mapcar (lambda (r) (cdr (assq 'weight r))) ranges)) - '<)) - (valid-weights `(,default-weight ,@range-weights)) - (ranges-regexp - (concat - (mapconcat - (lambda (focused-weight) - (concat - (format "\\(?%d:[" focused-weight) - (mapconcat - (lambda (entry) - (let ((weight (cdr (assq 'weight entry))) - (start (cdr (assq 'start entry))) - (end (cdr (assq 'end entry)))) - (if (not (= weight focused-weight)) - "" - (format "%c-%c" start (- end 1))))) - ranges - "") - "]+\\)")) - range-weights - "\\|") - ;; otherwise - "\\|" - (format "\\(?%d:[^" default-weight) - (mapconcat - (lambda (entry) - (let ((start (cdr (assq 'start entry))) - (end (cdr (assq 'end entry)))) - (format "%c-%c" start (- end 1)))) - ranges - "") - "]+\\)" - ))) - `(,@(remove - nil - (mapcar (lambda (entry) - (if (memq (car entry) '(ranges-regexp valid-weights)) - nil - entry)) - config)) - (ranges-regexp . ,ranges-regexp) - (valid-weights . ,valid-weights)))) - -(defun twittering-get-service-configuration (entry) - (let* ((configuration (append twittering-service-configuration - twittering-text-configuration)) - (default-configuration - (append twittering-service-configuration-default - twittering-text-configuration-default)) - (pair (assq entry configuration))) - (if (null pair) - (cdr (assq entry default-configuration)) - (cdr pair)))) - -(defun twittering-update-service-configuration (&optional ignore-time) - "Update `twittering-service-configuration' if necessary." - (when (and - (memq twittering-service-method '(twitter twitter-api-v1.1)) - (null twittering-service-configuration-queried) - (or ignore-time - (let ((current (twittering-get-service-configuration 'time)) - (interval - (seconds-to-time - twittering-service-configuration-update-interval))) - (if (null current) - t - ;; If time passed more than `interval', - ;; update the configuration. - (time-less-p interval (time-since current)))))) - (when (eq nil - (assq 'ranges-regexp twittering-text-configuration-default)) - (setq twittering-text-configuration-default - (twittering-prepare-text-configuration - twittering-text-configuration-default))) - (setq twittering-service-configuration-queried t) - (twittering-call-api - 'get-service-configuration - '((sentinel . twittering-update-service-configuration-sentinel) - (clean-up-sentinel - . twittering-update-service-configuration-clean-up-sentinel))) - (let* ((url twittering-text-configuration-url) - (request (twittering-make-http-request-from-uri "GET" nil url))) - (setq twittering-text-configuration-queried t) - (twittering-send-http-request - request nil - 'twittering-update-text-configuration-sentinel - 'twittering-update-text-configuration-clean-up-sentinel)) - )) - -(defun twittering-update-service-configuration-sentinel (proc status connection-info header-info) - (let ((status-line (cdr (assq 'status-line header-info))) - (status-code (cdr (assq 'status-code header-info))) - (format - (twittering-get-content-subtype-symbol-from-header-info header-info))) - (case-string - status-code - (("200") - (let* ((conf-alist - (cond - ((eq format 'xml) - (let ((xml - (twittering-xml-parse-region (point-min) (point-max)))) - (mapcar - (lambda (entry) - `(,(car entry) . ,(elt entry 2))) - (cddr (assq 'configuration xml))))) - ((eq format 'json) - (twittering-json-read)) - (t - (error "Format \"%s\" is not supported" format) - nil))) - (entries '(dm_text_character_limit - short_url_length short_url_length_https))) - (setq twittering-service-configuration - `((time . ,(current-time)) - ,@(mapcar (lambda (entry) - (let ((value (cdr (assq entry conf-alist)))) - (cons - entry - (cond - ((stringp value) - (string-to-number value)) - (t - value))))) - entries))) - (setq twittering-service-configuration-queried nil) - nil)) - (("400") - ;; Rate limit exceeded. - (setq twittering-service-configuration-queried nil) - (format "Response: %s" - (twittering-get-error-message header-info connection-info))) - (t - (setq twittering-service-configuration-queried nil) - (format "Response: %s" - (twittering-get-error-message header-info connection-info)))))) - -(defun twittering-update-service-configuration-clean-up-sentinel (proc status connection-info) - (when (not (twittering-process-alive-p proc)) - (setq twittering-service-configuration-queried nil))) - -(defun twittering-update-text-configuration-sentinel (proc status connection-info header-info) - (let ((status-line (cdr (assq 'status-line header-info))) - (status-code (cdr (assq 'status-code header-info))) - (format - (twittering-get-content-subtype-symbol-from-header-info header-info))) - (case-string - status-code - (("200") - (let* ((conf-alist - (cond - ((eq format 'plain) - (twittering-json-read)) - (t - (error "Format \"%s\" is not supported" format) - nil))) - (entries - '(ranges transformedURLLength defaultWeight scale - maxWeightedTweetLength version))) - (setq twittering-text-configuration - (twittering-prepare-text-configuration - `((time . ,(current-time)) - ,@(mapcar (lambda (entry) - (let ((value (cdr (assq entry conf-alist)))) - (cons - entry - (cond - ((stringp value) - (string-to-number value)) - (t - value))))) - entries)))) - (setq twittering-text-configuration-queried nil) - nil)) - (t - (setq twittering-text-configuration-queried nil) - (format "Response: %s" - (twittering-get-error-message header-info connection-info)))))) - -(defun twittering-update-text-configuration-clean-up-sentinel (proc status connection-info) - (when (not (twittering-process-alive-p proc)) - (setq twittering-text-configuration-queried nil))) - - -(defun twittering-get-maximum-message-length (&optional tweet-type) - "Return the maximum message length of TWEET-TYPE. -If TWEET-TYPE is a symbol `direct-message', return the value of the - service configuration `dm_text_character_limit'. -Otherwise, return 140." - (let ((max-length - (if (eq tweet-type 'direct-message) - (twittering-get-service-configuration 'dm_text_character_limit) - (twittering-get-service-configuration 'maxWeightedTweetLength)))) - max-length)) - -;;;; -;;;; Account authorization -;;;; - -(defun twittering-register-account-info (account-info) - (setq twittering-oauth-access-token-alist account-info) - (let* ((account-info twittering-oauth-access-token-alist) - (table '(("user_id" . id) - ("screen_name" . screen-name))) - (properties - (mapcar (lambda (pair) - (let ((source (car pair)) - (dest (cdr pair))) - `(,dest . ,(cdr (assoc source account-info))) - )) - table)) - (user-id (cdr (assq 'id properties)))) - (twittering-register-user-id user-id properties))) - -(defun twittering-get-main-account-info () - (cond - ((eq twittering-auth-method 'basic) - `(("screen_name" . ,twittering-username) - ("password" . ,twittering-password))) - ((memq twittering-auth-method '(oauth xauth)) - twittering-oauth-access-token-alist))) - -(defun twittering-get-from-account-info (param account-info) - (cdr (assoc param account-info))) - -(defun twittering-get-username () - (let ((account-info (twittering-get-main-account-info))) - (twittering-get-from-account-info "screen_name" account-info))) - -(defun twittering-get-password () - (let ((account-info (twittering-get-main-account-info))) - (twittering-get-from-account-info "password" account-info))) - -(defun twittering-make-basic-authentication-string (account-info) - (concat "Basic " - (base64-encode-string - (concat (cdr (assoc "screen_name" account-info)) - ":" (cdr (assoc "password" account-info)))))) - -(defun twittering-make-oauth-authentication-string (account-info request) - (let ((method (cdr (assq 'method request))) - (access-token (cdr (assoc "oauth_token" account-info))) - (access-token-secret (cdr (assoc "oauth_token_secret" account-info)))) - (unless (and (stringp access-token) - (stringp access-token-secret)) - (error "`account-info' has no valid OAuth token")) - (twittering-oauth-auth-str-access - method - (cdr (assq 'uri-without-query request)) - (cdr (assq 'encoded-query-alist request)) - twittering-oauth-consumer-key twittering-oauth-consumer-secret - access-token access-token-secret))) - -(defun twittering-account-authorized-p () - (eq twittering-account-authorization 'authorized)) -(defun twittering-account-authorization-queried-p () - (eq twittering-account-authorization 'queried)) - -(defun twittering-prepare-account-info () - "Return a pair of username and password. -If `twittering-username' is nil, read it from the minibuffer. -If `twittering-password' is nil, read it from the minibuffer." - (let* ((username (or twittering-username - (read-string "your twitter username: "))) - (password (or twittering-password - (read-passwd (format "%s's twitter password: " - username))))) - `(,username . ,password))) - -(defun twittering-has-oauth-access-token-p () - (let* ((required-entries '("oauth_token" - "oauth_token_secret" - "user_id" - "screen_name")) - (value-list - (mapcar - (lambda (key) - (cdr (assoc key twittering-oauth-access-token-alist))) - required-entries))) - (null (remove t (mapcar 'stringp value-list))))) - -(defun twittering-verify-credentials () - "Verify the account. - -This function is an internal function, which should be called from -`twittering-ensure-account-verification'. - -If the account has been authorized already, return t. -Otherwise, this function tries to authorize the account. -If the authorization succeeded, return t. -If the authorization failed, return nil." - (cond - ((twittering-account-authorized-p) - ;; The account has been authorized already. - t) - ((not (twittering-account-authorization-queried-p)) - ;; This function must be invoked from - ;; `twittering-ensure-account-verification', which updates the variable - ;; `twittering-account-authorization' into the symbol `queried'. - (error "`twittering-verify-credentials' is invoked multiple times.") - nil) - ((and (memq twittering-auth-method '(oauth xauth)) - (or (null twittering-oauth-consumer-key) - (null twittering-oauth-consumer-secret))) - (message "Consumer for OAuth is not specified.") - nil) - ((twittering-has-oauth-access-token-p) - (let* ((username (cdr (assoc "screen_name" - (twittering-get-main-account-info)))) - (proc - (twittering-call-api-with-account - (twittering-get-main-account-info) - 'verify-credentials - `((sentinel - . twittering-http-get-verify-credentials-sentinel) - (clean-up-sentinel - . twittering-http-get-verify-credentials-clean-up-sentinel))))) - (cond - ((null proc) - (message "Process invocation for authorizing \"%s\" failed." username) - ;; Failed to authorize the account. - nil) - (t - ;; wait for verification to finish. - (twittering-wait-while nil 0.1 - (and - (twittering-account-authorization-queried-p) - (twittering-process-alive-p proc))) - (if (not (twittering-account-authorization-queried-p)) - ;; The query is completed. - (twittering-account-authorized-p) - ;; If the process has been dead, wait a moment because - ;; Emacs may be in the middle of evaluating the sentinel. - (twittering-wait-while - 10 0.1 - (twittering-account-authorization-queried-p) - ;; Succeeded in authorizing the account. - t - ;; Display a message. - (message - "Status of Authorization process is `%s'. Type M-x twit to retry." - (process-status proc)) - ;; Failed to authorize the account. - nil)))))) - ((eq twittering-auth-method 'oauth) - (let* ((scheme (if twittering-oauth-use-ssl - "https" - "http")) - (request-token-url - (concat scheme twittering-oauth-request-token-url-without-scheme)) - (access-token-url - (concat scheme twittering-oauth-access-token-url-without-scheme)) - (token-alist - (twittering-oauth-get-access-token - request-token-url - (lambda (token) - (concat scheme - twittering-oauth-authorization-url-base-without-scheme - token)) - access-token-url - twittering-oauth-consumer-key twittering-oauth-consumer-secret - "twittering-mode"))) - (cond - ((and (assoc "oauth_token" token-alist) - (assoc "oauth_token_secret" token-alist) - (assoc "screen_name" token-alist)) - (let ((username (cdr (assoc "screen_name" token-alist)))) - (twittering-register-account-info token-alist) - (message "Authorization for the account \"%s\" succeeded." - username) - (when (and twittering-use-master-password - (twittering-capable-of-encryption-p) - (not (file-exists-p twittering-private-info-file))) - (twittering-save-private-info-with-guide)) - ;; Succeeded in authorizing the account. - t)) - (t - ;; There is no global account info that should be invalidated. - ;; Failed to authorize the account. - (message "Authorization via OAuth failed. Type M-x twit to retry.") - nil)))) - ((eq twittering-auth-method 'xauth) - (let* ((account-info (twittering-prepare-account-info)) - (scheme (if twittering-oauth-use-ssl - "https" - "http")) - (access-token-url - (concat scheme twittering-oauth-access-token-url-without-scheme)) - (token-alist - (twittering-xauth-get-access-token - access-token-url - twittering-oauth-consumer-key twittering-oauth-consumer-secret - (car account-info) - (cdr account-info)))) - ;; Dispose of password as recommended by Twitter. - ;; http://dev.twitter.com/pages/xauth - (setcdr account-info nil) - (cond - ((and token-alist - (assoc "oauth_token" token-alist) - (assoc "oauth_token_secret" token-alist)) - (twittering-register-account-info token-alist) - (message "Authorization for the account \"%s\" succeeded." - (twittering-get-username)) - (when (and twittering-use-master-password - (twittering-capable-of-encryption-p) - (not (file-exists-p twittering-private-info-file))) - (twittering-save-private-info-with-guide)) - ;; Succeeded in authorizing the account. - t) - (t - ;; Failed to authorize the account. - (message "Authorization via xAuth failed. Type M-x twit to retry.") - nil)))) - ((eq twittering-auth-method 'basic) - (let* ((account-info - (let ((pair (twittering-prepare-account-info))) - `(("screen_name" . ,(car pair)) - ("password" . ,(cdr pair))))) - ;; Bind account information locally to ensure that - ;; the variables are reset when the verification fails. - (twittering-username (car account-info)) - (twittering-password (cdr account-info)) - (proc - (twittering-call-api-with-account - account-info - 'verify-credentials - `((sentinel . twittering-http-get-verify-credentials-sentinel) - (clean-up-sentinel - . twittering-http-get-verify-credentials-clean-up-sentinel))))) - (cond - ((null proc) - (message "Process invocation for authorizing \"%s\" failed." - (twittering-get-from-account-info "screen_name" account-info)) - ;; Failed to authorize the account. - nil) - (t - ;; wait for verification to finish. - (twittering-wait-while nil 0.1 - (and - (twittering-account-authorization-queried-p) - (twittering-process-alive-p proc))) - (if (not (twittering-account-authorization-queried-p)) - ;; The query is finished. - (twittering-account-authorized-p) - ;; If the process has been dead, wait a moment because - ;; Emacs may be in the middle of evaluating the sentinel. - (twittering-wait-while - 10 0.1 - (twittering-account-authorization-queried-p) - ;; Succeeded in authorizing the account. - t - ;; Display a message. - (message - "Status of Authorization process is `%s'. Type M-x twit to retry." - (process-status proc)) - ;; Failed to authorize the account. - nil)))))) - (t - (message "%s is invalid as an authorization method." - twittering-auth-method) - nil))) - -(defun twittering-http-get-verify-credentials-sentinel (proc status connection-info header-info) - (let* ((status-line (cdr (assq 'status-line header-info))) - (status-code (cdr (assq 'status-code header-info))) - (account-info (cdr (assq 'account-info connection-info))) - (username - (twittering-get-from-account-info "screen_name" account-info)) - (password - (twittering-get-from-account-info "password" account-info))) - (case-string - status-code - (("200") - (twittering-register-account-info account-info) - (setq twittering-account-authorization 'authorized) - (message "Authorization for the account \"%s\" succeeded." username) - nil) - (("401") - (setq twittering-account-authorization nil) - (let ((error-mes - (format "Authorization for the account \"%s\" failed. Type M-x twit to retry with correct information." - username))) - ;; Invalidate the account info. - (twittering-register-account-info nil) - (message "%s" error-mes) - nil)) - (t - (setq twittering-account-authorization nil) - (let ((error-mes - (format "Authorization for the account \"%s\" failed due to \"%s\"." - username status-line))) - (message "%s" error-mes) - nil))))) - -(defun twittering-http-get-verify-credentials-clean-up-sentinel (proc status connection-info) - (when (and (memq status '(exit signal closed failed)) - (eq twittering-account-authorization 'queried)) - (setq twittering-account-authorization nil) - (let ((exit-status (cond - ((processp proc) (process-exit-status proc)) - (t 0))) - (command (process-command proc))) - (if (= 0 exit-status) - (message "Authorization failed. Type M-x twit to retry.") - (message "Authorization failed: %s exited abnormally (exit-status=%s)." - (car command) exit-status))) - (setq twittering-username nil) - (setq twittering-password nil))) - -(defun twittering-ensure-account-verification () - "Ensure verification of an account. - -If an account has been already authorized, return t. -If a query of authorization is being processed, return nil. - -Otherwise, this function tries to authorize an account by calling -`twittering-verify-credentials'. -If the authorization succeeded, return t. -If the authorization failed, return nil." - (cond - ((twittering-account-authorized-p) - ;; The account has been already authorized. - t) - ((twittering-account-authorization-queried-p) - ;; The account has not been authorized yet. - nil) - (t - (setq twittering-account-authorization 'queried) - (let ((result nil)) - (unwind-protect - (setq result (twittering-verify-credentials)) - (if result - (setq twittering-account-authorization 'authorized) - (setq twittering-account-authorization nil))) - result)))) - -;;;; -;;;; Status retrieval -;;;; - -(defun twittering-add-timeline-history (spec-string) - (when (or (null twittering-timeline-history) - (not (string= spec-string (car twittering-timeline-history)))) - (twittering-add-to-history 'twittering-timeline-history spec-string)) - (let ((spec (twittering-string-to-timeline-spec spec-string))) - (when (and (twittering-timeline-spec-is-user-p spec) - (or (null twittering-user-history) - (not (string= spec-string (car twittering-user-history))))) - (twittering-add-to-history 'twittering-user-history (cadr spec))))) - -(defun twittering-remove-timeline-spec-string-from-history (spec-string) - (setq twittering-timeline-history - (remove nil - (mapcar - (lambda (str) - (if (twittering-equal-string-as-timeline spec-string str) - nil - str)) - twittering-timeline-history)))) - -(defun twittering-make-alist-of-forbidden-tweet (id &optional user-screen-name) - (let ((created-at - (or - (twittering-id-to-time id) - (apply 'encode-time - (parse-time-string "Jan 01 00:00:00 +0000 2012"))))) - `((forbidden . t) - (id . ,id) - (created-at . ,created-at) - (user-name . nil) - (user-screen-name . ,user-screen-name) - (text . "SORRY, YOU ARE NOT AUTHORIZED TO SEE THIS TWEET.") - ))) - -(defun twittering-make-alist-of-non-existent-tweet (id &optional user-screen-name) - (let ((created-at - (or - (twittering-id-to-time id) - (apply 'encode-time - (parse-time-string "Jan 01 00:00:00 +0000 2012"))))) - `((forbidden . t) - (id . ,id) - (created-at . ,created-at) - (user-name . nil) - (user-screen-name . ,user-screen-name) - (text . ,(format "THE TWEET WITH ID %s DOES NOT EXIST." id)) - ))) - -(defun twittering-atom-xmltree-to-status-datum (atom-xml-entry) - (let* ((id-str (car (cddr (assq 'id atom-xml-entry)))) - (time-str (car (cddr (assq 'updated atom-xml-entry)))) - (author-str (car (cddr (assq 'name (assq 'author atom-xml-entry))))) - (formatted-time-str - ;; ISO 8601 - ;; Twitter -> "2010-05-08T05:59:41Z" - ;; StatusNet -> "2010-05-08T08:44:39+00:00" - (cond - ((string-match - "\\(.*\\)T\\(.*\\)\\(Z\\|\\([-+][0-2][0-9]\\):?\\([0-5][0-9]\\)\\)" - time-str) - ;; time-str is formatted as - ;; "Combined date and time in UTC:" in ISO 8601. - (let ((timezone (match-string 3 time-str))) - (format "%s %s %s" - (match-string 1 time-str) (match-string 2 time-str) - (if (string= "Z" timezone) - "+0000" - (concat (match-string 4 time-str) - (match-string 5 time-str)))))) - (t - ;; unknown format? - time-str)))) - `((created-at . ,(date-to-time formatted-time-str)) - (id . ,(progn - (string-match ":\\([0-9]+\\)$" id-str) - (match-string 1 id-str))) - ,@(let ((source (twittering-decode-html-entities - (car (cddr (assq 'twitter:source atom-xml-entry)))))) - `(,@(if (string-match "\\(.*\\)" - source) - (let ((uri (match-string-no-properties 1 source)) - (caption (match-string-no-properties 2 source))) - `((source . ,caption) - (source-uri . ,uri))) - `((source . ,source) - (source-uri . ""))))) - (text . ,(twittering-decode-html-entities - (car (cddr (assq 'title atom-xml-entry))))) - ,@(cond - ((and (eq twittering-service-method 'statusnet) - (string-match "^\\([^ ]+\\)\\( (\\(.*\\))\\)?$" author-str)) - ;; StatusNet - `((user-screen-name . ,(match-string 1 author-str)) - (user-name . ,(or (match-string 3 author-str) "")))) - ((string-match "^\\([^ ]+\\) (\\(.*\\))$" author-str) - ;; Twitter (default) - `((user-screen-name . ,(match-string 1 author-str)) - (user-name . ,(match-string 2 author-str)))) - (t - '((user-screen-name . "PARSING FAILED!!") - (user-name . "")))) - (user-profile-image-url - . ,(let* ((link-items - (mapcar - (lambda (item) - (when (eq 'link (car-safe item)) - (cadr item))) - atom-xml-entry)) - (image-urls - (mapcar - (lambda (item) - (cond - ((and (eq twittering-service-method 'statusnet) - (member '(rel . "related") item)) - ;; StatusNet - (cdr (assq 'href item))) - ((member '(rel . "image") item) - ;; Twitter (default) - (cdr (assq 'href item))) - (t - nil))) - link-items))) - (car-safe (remq nil image-urls))))))) - -(defun twittering-atom-xmltree-to-status (atom-xmltree) - (let ((entry-list - (apply 'append - (mapcar (lambda (x) - (if (eq (car-safe x) 'entry) `(,x) nil)) - (cdar atom-xmltree))))) - (mapcar 'twittering-atom-xmltree-to-status-datum - entry-list))) - -(eval-and-compile - (defsubst twittering-make-gap-list (text) - "Return a list representing index gaps between TEXT and the decoded and normalized text. -Indices of a text in a response from Twitter are calculated with the -assumption that \"&\", \"<\" and \">\" are encoded as \"&\", \"<\" -and \">\" respectively and a Unicode combining character is considered -as a character. -On rendering a tweet, twittering-mode decode \"&\", \"<\" and \">\". -And twittering-mode also normalize its text into canonically equivalent text -without combining characters. -Therefore, the indices in entities differ from the indices of the corresponding -positions in the decoded text. -In addition, the normalization to NFC also makes additional gaps between -the indices in entities and the corresponding positions. - -This function assumes that TEXT is already decoded but not normalized. -From TEXT, the function calculates the gaps between the encoded text and the -decoded and normalized text. -This function returns a list of pairs representing the gaps. -For each pair, the car means the position in the original TEXT and the cdr -means the gap. The (car pair)-th character in the original TEXT corresponds -to the (- (car pair) (cdr pair))-th character in the decoded and normalized -text." - (let ((result nil) - (regexp - (if (require 'ucs-normalize nil t) - (concat "\\(?:\\([<>&]\\)\\|\\(" - ucs-normalize-combining-chars-regexp "\\)\\)") - "\\([<>&]\\)")) - (pos 0) - (gap 0)) - (while (string-match regexp text pos) - (let* ((str (match-string 1 text)) - (shift (if str - (if (string= str "&") - 4 - 3) - 1))) - (setq result - (cons `(,(+ gap (match-end 0)) . ,(+ gap shift)) result)) - (setq gap (+ shift gap))) - (setq pos (match-end 0))) - (reverse result))) - - (defun twittering-get-gap (pos gap-list) - "Return the gap at the specific position. -GAP-LIST must be generated by `twittering-make-gap-list'." - (let ((rest-gaps gap-list) - (gap 0)) - (while (and rest-gaps (< (caar rest-gaps) pos)) - (setq gap (cdar rest-gaps)) - (setq rest-gaps (cdr rest-gaps))) - gap))) - -(defun twittering-normalize-raw-status (raw-status &optional ignore-retweet) - (let* ((status-data (cddr raw-status)) - (raw-retweeted-status (assq 'retweeted_status status-data))) - (cond - ((and raw-retweeted-status - (not ignore-retweet)) - (let ((retweeted-status - (twittering-normalize-raw-status raw-retweeted-status t)) - (retweeting-status - (twittering-normalize-raw-status raw-status t)) - (items-overwritten-by-retweet - '(id))) - `(,@(mapcar - (lambda (entry) - (let ((sym (car entry)) - (value (cdr entry))) - (if (memq sym items-overwritten-by-retweet) - (let ((value-on-retweet - (cdr (assq sym retweeting-status)))) - ;; Replace the value in `retweeted-status' with - ;; that in `retweeting-status'. - `(,sym . ,value-on-retweet)) - `(,sym . ,value)))) - retweeted-status) - ,@(mapcar - (lambda (entry) - (let ((sym (car entry)) - (value (cdr entry))) - `(,(intern (concat "retweeted-" (symbol-name sym))) - . ,value))) - retweeted-status) - ,@(mapcar - (lambda (entry) - (let ((sym (car entry)) - (value (cdr entry))) - `(,(intern (concat "retweeting-" (symbol-name sym))) - . ,value))) - retweeting-status)))) - (t - (let ((assq-get (lambda (item seq) - (car (cddr (assq item seq)))))) - `(,@(mapcar - (lambda (entry) - (let* ((sym (elt entry 0)) - (sym-in-data (elt entry 1)) - (encoded (elt entry 2)) - (data (funcall assq-get sym-in-data status-data))) - `(,sym . ,(if encoded - (twittering-decode-html-entities - (twittering-decode-entities-after-parsing-xml - data)) - data)))) - '(;; Raw entries. - (id id) - (in-reply-to-screen-name in_reply_to_screen_name) - (in-reply-to-status-id in_reply_to_status_id) - (recipient-screen-name recipient_screen_name) - ;; Encoded entries. - (text text t) - )) - ;; created_at - (created-at - . ,(date-to-time (funcall assq-get 'created_at status-data))) - ;; Replace "true" and "false" into t and nil. - ,@(mapcar (lambda (sym) - `(,sym . ,(string= "true" - (funcall assq-get sym status-data)))) - '(favorited truncated)) - ;; Entities. - ,(let* ((entity-data (cddr (assq 'entities status-data))) - (encoded-text (funcall assq-get 'text status-data)) - (text - (twittering-decode-html-entities - (twittering-decode-entities-after-parsing-xml - encoded-text))) - (gap-list (twittering-make-gap-list text))) - (list - 'entity - ;; hashtags - (cons - 'hashtags - (remove nil - (mapcar - (lambda (entry) - (when (and (consp entry) - (eq 'hashtag (car entry))) - (let* ((data (cdr entry)) - (start-str (cdr (assq 'start (car data)))) - (end-str (cdr (assq 'end (car data)))) - (start (if (stringp start-str) - (string-to-number start-str) - 0)) - (end (if (stringp end-str) - (string-to-number end-str) - 0)) - (gap (twittering-get-gap start gap-list))) - `((start . ,(- start gap)) - (end . ,(- end gap)) - (text . ,(elt (assq 'text data) 2)))))) - (assq 'hashtags entity-data)))) - ;; mentions - (cons - 'mentions - (remove nil - (mapcar - (lambda (entry) - (when (and (consp entry) - (eq 'user_mention (car entry))) - (let* ((data (cdr entry)) - (start-str (cdr (assq 'start (car data)))) - (end-str (cdr (assq 'end (car data)))) - (start (if (stringp start-str) - (string-to-number start-str) - 0)) - (end (if (stringp end-str) - (string-to-number end-str) - 0)) - (gap (twittering-get-gap start gap-list))) - `((start . ,(- start gap)) - (end . ,(- end gap)) - (id . ,(elt (assq 'id data) 2)) - (screen-name - . ,(elt (assq 'screen_name data) 2)) - (name - . ,(elt (assq 'name data) 2)))))) - (assq 'user_mentions entity-data)))) - ;; urls - (cons - 'urls - (remove nil - (mapcar - (lambda (entry) - (when (and (consp entry) - (eq 'url (car entry))) - (let* ((data (cdr entry)) - (start-str (cdr (assq 'start (car data)))) - (end-str (cdr (assq 'end (car data)))) - (start (if (stringp start-str) - (string-to-number start-str) - 0)) - (end (if (stringp end-str) - (string-to-number end-str) - 0)) - (gap (twittering-get-gap start gap-list))) - `((start . ,(- start gap)) - (end . ,(- end gap)) - (url . ,(elt (assq 'url data) 2)) - (display-url - . ,(elt (assq 'display_url data) 2)) - (expanded-url - . ,(elt (assq 'expanded_url data) 2)))))) - (assq 'urls entity-data)))))) - ;; Source. - ,@(let ((source (twittering-decode-html-entities - (funcall assq-get 'source status-data)))) - (if (and source - (string-match "\\(.*\\)" - source)) - (let ((uri (match-string-no-properties 1 source)) - (caption (match-string-no-properties 2 source))) - `((source . ,caption) - (source-uri . ,uri))) - `((source . ,source) - (source-uri . "")))) - ;; Items related to the user that posted the tweet. - ,@(let ((user-data (cddr (assq 'user status-data)))) - (mapcar - (lambda (entry) - (let* ((sym (elt entry 0)) - (sym-in-user-data (elt entry 1)) - (encoded (elt entry 2)) - (value (funcall assq-get sym-in-user-data user-data))) - `(,sym . ,(if encoded - (twittering-decode-html-entities value) - value)))) - '(;; Raw entries. - (user-id id) - (user-profile-image-url profile_image_url) - (user-url url) - ;; Encoded entries. - (user-name name t) - (user-screen-name screen_name t) - (user-location location t) - (user-description description t)))) - ,@(let ((user-data (cddr (assq 'user status-data)))) - (mapcar (lambda (entry) - `(,(car entry) - . ,(string= - "true" - (funcall assq-get (cdr entry) user-data)))) - '((user-protected . protected)))))))))) - -(defun twittering-xmltree-to-status (xmltree) - (setq xmltree - (cond - ((eq 'direct-messages (caar xmltree)) - `(,@(mapcar - (lambda (c-node) - `(status nil - (created_at - nil ,(caddr (assq 'created_at c-node))) - (id nil ,(caddr (assq 'id c-node))) - (text nil ,(caddr (assq 'text c-node))) - (source nil ,(format "%s" (car c-node))) ;; fake - (truncated nil "false") - (in_reply_to_status_id nil) - (in_reply_to_user_id - nil ,(caddr (assq 'recipient_id c-node))) - (favorited nil "false") - (recipient_screen_name - nil ,(caddr (assq 'recipient_screen_name c-node))) - (user nil ,@(cdddr (assq 'sender c-node))) - (entities nil ,@(cdddr (assq 'entities c-node))))) - (remove nil - (mapcar - (lambda (node) - (and (consp node) (eq 'direct_message (car node)) - node)) - (cdr-safe (assq 'direct-messages xmltree)))) - ))) - ((eq 'statuses (caar xmltree)) - (cddr (car xmltree))) - (t ;; unknown format? - nil))) - - (mapcar #'twittering-normalize-raw-status - ;; quirk to treat difference between xml.el in Emacs21 and Emacs22 - ;; On Emacs22, there may be blank strings - (remove nil (mapcar (lambda (x) - (if (consp x) x)) - xmltree)))) - -(defun twittering-decode-entities-after-parsing-xml (encoded-str) - "Decode ENCODED-STR retrieved by parsing XML and return the result. -On Emacs 22 and later, `xml-parse-region' resolves numeric character -references. It is redundant to resolve numeric character references -again. However, in a XML response from Twitter, the two characters, -\"<\" and \">\", are doubly escaped as \"&lt;\" and \"&gt;\", -respectively. Then, they are represented as \"<\" and \">\" in -the result of `xml-parse-region'. This function decodes them. - -On Emacs 21, `xml-parse-region' does not resolve numeric character -references. This function decodes them." - (cond - ((null encoded-str) - "") - ((> 22 emacs-major-version) - (replace-regexp-in-string - "&#\\([0-9]+\\);" - (lambda (str) - (let ((number-entity - (progn - (string-match "&#\\([0-9]+\\);" str) - (match-string 1 str)))) - (char-to-string - (twittering-ucs-to-char (string-to-number number-entity))))) - encoded-str)) - (t - (replace-regexp-in-string - "&\\(?:\\(gt\\)\\|\\(lt\\)\\);" - (lambda (str) - (if (match-beginning 1) - ">" - "<")) - encoded-str)))) - -(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= "amp" letter-entity) (list-push "&" result)) - ((string= "gt" letter-entity) (list-push ">" result)) - ((string= "lt" letter-entity) (list-push "<" result)) - ((string= "quot" 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))) - "")) - -;; JSON -(defun twittering-extract-common-element-from-json (json-object) - "Extract common parameters of a tweet from JSON-OBJECT. -Return an alist including text, created_at and entities, which are common -to JSON objects from ordinary timeline and search timeline." - (let* ((encoded-text - (cdr (or (assq 'text json-object) - (assq 'full_text json-object)))) - (text - (twittering-decode-html-entities - (twittering-decode-entities-after-parsing-xml encoded-text))) - (gap-list (twittering-make-gap-list text)) - (entities (cdr (assq 'entities json-object))) - (urls (cdr (assq 'urls entities))) - (hashtags (cdr (assq 'hashtags entities))) - (mentions (cdr (assq 'user_mentions entities))) - (media (cdr (assq 'media entities))) - (func - (lambda (entry sym-table) - (mapcar (lambda (sym-entry) - (let ((sym (car sym-entry)) - (target (cdr sym-entry))) - `(,sym . ,(cdr (assq target entry))))) - sym-table)))) - `((text . ,(twittering-normalize-string text)) - ,@(let ((obj (cdr (assq 'created_at json-object)))) - (when obj - ;; If the `json-object' does not have a `created_at' key, - ;; simply do nothing. - ;; Such a json-object may be generated by the function - ;; `twittering-json-object-to-statuses-on-direct-message-events'. - ;; because the objects of direct message events do not have - ;; a human readable timestamp string. - `((created-at . ,(apply 'encode-time - (parse-time-string obj)))))) - (entity - (hashtags . ,(mapcar (lambda (entry) - (let* ((indices (cdr (assq 'indices entry))) - (start (elt indices 0)) - (end (elt indices 1)) - (gap - (twittering-get-gap start gap-list))) - `((start . ,(- start gap)) - (end . ,(- end gap)) - (text - . ,(twittering-normalize-string - (cdr (assq 'text entry))))))) - hashtags)) - (mentions . ,(mapcar (lambda (entry) - (let* ((indices (cdr (assq 'indices entry))) - (start (elt indices 0)) - (end (elt indices 1)) - (gap - (twittering-get-gap start gap-list))) - `((start . ,(- start gap)) - (end . ,(- end gap)) - (id . ,(cdr (assq 'id_str entry))) - (name - . ,(twittering-normalize-string - (cdr (assq 'name entry)))) - (screen-name - . ,(cdr (assq 'screen_name entry)))))) - mentions)) - (urls . ,(mapcar (lambda (entry) - (let* ((indices (cdr (assq 'indices entry))) - (start (elt indices 0)) - (end (elt indices 1)) - (gap (twittering-get-gap start gap-list))) - `((start . ,(- start gap)) - (end . ,(- end gap)) - (url . ,(cdr (assq 'url entry))) - (display-url - . ,(cdr (assq 'display_url entry))) - (expanded-url - . ,(cdr (assq 'expanded_url entry)))))) - urls)) - (media . ,(mapcar (lambda (entry) - (let* ((indices (cdr (assq 'indices entry))) - (start (elt indices 0)) - (end (elt indices 1)) - (gap (twittering-get-gap start gap-list))) - `((start . ,(- start gap)) - (end . ,(- end gap)) - (url . ,(cdr (assq 'url entry))) - (raw-entry . ,entry) - ,@(funcall func entry - '((media-url . media_url) - (display-url . display_url) - (expanded-url . expanded_url)))))) - media))) - (retweet-count . ,(cdr (assq 'retweet_count json-object))) - (favorite-count . ,(cdr (assq 'favorite_count json-object))) - ))) - -(defun twittering-json-object-to-a-status (json-object) - "Convert JSON-OBJECT representing a tweet into an alist representation. -JSON-OBJECT must originate in an ordinary timeline, not a search timeline. -To convert a JSON object from a search timeline, use -`twittering-json-object-to-a-status-on-search'." - (let* ((raw-retweeted-status (cdr (assq 'retweeted_status json-object)))) - (cond - (raw-retweeted-status - (let ((retweeted-status - (twittering-json-object-to-a-status-base raw-retweeted-status)) - (retweeting-status - (twittering-json-object-to-a-status-base json-object)) - (items-overwritten-by-retweet - '(id))) - `(,@(mapcar - (lambda (entry) - (let ((sym (car entry)) - (value (cdr entry))) - (if (memq sym items-overwritten-by-retweet) - (let ((value-on-retweet - (cdr (assq sym retweeting-status)))) - ;; Replace the value in `retweeted-status' with - ;; that in `retweeting-status'. - `(,sym . ,value-on-retweet)) - `(,sym . ,value)))) - retweeted-status) - ,@(mapcar - (lambda (entry) - (let ((sym (car entry)) - (value (cdr entry))) - `(,(intern (concat "retweeted-" (symbol-name sym))) - . ,value))) - retweeted-status) - ,@(mapcar - (lambda (entry) - (let ((sym (car entry)) - (value (cdr entry))) - `(,(intern (concat "retweeting-" (symbol-name sym))) - . ,value))) - retweeting-status)))) - (t - (twittering-json-object-to-a-status-base json-object))))) - -(defun twittering-json-object-to-a-status-base (json-object) - (let* ((user-data (cdr (assq 'user json-object))) - (raw-quoted-status (cdr (assq 'quoted_status json-object))) - (quoted-status - (when raw-quoted-status - (twittering-json-object-to-a-status raw-quoted-status)))) - `(,@(twittering-extract-common-element-from-json json-object) - ,@(let ((symbol-table - '((favorited . favorited) - (id_str . id) - (in_reply_to_screen_name . in-reply-to-screen-name) - (in_reply_to_status_id_str . in-reply-to-status-id) - (recipient_screen_name . recipient-screen-name) - (truncated . truncated)))) - (remove nil - (mapcar - (lambda (entry) - (let* ((sym (car entry)) - (value (cdr entry)) - (value - (if (and (memq sym '(favorited truncated)) - (eq value :json-false)) - nil - value)) - (dest (cdr (assq sym symbol-table)))) - (when (and dest value) - `(,dest . ,value)))) - json-object))) - ;; source - ,@(let ((source (cdr (assq 'source json-object)))) - (if (and source - (string-match "\\(.*\\)" - source)) - (let ((uri (match-string-no-properties 1 source)) - (caption (match-string-no-properties 2 source))) - `((source . ,(twittering-normalize-string caption)) - (source-uri . ,uri))) - `((source . ,(twittering-normalize-string source)) - (source-uri . "")))) - ;; user data - ,@(let ((symbol-table - '((id_str . user-id) - (profile_image_url . user-profile-image-url) - (url . user-url) - (protected . user-protected) - (name . user-name) - (screen_name . user-screen-name) - (location . user-location) - (description . user-description)))) - (remove nil - (mapcar (lambda (entry) - (let* ((sym (car entry)) - (value (cdr entry)) - (value - (cond - ((and (eq sym 'protected) - (eq value :json-false)) - nil) - ((memq sym '(name location description)) - (twittering-normalize-string value)) - (t - value)))) - (when value - (let ((dest (cdr (assq sym symbol-table)))) - (when dest - `(,dest . ,value)))))) - user-data))) - ;; Quoted status. - ,(when quoted-status - `(quoted-status . ,quoted-status)) - ))) - -(defun twittering-json-object-to-a-status-on-search (json-object) - "Convert JSON-OBJECT representing a tweet into an alist representation. -JSON-OBJECT must originate in a search timeline. -To convert a JSON object from other timelines, use -`twittering-json-object-to-a-status'." - `(,@(twittering-extract-common-element-from-json json-object) - ,@(let ((symbol-table - '((id_str . id) - (to_user . in-reply-to-screen-name) - (in_reply_to_status_id_str . in-reply-to-status-id) - ;; user data - (from_user_id_str . user-id) - (profile_image_url . user-profile-image-url) - (from_user_name . user-name) - (from_user . user-screen-name)))) - (remove nil - (mapcar - (lambda (entry) - (let* ((sym (car entry)) - (value (cdr entry)) - (dest (cdr (assq sym symbol-table)))) - (when (and dest value) - `(,dest . ,value)))) - json-object))) - ;; source - ,@(let ((source - (twittering-decode-html-entities - (cdr (assq 'source json-object))))) - (if (and source - (string-match "\\(.*\\)" - source)) - (let ((uri (match-string-no-properties 1 source)) - (caption (match-string-no-properties 2 source))) - `((source . ,caption) - (source-uri . ,uri))) - `((source . ,source) - (source-uri . "")))))) - -(defun twittering-json-object-to-statuses-on-direct-message-events (json-object) - "Convert JSON-OBJECT representing DM events into an alist representation. -JSON-OBJECT must originate in the timeline of direct message events. -To convert a JSON object from other timelines, use -`twittering-json-object-to-a-status'." - (let* ((events (cdr (assq 'events json-object))) - (apps (cdr (assq 'apps json-object)))) - (mapcar - (lambda (ev) - (let* ((id (cdr (assq 'id ev))) - (epoch-timestamp-str (cdr (assq 'created_timestamp ev))) - (created-at - (twittering-epoch-timestamp-to-time epoch-timestamp-str)) - (msg-create (cdr (assq 'message_create ev))) - (msg-data (cdr (assq 'message_data msg-create))) - (target (cdr (assq 'target msg-create))) - (recipient-id (cdr (assq 'recipient_id target))) - (recipient-info (twittering-find-user recipient-id)) - (recipient-name - (or (cdr (assq 'name recipient-info)) - (format "UNKNOWN-NAME(ID:%s)" recipient-id))) - (recipient-screen-name - (or (cdr (assq 'screen-name recipient-info)) - (format "UNKNOWN-SCREEN-NAME(ID:%s)" recipient-id))) - (sender-id (cdr (assq 'sender_id msg-create))) - (user-info (twittering-find-user sender-id)) - (user-name (or (cdr (assq 'name user-info)) - (format "UNKNOWN-NAME(ID:%s)" sender-id))) - (user-screen-name - (or (cdr (assq 'screen-name user-info)) - (format "UNKNOWN-SCREEN-NAME(ID:%s)" sender-id))) - (user-profile-image-url (cdr (assq 'profile-image-url user-info))) - (source-app-id (cdr (assq 'source_app_id msg-create))) - (source-app-name - (if source-app-id - (cdr (assq 'name (assq (intern source-app-id) apps))) - ;; A message without `source_app_id' has been observed. - "")) - (source-app-url - (if source-app-id - (cdr (assq 'url (assq (intern source-app-id) apps))) - ;; A message without `source_app_id' has been observed. - "")) - ) - `(,@(twittering-extract-common-element-from-json msg-data) - (id . ,id) - (created-at . ,created-at) - (user-id . ,sender-id) - (user-name . ,user-name) - (user-screen-name . ,user-screen-name) - (user-profile-image-url . ,user-profile-image-url) - (recipient-id . ,recipient-id) - (recipient-name . ,recipient-name) - (recipient-screen-name . ,recipient-screen-name) - (source . ,source-app-name) - (source-uri . ,source-app-url) - ))) - events) - )) - -(defun twittering-json-object-to-a-status-on-direct-messages (json-object) - "Convert JSON-OBJECT representing a tweet into an alist representation. -JSON-OBJECT must originate in timelines related to direct messages. -To convert a JSON object from other timelines, use -`twittering-json-object-to-a-status'." - `(,@(twittering-extract-common-element-from-json json-object) - ,@(let ((symbol-table - '((id_str . id) - (recipient_screen_name . recipient-screen-name)))) - (remove nil - (mapcar - (lambda (entry) - (let* ((sym (car entry)) - (value (cdr entry)) - (dest (cdr (assq sym symbol-table)))) - (when (and dest value) - `(,dest . ,value)))) - json-object))) - ;; sender - ,@(let ((symbol-table - '((id_str . user-id) - (name . user-name) - (profile_image_url . user-profile-image-url) - (protected . user-protected) - (screen_name . user-screen-name)))) - (remove nil - (mapcar - (lambda (entry) - (let* ((sym (car entry)) - (value (cdr entry)) - (value - (cond - ((eq sym 'protected) - (if (eq value :json-false) - nil - t)) - ((eq value :json-false) - nil) - (t - value)))) - (when value - (let ((dest (cdr (assq sym symbol-table)))) - (when dest - `(,dest . ,value)))))) - (cdr (assq 'sender json-object))))))) - -;;;; -;;;; List info retrieval -;;;; - -(defun twittering-get-list-index (username) - (twittering-call-api - 'get-list-index - `((username . ,username) - (sentinel . twittering-http-get-list-index-sentinel)))) - -(defun twittering-get-list-subscriptions (username) - (twittering-call-api - 'get-list-subscriptions - `((username . ,username) - (sentinel . twittering-http-get-list-subscriptions-sentinel)))) - -(defun twittering-get-list-sync (username function) - (setq twittering-list-index-retrieved nil) - (let ((proc (funcall function username))) - (when proc - (twittering-wait-while nil 0.1 - (and (not twittering-list-index-retrieved) - (twittering-process-alive-p proc))) - (when (and (not twittering-list-index-retrieved) - (not (twittering-process-alive-p proc))) - ;; If the process has been dead, wait a moment because - ;; Emacs may be in the middle of evaluating the sentinel. - (twittering-wait-while 10 0.1 - (not twittering-list-index-retrieved))))) - (cond - ((null twittering-list-index-retrieved) - (message "Failed to retrieve %s's lists." username) - nil) - ((stringp twittering-list-index-retrieved) - (if (string= "" twittering-list-index-retrieved) - (message "%s does not have a list." username) - (message "%s" twittering-list-index-retrieved)) - nil) - ((listp twittering-list-index-retrieved) - twittering-list-index-retrieved))) - -(defun twittering-get-list-index-sync (username) - (twittering-get-list-sync username 'twittering-get-list-index)) - -(defun twittering-get-list-subscriptions-sync (username) - (twittering-get-list-sync username 'twittering-get-list-subscriptions)) - -;;;; -;;;; Buffer info -;;;; - -(defvar twittering-buffer-info-list nil - "List of buffers managed by `twittering-mode'.") - -(defun twittering-get-buffer-list () - "Return buffers managed by `twittering-mode'." - (twittering-unregister-killed-buffer) - twittering-buffer-info-list) - -(defun twittering-get-active-buffer-list () - "Return active buffers managed by `twittering-mode', where statuses are -retrieved periodically." - (twittering-unregister-killed-buffer) - (remove nil - (mapcar (lambda (buffer) - (if (twittering-buffer-active-p buffer) - buffer - nil)) - twittering-buffer-info-list))) - -(defun twittering-buffer-p (&optional buffer) - "Return t if BUFFER is managed by `twittering-mode'. -BUFFER defaults to the the current buffer." - (let ((buffer (or buffer (current-buffer)))) - (and (buffer-live-p buffer) - (memq buffer twittering-buffer-info-list)))) - -(defun twittering-buffer-related-p () - "Return t if current buffer relates to `twittering-mode'." - (or (twittering-buffer-p) - (eq major-mode 'twittering-edit-mode) - (string= (buffer-name (current-buffer)) - twittering-debug-buffer))) - -(defun twittering-buffer-active-p (&optional buffer) - "Return t if BUFFER is an active buffer managed by `twittering-mode'. -BUFFER defaults to the the current buffer." - (let ((buffer (or buffer (current-buffer)))) - (and (twittering-buffer-p buffer) - (with-current-buffer buffer - twittering-active-mode)))) - -(defun twittering-get-buffer-from-spec (spec) - "Return the buffer bound to SPEC. If no buffers are bound to SPEC, -return nil." - (let* ((spec-string (twittering-timeline-spec-to-string spec)) - (buffers - (remove - nil - (mapcar - (lambda (buffer) - (if (twittering-equal-string-as-timeline - spec-string - (twittering-get-timeline-spec-string-for-buffer buffer)) - buffer - nil)) - (twittering-get-buffer-list))))) - (if buffers - ;; We assume that the buffer with the same spec is unique. - (car buffers) - nil))) - -(defun twittering-get-buffer-from-spec-string (spec-string) - "Return the buffer bound to SPEC-STRING. If no buffers are bound to it, -return nil." - (let ((spec (twittering-string-to-timeline-spec spec-string))) - (and spec (twittering-get-buffer-from-spec spec)))) - -(defun twittering-get-timeline-spec-for-buffer (buffer) - "Return the timeline spec bound to BUFFER. If BUFFER is not managed by -`twittering-mode', return nil." - (when (twittering-buffer-p buffer) - (with-current-buffer buffer - twittering-timeline-spec))) - -(defun twittering-get-timeline-spec-string-for-buffer (buffer) - "Return the timeline spec string bound to BUFFER. If BUFFER is not managed -by `twittering-mode', return nil." - (when (twittering-buffer-p buffer) - (with-current-buffer buffer - twittering-timeline-spec-string))) - -(defun twittering-current-timeline-spec () - "Return the timeline spec bound to the current buffer. If it is not managed -by `twittering-mode', return nil." - (twittering-get-timeline-spec-for-buffer (current-buffer))) - -(defun twittering-current-timeline-spec-string () - "Return the timeline spec string bound to the current buffer. If it is not -managed by `twittering-mode', return nil." - (twittering-get-timeline-spec-string-for-buffer (current-buffer))) - -(defun twittering-unregister-buffer (buffer &optional keep-timer) - "Unregister BUFFER from `twittering-buffer-info-list'. -If BUFFER is the last managed buffer and KEEP-TIMER is nil, call -`twittering-stop' to stop timers." - (when (memq buffer twittering-buffer-info-list) - (setq twittering-buffer-info-list - (delq buffer twittering-buffer-info-list)) - (when (and (null twittering-buffer-info-list) - (not keep-timer)) - (twittering-stop)))) - -(defun twittering-unregister-killed-buffer () - "Unregister buffers which has been killed." - (mapc (lambda (buffer) - (unless (buffer-live-p buffer) - (twittering-unregister-buffer buffer))) - twittering-buffer-info-list)) - -(defun twittering-replace-spec-string-for-buffer (buffer spec-string) - "Replace the timeline spec string for BUFFER with SPEC-STRING when -BUFFER is managed by `twittering-mode' and SPEC-STRING is equivalent -to the current one." - (when (twittering-buffer-p buffer) - (let ((current (twittering-get-timeline-spec-string-for-buffer buffer))) - (when (and (not (string= current spec-string)) - (twittering-equal-string-as-timeline current spec-string)) - (with-current-buffer buffer - (rename-buffer spec-string t) - (setq twittering-timeline-spec-string spec-string)))))) - -(defun twittering-set-active-flag-for-buffer (buffer active) - "Set ACTIVE to active-flag for BUFFER." - (when (twittering-buffer-p buffer) - (let ((current (twittering-buffer-active-p buffer))) - (when (or (and active (not current)) - (and (not active) current)) - (twittering-toggle-activate-buffer buffer))))) - -(defun twittering-toggle-activate-buffer (&optional buffer) - "Toggle whether to retrieve timeline for the current buffer periodically." - (interactive) - (let ((buffer (or buffer (current-buffer)))) - (when (twittering-buffer-p buffer) - (with-current-buffer buffer - (let* ((new-mode (not twittering-active-mode)) - (active-buffer-list (twittering-get-active-buffer-list)) - (start-timer (and new-mode (null active-buffer-list)))) - (setq twittering-active-mode new-mode) - (when start-timer - (twittering-start)) - (twittering-update-mode-line)))))) - -(defun twittering-activate-buffer (&optional buffer) - "Activate BUFFER to retrieve timeline for it periodically." - (interactive) - (let ((buffer (or buffer (current-buffer)))) - (twittering-set-active-flag-for-buffer buffer t))) - -(defun twittering-deactivate-buffer (&optional buffer) - "Deactivate BUFFER not to retrieve timeline for it periodically." - (interactive) - (let ((buffer (or buffer (current-buffer)))) - (twittering-set-active-flag-for-buffer buffer nil))) - -(defun twittering-kill-buffer (&optional buffer) - "Kill BUFFER managed by `twittering-mode'." - (interactive) - (let ((buffer (or buffer (current-buffer)))) - (when (twittering-buffer-p buffer) - (twittering-deactivate-buffer buffer) - (kill-buffer buffer) - (twittering-unregister-killed-buffer)))) - -(defun twittering-get-managed-buffer (spec) - "Return the buffer bound to SPEC. If no buffers are bound to SPEC, return -newly generated buffer. -SPEC may be a timeline spec or a timeline spec string." - (let* ((original-spec spec) - (spec-string (if (stringp spec) - spec - (twittering-timeline-spec-to-string spec))) - ;; `spec-string' without text properties is required because - ;; Emacs21 displays `spec-string' with its properties on mode-line. - ;; In addition, copying `spec-string' keeps timeline-data from - ;; being modified by `minibuf-isearch.el'. - (spec-string (copy-sequence spec-string)) - (spec (if (stringp spec-string) - (twittering-string-to-timeline-spec spec-string) - nil))) - (when (null spec) - (error "\"%s\" is invalid as a timeline spec" - (or spec-string original-spec))) - (set-text-properties 0 (length spec-string) nil spec-string) - (twittering-add-timeline-history spec-string) - (let ((buffer (twittering-get-buffer-from-spec spec))) - (if buffer - (progn - (twittering-replace-spec-string-for-buffer buffer spec-string) - (twittering-update-mode-line) - buffer) - (let ((buffer (generate-new-buffer spec-string)) - (start-timer (null twittering-buffer-info-list))) - (add-to-list 'twittering-buffer-info-list buffer t) - (with-current-buffer buffer - (twittering-mode-setup spec-string) - (twittering-rerender-timeline-all buffer) - (when (twittering-account-authorized-p) - (when start-timer - ;; If `buffer' is the first managed buffer, - ;; call `twittering-start' to start timers. - (twittering-start)) - (unless (and start-timer twittering-active-mode) - ;; If `buffer' is active and the first managed buffer, - ;; `twittering-start' invokes - ;; `twittering-get-and-render-timeline' indirectly. - ;; Otherwise, `twittering-get-and-render-timeline' should be - ;; invoked here. - (twittering-get-and-render-timeline)))) - buffer))))) - -;;;; -;;;; Icon mode -;;;; - -(defvar twittering-icon-mode nil - "You MUST NOT CHANGE this variable directly. -You should change through function `twittering-icon-mode'.") - -(defun twittering-icon-mode (&optional arg) - "Toggle display of icon images on timelines. -With a numeric argument, if the argument is positive, turn on -icon mode; otherwise, turn off icon mode." - (interactive "P") - (let ((prev-mode twittering-icon-mode)) - (setq twittering-icon-mode - (if (null arg) - (not twittering-icon-mode) - (< 0 (prefix-numeric-value arg)))) - (unless (eq prev-mode twittering-icon-mode) - (twittering-update-mode-line) - (twittering-rerender-timeline-all (current-buffer) t)))) - -(defvar twittering-icon-prop-hash (make-hash-table :test 'equal) - "Hash table for storing display properties of icon. The key is the size of -icon and the value is a hash. The key of the child hash is URL and its value -is the display property for the icon.") - -(defcustom twittering-convert-program (executable-find "convert") - "*A path of the command which is invoked for image conversion. - -The default is determined by searching \"convert\" in `exec-path'. -The command must be compatible with \"convert\" of ImageMagick." - :group 'twittering-mode - :type 'file) - -(defcustom twittering-convert-fix-size 48 - "*Size of an icon image. - -If nil, an icon image is displayed as is." - :group 'twittering-mode - :type '(choice (const nil) - integer)) - -(defcustom twittering-use-convert (not (null twittering-convert-program)) - "*If non-nil, use \"convert\" for converting or resizing icon images." - :group 'twittering-mode - :type 'boolean) - -(defcustom twittering-fallback-image-format 'xpm - "*Fallback format used for displaying an image without a supproted format. -Images which Emacs does not supports are converted into the fallback image -format." - :group 'twittering-mode - :type 'symbol) - -(defcustom twittering-use-profile-image-api nil - "*Whether to use `profile_image' API for retrieving scaled icon images. -NOTE: This API is rate limited and is obsolete in the Twitter REST API v1.1." - :group 'twittering-mode - :type 'boolean) - -(defcustom twittering-icon-storage-file - (expand-file-name "~/.twittering-mode-icons.gz") - "*The file to which icon images are stored. -`twittering-icon-storage-limit' determines the number icons stored in the -file. -The file is loaded with `with-auto-compression-mode'." - :group 'twittering-mode - :type 'file) - -(defcustom twittering-use-icon-storage nil - "*Whether to use the persistent icon storage. -If this variable is non-nil, icon images are stored to the file specified -by `twittering-icon-storage-file'." - :group 'twittering-mode - :type 'boolean) - -(defvar twittering-icon-storage-recent-icons nil - "List of recently rendered icons.") - -(defcustom twittering-icon-storage-limit 500 - "*How many icons are stored in the persistent storage. -If `twittering-use-icon-storage' is nil, this variable is ignored. -If a positive integer N, `twittering-save-icon-properties' saves N icons that -have been recently rendered. -If nil, the function saves all icons." - :group 'twittering-mode - :type '(choice (const nil) - integer)) - -(defconst twittering-error-icon-data-pair - '(xpm . "/* XPM */ -static char * yellow3_xpm[] = { -\"16 16 2 1\", -\" c None\", -\". c #FF0000\", -\"................\", -\". .\", -\". . . .\", -\". . . .\", -\". . . .\", -\". . . .\", -\". . . .\", -\". .. .\", -\". .. .\", -\". . . .\", -\". . . .\", -\". . . .\", -\". . . .\", -\". . . .\", -\". .\", -\"................\"}; -") - "Image used when the valid icon cannot be retrieved.") - -(defun twittering-update-icon-storage-recent-icons (size image-url spec) - (unless (null twittering-icon-storage-limit) - (let ((dummy-icon-properties (twittering-make-display-spec-for-icon - twittering-error-icon-data-pair))) - (unless (equal spec dummy-icon-properties) - (let ((history-delete-duplicates t)) - (twittering-add-to-history 'twittering-icon-storage-recent-icons - (list size image-url) - twittering-icon-storage-limit)))))) - -(defun twittering-get-display-spec-for-icon (image-url) - (let ((hash - (gethash twittering-convert-fix-size twittering-icon-prop-hash))) - (when hash - (let ((spec (gethash image-url hash)) - (size twittering-convert-fix-size)) - (when spec - (twittering-update-icon-storage-recent-icons size image-url spec) - spec))))) - -(defun twittering-convert-image-data (image-data dest-type &optional src-type) - "Convert IMAGE-DATA into XPM format and return it. If it fails to convert, -return nil." - (with-temp-buffer - (set-buffer-multibyte nil) - (buffer-disable-undo) - (let ((coding-system-for-read 'binary) - (coding-system-for-write 'binary) - (require-final-newline nil) - ;; Bind `default-directory' to the temporary directory - ;; because it is possible that the directory pointed by - ;; `default-directory' has been already removed. - (default-directory temporary-file-directory)) - (insert image-data) - (let* ((args - `(,@(when (<= emacs-major-version 22) - ;; Emacs22 and earlier raises "Color allocation error" - ;; on decoding a XPM image with opacity. To ignore - ;; opacity, the option "+matte" is added. - '("+matte")) - ,@(unless (fboundp 'create-animated-image) - '("-flatten")) - ,(if src-type (format "%s:-" src-type) "-") - ,@(when (integerp twittering-convert-fix-size) - `("-resize" - ,(format "%dx%d" twittering-convert-fix-size - twittering-convert-fix-size))) - ,(format "%s:-" dest-type))) - (exit-status - (apply 'call-process-region (point-min) (point-max) - twittering-convert-program t `(t nil) nil args))) - (if (equal 0 exit-status) - (buffer-string) - ;; failed to convert the image. - nil))))) - -(defun twittering-create-image-pair (image-data) - "Return a pair of image type and image data. -IMAGE-DATA is converted by `convert' if the image type of IMAGE-DATA is not -available and `twittering-use-convert' is non-nil." - (let* ((image-type (and image-data (image-type-from-data image-data))) - (image-pair `(,image-type . ,image-data)) - (converted-size - `(,twittering-convert-fix-size . ,twittering-convert-fix-size))) - (cond - ((null image-data) - twittering-error-icon-data-pair) - ((and (image-type-available-p image-type) - (or (fboundp 'create-animated-image) - (not (and twittering-use-convert - (eq image-type 'gif)))) - (or (not (integerp twittering-convert-fix-size)) - (equal (image-size (create-image image-data image-type t) t) - converted-size))) - image-pair) - (twittering-use-convert - (let ((converted-data - (twittering-convert-image-data image-data - twittering-fallback-image-format))) - (if converted-data - `(,twittering-fallback-image-format . ,converted-data) - twittering-error-icon-data-pair))) - (t - twittering-error-icon-data-pair)))) - -(defun twittering-register-image-spec (image-url spec size) - (let ((hash (gethash size twittering-icon-prop-hash))) - (unless hash - (setq hash (make-hash-table :test 'equal)) - (puthash size hash twittering-icon-prop-hash)) - (puthash image-url spec hash))) - -(defun twittering-register-image-data (image-url image-data &optional size) - (let ((image-pair (twittering-create-image-pair image-data)) - (size (or size twittering-convert-fix-size))) - (when image-pair - (let ((spec (twittering-make-display-spec-for-icon image-pair))) - (twittering-register-image-spec image-url spec size) - spec)))) - -(defun twittering-make-slice-spec (image-spec) - "Return slice property for reducing the image size by cropping it." - (let* ((size (image-size image-spec t)) - (width (car size)) - (height (cdr size)) - (fixed-length twittering-convert-fix-size) - (half-fixed-length (/ fixed-length 2))) - (if (or (< fixed-length width) (< fixed-length height)) - `(slice ,(max 0 (- (/ width 2) half-fixed-length)) - ,(max 0 (- (/ height 2) half-fixed-length)) - ,fixed-length ,fixed-length) - `(slice 0 0 ,fixed-length ,fixed-length)))) - -(defun twittering-make-display-spec-for-icon (image-pair) - "Return the specification for `display' text property, which -limits the size of an icon image IMAGE-PAIR up to FIXED-LENGTH. If -the type of the image is not supported, nil is returned. - -If the size of the image exceeds FIXED-LENGTH, the center of the -image are displayed." - (let* ((type (car-safe image-pair)) - (data (cdr-safe image-pair)) - (raw-image-spec ;; without margins - (create-image data type t)) - (slice-spec - (when (and twittering-convert-fix-size (not twittering-use-convert)) - (twittering-make-slice-spec raw-image-spec))) - (image-spec - (if (fboundp 'create-animated-image) ;; Emacs24 or later - (create-animated-image data type t :margin 2 :ascent 'center) - (create-image data type t :margin 2 :ascent 'center)))) - (if slice-spec - `(display (,image-spec ,slice-spec)) - `(display ,image-spec)))) - -(defun twittering-make-icon-string (beg end image-url) - (let ((display-spec (twittering-get-display-spec-for-icon image-url)) - (image-data (gethash image-url twittering-url-data-hash)) - (properties (and beg (text-properties-at beg))) - (icon-string (copy-sequence " "))) - (when properties - (add-text-properties 0 (length icon-string) properties icon-string)) - (cond - (display-spec - (let ((icon-string (apply 'propertize "_" - (append properties display-spec)))) - ;; Remove the property required no longer. - (remove-text-properties 0 (length icon-string) - '(need-to-be-updated nil) - icon-string) - icon-string)) - ((and (integerp image-data) - (<= twittering-url-request-retry-limit image-data)) - ;; Try to retrieve the image no longer. - (twittering-register-image-data image-url nil) - (twittering-make-icon-string beg end image-url)) - ((and image-data (not (integerp image-data))) - (twittering-register-image-data image-url image-data) - (twittering-make-icon-string beg end image-url)) - (t - (put-text-property 0 (length icon-string) - 'need-to-be-updated - `(twittering-make-icon-string ,image-url) - icon-string) - (twittering-url-retrieve-async image-url 'twittering-register-image-data) - icon-string)))) - -(defun twittering-save-icon-properties (&optional filename) - (let ((filename (or filename twittering-icon-storage-file)) - (stored-data - (cond - ((null twittering-icon-storage-limit) - (let ((result nil) - (dummy-icon-properties (twittering-make-display-spec-for-icon - twittering-error-icon-data-pair))) - (maphash - (lambda (size hash) - (maphash (lambda (url properties) - (unless (equal properties dummy-icon-properties) - (setq result (cons (list size url) result)))) - hash)) - twittering-icon-prop-hash) - result)) - (t - (reverse twittering-icon-storage-recent-icons)))) - ;; Bind `default-directory' to the temporary directory - ;; because it is possible that the directory pointed by - ;; `default-directory' has been already removed. - (default-directory temporary-file-directory)) - (when (require 'jka-compr nil t) - (with-auto-compression-mode - (let ((coding-system-for-write 'binary)) - (with-temp-file filename - (insert "( 2 ") - (prin1 (cons 'emacs-version emacs-version) (current-buffer)) - (insert "(icon-list ") - (mapc - (lambda (entry) - (let* ((size (elt entry 0)) - (url (elt entry 1)) - (properties - (gethash url - (gethash size twittering-icon-prop-hash)))) - (insert (if size - (format "(%d " size) - "(nil ")) - (prin1 url (current-buffer)) - (insert " ") - (prin1 properties (current-buffer)) - (insert ")\n"))) - stored-data) - (insert "))"))))))) - -(defun twittering-load-icon-properties (&optional filename) - (let* ((filename (or filename twittering-icon-storage-file)) - ;; Bind `default-directory' to the temporary directory - ;; because it is possible that the directory pointed by - ;; `default-directory' has been already removed. - (default-directory temporary-file-directory) - (data - (with-temp-buffer - (condition-case err - (cond - ((and (require 'jka-compr) - (file-exists-p filename)) - (with-auto-compression-mode - (let ((coding-system-for-read 'binary) - (coding-system-for-write 'binary)) - (insert-file-contents filename))) - (read (current-buffer))) - (t - nil)) - (error - (message "Failed to load icon images. %s" (cdr err)) - nil))))) - (cond - ((equal 2 (car data)) - (let ((version (cdr (assq 'emacs-version data)))) - (cond - ((or (equal version emacs-version) - (y-or-n-p - (format "%s is generated by Emacs %s! Use it?" - filename version))) - (mapc (lambda (entry) - (let ((size (elt entry 0)) - (url (elt entry 1)) - (properties (elt entry 2))) - (twittering-update-icon-storage-recent-icons size url - properties) - (twittering-register-image-spec url properties size))) - (cdr (assq 'icon-list data)))) - (t - (message "Stopped loading icons"))))) - (t - (mapc (lambda (entry) - (let ((size (car entry)) - (prop-alist (cdr entry))) - (mapc (lambda (entry) - (let ((url (car entry)) - (properties (cdr entry))) - (twittering-update-icon-storage-recent-icons - size url properties) - (twittering-register-image-spec url properties - size))) - prop-alist))) - data))))) - -;;;; -;;;; Mode-line -;;;; - -;;; SSL -(defconst twittering-ssl-indicator-image - (when (image-type-available-p 'xpm) - '(image :type xpm - :ascent center - :data - "/* XPM */ -static char * lock[] = { -\"16 16 3 1\", -\" c None\", -\". c #000000\", -\"# c #FFFFFF\", -\" \", -\" \", -\" ........ \", -\" ..######.. \", -\" .##....##. \", -\" .#.. ..#. \", -\" .#. .#. \", -\" ..#......#.. \", -\" .##########. \", -\" .##########. \", -\" .####..####. \", -\" .###....###. \", -\" .###....###. \", -\" .##########. \", -\" ............ \", -\" \"}; -" - )) - "Image for indicator of SSL state.") - -(defconst twittering-modeline-ssl - (if twittering-ssl-indicator-image - (propertize "SSL" - 'display twittering-ssl-indicator-image - 'help-echo "SSL is enabled.") - "SSL")) - -;;; ACTIVE/INACTIVE -(defconst twittering-active-indicator-image - (when (image-type-available-p 'xpm) - '(image :type xpm - :ascent center - :data - "/* XPM */ -static char * connected[] = { -\"16 16 3 1\", -\" c None\", -\". c #000000\", -\"# c #FFFFFF\", -\" .##. ... \", -\" .##. .#. \", -\" .##...#.. \", -\" .##..###..\", -\" .##..###..\", -\" .##.#####.\", -\" ... .##.#.#.#.\", -\" .#. ..#...#...\", -\"...#...#.. .#. \", -\".#.#.#.##. .#. \", -\".#####.##. ... \", -\"..### .##. \", -\" .###..##. \", -\" ..#...##. \", -\" .#. .##. \", -\" ... .##. \"}; -")) - "Image for indicator of active state." -) - -(defconst twittering-inactive-indicator-image - (when (image-type-available-p 'xpm) - '(image :type xpm - :ascent center - :data - "/* XPM */ -static char * disconnected[] = { -\"16 16 3 1\", -\" c None\", -\". c #000000\", -\"# c #FFFFFF\", -\" .##. \", -\" .##. \", -\" . .##. \", -\" ...##. \", -\" ..##. \", -\" ..#. \", -\" .. ... \", -\" .. .. \", -\" .. .. \", -\" ... .. \", -\" .#.. \", -\" .##.. \", -\" .##... \", -\" .##. . \", -\" .##. \", -\" .##. \"}; -")) - "Image for indicator of inactive state." -) - -(defconst twittering-modeline-properties - (when (display-mouse-p) - `(local-map - ,(purecopy (make-mode-line-mouse-map - 'mouse-2 #'twittering-toggle-activate-buffer)) - help-echo "mouse-2 toggles activate buffer"))) - -(defconst twittering-modeline-active - (if twittering-active-indicator-image - (apply 'propertize " " - `(display ,twittering-active-indicator-image - ,@twittering-modeline-properties)) - " ")) - -(defconst twittering-modeline-inactive - (if twittering-inactive-indicator-image - (apply 'propertize "INACTIVE" - `(display ,twittering-inactive-indicator-image - ,@twittering-modeline-properties)) - "INACTIVE")) - -(defun twittering-mode-line-buffer-identification () - (let ((active-mode-indicator - (if twittering-active-mode - twittering-modeline-active - twittering-modeline-inactive)) - (enabled-options - `(,(if twittering-display-connection-method - (concat - (when twittering-use-ssl (concat twittering-modeline-ssl ":")) - (twittering-get-connection-method-name twittering-use-ssl)) - (when twittering-use-ssl twittering-modeline-ssl)) - ,@(when twittering-jojo-mode '("jojo")) - ,@(when twittering-icon-mode '("icon")) - ,@(when twittering-reverse-mode '("reverse")) - ,@(when twittering-proxy-use '("proxy"))))) - (concat active-mode-indicator - (when twittering-display-remaining - (let ((spec (twittering-current-timeline-spec))) - (twittering-get-ratelimit-indicator-string spec))) - (when enabled-options - (concat "[" (mapconcat 'identity enabled-options " ") "]"))))) - -(defun twittering-update-mode-line () - "Update mode line." - (force-mode-line-update)) - -;;;; -;;;; Format of a status -;;;; - -(eval-and-compile - (defsubst twittering-make-common-properties (status) - "Generate a property list that tweets should have irrespective of format." - (apply 'append - (mapcar (lambda (entry) - (let ((prop-sym (if (consp entry) (car entry) entry)) - (status-sym (if (consp entry) (cdr entry) entry))) - (list prop-sym (cdr (assq status-sym status))))) - '(id retweeted-id source-spec - (username . user-screen-name) text))))) - -(defun twittering-get-common-properties (pos) - "Get a common property list of the tweet rendered at POS. -The common property list is added to each rendered tweet irrespective -of format. The common properties follows: - properites generated by `twittering-make-common-properties', - `field' and `rendered-as' generated by `twittering-render-a-field' or - `twittering-make-properties-of-popped-ancestors'." - (apply 'append - (mapcar (lambda (prop) - (let ((value (get-text-property pos prop))) - (when value - `(,prop ,value)))) - '(field id rendered-as retweeted-id source-spec - text username)))) - -(defun twittering-format-string (string prefix replacement-table) - "Format STRING according to PREFIX and REPLACEMENT-TABLE. -PREFIX is a regexp. REPLACEMENT-TABLE is a list of (FROM . TO) pairs, -where FROM is a regexp and TO is a string or a 2-parameter function. - -The pairs in REPLACEMENT-TABLE are stored in order of precedence. -First, search PREFIX in STRING from left to right. -If PREFIX is found in STRING, try to match the following string with -FROM of each pair in the same order of REPLACEMENT-TABLE. If FROM in -a pair is matched, replace the prefix and the matched string with a -string generated from TO. -If TO is a string, the matched string is replaced with TO. -If TO is a function, the matched string is replaced with the -return value of (funcall TO CONTEXT), where CONTEXT is an alist. -Each element of CONTEXT is (KEY . VALUE) and KEY is one of the -following symbols; - 'following-string --the matched string following the prefix - 'match-data --the match-data for the regexp FROM. - 'prefix --PREFIX. - 'replacement-table --REPLACEMENT-TABLE. - 'from --FROM. - 'processed-string --the already processed string." - (let ((current-pos 0) - (result "") - (case-fold-search nil)) - (while (and (string-match prefix string current-pos) - (not (eq (match-end 0) current-pos))) - (let ((found nil) - (current-table replacement-table) - (next-pos (match-end 0)) - (matched-string (match-string 0 string)) - (skipped-string - (substring string current-pos (match-beginning 0)))) - (setq result (concat result skipped-string)) - (setq current-pos next-pos) - (while (and (not (null current-table)) - (not found)) - (let ((key (caar current-table)) - (value (cdar current-table)) - (following-string (substring string current-pos)) - (case-fold-search nil)) - (if (string-match (concat "\\`" key) following-string) - (let ((next-pos (+ current-pos (match-end 0))) - (output - (if (stringp value) - value - (funcall value - `((following-string . ,following-string) - (match-data . ,(match-data)) - (prefix . ,prefix) - (replacement-table . ,replacement-table) - (from . ,key) - (processed-string . ,result)))))) - (setq found t) - (setq current-pos next-pos) - (setq result (concat result output))) - (setq current-table (cdr current-table))))) - (if (not found) - (setq result (concat result matched-string))))) - (let ((skipped-string (substring string current-pos))) - (concat result skipped-string)) - )) - -(eval-and-compile - (defsubst twittering-make-string-with-user-name-property (str status) - (if str - (let* ((user-screen-name (cdr (assq 'user-screen-name status))) - (uri (twittering-get-status-url user-screen-name)) - (spec - (twittering-make-user-timeline-spec-direct user-screen-name))) - (propertize str - 'mouse-face 'highlight - 'keymap twittering-mode-on-uri-map - 'uri uri - 'screen-name-in-text user-screen-name - 'goto-spec spec - 'face 'twittering-username-face - 'front-sticky nil - 'rear-nonsticky t)) - "")) - - (defsubst twittering-make-string-with-source-property (str status) - (if str - (let ((uri (cdr (assq 'source-uri status)))) - (propertize str - 'mouse-face 'highlight - 'keymap twittering-mode-on-uri-map - 'uri uri - 'face 'twittering-uri-face - 'source str - 'front-sticky nil - 'rear-nonsticky t)) - "")) - - (defsubst twittering-make-string-with-uri-property (str status) - (if str - (let ((uri - (if (assq 'retweeted-id status) - (twittering-get-status-url - (cdr (assq 'retweeted-user-screen-name status)) - (cdr (assq 'retweeted-id status))) - (twittering-get-status-url - (cdr (assq 'user-screen-name status)) - (cdr (assq 'id status)))))) - (propertize str - 'mouse-face 'highlight - 'keymap twittering-mode-on-uri-map - 'uri uri - 'face 'twittering-uri-face - 'front-sticky nil - 'rear-nonsticky t)) - ""))) - -(defun twittering-make-fontified-tweet-text (str-expr regexp-hash regexp-atmark) - (let ((regexp-str - (mapconcat - 'identity - (list - ;; hashtag - (concat regexp-hash "\\([[:alpha:]0-9_-]+\\)") - ;; @USER/LIST - (concat regexp-atmark - "\\(\\([a-zA-Z0-9_-]+\\)/\\([a-zA-Z0-9_-]+\\)\\)") - ;; @USER - (concat regexp-atmark "\\([a-zA-Z0-9_-]+\\)") - ;; URI - "\\(https?://[-_.!~*'()a-zA-Z0-9;/?:@&=+$,%#]+\\)") - "\\|"))) - `(let ((pos 0) - (str (copy-sequence ,str-expr))) - (while (string-match ,regexp-str str pos) - (let* ((beg (match-beginning 0)) - (end (match-end 0)) - (range-and-properties - (cond - ((get-text-property beg 'face str) - ;; The matched substring has been already fontified. - ;; The fontification with entities must fontify the - ;; head of the matched string. - nil) - ((match-string 1 str) - ;; hashtag - (let* ((hashtag (match-string 1 str)) - (spec-string - (twittering-make-hashtag-timeline-spec-string-direct - hashtag)) - (url (twittering-get-search-url - (concat "#" hashtag)))) - (list - beg end - 'mouse-face 'highlight - 'keymap twittering-mode-on-uri-map - 'uri url - 'goto-spec spec-string - 'face 'twittering-username-face))) - ((match-string 2 str) - ;; @USER/LIST - (let ((owner (match-string 3 str)) - (list-name (match-string 4 str)) - ;; Properties are added to the matched part only. - ;; The prefixes `twittering-regexp-atmark' will not - ;; be highlighted. - (beg (match-beginning 2))) - (list - beg end - 'mouse-face 'highlight - 'keymap twittering-mode-on-uri-map - 'uri (twittering-get-list-url owner list-name) - 'goto-spec - (twittering-make-list-timeline-spec-direct owner - list-name) - 'face 'twittering-username-face))) - ((match-string 5 str) - ;; @USER - (let ((screen-name (match-string 5 str)) - ;; Properties are added to the matched part only. - ;; The prefixes `twittering-regexp-atmark' will not - ;; be highlighted. - (beg (match-beginning 5))) - (list - beg end - 'mouse-face 'highlight - 'keymap twittering-mode-on-uri-map - 'uri (twittering-get-status-url screen-name) - 'screen-name-in-text screen-name - 'goto-spec - (twittering-make-user-timeline-spec-direct screen-name) - 'face 'twittering-uri-face))) - ((match-string 6 str) - ;; URI - (let ((uri (match-string 6 str))) - (list - beg end - 'mouse-face 'highlight - 'keymap twittering-mode-on-uri-map - 'uri uri - 'uri-origin 'explicit-uri-in-tweet - 'face 'twittering-uri-face))))) - (beg (if range-and-properties - (car range-and-properties) - beg)) - (end (if range-and-properties - (cadr range-and-properties) - end)) - (properties - `(,@(cddr range-and-properties) - front-sticky nil - rear-nonsticky t))) - (when range-and-properties - (add-text-properties beg end properties str)) - (setq pos end))) - str))) - -(eval-and-compile - (defsubst twittering-make-fontified-tweet-text-with-entity (status) - (let* ((text (copy-sequence (cdr (assq 'text status)))) - (text-length (length text)) - (entities (cdr (assq 'entity status)))) - ;; hashtags - (mapc (lambda (hashtag) - (let* ((start (cdr (assq 'start hashtag))) - (end (min (cdr (assq 'end hashtag)) text-length)) - (tag (cdr (assq 'text hashtag))) - (spec-string - (twittering-make-hashtag-timeline-spec-string-direct tag))) - (set-text-properties - start end - `(mouse-face - highlight - keymap ,twittering-mode-on-uri-map - uri ,(twittering-get-search-url (concat "#" tag)) - goto-spec ,spec-string - face twittering-username-face - front-sticky nil - rear-nonsticky t) - text))) - (cdr (assq 'hashtags entities))) - ;; mentions - (mapc (lambda (mention) - (let ((start (cdr (assq 'start mention))) - (end (min (cdr (assq 'end mention)) text-length)) - (screen-name (cdr (assq 'screen-name mention)))) - (set-text-properties - start end - `(mouse-face - highlight - keymap ,twittering-mode-on-uri-map - uri ,(twittering-get-status-url screen-name) - screen-name-in-text ,screen-name - goto-spec - ,(twittering-make-user-timeline-spec-direct screen-name) - face twittering-uri-face - front-sticky nil - rear-nonsticky t) - text))) - (cdr (assq 'mentions entities))) - ;; urls - (let ((offset 0)) - (mapc (lambda (url-info) - (let* ((text-length (length text)) - (start (cdr (assq 'start url-info))) - (end (cdr (assq 'end url-info))) - (url (cdr (assq 'url url-info))) - (expanded-url - ;; If the `url' is short and not wrapped, - ;; `expanded-url' is nil. - (or (cdr (assq 'expanded-url url-info)) - url)) - (replacement - (propertize - expanded-url - 'mouse-face 'highlight - 'keymap twittering-mode-on-uri-map - 'uri url - 'uri-origin 'explicit-uri-in-tweet - 'expanded-uri expanded-url - 'face 'twittering-uri-face - 'front-sticky nil - 'rear-nonsticky t))) - (setq text - (concat - (substring text 0 (min (+ offset start) text-length)) - replacement - (substring text (min (+ offset end) text-length)))) - (setq offset - (+ offset (- (length expanded-url) (- end start)))))) - (cdr (assq 'urls entities)))) - text))) - -(defun twittering-generate-format-table (status-sym prefix-sym) - `(("%" . "%") - ("}" . "}") - ("#" . (cdr (assq 'id ,status-sym))) - ("'" . (when (cdr (assq 'truncated ,status-sym)) - "...")) - ("c" . - (let ((system-time-locale "C")) - (format-time-string "%a %b %d %H:%M:%S %z %Y" - (cdr (assq 'created-at ,status-sym))))) - ("d" . (cdr (assq 'user-description ,status-sym))) - ("f" . - (twittering-make-string-with-source-property - (cdr (assq 'source ,status-sym)) ,status-sym)) - ("i" . - (when (and twittering-icon-mode window-system) - (let ((url - (cond - ((and twittering-use-profile-image-api - (eq twittering-service-method 'twitter) - (or (null twittering-convert-fix-size) - (member twittering-convert-fix-size '(48 73)))) - (let ((user (cdr (assq 'user-screen-name ,status-sym))) - (size - (if (or (null twittering-convert-fix-size) - (= 48 twittering-convert-fix-size)) - "normal" - "bigger"))) - (format "http://%s/%s/%s.xml?size=%s" twittering-api-host - (twittering-api-path "users/profile_image") user size))) - (t - (cdr (assq 'user-profile-image-url ,status-sym)))))) - (twittering-make-icon-string nil nil url)))) - ("j" . (cdr (assq 'user-id ,status-sym))) - ("L" . - (let ((location (or (cdr (assq 'user-location ,status-sym)) ""))) - (unless (string= "" location) - (concat " [" location "]")))) - ("l" . (cdr (assq 'user-location ,status-sym))) - ("p" . (when (cdr (assq 'user-protected ,status-sym)) - "[x]")) - ("r" . - (let ((reply-id (or (cdr (assq 'in-reply-to-status-id ,status-sym)) "")) - (reply-name (or (cdr (assq 'in-reply-to-screen-name ,status-sym)) - "")) - (recipient-screen-name - (cdr (assq 'recipient-screen-name ,status-sym)))) - (let* ((pair - (cond - (recipient-screen-name - (cons (format "sent to %s" recipient-screen-name) - (twittering-get-status-url recipient-screen-name))) - ((and (not (string= "" reply-id)) - (not (string= "" reply-name))) - (cons (format "in reply to %s" reply-name) - (twittering-get-status-url reply-name reply-id))) - (t nil))) - (str (car pair)) - (url (cdr pair)) - (properties - (list 'mouse-face 'highlight 'face 'twittering-uri-face - 'keymap twittering-mode-on-uri-map - 'uri url - 'front-sticky nil - 'rear-nonsticky t))) - (when (and str url) - (concat " " (apply 'propertize str properties)))))) - ("R" . - (let ((retweeted-by - (or (cdr (assq 'retweeting-user-screen-name ,status-sym)) ""))) - (unless (string= "" retweeted-by) - (concat " (retweeted by " retweeted-by ")")))) - ("S" . - (twittering-make-string-with-user-name-property - (cdr (assq 'user-name ,status-sym)) ,status-sym)) - ("s" . - (twittering-make-string-with-user-name-property - (cdr (assq 'user-screen-name ,status-sym)) ,status-sym)) - ("T" . - ,(twittering-make-fontified-tweet-text - `(twittering-make-fontified-tweet-text-with-entity ,status-sym) - twittering-regexp-hash twittering-regexp-atmark)) - ("t" . - ,(twittering-make-fontified-tweet-text - `(twittering-make-fontified-tweet-text-with-entity ,status-sym) - twittering-regexp-hash twittering-regexp-atmark)) - ("u" . (cdr (assq 'user-url ,status-sym))))) - -(defun twittering-generate-formater-for-first-spec (format-str status-sym prefix-sym) - (cond - ((string-match "\\`}" format-str) - ;; "}" at the first means the end of the current level. - `(nil . ,(substring format-str (match-end 0)))) - ((string-match "\\`%" format-str) - (let* ((following (substring format-str 1)) - (table (twittering-generate-format-table status-sym prefix-sym)) - (regexp (concat "\\`\\(" (mapconcat 'car table "\\|") "\\)")) - (case-fold-search nil)) - (cond - ((string-match "\\`@\\({\\([^}]*\\)}\\)?" following) - (let ((time-format (or (match-string 2 following) - "%I:%M %p %B %d, %Y")) - (rest (substring following (match-end 0)))) - `((let* ((created-at (cdr (assq 'created-at ,status-sym))) - (url - (if (assq 'retweeted-id ,status-sym) - (twittering-get-status-url - (cdr (assq 'retweeted-user-screen-name ,status-sym)) - (cdr (assq 'retweeted-id ,status-sym))) - (twittering-get-status-url - (cdr (assq 'user-screen-name ,status-sym)) - (cdr (assq 'id ,status-sym))))) - (properties - (list 'mouse-face 'highlight 'face 'twittering-uri-face - 'keymap twittering-mode-on-uri-map - 'uri url - 'front-sticky nil - 'rear-nonsticky t))) - (twittering-make-passed-time-string - nil nil created-at ,time-format properties)) - . ,rest))) - ((string-match "\\`C\\({\\([^}]*\\)}\\)?" following) - (let ((time-format (or (match-string 2 following) "%H:%M:%S")) - (rest (substring following (match-end 0)))) - `((let* ((created-at (cdr (assq 'created-at ,status-sym)))) - (twittering-make-string-with-uri-property - (format-time-string ,time-format created-at) ,status-sym)) - . ,rest))) - ((string-match "\\`FACE\\[\\([a-zA-Z0-9:-]+\\)\\]{" following) - (let* ((face-name-str (match-string 1 following)) - (str-after-brace (substring following (match-end 0))) - (face-sym (intern face-name-str)) - (pair (twittering-generate-formater-for-current-level - str-after-brace status-sym prefix-sym)) - (braced-body (car pair)) - (rest (cdr pair))) - `((propertize (concat ,@braced-body) 'face ',face-sym) - . ,rest))) - ((string-match "\\`FIELD\\(\\[\\([^]]*\\)\\]\\)?{\\([a-z_]*\\)}" - following) - (let* ((format-str (or (match-string 2 following) "%s")) - (field-raw-name (match-string 3 following)) - (field-name (replace-regexp-in-string "_" "-" field-raw-name)) - (field-symbol (intern field-name)) - (rest (substring following (match-end 0)))) - `((let* ((field-value (cdr (assq ',field-symbol ,status-sym)))) - (if field-value - (format ,format-str field-value) - "")) - . ,rest))) - ((string-match "\\`FIELD-IF-NONZERO\\(\\[\\([^]]*\\)\\]\\)?{\\([a-z_]*\\)}" - following) - (let* ((format-str (or (match-string 2 following) "%s")) - (field-raw-name (match-string 3 following)) - (field-name (replace-regexp-in-string "_" "-" field-raw-name)) - (field-symbol (intern field-name)) - (rest (substring following (match-end 0)))) - `((let* ((field-value (cdr (assq ',field-symbol ,status-sym)))) - (if (and (integerp field-value) - (not (zerop field-value))) - (format ,format-str field-value) - "")) - . ,rest))) - ((string-match "\\`\\(FILL\\|FOLD\\)\\(\\[\\([^]]*\\)\\]\\)?{" - following) - (let* ((str-after-brace (substring following (match-end 0))) - (specifier (match-string 1 following)) - (prefix-str (match-string 3 following)) - (pair (twittering-generate-formater-for-current-level - str-after-brace status-sym prefix-sym)) - (filled-body (car pair)) - (formater - `(lambda (,status-sym ,prefix-sym) - (let ((,prefix-sym (concat ,prefix-sym ,prefix-str))) - (concat ,@filled-body)))) - (keep-newline (string= "FOLD" specifier)) - (rest (cdr pair))) - `((twittering-update-filled-string - nil nil ,formater ,status-sym ,prefix-sym ,prefix-str - ,keep-newline) - . ,rest))) - ((string-match "\\`RT{" following) - (let* ((str-after-brace (substring following (match-end 0))) - (pair (twittering-generate-formater-for-current-level - str-after-brace 'retweeting prefix-sym)) - (braced-body (car pair)) - (rest (cdr pair))) - `((when (assq 'retweeted-id ,status-sym) - (let ((retweeting - (mapcar (lambda (entry) - (let ((key-str (symbol-name (car entry))) - (value (cdr entry))) - (when (string-match "\\`retweeting-" key-str) - (let ((new-key - (intern (substring key-str - (match-end 0))))) - (cons new-key value))))) - ,status-sym))) - (concat ,@braced-body))) - . ,rest))) - ((string-match "\\`QT{" following) - (let* ((str-after-brace (substring following (match-end 0))) - (pair (twittering-generate-formater-for-current-level - str-after-brace 'quoted prefix-sym)) - (braced-body (car pair)) - (rest (cdr pair))) - `((when (assq 'quoted-status ,status-sym) - (let ((quoted (cdr (assq 'quoted-status ,status-sym)))) - (concat ,@braced-body))) - . ,rest))) - ((string-match regexp following) - (let ((specifier (match-string 1 following)) - (rest (substring following (match-end 0)))) - `(,(cdr (assoc specifier table)) . ,rest))) - (t - `("%" . ,following))))) - ((string-match "\\(%\\|}\\)" format-str) - (let* ((sep (match-beginning 0)) - (first (substring format-str 0 sep)) - (last (substring format-str sep))) - ;; Split before "%" or "}". - `(,first . ,last))) - (t - `(,format-str . nil)))) - -(defun twittering-generate-formater-for-current-level (format-str status-sym prefix-sym) - (let ((result nil) - (rest format-str) - (continue t)) - (while (and continue rest) - (let* ((pair - (twittering-generate-formater-for-first-spec - rest status-sym prefix-sym)) - (current-result (car pair))) - (if current-result - (setq result (append result `(,current-result))) - ;; If `result' is nil, it means the end of the current level. - (setq continue nil)) - (setq rest (cdr pair)))) - `(,result . ,rest))) - -(defun twittering-generate-format-status-function (format-str) - (let* ((status-sym 'status) - (prefix-sym 'prefix) - (pair - (twittering-generate-formater-for-current-level - format-str status-sym prefix-sym)) - (body (car pair)) - (rest (cdr pair))) - (cond - ((null rest) - `(lambda (status prefix) - (let* ((common-properties (twittering-make-common-properties status)) - (str (concat ,@body)) - (str (if prefix - (replace-regexp-in-string "^" prefix str) - str)) - (next (next-single-property-change 0 'need-to-be-updated str)) - (need-to-be-updated - (or (get-text-property 0 'need-to-be-updated str) - (and next (< next (length str)))))) - (add-text-properties 0 (length str) common-properties str) - (when (and prefix need-to-be-updated) - ;; With a prefix, redisplay the total status instead of - ;; redisplaying partially. - (remove-text-properties 0 (length str) - '(need-to-be-updated nil) str) - (put-text-property 0 (length str) 'need-to-be-updated - `(twittering-format-status-for-redisplay - ,status ,prefix) - str)) - str))) - (t - (message "Failed to generate a status formater for `twittering-mode'.") - nil)))) - -(defun twittering-update-status-format (&optional format-str) - "Update the format for rendering a tweet. -If FORMAT-STR is nil, `twittering-status-format' is used in place of -FORMAT-STR. - -If FORMAT-STR is valid as a format, `twittering-format-status-function' -is replaced by the result of `twittering-generate-format-status-function' -for FORMAT-STR. -If FORMAT-STR is invalid as a format, an error is signaled and -`twittering-format-status-function' is not updated." - (let ((format-str (or format-str twittering-status-format))) - (unless (string= format-str twittering-format-status-function-source) - (let* ((before (get-buffer "*Compile-Log*")) - (func (twittering-generate-format-status-function format-str))) - (cond - ((and func (functionp func)) - (setq twittering-format-status-function-source format-str) - (setq twittering-format-status-function (byte-compile func)) - (setq twittering-format-status-function-without-compile func) - (setq twittering-status-format format-str) - (let ((current (get-buffer "*Compile-Log*"))) - (when (and (null before) current (= 0 (buffer-size current))) - (kill-buffer current)))) - (t - (error "Invalid format: %s" format-str) - nil)))))) - -(defun twittering-format-status (status &optional prefix) - "Format a STATUS by using `twittering-format-status-function'. -PREFIX is the prefix that will be added to the result of this function. -PREFIX is used in order to calculate appropriate width for filling texts. -Specification of the format is described in the document for the -variable `twittering-status-format'." - (funcall twittering-format-status-function status prefix)) - -(defun twittering-format-status-for-redisplay (beg end status &optional prefix) - (twittering-format-status status prefix)) - -;;;; -;;;; Rendering -;;;; - -(defun twittering-field-id< (field1 field2) - (string< field1 field2)) - -(defun twittering-field-id= (field1 field2) - (string= field1 field2)) - -(defun twittering-make-field-id-from-id (id &optional base-id) - "Generate a field property for the tweet corresponding to ID. -Tweets are rendered in order of the field on `twittering-mode'. - -If BASE-ID is non-nil, generate a field id for a tweet rendered -as a popped ancestor tweet by `twittering-show-replied-statuses'. -In the case, BASE-ID means the ID of the descendant." - (let ((format-func (lambda (id) (format "%02d-%s" (length id) id)))) - (cond - (base-id - (format "O:%s:5:ancestor:%s" - (funcall format-func base-id) - (funcall format-func id))) - (t - (format "O:%s:8" (funcall format-func id)))))) - -(defun twittering-make-field-id (status &optional base-id) - "Generate a field property for STATUS. -Tweets are rendered in order of the field on `twittering-mode'. - -If BASE-ID is non-nil, generate a field id for a tweet rendered -as a popped ancestor tweet by `twittering-show-replied-statuses'. -In the case, BASE-ID means the ID of the descendant." - (let ((id (cdr (assq 'id status)))) - (twittering-make-field-id-from-id id base-id))) - -(defun twittering-make-properties-of-popped-ancestors (base-id) - `(rendered-as ((ancestor-of . ,base-id)))) - -(defun twittering-make-field-id-of-timeline-oldest-end (spec-string) - "Return the field ID for the oldest end. -This is given to a special field, header or footer, which does not correspond -to a tweet. -It must be less than IDs made by `twittering-make-field-id' for any other -normal fields in the meaning of `twittering-field-id<'." - (format "H:%s" spec-string)) - -(defun twittering-make-field-id-of-timeline-latest-end (spec-string) - "Return the field ID for the oldest end. -This is given to a special field, header or footer, which does not correspond -to a tweet. -It must be greater than IDs made by `twittering-make-field-id' for any other -normal fields in the meaning of `twittering-field-id<'." - (format "U:%s" spec-string)) - -(defun twittering-field-id-is-timeline-oldest-end (field-id) - "Return non-nil if FIELD-ID corresponds to the oldest end field. -Return non-nil if FIELD-ID is made by -`twittering-make-field-id-of-timeline-oldest-end'." - (and (stringp field-id) (string= (substring field-id 0 2) "H:"))) - -(defun twittering-field-id-is-timeline-latest-end (field-id) - "Return non-nil if FIELD-ID corresponds to the latest end field. -Return non-nil if FIELD-ID is made by -`twittering-make-field-id-of-timeline-latest-end'." - (and (stringp field-id) (string= (substring field-id 0 2) "U:"))) - -(defun twittering-rendered-as-ancestor-status-p (&optional pos) - "Return non-nil if the status at POS is rendered as an ancestor. -Ancestor statuses are rendered by `twittering-show-replied-statuses'." - (let ((pos (or pos (point)))) - (assq 'ancestor-of (get-text-property pos 'rendered-as)))) - -(defun twittering-get-base-id-of-ancestor-at (&optional pos) - "Return the base ID of a popped ancestor status rendered at POS. -If the status at POS is not a popped ancestor status or no status is -rendered at POS, return nil." - (let ((pos (or pos (point)))) - (cdr (assq 'ancestor-of (get-text-property pos 'rendered-as))))) - -(eval-and-compile - (defsubst twittering-fill-string (str &optional adjustment prefix keep-newline) - (when (and (not (boundp 'kinsoku-limit)) - enable-kinsoku) - ;; `kinsoku-limit' is defined on loading "international/kinsoku.el". - ;; Without preloading, "kinsoku.el" will be loaded by auto-loading - ;; triggered by `fill-region-as-paragraph'. - ;; In that case, the local binding of `kinsoku-limit' conflicts the - ;; definition by `defvar' in "kinsoku.el". - ;; The below warning is displayed; - ;; "Warning: defvar ignored because kinsoku-limit is let-bound". - ;; So, we load "kinsoku.el" in advance if necessary. - (load "international/kinsoku")) - (let* ((kinsoku-limit 1) - (adjustment (+ (or adjustment 0) - (if enable-kinsoku - kinsoku-limit - 0))) - (min-width - (apply 'min - (or - (mapcar 'window-width - (get-buffer-window-list (current-buffer) nil t)) - ;; Use `(frame-width)' if no windows display - ;; the current buffer. - `(,(frame-width))))) - (temporary-fill-column (- (or twittering-fill-column (1- min-width)) - adjustment))) - (with-temp-buffer - (let ((fill-column temporary-fill-column) - (fill-prefix (or prefix fill-prefix)) - (adaptive-fill-regexp "")) - (if keep-newline - (let* ((hard-newline (propertize "\n" 'hard t)) - (str (mapconcat 'identity (split-string str "\n") - (concat hard-newline fill-prefix)))) - (use-hard-newlines) - (insert (concat prefix str)) - (fill-region (point-min) (point-max) nil t) - (remove-text-properties (point-min) (point-max) '(hard nil))) - (insert (concat prefix str)) - (fill-region-as-paragraph (point-min) (point-max))) - (buffer-substring (point-min) (point-max)))))) - - (defsubst twittering-update-filled-string (beg end formater status prefix local-prefix &optional keep-newline) - (let* ((str (twittering-fill-string (funcall formater status prefix) - (length prefix) local-prefix - keep-newline)) - (next (next-single-property-change 0 'need-to-be-updated str))) - (if (or (get-text-property 0 'need-to-be-updated str) - (and next (< next (length str)))) - (put-text-property 0 (length str) 'need-to-be-updated - `(twittering-update-filled-string - ,formater ,status ,prefix ,local-prefix - ,keep-newline) - str) - ;; Remove the property required no longer. - (remove-text-properties 0 (length str) '(need-to-be-updated nil) str)) - str)) - - (defsubst twittering-make-passed-time-string - (beg end encoded-created-at time-format &optional additional-properties) - (let* ((now (current-time)) - (secs (+ (* (- (car now) (car encoded-created-at)) 65536) - (- (cadr now) (cadr encoded-created-at)))) - (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 time-format encoded-created-at)))) - (properties (append additional-properties - (and beg (text-properties-at beg)))) - (time-string - ;; Copy a string and restore properties. - (apply 'propertize time-string properties))) - (if (< secs 84600) - (put-text-property 0 (length time-string) - 'need-to-be-updated - `(twittering-make-passed-time-string - ,encoded-created-at ,time-format) - time-string) - ;; Remove the property required no longer. - (remove-text-properties 0 (length time-string) - '(need-to-be-updated nil) - time-string)) - time-string))) - -(defmacro twittering-render-a-field (pos field-id generator &optional without-separator) - "Render a field on the current buffer managed by `twittering-mode'. -Insert a field to the position pointed by FIELD-ID. The position is searched -after POS. The string for the field is generated by the GENERATOR expression. -This function does not render the status if a status with the same field ID -as FIELD-ID is already rendered. -Return non-nil if the status is rendered. Otherwise, return nil." - `(lexical-let ((pos ,pos) - (field-id ,field-id)) - (while - (let ((buf-field-id (get-text-property pos 'field))) - (if (and buf-field-id - (if twittering-reverse-mode - (twittering-field-id< buf-field-id field-id) - (twittering-field-id< field-id buf-field-id))) - (let ((next-pos - (twittering-get-next-status-head pos))) - (setq pos (or next-pos (point-max))) - next-pos) - nil))) - (goto-char pos) - (unless (twittering-field-id= field-id (get-text-property pos 'field)) - (let ((formatted-status (propertize ,generator 'field ,field-id)) - (separator (if ,without-separator - "" - "\n"))) - (if (eq pos (point-max)) - ;; Use `insert' only if no statuses are rendered on the below. - (insert formatted-status separator) - ;; Use `insert-before-markers' in order to keep - ;; which status is pointed by each marker. - (insert-before-markers formatted-status separator)) - t)))) - -(defun twittering-render-timeline (buffer timeline-data &optional invoke-hook keep-point) - "Render statuses for BUFFER and return the list of the rendered statuses. -TIMELINE-DATA is a list of statuses being rendered. -If INVOKE-HOOK is non-nil and one or more tweets are rendered, run hooks -specified by `twittering-new-tweets-rendered-hook'. -If KEEP-POINT is nil and BUFFER is empty, this function moves cursor positions -to the latest status. - -This function returns a list of the statuses newly rendered by the invocation." - (with-current-buffer buffer - (let* ((spec (twittering-get-timeline-spec-for-buffer buffer)) - (referring-id-table - (twittering-current-timeline-referring-id-table spec)) - (current-user (twittering-get-username)) - (timeline-data - ;; Collect visible statuses. - (let ((prev-id nil)) - (remove - nil - (mapcar - (lambda (status) - (let ((id (cdr (assq 'id status))) - (retweeted-id (cdr (assq 'retweeted-id status)))) - (if (twittering-status-id= prev-id id) - ;; `status' is equivalent the previous one. - nil - (setq prev-id id) - (cond - ((null retweeted-id) - ;; `status' is not a retweet. - status) - ((and retweeted-id - (twittering-status-id= - id (gethash retweeted-id referring-id-table))) - ;; `status' is the first retweet. - status) - ((and retweeted-id - (string= (cdr (assq 'retweeting-user-screen-name - status)) - current-user)) - ;; `status' is retweeted by the current account. - status) - ((null (gethash retweeted-id referring-id-table)) - ;; If the first ID referring the retweet is unknown, - ;; render it. - ;; This is necessary because a referring ID table - ;; of a composite timeline may lack information of - ;; some component timelines. - status) - (t - ;; Otherwise, do not render it. - nil))))) - timeline-data)))) - (timeline-data (if twittering-reverse-mode - (reverse timeline-data) - timeline-data)) - (rendering-entire (null (twittering-get-first-status-head))) - (result-tweets nil) - (buffer-read-only nil)) - (twittering-update-status-format) - (twittering-update-mode-line) - (save-excursion - (let ((pos (point-min)) - (spec-string - (twittering-get-timeline-spec-string-for-buffer buffer))) - (cond - (rendering-entire - (let* ((latest-id - (twittering-make-field-id-of-timeline-latest-end - spec-string)) - (oldest-id - (twittering-make-field-id-of-timeline-oldest-end - spec-string)) - (footer-id - (if twittering-reverse-mode - latest-id - oldest-id)) - (header-id - (if twittering-reverse-mode - oldest-id - latest-id))) - (setq - pos - (let ((footer - ;; To avoid adding a face to newlines. - (mapconcat - (lambda (substr) - (propertize substr - 'face twittering-timeline-footer-face)) - (split-string (or twittering-timeline-footer "") "\n") - "\n")) - (header - ;; To avoid adding a face to newlines. - (mapconcat - (lambda (substr) - (propertize substr - 'face twittering-timeline-header-face)) - (split-string (or twittering-timeline-header "") "\n") - "\n"))) - (twittering-render-a-field (point-min) footer-id footer t) - (twittering-render-a-field (point-min) header-id header t) - (point))))) - (t - (setq pos (twittering-get-first-status-head)))) - (goto-char pos) - (let* ((rendered-tweets - (remove nil - (mapcar - (lambda (status) - (when (twittering-render-a-field - (point) - (twittering-make-field-id status) - (twittering-format-status status)) - (when twittering-default-show-replied-tweets - (twittering-show-replied-statuses - twittering-default-show-replied-tweets)) - status)) - timeline-data))) - (twittering-rendered-new-tweets - (if twittering-reverse-mode - (reverse rendered-tweets) - rendered-tweets)) - (twittering-rendered-new-tweets-spec spec) - (twittering-rendered-new-tweets-spec-string spec-string)) - (setq result-tweets rendered-tweets) - (when (and invoke-hook twittering-rendered-new-tweets) - (run-hooks 'twittering-new-tweets-rendered-hook))))) - (debug-print (current-buffer)) - (cond - ((and (not keep-point) rendering-entire) - ;; Go to the latest status of buffer after full insertion. - (let ((dest (if twittering-reverse-mode - (or (twittering-get-last-normal-field-head) - (twittering-get-last-status-head) - (point-max)) - (or (twittering-get-first-normal-field-head) - (twittering-get-first-status-head) - (point-min)))) - (window-list (get-buffer-window-list (current-buffer) nil t))) - (if window-list - (mapc - (lambda (window) - (set-window-point window dest) - (if twittering-reverse-mode - (twittering-set-window-end window (point-max)) - (set-window-start window (point-min)))) - window-list) - ;; Move the buffer position if the buffer is invisible. - (goto-char dest)))) - ) - result-tweets) - )) - -(defun twittering-rerender-timeline-all (buffer &optional restore-point) - "Re-render statuses on BUFFER after clearing BUFFER. -If RESTORE-POINT is non-nil, positions on buffers bound to the same timeline -will be restored after rendering statuses." - (with-current-buffer buffer - (let* ((window-list (get-buffer-window-list (current-buffer) nil t)) - (point-window-list - (mapcar (lambda (window) - (cons (window-point window) window)) - window-list)) - (original-pos (point))) - (let ((buffer-read-only nil)) - (erase-buffer)) - (twittering-render-timeline - (current-buffer) (twittering-current-timeline-data) nil restore-point) - (when restore-point - ;; Restore points. - (mapc (lambda (pair) - (let* ((point (car pair)) - (window (cdr pair)) - (dest (max (point-max) point))) - (set-window-point window dest))) - point-window-list) - (goto-char original-pos))))) - -(defun twittering-retrieve-timeline (spec-string noninteractive api-arguments additional-info) - "Retrieve and render a timeline specified by SPEC-STRING. -Retrieve a timeline specified by SPEC-STRING, which must be a timeline spec -string. Any timeline spec string including that for composite timeline can be -used as SPEC-STRING, though the primitive function `twittering-call-api' -accepts only a spec of a primary timeline. - -NONINTERACTIVE is sent to the sentinel as a parameter `noninteractive' via -an argument `additional-info' of `twittering-call-api'. -API-ARGUMENTS is also sent to `twittering-call-api' as its argument -`args-alist'." - (let ((spec (twittering-string-to-timeline-spec spec-string))) - (cond - ((not (twittering-account-authorized-p)) - ;; ignore any requests if the account has not been authorized. - (message "No account for Twitter has been authorized.") - t) - ((and noninteractive (twittering-process-active-p spec)) - ;; ignore non-interactive request if a process is waiting for responses. - t) - ((twittering-timeline-spec-primary-p spec) - (let* ((args - `(,@api-arguments - (timeline-spec . ,spec) - (timeline-spec-string . ,spec-string) - (format . ,(when (require 'json nil t) - 'json)) - (clean-up-sentinel - . ,(lambda (proc status connection-info) - (when (memq status '(exit signal closed failed)) - (twittering-release-process proc)))))) - (additional-info - `(,@additional-info - (noninteractive . ,noninteractive) - (timeline-spec . ,spec) - (timeline-spec-string . ,spec-string))) - (proc - (twittering-call-api 'retrieve-timeline args additional-info))) - (when proc - (twittering-register-process proc spec spec-string) - (twittering-initialize-retrieval-count spec)))) - ((twittering-timeline-spec-composite-p spec) - (mapc - (lambda (spec) - (let* ((buffer (twittering-get-buffer-from-spec spec)) - (spec-string - (if buffer - (twittering-get-timeline-spec-string-for-buffer buffer) - (twittering-timeline-spec-to-string spec)))) - (twittering-retrieve-timeline spec-string noninteractive - api-arguments additional-info))) - (twittering-get-base-timeline-specs spec))) - (t - (let ((type (car spec))) - (error "%s has not been supported yet" type)))))) - -(defun twittering-get-and-render-timeline (&optional noninteractive id spec spec-string) - (let* ((spec (or spec (twittering-current-timeline-spec))) - (spec-string - (or spec-string (twittering-current-timeline-spec-string))) - (latest-status - ;; Assume that a list which was returned by - ;; `twittering-current-timeline-data' is sorted. - (car (twittering-current-timeline-data spec))) - (since_id (cdr-safe (assq 'id latest-status))) - (args `(,@(cond - (id `((max_id . ,id))) - (since_id `((since_id . ,since_id))) - (t nil))))) - (twittering-retrieve-timeline spec-string noninteractive args nil))) - -;;;; -;;;; Map function for statuses on buffer -;;;; - -(defun twittering-for-each-property-region (prop func &optional buffer interrupt) - "Apply FUNC to each region, where property PROP is non-nil, on BUFFER. -If INTERRUPT is non-nil, the iteration is stopped if FUNC returns nil." - (with-current-buffer (or buffer (current-buffer)) - (let ((beg (point-min)) - (end-marker (make-marker))) - (set-marker-insertion-type end-marker t) - (while - (let ((value (get-text-property beg prop))) - (if value - (let* ((end (next-single-property-change beg prop)) - (end (or end (point-max))) - (end-marker (set-marker end-marker end)) - (func-result (funcall func beg end value)) - (end (marker-position end-marker))) - (when (or (null interrupt) func-result) - (if (get-text-property end prop) - (setq beg end) - (setq beg (next-single-property-change end prop))))) - (setq beg (next-single-property-change beg prop))))) - (set-marker end-marker nil)))) - -;;;; -;;;; Automatic redisplay of statuses on buffer -;;;; - -(defun twittering-redisplay-status-on-buffer () - (mapc (lambda (buffer) - (unless (with-current-buffer buffer - (or (and (fboundp 'use-region-p) (use-region-p)) - (and transient-mark-mode mark-active))) - (twittering-redisplay-status-on-each-buffer buffer))) - (twittering-get-buffer-list))) - -(defun twittering-redisplay-status-on-each-buffer (buffer &optional prop) - "Redisplay regions with the text property PROP on BUFFER." - (let ((prop (or prop 'need-to-be-updated)) - (deactivate-mark deactivate-mark) - (window-list (get-buffer-window-list buffer nil t)) - (marker (with-current-buffer buffer (point-marker))) - (result nil)) - (with-current-buffer buffer - (save-excursion - (twittering-for-each-property-region - prop - (lambda (beg end value) - (let* ((func (car value)) - (args (cdr value)) - (current-str (buffer-substring beg end)) - (updated-str (apply func beg end args)) - (config (twittering-current-window-config window-list)) - (buffer-read-only nil)) - ;; Replace `current-str' if it differs to `updated-str' with - ;; ignoring properties. This is an ad-hoc solution. - ;; `current-str' is a part of the displayed status, but it has - ;; properties which are determined by the whole status. - ;; (For example, the `id' property.) - ;; Therefore, we cannot compare the strings with their - ;; properties. - (unless (string= current-str updated-str) - ;; If the region to be modified includes the current position, - ;; the point moves to the beginning of the region. - (when (and (< beg marker) (< marker end)) - ;; This is required because the point moves to the center if - ;; the point becomes outside of the window by the effect of - ;; `set-window-start'. - (setq result beg)) - (let ((common-properties - (twittering-get-common-properties beg))) - ;; Restore common properties. - (delete-region beg end) - (goto-char beg) - (insert (apply 'propertize updated-str common-properties))) - (twittering-restore-window-config-after-modification - config beg end)))) - buffer)) - (set-marker marker nil) - (when (and result (eq (window-buffer) buffer)) - (let ((win (selected-window))) - (when (< result (window-start win)) - (set-window-start win result)) - (set-window-point win result)))))) - -;;;; -;;;; Display replied statuses -;;;; - -(defun twittering-replied-statuses-visible-p (&optional pos) - "Return non-nil if a replied status related to POS is visible. -Return non-nil if a replied status has been rendered at POS by -`twittering-show-replied-statuses'. -Return non-nil if a reply is rendered at POS and the replied statuses -has been rendered by `twittering-show-replied-statuses'. -Otherwise, return nil." - (let* ((pos (twittering-get-current-status-head pos)) - (id (twittering-get-id-at pos)) - (prev (twittering-get-previous-status-head pos)) - (next (twittering-get-next-status-head pos))) - (when id - ;; If ID is nil, it means that no normal tweets are rendered at POS. - (or - (twittering-get-base-id-of-ancestor-at pos) - (and prev - (twittering-status-id= - id (twittering-get-base-id-of-ancestor-at prev))) - (and next - (twittering-status-id= - id (twittering-get-base-id-of-ancestor-at next))))))) - -(defun twittering-get-beginning-of-visible-replied-statuses (&optional pos) - "Return the beginning position of visible replied statuses at POS. -If POS is nil, the current position is used instead. -If `twittering-show-replied-statuses' has rendered a replied status at POS, -return the beginning position of the replied statuses with the common base -status. -If a reply is rendered at POS and its ancestors has been rendered by -`twittering-show-replied-statuses', return the beginning position of the -replied statuses. -Otherwise, return nil." - (let* ((pos (or pos (point))) - (base-id (twittering-get-base-id-of-ancestor-at pos))) - (cond - (base-id - ;; A replied status is rendered at POS. - (while - (let* ((prev (twittering-get-previous-status-head pos)) - (prev-base-id - (when prev - (twittering-get-base-id-of-ancestor-at prev)))) - (and prev prev-base-id - (twittering-status-id= base-id prev-base-id) - (setq pos prev)))) - (or pos (point-min))) - ((twittering-replied-statuses-visible-p pos) - ;; A reply is rendered at POS and its replied statuses are visible. - (if twittering-reverse-mode - (twittering-get-beginning-of-visible-replied-statuses - (twittering-get-previous-status-head pos)) - (twittering-get-next-status-head pos))) - (t - nil)))) - -(defun twittering-get-end-of-visible-replied-statuses (&optional pos) - "Return the end position of visible replied statuses at POS. -If POS is nil, the current position is used instead. -If `twittering-show-replied-statuses' has rendered a replied status at POS, -return the end position of the replied statuses with the common base status. -If a reply is rendered at POS and its ancestors has been rendered by -`twittering-show-replied-statuses', return the beginning position of the -replied statuses. -Otherwise, return nil." - (let* ((pos (or pos (point))) - (base-id (twittering-get-base-id-of-ancestor-at pos))) - (cond - (base-id - ;; A replied status is rendered at POS. - (while - (let ((current-base-id (twittering-get-base-id-of-ancestor-at pos))) - (and current-base-id - (twittering-status-id= base-id current-base-id) - (setq pos (twittering-get-next-status-head pos))))) - (or pos (point-max))) - ((twittering-replied-statuses-visible-p pos) - ;; A reply is rendered at POS and its replied statuses are visible. - (if twittering-reverse-mode - (twittering-get-current-status-head pos) - (twittering-get-end-of-visible-replied-statuses - (twittering-get-next-status-head pos)))) - (t - nil)))) - -(defun twittering-render-replied-statuses (&optional pos count) - "Render replied statuses on the position specified by POS. -If POS is nil, the current position is used instead. -If COUNT is a positive integer, it specifies the number of rendered statuses. -If COUNT is nil, all ancestor statuses that have been already retrieved are -rendered. - -Return non-nil if one or more statuses are rendered. -Return nil if no statuses are rendered." - (let* ((pos (or pos (point))) - (id - ;; nil if no normal statuses are rendered at POS. - (twittering-get-id-at pos)) - (replied-status-are-visible - (when id - (twittering-replied-statuses-visible-p pos))) - (base-id (if replied-status-are-visible - (or - ;; If a replied status is rendered at POS. - (twittering-get-base-id-of-ancestor-at pos) - ;; If the base reply is rendered at POS. - id) - id)) - (statuses - (when base-id - (twittering-get-replied-statuses base-id (if (numberp count) - count)))) - (statuses (if twittering-reverse-mode - statuses - (reverse statuses)))) - (cond - ((null id) - ;; No normal statuses are rendered here. - nil) - (statuses - (let ((pos - (cond - ((twittering-replied-statuses-visible-p pos) - ;; Some replied statuses have been already rendered. - (twittering-get-beginning-of-visible-replied-statuses pos)) - (twittering-reverse-mode - (twittering-get-current-status-head pos)) - (t - (or (twittering-get-next-status-head pos) - (point-max))))) - (prefix " ") - (buffer-read-only nil)) - (save-excursion - (goto-char pos) - (mapc - (lambda (status) - (twittering-render-a-field - (point) - (twittering-make-field-id status base-id) - (let ((formatted-status (twittering-format-status status prefix)) - (field-properties - (twittering-make-properties-of-popped-ancestors base-id))) - (add-text-properties 0 (length formatted-status) - field-properties formatted-status) - formatted-status))) - statuses) - t))) - (t - nil)))) - -(defun twittering-render-a-status-with-delay (beg end id prefix) - "Render a status with a delay. -It is assumed that this function is used as a property value that is -processed by the function `twittering-redisplay-status-on-each-buffer'." - (let ((status (twittering-find-status id))) - (when status - (let ((properties (and beg (text-properties-at beg)))) - (apply 'propertize (twittering-format-status status prefix) - properties))))) - -(defun twittering-toggle-or-retrieve-replied-statuses () - "Show/Hide all of replied statuses or retrieve a replied status. -If the cursor points to a reply or one of expanded replied statuses and -some of ancestor replied statuses have been already retrieved but they have -not been rendered, render them. -If the cursor points to a reply or one of expanded replied statuses and -all of retrieved ancestor statuses have been already rendered but the oldest -one of them is also a reply, retrieve the replied status. -If the cursor points to a reply or one of expanded replied statuses and -all of ancestor replied statuses have been already rendered, hide them by -`twittering-hide-replied-statuses'." - (interactive) - (let* ((pos (point)) - (pos - ;; POS points to the head of the direct reply of the status being - ;; retrieved. - (cond - ((twittering-replied-statuses-visible-p pos) - ;; If some replied statuses are visible, find the edge. - (if twittering-reverse-mode - (twittering-get-beginning-of-visible-replied-statuses pos) - (twittering-get-previous-status-head - (twittering-get-end-of-visible-replied-statuses pos)))) - (t - (twittering-get-current-status-head pos)))) - (id (twittering-get-id-at pos)) - (status (twittering-find-status id)) - (reply-id (cdr (assq 'in-reply-to-status-id status))) - (reply-username (cdr (assq 'in-reply-to-screen-name status))) - (base-id (or (twittering-get-base-id-of-ancestor-at pos) - id))) - (cond - ((twittering-find-status reply-id) - ;; The status corresponding to REPLY-ID has been already retrieved - ;; but it has not been rendered. - ;; - ;; `twittering-render-replied-statuses' additionally renders all - ;; of already retrieved statuses. - (twittering-render-replied-statuses)) - (reply-id - (let* ((pos - ;; POS points to the position where the new field will be - ;; inserted. - (if twittering-reverse-mode - pos - (or (twittering-get-next-status-head pos) - (point-max)))) - (field-id (twittering-make-field-id-from-id reply-id base-id)) - (prefix " ") - (label "[RETRIEVING...]") - (symbol-for-redisplay 'waiting-for-retrieval) - (properties - `(,@(twittering-make-properties-of-popped-ancestors base-id) - ,symbol-for-redisplay - (twittering-render-a-status-with-delay ,reply-id ,prefix))) - (str (apply 'propertize (concat prefix label) properties)) - (buffer-read-only nil)) - (twittering-call-api - 'retrieve-single-tweet - `((id . ,reply-id) - (username . ,reply-username) - (format . ,(when (require 'json nil t) - 'json)) - (sentinel . twittering-retrieve-single-tweet-sentinel)) - `((buffer . ,(current-buffer)) - (property-to-be-redisplayed . ,symbol-for-redisplay))) - (save-excursion - (goto-char pos) - (twittering-render-a-field (point) field-id str)) - (goto-char pos))) - ((twittering-replied-statuses-visible-p) - ;; All ancestor replied statuses have been rendered. - (twittering-hide-replied-statuses)) - (t - ;; The pointed status is not a reply. - (message "This status is not a reply."))))) - -(defun twittering-show-replied-statuses (&optional count interactive) - (interactive) - (cond - ((twittering-replied-statuses-visible-p) - (when interactive - (message "The replied statuses were already showed."))) - ((twittering-render-replied-statuses (point) count) - t) - (t - ;; Failed to render replied statuses. - (when interactive - (let ((base-id (twittering-get-id-at))) - (if (twittering-have-replied-statuses-p base-id) - (message "The status this replies to has not been fetched yet.") - (message "This status is not a reply."))))))) - -(defun twittering-hide-replied-statuses (&optional interactive) - (interactive) - (cond - ((twittering-replied-statuses-visible-p) - (let* ((pos (twittering-get-current-status-head (point))) - (base-id (or (twittering-get-base-id-of-ancestor-at pos) - (twittering-get-id-at pos))) - (pointing-to-base-status - (not (twittering-rendered-as-ancestor-status-p pos))) - (beg (twittering-get-beginning-of-visible-replied-statuses pos)) - (end (twittering-get-end-of-visible-replied-statuses pos)) - (buffer-read-only nil)) - (unless pointing-to-base-status - (goto-char (if twittering-reverse-mode - beg - (or (twittering-get-previous-status-head beg) - (point-min))))) - (delete-region beg end))) - (interactive - (message "The status this replies to was already hidden.")))) - -(defun twittering-toggle-show-replied-statuses () - (interactive) - (if (twittering-replied-statuses-visible-p) - (twittering-hide-replied-statuses (interactive-p)) - (twittering-show-replied-statuses twittering-show-replied-tweets - (interactive-p)))) - -;;;; -;;;; Unread statuses info -;;;; - -(defvar twittering-unread-status-info nil - "A list of (buffer unread-statuses-counter), where `unread-statuses-counter' -means the number of statuses retrieved after the last visiting of the buffer.") - -(defun twittering-reset-unread-status-info-if-necessary () - (when (twittering-buffer-p) - (twittering-set-number-of-unread (current-buffer) 0))) - -(defun twittering-set-number-of-unread (buffer number) - (let* ((entry (assq buffer twittering-unread-status-info)) - (current (or (cadr entry) 0))) - (unless (= number current) - (setq twittering-unread-status-info - (cons - `(,buffer ,number) - (if entry - (remq entry twittering-unread-status-info) - twittering-unread-status-info)))))) - -(defun twittering-make-unread-status-notifier-string () - "Generate a string that displays unread statuses." - (setq twittering-unread-status-info - (remove nil - (mapcar (lambda (entry) - (when (buffer-live-p (car entry)) - entry)) - twittering-unread-status-info))) - (let ((sum (apply '+ (mapcar 'cadr twittering-unread-status-info)))) - (if (= 0 sum) - "" - (format "tw(%d)" sum)))) - -(defun twittering-update-unread-status-info () - "Update `twittering-unread-status-info' with new tweets." - (let* ((buffer (twittering-get-buffer-from-spec - twittering-rendered-new-tweets-spec)) - (current (or (cadr (assq buffer twittering-unread-status-info)) 0)) - (result (+ current (length twittering-rendered-new-tweets)))) - (when buffer - (twittering-set-number-of-unread buffer result)))) - -(defun twittering-enable-unread-status-notifier () - "Enable a notifier of unread statuses on `twittering-mode'." - (interactive) - (setq twittering-unread-status-info - (mapcar (lambda (buffer) `(,buffer ,0)) - (twittering-get-buffer-list))) - (add-hook 'twittering-new-tweets-rendered-hook - 'twittering-update-unread-status-info) - (add-hook 'post-command-hook - 'twittering-reset-unread-status-info-if-necessary) - (add-to-list 'global-mode-string - '(:eval (twittering-make-unread-status-notifier-string)) - t)) - -(defun twittering-disable-unread-status-notifier () - "Disable a notifier of unread statuses on `twittering-mode'." - (interactive) - (setq twittering-unread-status-info nil) - (remove-hook 'twittering-new-tweets-hook - 'twittering-update-unread-status-info) - (remove-hook 'post-command-hook - 'twittering-reset-unread-status-info-if-necessary) - (setq global-mode-string - (remove '(:eval (twittering-make-unread-status-notifier-string)) - global-mode-string))) - -;;;; -;;;; Timer -;;;; - -(defvar twittering-idle-timer-for-redisplay nil) - -(defun twittering-timer-action (func) - (let ((buf (twittering-get-active-buffer-list))) - (if (null buf) - (twittering-stop) - (funcall func) - ))) - -(defun twittering-run-on-idle (idle-interval func &rest args) - "Run FUNC the next time Emacs is idle for IDLE-INTERVAL. -Even if Emacs has been idle longer than IDLE-INTERVAL, run FUNC immediately. -Since immediate invocation requires `current-idle-time', it is available -on Emacs 22 and later. -FUNC is called as (apply FUNC ARGS)." - (let ((sufficiently-idling - (and (fboundp 'current-idle-time) - (current-idle-time) - (time-less-p (seconds-to-time idle-interval) - (current-idle-time))))) - (if (not sufficiently-idling) - (apply 'run-with-idle-timer idle-interval nil func args) - (apply func args) - nil))) - -(defun twittering-run-repeatedly-on-idle (check-interval var idle-interval func &rest args) - "Run FUNC every time Emacs is idle for IDLE-INTERVAL. -Even if Emacs remains idle longer than IDLE-INTERVAL, run FUNC every -CHECK-INTERVAL seconds. Since this behavior requires `current-idle-time', -invocation on long idle time is available on Emacs 22 and later. -VAR is a symbol of a variable to which the idle-timer is bound. -FUNC is called as (apply FUNC ARGS)." - (apply 'run-at-time "0 sec" - check-interval - (lambda (var idle-interval func &rest args) - (let ((registerd (symbol-value var)) - (sufficiently-idling - (and (fboundp 'current-idle-time) - (current-idle-time) - (time-less-p (seconds-to-time idle-interval) - (current-idle-time))))) - (when (or (not registerd) sufficiently-idling) - (when (and registerd sufficiently-idling) - (cancel-timer (symbol-value var)) - (apply func args)) - (set var (apply 'run-with-idle-timer idle-interval nil - (lambda (var func &rest args) - (set var nil) - (apply func args)) - var func args))))) - var idle-interval func args)) - -(defun twittering-start (&optional action) - (interactive) - (unless twittering-timer - (let ((action (or action #'twittering-update-active-buffers))) - ;; Update all active timelines forcibly. - (twittering-update-active-buffers t) - (setq twittering-timer - (run-at-time (format "%d sec" twittering-timer-interval) - twittering-timer-interval - #'twittering-timer-action action)))) - (unless twittering-timer-for-redisplaying - (setq twittering-timer-for-redisplaying - (twittering-run-repeatedly-on-idle - (* 2 twittering-timer-interval-for-redisplaying) - 'twittering-idle-timer-for-redisplay - twittering-timer-interval-for-redisplaying - #'twittering-redisplay-status-on-buffer)))) - -(defun twittering-stop () - (interactive) - (when twittering-timer - (cancel-timer twittering-timer) - (setq twittering-timer nil)) - (when twittering-timer-for-redisplaying - (when twittering-idle-timer-for-redisplay - (cancel-timer twittering-idle-timer-for-redisplay) - (setq twittering-idle-timer-for-redisplay nil)) - (cancel-timer twittering-timer-for-redisplaying) - (setq twittering-timer-for-redisplaying nil))) - -(defun twittering-get-relative-interval (spec) - (let* ((spec-string (twittering-timeline-spec-to-string spec)) - (normalized-alist - (apply 'append - (mapcar - (lambda (entry) - (let ((interval (car (last entry))) - (regexp-list (butlast entry 1))) - (when (integerp interval) - (mapcar (lambda (regexp) `(,regexp . ,interval)) - regexp-list)))) - twittering-relative-retrieval-interval-alist))) - (rest normalized-alist) - (current normalized-alist) - (result 0)) - (while (not - (or (and (stringp (car current)) - (string-match (car current) spec-string)) - (eq t (car current)))) - (setq current (car rest)) - (setq rest (cdr rest))) - (if (integerp (cdr current)) - (cdr current) - ;; The default relative interval is 1. - 1))) - -(defun twittering-get-retrieval-count (spec) - (cdr (assoc spec twittering-relative-retrieval-count-alist))) - -(defun twittering-set-retrieval-count (spec count) - (let ((current (assoc spec twittering-relative-retrieval-count-alist))) - (if (null current) - (add-to-list 'twittering-relative-retrieval-count-alist - `(,spec . ,count)) - (setcdr current count)))) - -(defun twittering-initialize-retrieval-count (spec) - (twittering-set-retrieval-count spec - (twittering-get-relative-interval spec))) - -(defun twittering-update-active-buffers (&optional force noninteractive) - "Update active buffers managed by `twittering-mode' at a certain interval. - -If FORCE is nil, each active buffer is updated at a relative interval -determined by `twittering-relative-retrieval-interval-alist'. -If a relative interval of a timeline is 3, the timeline is updated once -by three invocations of this function. - -If FORCE is non-nil, all active buffers are updated forcibly." - (when (twittering-account-authorized-p) - (twittering-update-service-configuration) - (let* ((buffer-list (twittering-get-active-buffer-list)) - (primary-spec-list - (twittering-remove-duplicates - (apply 'append - (mapcar - (lambda (buffer) - (twittering-get-primary-base-timeline-specs - (twittering-get-timeline-spec-for-buffer buffer))) - buffer-list))))) - (mapc - (lambda (spec) - (let ((current - (if force - 1 - (twittering-get-retrieval-count spec)))) - (cond - ((null current) - ;; Initialize the count if no entry for the primary timeline - ;; exists. - (twittering-initialize-retrieval-count spec)) - ((and (integerp current) (= 0 current)) - ;; Do nothing. - ) - ((and (integerp current) (= 1 current)) - ;; Retrieve the timeline and initialize count. - (let ((spec-string - (twittering-timeline-spec-to-string spec))) - (twittering-get-and-render-timeline - noninteractive nil spec spec-string) - (twittering-initialize-retrieval-count spec))) - ((and (integerp current) (< 1 current)) - ;; Decrement count. - (twittering-set-retrieval-count spec (1- current))) - (t - nil)))) - primary-spec-list)))) - -;;;; -;;;; Keymap -;;;; - -(if twittering-mode-map - (let ((km twittering-mode-map)) - (define-key km (kbd "C-c C-f") 'twittering-friends-timeline) - (define-key km (kbd "C-c C-r") 'twittering-replies-timeline) - (define-key km (kbd "C-c C-n") 'twittering-mentions-timeline) - (define-key km (kbd "C-c C-u") 'twittering-user-timeline) - (define-key km (kbd "C-c C-d") 'twittering-direct-messages-timeline) - (define-key km (kbd "C-c C-s") 'twittering-update-status-interactive) - (define-key km (kbd "C-c C-e") 'twittering-erase-old-statuses) - (define-key km (kbd "C-c C-m") 'twittering-retweet) - (define-key km (kbd "C-c C-t") 'twittering-set-current-hashtag) - (define-key km (kbd "C-m") 'twittering-enter) - (define-key km (kbd "C-c C-l") 'twittering-update-lambda) - (define-key km (kbd "") 'twittering-click) - (define-key km (kbd "C-") 'mouse-set-point) - (define-key km (kbd "C-") 'twittering-push-tweet-onto-kill-ring) - (define-key km (kbd "C-c C-v") 'twittering-view-user-page) - (define-key km (kbd "C-c D") 'twittering-delete-status) - (define-key km (kbd "C-c C-w") 'twittering-delete-status) - (define-key km (kbd "a") 'twittering-toggle-activate-buffer) - (define-key km (kbd "g") 'twittering-current-timeline) - (define-key km (kbd "u") 'twittering-update-status-interactive) - (define-key km (kbd "U") 'twittering-push-uri-onto-kill-ring) - (define-key km (kbd "d") 'twittering-direct-message) - (define-key km (kbd "v") 'twittering-other-user-timeline) - (define-key km (kbd "V") 'twittering-visit-timeline) - (define-key km (kbd "L") 'twittering-other-user-list-interactive) - (define-key km (kbd "f") 'twittering-switch-to-next-timeline) - (define-key km (kbd "b") 'twittering-switch-to-previous-timeline) - ;; (define-key km (kbd "j") 'next-line) - ;; (define-key km (kbd "k") 'previous-line) - (define-key km (kbd "j") 'twittering-goto-next-status) - (define-key km (kbd "k") 'twittering-goto-previous-status) - (define-key km (kbd "l") 'forward-char) - (define-key km (kbd "h") 'backward-char) - (define-key km (kbd "0") 'beginning-of-line) - (define-key km (kbd "^") 'beginning-of-line-text) - (define-key km (kbd "$") 'end-of-line) - (define-key km (kbd "n") 'twittering-goto-next-status-of-user) - (define-key km (kbd "p") 'twittering-goto-previous-status-of-user) - (define-key km (kbd "C-i") 'twittering-goto-next-thing) - (define-key km (kbd "M-C-i") 'twittering-goto-previous-thing) - (define-key km (kbd "") 'twittering-goto-previous-thing) - (define-key km (kbd "") 'twittering-scroll-down) - (define-key km (kbd "M-v") 'twittering-scroll-down) - (define-key km (kbd "SPC") 'twittering-scroll-up) - (define-key km (kbd "C-v") 'twittering-scroll-up) - (define-key km (kbd "G") 'twittering-goto-last-status) - (define-key km (kbd "H") 'twittering-goto-first-status) - (define-key km (kbd "i") 'twittering-icon-mode) - (define-key km (kbd "r") 'twittering-toggle-show-replied-statuses) - (define-key km (kbd "R") 'twittering-toggle-or-retrieve-replied-statuses) - (define-key km (kbd "t") 'twittering-toggle-proxy) - (define-key km (kbd "C-c C-p") 'twittering-toggle-proxy) - (define-key km (kbd "q") 'twittering-kill-buffer) - (define-key km (kbd "C-c C-q") 'twittering-search) - (define-key km (kbd "=") 'twittering-display-user-information) - nil)) - -(let ((km twittering-mode-menu-on-uri-map)) - (when km - (define-key km [ct] '("Copy tweet" . twittering-push-tweet-onto-kill-ring)) - (define-key km [cl] '("Copy link" . twittering-push-uri-onto-kill-ring)) - (define-key km [ll] '("Load link" . twittering-click)) - (let ((km-on-uri twittering-mode-on-uri-map)) - (when km-on-uri - (define-key km-on-uri (kbd "C-") 'mouse-set-point) - (define-key km-on-uri (kbd "C-") km))))) - -(defun twittering-keybind-message () - (let ((important-commands - '(("Timeline" . twittering-friends-timeline) - ("Replies" . twittering-replies-timeline) - ("Mentions" . twittering-mentions-timeline) - ("Update status" . twittering-update-status-interactive) - ("Next" . twittering-goto-next-status) - ("Prev" . twittering-goto-previous-status)))) - (mapconcat (lambda (command-spec) - (let ((descr (car command-spec)) - (command (cdr command-spec))) - (format "%s: %s" descr (key-description - (where-is-internal - command - overriding-local-map t))))) - important-commands ", "))) - -;; (run-with-idle-timer -;; 0.1 t -;; '(lambda () -;; (when (equal (buffer-name (current-buffer)) twittering-buffer) -;; (message (twittering-keybind-message))))) - - -;;;; -;;;; Initialization -;;;; - -(defvar twittering-initialized nil) -(defvar twittering-mode-syntax-table nil "") - -(unless 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-initialize-global-variables-if-necessary () - "Initialize global variables for `twittering-mode' if they have not -been initialized yet." - (unless twittering-initialized - (defface twittering-username-face - `((t ,(append '(:underline t) - (face-attr-construct - (if (facep 'font-lock-string-face) - 'font-lock-string-face - 'bold))))) - "" :group 'faces) - (defface twittering-uri-face `((t (:underline t))) "" :group 'faces) - (defface twittering-timeline-header-face - `((t ,(face-attr-construct - (if (facep 'font-lock-preprocessor-face) - 'font-lock-preprocessor-face - 'bold)))) - "Timeline header on twittering-mode" :group 'faces) - (defface twittering-timeline-footer-face - `((t ,(face-attr-construct - (if (facep 'font-lock-preprocessor-face) - 'font-lock-preprocessor-face - 'bold)))) - "Timeline footer on twittering-mode" :group 'faces) - (twittering-update-status-format) - (twittering-load-user-id-db) - (add-hook 'kill-emacs-hook 'twittering-save-user-id-db) - (when twittering-use-convert - (if (null twittering-convert-program) - (setq twittering-use-convert nil) - (with-temp-buffer - (let ((coding-system-for-read 'iso-safe) - (coding-system-for-write 'iso-safe) - ;; Bind `default-directory' to the temporary directory - ;; because it is possible that the directory pointed by - ;; `default-directory' has been already removed. - (default-directory temporary-file-directory)) - (call-process twittering-convert-program nil (current-buffer) nil - "-version") - (goto-char (point-min)) - (if (null (search-forward-regexp "\\(Image\\|Graphics\\)Magick" - nil t)) - (setq twittering-use-convert nil)))))) - (twittering-setup-proxy) - (when twittering-use-icon-storage - (cond - ((require 'jka-compr nil t) - (twittering-load-icon-properties) - (add-hook 'kill-emacs-hook 'twittering-save-icon-properties)) - (t - (setq twittering-use-icon-storage nil) - (error "Disabled icon-storage because it failed to load jka-compr.")))) - (cond - ((and - (boundp 'twittering-sign-simple-string) - twittering-sign-simple-string - (or (not (boundp 'twittering-sign-string-function)) - (null twittering-sign-string-function)) - (eq twittering-edit-skeleton 'none) - (or (null twittering-edit-skeleton-footer) - (string= twittering-edit-skeleton-footer ""))) - ;; Configure `twittering-edit-skeleton' as an alternative of - ;; `twittering-sign-simple-string'. - (twittering-edit-skeleton-change-footer - (format " [%s]" twittering-sign-simple-string)) - (setq twittering-edit-skeleton 'footer) - (message "Warning: `twittering-sign-simple-string' is obsolete. Use `twittering-edit-skeleton-footer' instead.")) - ((or (boundp 'twittering-sign-simple-string) - (boundp 'twittering-sign-string-function)) - (message "Warning: `twittering-sign-simple-string' and `twittering-sign-string-function' are obsolete. Use the new feature `twittering-edit-skeleton'.") - )) - (add-hook 'twittering-new-tweets-rendered-hook - 'twittering-jojo-mode-hook-function) - (run-hooks 'twittering-mode-init-hook) - (setq twittering-initialized t))) - -(defun twittering-mode-setup (spec-string) - "Set up the current buffer for `twittering-mode'." - (kill-all-local-variables) - (setq major-mode 'twittering-mode) - (setq buffer-read-only t) - (buffer-disable-undo) - (setq mode-name "twittering-mode") - (setq mode-line-buffer-identification - `(,(default-value 'mode-line-buffer-identification) - (:eval (twittering-mode-line-buffer-identification)))) - - ;; Prevent `global-font-lock-mode' enabling `font-lock-mode'. - ;; This technique is derived from `lisp/bs.el' distributed with Emacs 22.2. - (make-local-variable 'font-lock-global-modes) - (setq font-lock-global-modes '(not twittering-mode)) - - ;; Prevent the field property attached to tweets from interfering - ;; the cursor motion based on logical lines. - (make-local-variable 'inhibit-field-text-motion) - (setq inhibit-field-text-motion t) - - (make-local-variable 'twittering-timeline-spec) - (make-local-variable 'twittering-timeline-spec-string) - (make-local-variable 'twittering-active-mode) - (make-local-variable 'twittering-icon-mode) - (make-local-variable 'twittering-jojo-mode) - (make-local-variable 'twittering-reverse-mode) - - (setq twittering-timeline-spec-string spec-string) - (setq twittering-timeline-spec - (twittering-string-to-timeline-spec spec-string)) - (setq twittering-active-mode t) - - (use-local-map twittering-mode-map) - (twittering-update-mode-line) - (set-syntax-table twittering-mode-syntax-table) - (when (and (boundp 'font-lock-mode) font-lock-mode) - (font-lock-mode -1)) - (add-to-list 'twittering-buffer-info-list (current-buffer) t) - (run-hooks 'twittering-mode-hook)) - -(defun twittering-mode () - "Major mode for Twitter -\\{twittering-mode-map}" - (interactive) - (let ((timeline-spec-list - (if (listp twittering-initial-timeline-spec-string) - twittering-initial-timeline-spec-string - (cons twittering-initial-timeline-spec-string nil)))) - (twittering-visit-timeline (car timeline-spec-list)) - (when (twittering-account-authorized-p) - (mapc 'twittering-visit-timeline (cdr timeline-spec-list))))) - -;;;; -;;;; Preparation for invoking APIs -;;;; - -(defun twittering-api-invocation-is-ready-p () - "Return non-nil if the preparation for invoking APIs has been completed." - (and - ;; The global variables are initialized. - twittering-initialized - ;; A connection method is prepared. - (let ((use-ssl (or twittering-use-ssl twittering-oauth-use-ssl))) - (twittering-lookup-connection-type use-ssl)) - ;; The account has been already authorized. - (twittering-account-authorized-p))) - -(defun twittering-ensure-preparation-for-api-invocation () - "Ensure prerequisites for invoking APIs. Return non-nil in success. -If prerequisites has been already satisifed, just return non-nil. -If prerequisites are not satisfied, this function try to satisfy them. -Then, return non-nil if they has been satisfied and return nil otherwise." - (twittering-initialize-global-variables-if-necessary) - (and (twittering-ensure-connection-method) - (twittering-ensure-private-info) - (twittering-ensure-account-verification))) - -;;;; -;;;; Edit mode skeleton -;;;; - -(defcustom twittering-edit-skeleton-footer "" - "*String to be used as the footer in the edit skeleton." - :group 'twittering-mode - :type 'string) - -(defvar twittering-edit-skeleton-footer-history nil) - -(defcustom twittering-edit-skeleton-alist - '((none . nil) - (footer . ((nil _ twittering-edit-skeleton-footer))) - (footer-only-normal - . ((nil _ twittering-edit-skeleton-footer) . normal)) - (inherit-hashtags - . [(twittering-edit-skeleton-inherit-hashtags . normal) - (twittering-edit-skeleton-inherit-hashtags . reply)]) - (inherit-mentions - . (twittering-edit-skeleton-inherit-mentions . reply)) - (inherit-any - . [(twittering-edit-skeleton-inherit-mentions . reply) - (twittering-edit-skeleton-inherit-hashtags . normal) - (twittering-edit-skeleton-inherit-hashtags . reply)])) - "*Alist of skeletons performed on `twittering-update-status-interactive'. -A key of the alist is a symbol and each value is nil, (SKELETON . PRED), - (FUNC . PRED) or a vector of them. - -When invoking `twittering-update-status-interactive', the value corresponding -to the key specified `twittering-edit-skeleton' are performed. - -The value like (SKELETON . PRED) or (FUNC . PRED) is performed when the -current context matches with PRED. -PRED is nil, a symbol or a function. -If PRED is nil, the value is unconditionally performed. -If PRED is a symbol, the value is performed only when it equals to the -type of the tweet being edited. The type is one of 'direct-message, 'normal, -'organic-retweet and 'reply. -If PRED is a function, the value is performed only when the predicate -function PRED returns non-nil. PRED is invoked with three arguments -TWEET-TYPE, IN-REPLY-TO-ID and CURRENT-SPEC. -TWEET-TYPE is a symbol, which is one of 'direct-message, 'normal, -'organic-retweet and 'reply, specifying which type of tweet will be edited. -If the tweet will be edited as a reply or an organic retweet, IN-REPLY-TO-ID -is a string specifying the replied tweet. Otherwise, IN-REPLY-TO-ID is nil. -CURRENT-SPEC specifies where the action of posting a tweet is performed. -If the action is performed on a twittering-mode buffer, CURRENT-SPEC is -a timeline spec string of the buffer. -If the action is performed on other buffers, CURRENT-SPEC is nil. -If the option IGNORE-CURRENT-SPEC for `twittering-update-status' is non-nil, -CURRENT-SPEC is also nil. - -If PRED matches the current context, the value is performed as follows. -The value like (SKELETON . PRED) is performed by directly using SKELETON as an -argument of `skeleton-insert'. -The value like (FUNC . PRED) is performed by invoking FUNC with three -arguments, TWEET-TYPE, IN-REPLY-TO-ID and CURRENT-SPEC as same as PRED. - -If the value is a vector, each element is performed in order of elements -in the vector. - -Note that the effective skeleton is invoked after inserting a -recipient." - :group 'twittering-mode - :type 'alist) - -(defcustom twittering-edit-skeleton 'none - "*A symbol specifying an effective skeleton. - -The list of valid value is defined in `twittering-edit-skeleton-alist'. -To be valid, an entry should be added to `twittering-edit-skeleton-alist' -first. - -When entering `twittering-edit-mode', the skeletons in the specified -entry in `twittering-edit-skeleton-alist' are performed." - :group 'twittering-mode - :type (if (> (length (mapcar #'car twittering-edit-skeleton-alist)) 0) - `(choice ,@(mapcar (lambda (entry) `(const ,(car entry))) - twittering-edit-skeleton-alist)) - 'symbol)) - -(defun twittering-switch-edit-skeleton () - (interactive) - (let ((skeleton-keys - (mapcar (lambda (entry) (symbol-name (car entry))) - twittering-edit-skeleton-alist)) - (current (symbol-name (or twittering-edit-skeleton 'none)))) - (let ((selected - (twittering-completing-read - (format "Skeleton (%s): " current) - skeleton-keys nil t nil nil current))) - (when selected - (setq twittering-edit-skeleton (intern selected))))) - (when (null twittering-edit-skeleton) - (setq twittering-edit-skeleton 'none)) - (message "Current skeleton: %s" twittering-edit-skeleton)) - -(defun twittering-edit-skeleton-change-footer (&optional footer-str) - (interactive) - (let ((footer-str - (or footer-str - (read-from-minibuffer "Footer: " twittering-edit-skeleton-footer - nil nil - 'twittering-edit-skeleton-footer-history)))) - (when footer-str - (setq twittering-edit-skeleton-footer footer-str))) - (message "Current footer: [%s]" twittering-edit-skeleton-footer)) - -(defun twittering-edit-skeleton-insert-base (&optional tweet-type in-reply-to-id current-spec) - (let ((entry - (cdr (assq twittering-edit-skeleton twittering-edit-skeleton-alist)))) - (when entry - (require 'skeleton) - (let ((skeletons (if (vectorp entry) - entry - (list entry)))) - (mapcar (lambda (def) - (let ((skeleton-or-func (car def)) - (pred (cdr def))) - (when (or (null pred) - (and (functionp pred) - (funcall pred tweet-type in-reply-to-id)) - (and (symbolp pred) - (eq pred tweet-type))) - (cond - ((functionp skeleton-or-func) - (funcall skeleton-or-func tweet-type in-reply-to-id - current-spec)) - (t - (skeleton-insert skeleton-or-func)))))) - skeletons))))) - -(defun twittering-edit-skeleton-insert (&optional tweet-type in-reply-to-id current-spec) - (if (> 22 emacs-major-version) - ;; This prevents Emacs21 from inserting skeletons before the cursor. - (let ((current (point)) - (pair (with-temp-buffer - (twittering-edit-skeleton-insert-base tweet-type - in-reply-to-id - current-spec) - `(,(buffer-string) . ,(point))))) - (insert (car pair)) - (goto-char (+ -1 current (cdr pair)))) - (twittering-edit-skeleton-insert-base tweet-type in-reply-to-id - current-spec))) - -(defun twittering-edit-skeleton-inherit-hashtags (tweet-type in-reply-to-id current-spec) - (cond - (in-reply-to-id - (let* ((status (twittering-find-status in-reply-to-id)) - (text (cdr (assq 'text status))) - (hashtags - (twittering-extract-matched-substring-all - (concat twittering-regexp-hash - "\\([[:alpha:]0-9_-]+\\)") - text)) - (footer - (mapconcat (lambda (tag) (concat "#" tag)) - hashtags " "))) - (when hashtags - (skeleton-insert `(nil _ " " ,footer))))) - ((twittering-timeline-spec-is-search-p current-spec) - (let* ((query-string - (twittering-extract-query-string-from-search-timeline-spec - current-spec)) - (hashtag-list - (twittering-extract-matched-substring-all - (concat "\\(" twittering-regexp-hash "[[:alpha:]0-9_-]+\\)") - query-string))) - (when hashtag-list - (let ((footer (mapconcat 'identity hashtag-list " "))) - (skeleton-insert `(nil _ " " ,footer)))))))) - -(defun twittering-edit-skeleton-inherit-mentions (tweet-type in-reply-to-id current-spec) - (when in-reply-to-id - (let* ((status (twittering-find-status in-reply-to-id)) - (text (cdr (assq 'text status))) - (recipient (cdr (assq 'user-screen-name status))) - (mentions - (twittering-extract-matched-substring-all - (concat twittering-regexp-atmark - "\\([a-zA-Z0-9_-]+\\)") - text)) - (reduced-mentions - (remove nil - (mapcar - (lambda (mention) - (unless (or (string= mention recipient) - (string= mention (twittering-get-username))) - mention)) - mentions)))) - (when reduced-mentions - (let ((header (mapconcat (lambda (user) (concat "@" user)) - reduced-mentions " "))) - (skeleton-insert `(nil ,header " " _))))))) - -;;;; -;;;; Edit mode -;;;; - -(defvar twittering-edit-buffer "*twittering-edit*") -(defvar twittering-pre-edit-window-configuration nil) -(defvar twittering-edit-history nil) -(defvar twittering-edit-local-history nil) -(defvar twittering-edit-local-history-idx nil) -(defvar twittering-warning-overlay nil) - -(define-derived-mode twittering-edit-mode nil "twmode-status-edit" - (use-local-map twittering-edit-mode-map) - - ;; Prevent `global-font-lock-mode' enabling `font-lock-mode'. - ;; This technique is derived from `lisp/bs.el' distributed with Emacs 22.2. - (make-local-variable 'font-lock-global-modes) - (setq font-lock-global-modes '(not twittering-edit-mode)) - - (make-local-variable 'twittering-warning-overlay) - (setq twittering-warning-overlay (make-overlay 1 1 nil nil nil)) - (overlay-put twittering-warning-overlay 'face 'font-lock-warning-face) - - (make-local-variable 'twittering-edit-local-history) - (setq twittering-edit-local-history (cons (buffer-string) - twittering-edit-history)) - (make-local-variable 'twittering-edit-local-history-idx) - (setq twittering-edit-local-history-idx 0) - - (make-local-variable 'after-change-functions) - (add-to-list 'after-change-functions 'twittering-edit-length-check) - ) - -(when twittering-edit-mode-map - (let ((km twittering-edit-mode-map)) - (define-key km (kbd "C-c C-c") 'twittering-edit-post-status) - (define-key km (kbd "C-c C-k") 'twittering-edit-cancel-status) - (define-key km (kbd "C-c C-r") 'twittering-edit-toggle-reply) - (define-key km (kbd "M-n") 'twittering-edit-next-history) - (define-key km (kbd "M-p") 'twittering-edit-previous-history) - (define-key km (kbd "") 'twittering-edit-replace-at-point))) - -(defun twittering-get-weighted-length-info (str &optional threshold) - "Get weighted length information of STR according to twitter-text Parser. - -Return a cons cell (weighted-length . exceeding-pos). -The weighted-length is the weighted length of STR. -If THRESHOLD is nil, the exceeding-pos is also nil. -If THRESHOLD is a non-integer or negative integer, it is considered 0. - -If THRESHOLD is a positive integer and the weighted length of STR is -less than or equal to THRESHOLD, the exceeding-pos is nil. -If THRESHOLD is a positive integer and the weighted length of STR is -larger than THRESHOLD, the exceeding-pos is the position -where the weighted length exceeds the THRESHOLD. - -The exceeding-pos satisfies the following (for a positive THRESHOLD); -- The weighted length of (substring str 0 exceeding-pos) must be less than - or equal to THRESHOLD. -- If exceeding-pos is non-nil, the weighted length of - (substring str 0 (+ 1 exceeding-pos)) must be larger than THRESHOLD. - -STR should be NFC normalized. -The weights are defined in `twittering-text-configuration'." - (let* ((scale (twittering-get-service-configuration 'scale)) - (valid-weights (twittering-get-service-configuration 'valid-weights)) - (ranges-regexp (twittering-get-service-configuration 'ranges-regexp)) - (pos 0) - (scaled-length 0) - (scaled-threshold (if (and (integerp threshold) (< 0 threshold)) - (* threshold scale) - 0)) - (exceeding-pos nil)) - (save-match-data - (while (string-match ranges-regexp str pos) - (let ((current (car valid-weights)) - (rest (cdr valid-weights))) - (while (null (match-beginning current)) - (setq current (car rest)) - (setq rest (cdr rest))) - (let* ((end (match-end current)) - (number-of-code-points - (- end (match-beginning current))) - (next-scaled-length (+ scaled-length - (* current number-of-code-points)))) - (when (and (null exceeding-pos) - (< scaled-threshold next-scaled-length)) - (let* ((diff (/ (- next-scaled-length scaled-threshold) - current)) - (remainder (% (- next-scaled-length scaled-threshold) - current)) - (diff (if (< 0 remainder) - (+ 1 diff) - diff))) - (setq exceeding-pos (- end diff)))) - (setq scaled-length next-scaled-length)) - (setq pos (match-end current))))) - (cons (/ scaled-length scale) (if (null threshold) nil exceeding-pos)))) - -(defun twittering-get-weighted-length (str) - "Calculate a weighted length of STR according to twitter-text Parser. - -STR should be NFC normalized. -The weights are defined in `twittering-text-configuration'. -For detail, see `twittering-get-weighted-length-info'. -" - (let ((info (twittering-get-weighted-length-info str))) - (car info))) - -(defun twittering-get-effective-length-info (str &optional threshold short-length-http short-length-https) - "Return the effective length information of STR. - -Return a cons cell (effective-length . exceeding-pos), -where the effective-length is the effective length of STR which is calculated -with taking account of shortening URIs. - -It is assumed that a URI via HTTP or HTTPS will be converted into a URI -consisting of SHORT-LENGTH-HTTP or SHORT-LENGTH-HTTPS characters, respectively. -If THRESHOLD is nil or a negative integer, the THRESHOLD is considered 0. - -If the effective length of STR is less than or equal to THRESHOLD, -the exceeding-pos is nil. -If the effective length of STR is larger than THRESHOLD, the exceeding-pos -is the position where the effective length exceeds the THRESHOLD. -Note that the exceeding-pos does not divide a URL. - -The exceeding-pos satisfies the following (for non-nil THRESHOLD); -- The effective length of (substring str 0 exceeding-pos) must be less than - or equal to THRESHOLD. -- If exceeding-pos is non-nil, the effective length of - (substring str 0 (+ 1 exceeding-pos)) must be larger than THRESHOLD. -" - (let* ((str (twittering-normalize-string str)) - (threshold (or threshold 0)) - (regexp "\\(?:^\\|[[:space:]]\\)\\(http\\(s\\)?://[-_.!~*'()a-zA-Z0-9;/?:@&=+$,%#]+\\)") - (short-length-http - (or short-length-http - (twittering-get-service-configuration 'short_url_length))) - (short-length-https - (or short-length-https - (twittering-get-service-configuration 'short_url_length_https))) - (rest str) - (pos 0) - (len 0) - (exceeding-pos nil)) - (save-match-data - (while (string-match regexp str pos) - (let* ((beg (match-beginning 1)) - (end (match-end 1)) - (relative-threshold (- threshold len)) - (text-weighted-len-info - (twittering-get-weighted-length-info - (substring str pos beg) relative-threshold)) - (text-weighted-len (car text-weighted-len-info)) - (text-exceeding-pos (cdr text-weighted-len-info)) - (short-len (if (match-beginning 2) - short-length-https - short-length-http))) - (when (and (null exceeding-pos) text-exceeding-pos) - (setq exceeding-pos (+ pos text-exceeding-pos))) - (let ((additional-length - ;; Ignore the original length to follow the change - ;; of t.co URL wrapper. - ;; - ;; https://dev.twitter.com/docs/tco-url-wrapper - ;; As of October 10, 2011 the t.co URL wrapper - ;; automatically wraps all links submitted to - ;; Twitter, regardless of length. This includes - ;; so-called URLs without protocols. - (+ text-weighted-len short-len))) - (when (and (null exceeding-pos) - (< threshold (+ len additional-length))) - (setq exceeding-pos beg)) - (setq len (+ len additional-length)) - (setq pos end))))) - (let* ((text-weighted-len-info - (twittering-get-weighted-length-info - (substring str pos) (- threshold len))) - (text-weighted-len (car text-weighted-len-info)) - (text-exceeding-pos (cdr text-weighted-len-info))) - (when (and (null exceeding-pos) text-exceeding-pos) - (setq exceeding-pos (+ pos text-exceeding-pos))) - (cons (+ len text-weighted-len) exceeding-pos)))) - -(defun twittering-effective-length (str &optional short-length-http short-length-https) - "Return the effective length of STR with taking account of shortening URIs. - -The returned length is calculated with taking account of shortening URIs -if `twittering-service-method' is the symbol `twitter' or `twitter-api-v1.1'. -It is assumed that a URI via HTTP will be converted into a URI consisting of -SHORT-LENGTH-HTTP characters. -It is assumed that a URI via HTTPS will be converted into a URI consisting of -SHORT-LENGTH-HTTPS characters. - -If SHORT-LENGTH-HTTP is nil, the value of - (twittering-get-service-configuration 'short_url_length) is used instead. -If SHORT-LENGTH-HTTPS is nil, the value of - (twittering-get-service-configuration 'short_url_length_https) is used -instead. - -For detail, see `twittering-get-effective-length-info'. -" - (cond - ((memq twittering-service-method '(twitter twitter-api-v1.1)) - (let* ((threshold nil) - (info (twittering-get-effective-length-info - str threshold short-length-http short-length-https))) - (car info))) - (t - (length str)))) - -(defun twittering-edit-length-check (&optional beg end len) - (let* ((status (twittering-edit-extract-status)) - (tweet-type (cdr (assq 'tweet-type twittering-edit-mode-info))) - (raw-length (length status)) - (maxlen (twittering-get-maximum-message-length tweet-type)) - (length-info (twittering-get-effective-length-info status maxlen)) - (length (car length-info)) - (exceeding-pos (cdr length-info))) - (setq mode-name - (format "twmode-status-edit[%d/%d]" length maxlen)) - (force-mode-line-update) - (unless twittering-disable-overlay-on-too-long-string - (if (< maxlen length) - (move-overlay twittering-warning-overlay - (- (point-max) (- raw-length exceeding-pos)) - (point-max)) - (move-overlay twittering-warning-overlay 1 1))))) - -(defun twittering-edit-get-help-end () - "Return the end position of the help on `twittering-edit-mode'." - (when (eq major-mode 'twittering-edit-mode) - (next-single-property-change (point-min) 'read-only nil (point-max)))) - -(defun twittering-edit-extract-status () - "Return the text of the status being edited on `twittering-edit-mode'." - (if (eq major-mode 'twittering-edit-mode) - (buffer-substring-no-properties (twittering-edit-get-help-end) - (point-max)) - "")) - -(defun twittering-edit-reset-status (str) - "Reset the contents of the current `twittering-edit-mode' buffer with STR." - (when (eq major-mode 'twittering-edit-mode) - (let ((help-end (twittering-edit-get-help-end))) - (delete-region help-end (point-max)) - (goto-char help-end) - (insert str) - (goto-char help-end)))) - -(defun twittering-edit-set-help-string (str) - "Render STR as a help for `twittering-edit-mode' to the current buffer." - (let* ((help-str (propertize str 'read-only t)) - (len (length help-str))) - (add-text-properties 0 1 '(front-sticky (read-only)) help-str) - (add-text-properties (1- len) len '(rear-nonsticky t) help-str) - (save-excursion - (let ((inhibit-read-only t) - (inhibit-modification-hooks t) - (help-end (twittering-edit-get-help-end))) - (goto-char help-end) - (if (= (point-min) help-end) - ;; When no helps are rendered, the all markers should be - ;; placed after the new help. - (insert help-str) - ;; Use `insert-before-markers' because the marker of the current - ;; position should follow the new help. - ;; Delete the old help after inserting the new help to make - ;; the new help visible if possible. - (insert-before-markers help-str) - (delete-region (point-min) help-end)))))) - -(defun twittering-edit-setup-help () - (let* ((direct-message-recipient - (cdr (assq 'direct-message-recipient twittering-edit-mode-info))) - (tweet-type (cdr (assq 'tweet-type twittering-edit-mode-info))) - (cited-id (cdr (assq 'cited-id twittering-edit-mode-info))) - (item (cond - ((eq tweet-type 'direct-message) - (format "a direct message to %s" direct-message-recipient)) - ((eq tweet-type 'reply) - "a reply") - (t - "a tweet"))) - (status-format - (cond - ((eq tweet-type 'direct-message) - (format "%%FILL{DIRECT MESSAGE to %s}\n" direct-message-recipient)) - ((eq tweet-type 'reply) - "%FILL{REPLY to the tweet by %s at %C{%y/%m/%d %H:%M:%S};}\n%FILL{%FACE[font-lock-doc-face]{\"%T\"}}\n") - (t - nil))) - (func (when status-format - (twittering-generate-format-status-function status-format))) - (help-str - (apply 'concat - `(,@(when func - `(,(funcall func - (twittering-find-status cited-id) - nil))) - ,(propertize (format (substitute-command-keys "Keymap: - \\[twittering-edit-post-status]: send %s - \\[twittering-edit-cancel-status]: cancel %s - \\[twittering-edit-toggle-reply]: toggle a normal tweet and a reply. - \\[twittering-edit-next-history]: next history element - \\[twittering-edit-previous-history]: previous history element - \\[twittering-edit-replace-at-point]: shorten URL at point - ----- text above this line is ignored ---- -") item item) - 'face 'font-lock-comment-face))))) - (twittering-edit-set-help-string help-str))) - -(defun twittering-edit-close () - (kill-buffer (current-buffer)) - (when twittering-pre-edit-window-configuration - (set-window-configuration twittering-pre-edit-window-configuration) - (setq twittering-pre-edit-window-configuration nil))) - -(defvar twittering-edit-mode-info nil - "Alist of a tweet being edited. -Pairs of a key symbol and an associated value are following: - direct-message-recipient -- the recipient when the edited message is - sent as a direct message. - cited-id -- the id of the tweet that the edited message refers to. - tweet-type -- the type of the edited message, which is one of the - following symbol; normal, reply or direct-message.") - -(defun twittering-ensure-whole-of-status-is-visible (&optional window) - "Ensure that the whole of the tweet on the current point is visible." - (interactive) - (let* ((window (or window (selected-window))) - (buffer (window-buffer window))) - (when (twittering-buffer-p buffer) - (with-current-buffer buffer - (save-excursion - (let* ((next-head (or (twittering-get-next-status-head) (point-max))) - (current-tail (max (1- next-head) (point-min)))) - (when (< (window-end window t) current-tail) - (twittering-set-window-end window current-tail)))))))) - -(defun twittering-update-status-from-pop-up-buffer (&optional init-string-or-skeleton reply-to-id username tweet-type current-spec) - (interactive) - (let ((buf (generate-new-buffer twittering-edit-buffer))) - (setq twittering-pre-edit-window-configuration - (current-window-configuration)) - (twittering-pop-to-buffer buf) - (twittering-edit-mode) - (make-local-variable 'twittering-edit-mode-info) - (setq twittering-edit-mode-info - `((cited-id . ,reply-to-id) - (tweet-type . ,(cdr (assq tweet-type - '((direct-message . direct-message) - (normal . normal) - (organic-retweet . normal) - (reply . reply))))) - (direct-message-recipient . ,username))) - (twittering-edit-setup-help) - (twittering-edit-length-check) ;; Update mode-line - (setq buffer-undo-list nil) - (goto-char (twittering-edit-get-help-end)) - (if (eq tweet-type 'direct-message) - (message "C-c C-c to send, C-c C-k to cancel") - (and (null init-string-or-skeleton) - twittering-current-hashtag - (setq init-string-or-skeleton - (format " #%s " twittering-current-hashtag))) - (message "C-c C-c to post, C-c C-k to cancel")) - (when init-string-or-skeleton - (require 'skeleton) - (cond - ((stringp init-string-or-skeleton) - (insert init-string-or-skeleton)) - ((listp init-string-or-skeleton) - (skeleton-insert init-string-or-skeleton)))) - (twittering-edit-skeleton-insert tweet-type reply-to-id - current-spec) - (set-buffer-modified-p nil))) - -(defun twittering-edit-post-status () - (interactive) - (let* ((status (twittering-edit-extract-status)) - (cited-id (cdr (assq 'cited-id twittering-edit-mode-info))) - (cited-tweet (twittering-find-status cited-id)) - (cited-username (cdr (assq 'user-screen-name cited-tweet))) - (direct-message-recipient - (cdr (assq 'direct-message-recipient twittering-edit-mode-info))) - (tweet-type (cdr (assq 'tweet-type twittering-edit-mode-info))) - (max-length (twittering-get-maximum-message-length tweet-type))) - (cond - ((string-match "\\` *\\'" status) - (message "Empty tweet!")) - ((< max-length (twittering-effective-length status)) - (message "Tweet is too long!")) - ((cond - (twittering-request-confirmation-on-posting - (y-or-n-p "Send this tweet? ")) - (t - t)) - (setq twittering-edit-history - (cons status twittering-edit-history)) - (cond - ((eq tweet-type 'direct-message) - (if (null direct-message-recipient) - (message "No direct message recipient specified") - (let* ((recipient-info - (twittering-find-user-screen-name direct-message-recipient)) - (recipient-id (cdr (assq 'id recipient-info)))) - (if recipient-id - (twittering-call-api 'send-direct-message - `((recipient-id . ,recipient-id) - (text . ,status))) - (message "Failed to find the user ID of %s" - direct-message-recipient))))) - ((eq tweet-type 'reply) - (twittering-call-api 'update-status - `((status . ,status) - (in-reply-to-status-id . ,cited-id)))) - (t - (twittering-call-api 'update-status `((status . ,status))))) - (twittering-edit-close)) - (t - nil)))) - -(defun twittering-edit-cancel-status () - (interactive) - (when (or (not (buffer-modified-p)) - (prog1 (if (y-or-n-p "Cancel this tweet? ") - (message "Request canceled") - (message nil)))) - (twittering-edit-close))) - -(defun twittering-edit-next-history () - (interactive) - (if (>= 0 twittering-edit-local-history-idx) - (message "End of history.") - (let ((current-history (nthcdr twittering-edit-local-history-idx - twittering-edit-local-history))) - (setcar current-history (twittering-edit-extract-status)) - (decf twittering-edit-local-history-idx) - (twittering-edit-reset-status (nth twittering-edit-local-history-idx - twittering-edit-local-history))))) - -(defun twittering-edit-previous-history () - (interactive) - (if (>= twittering-edit-local-history-idx - (- (length twittering-edit-local-history) 1)) - (message "Beginning of history.") - (let ((current-history (nthcdr twittering-edit-local-history-idx - twittering-edit-local-history))) - (setcar current-history (twittering-edit-extract-status)) - (incf twittering-edit-local-history-idx) - (twittering-edit-reset-status (nth twittering-edit-local-history-idx - twittering-edit-local-history))))) - -(defun twittering-edit-replace-at-point () - (interactive) - (when (eq major-mode 'twittering-edit-mode) - (twittering-tinyurl-replace-at-point) - (twittering-edit-length-check))) - -(defun twittering-edit-toggle-reply () - "Toggle whether the tweet being edited will be sent as a reply or not." - (interactive) - (let ((tweet-type (cdr (assq 'tweet-type twittering-edit-mode-info))) - (cited-id (cdr (assq 'cited-id twittering-edit-mode-info)))) - (cond - ((eq tweet-type 'direct-message) - (message "The current message is a direct message.")) - ((null cited-id) - (message "The current message does not have a reply target.")) - (t - (setq twittering-edit-mode-info - (mapcar (lambda (entry) - (if (eq (car entry) 'tweet-type) - `(tweet-type - . ,(cdr (assq (cdr entry) - '((normal . reply) - (reply . normal))))) - entry)) - twittering-edit-mode-info)) - (twittering-edit-setup-help))))) - -;;;; -;;;; Edit a status on minibuffer -;;;; - -(defun twittering-show-minibuffer-length (&optional beg end len) - "Show the number of characters in minibuffer." - (when (minibuffer-window-active-p (selected-window)) - (if (and transient-mark-mode deactivate-mark) - (deactivate-mark)) - (let* ((deactivate-mark deactivate-mark) - (status-len (- (twittering-effective-length (buffer-string)) - (minibuffer-prompt-width))) - (mes (format "%d" status-len))) - (if (<= 23 emacs-major-version) - (minibuffer-message mes) ;; Emacs23 or later - (minibuffer-message (concat " (" mes ")"))) - ))) - -(defun twittering-setup-minibuffer () - (add-hook 'post-command-hook 'twittering-show-minibuffer-length t t)) - -(defun twittering-finish-minibuffer () - (remove-hook 'post-command-hook 'twittering-show-minibuffer-length t)) - -(defun twittering-status-not-blank-p (status) - (let ((coding-system-for-read 'binary) - (coding-system-for-write 'binary)) - (with-temp-buffer - (insert status) - (goto-char (point-min)) - ;; skip user name - (re-search-forward "\\`[[:space:]]*@[a-zA-Z0-9_-]+\\([[:space:]]+@[a-zA-Z0-9_-]+\\)*" nil t) - (re-search-forward "[^[:space:]]" nil t)))) - -(defun twittering-update-status-from-minibuffer (&optional init-string-or-skeleton reply-to-id username tweet-type current-spec) - (and (not (eq tweet-type 'direct-message)) - (null init-string-or-skeleton) - twittering-current-hashtag - (setq init-string-or-skeleton - (format " #%s " twittering-current-hashtag))) - (let ((status - (with-temp-buffer - (when init-string-or-skeleton - (require 'skeleton) - (cond - ((stringp init-string-or-skeleton) - (insert init-string-or-skeleton)) - ((listp init-string-or-skeleton) - (skeleton-insert init-string-or-skeleton)))) - (twittering-edit-skeleton-insert tweet-type reply-to-id - current-spec) - `(,(buffer-string) . ,(point)))) - (not-posted-p t) - (prompt "status: ") - (map minibuffer-local-map) - (minibuffer-message-timeout nil)) - (define-key map (kbd "") 'twittering-tinyurl-replace-at-point) - (when twittering-use-show-minibuffer-length - (add-hook 'minibuffer-setup-hook 'twittering-setup-minibuffer t) - (add-hook 'minibuffer-exit-hook 'twittering-finish-minibuffer t)) - (unwind-protect - (while not-posted-p - (setq status (read-from-minibuffer prompt status map nil 'twittering-tweet-history nil t)) - (let ((status status) - (max-length - (twittering-get-maximum-message-length tweet-type))) - (if (< max-length (twittering-effective-length status)) - (setq prompt "status (too long): ") - (setq prompt "status: ") - (when (twittering-status-not-blank-p status) - (cond - ((eq tweet-type 'direct-message) - (if (null username) - (message "No direct message recipient specified") - (let* ((recipient-info - (twittering-find-user-screen-name username)) - (recipient-id (cdr (assq 'id recipient-info)))) - (if recipient-id - (twittering-call-api 'send-direct-message - `((recipient-id . ,recipient-id) - (text . ,status))) - (message "Failed to find the user ID of %s" - username))))) - (t - (let ((parameters `(("status" . ,status))) - (as-reply - (and reply-to-id - username - (eq tweet-type 'reply) - (string-match - (concat "@" username "\\(?:[\n\r \t]+\\)*") - status)))) - ;; Add in_reply_to_status_id only when a posting - ;; status begins with @username. - (twittering-call-api - 'update-status - `((status . ,status) - ,@(when as-reply - `((in-reply-to-status-id - . ,(format "%s" reply-to-id)))))) - ))) - (setq not-posted-p nil)) - ))) - ;; unwindforms - (when (memq 'twittering-setup-minibuffer minibuffer-setup-hook) - (remove-hook 'minibuffer-setup-hook 'twittering-setup-minibuffer)) - (when (memq 'twittering-finish-minibuffer minibuffer-exit-hook) - (remove-hook 'minibuffer-exit-hook 'twittering-finish-minibuffer)) - ))) - -;;;; -;;;; Reading username/listname with completion -;;;; - -(defun twittering-get-usernames-from-timeline (&optional timeline-data) - (let ((timeline-data (or timeline-data (twittering-current-timeline-data)))) - (twittering-remove-duplicates - (mapcar - (lambda (status) - (let* ((base-str (cdr (assq 'user-screen-name status))) - ;; `copied-str' is independent of the string in timeline-data. - ;; This isolation is required for `minibuf-isearch.el', - ;; which removes the text properties of strings in history. - (copied-str (copy-sequence base-str))) - (set-text-properties 0 (length copied-str) nil copied-str) - copied-str)) - timeline-data)))) - -(defun twittering-read-username-with-completion (prompt init-user &optional history) - (let ((collection (append twittering-user-history - (twittering-registered-user-screen-names)))) - (twittering-completing-read prompt collection nil nil init-user history))) - -(defun twittering-read-list-name (username &optional list-index) - (let* ((list-index (or list-index - (twittering-get-list-index-sync username))) - (username (prog1 (copy-sequence username) - (set-text-properties 0 (length username) nil username))) - (prompt (format "%s's list: " username)) - (listname - (if list-index - (twittering-completing-read prompt list-index nil t nil) - nil))) - (if (string= "" listname) - nil - listname))) - -(defun twittering-read-subscription-list-name (username &optional list-index) - (let* ((list-index (or list-index - (twittering-get-list-subscriptions-sync username))) - (username (prog1 (copy-sequence username) - (set-text-properties 0 (length username) nil username))) - (prompt (format "%s's subscription: " username)) - (listname - (if list-index - (twittering-completing-read prompt list-index nil t nil) - nil))) - (if (string= "" listname) - nil - listname))) - -(defun twittering-read-timeline-spec-with-completion (prompt initial &optional as-string) - (let* ((dummy-hist - (append twittering-timeline-history - (twittering-registered-user-screen-names) - '(":direct_message_events" - ":direct_messages" ":direct_messages_sent" - ":favorites" ":friends" - ":home" ":mentions" ":public" ":replies" - ":retweeted_by_me" ":retweeted_by_user/" - ":retweeted_to_me" ":retweeted_to_user/" - ":retweets_of_me") - (mapcar (lambda (cell) - (concat "$" (car cell) (if (listp (cdr cell)) "()" ""))) - twittering-timeline-spec-alias))) - (spec-with-username - '((":favorites/" . "Whose favorites: ") - (":retweeted_by_user/" . "Who has retweeted? ") - (":retweeted_to_user/" . "Who has received the retweets? "))) - (regexp-spec-with-username - (concat "\\`\\(" - (mapconcat (lambda (entry) (car entry)) - spec-with-username "\\|") - "\\)\\'")) - (spec-string (twittering-completing-read prompt dummy-hist - nil nil initial 'dummy-hist)) - (spec-string - (cond - ((string-match regexp-spec-with-username spec-string) - (let* ((spec-and-prompt - (assoc (match-string 1 spec-string) - spec-with-username)) - (prefix (car spec-and-prompt)) - (prompt (cdr spec-and-prompt)) - (username - (twittering-read-username-with-completion - prompt "" - 'twittering-user-history))) - (if username - (concat prefix username) - nil))) - ((string-match "^\\([a-zA-Z0-9_-]+\\)/$" spec-string) - (let* ((username (match-string 1 spec-string)) - (list-index (twittering-get-list-index-sync username)) - (listname - (if list-index - (twittering-read-list-name username list-index) - nil))) - (if listname - (concat username "/" listname) - nil))) - (t - spec-string))) - (spec (if (stringp spec-string) - (condition-case error-str - (twittering-string-to-timeline-spec spec-string) - (error - (message "Invalid timeline spec: %s" error-str) - nil)) - nil))) - (cond - ((null spec) - nil) - (spec (if as-string - spec-string - spec)) - ((string= "" spec-string) - (message "No timeline specs are specified.") - nil) - (t - (message "\"%s\" is invalid as a timeline spec." spec-string) - nil)))) - -;;;; -;;;; Commands -;;;; - -;;;; Commands for changing modes -(defun twittering-jojo-mode (&optional arg) - (interactive "P") - (let ((prev-mode twittering-jojo-mode)) - (setq twittering-jojo-mode - (if (null arg) - (not twittering-jojo-mode) - (< 0 (prefix-numeric-value arg)))) - (unless (eq prev-mode twittering-jojo-mode) - (twittering-update-mode-line)))) - -(defun twittering-toggle-reverse-mode (&optional arg) - (interactive "P") - (let ((prev-mode twittering-reverse-mode)) - (setq twittering-reverse-mode - (if (null arg) - (not twittering-reverse-mode) - (< 0 (prefix-numeric-value arg)))) - (unless (eq prev-mode twittering-reverse-mode) - (twittering-update-mode-line) - (twittering-rerender-timeline-all (current-buffer))))) - -(defun twittering-set-current-hashtag (&optional tag) - (interactive) - (unless tag - (setq tag (twittering-completing-read "hashtag (blank to clear): #" - twittering-hashtag-history - nil nil - twittering-current-hashtag - 'twittering-hashtag-history)) - (message - (if (eq 0 (length tag)) - (progn (setq twittering-current-hashtag nil) - "Current hashtag is not set.") - (progn - (setq twittering-current-hashtag tag) - (format "Current hashtag is #%s" twittering-current-hashtag)))))) - -;;;; Commands for switching buffers -(defun twittering-switch-to-next-timeline () - (interactive) - (when (twittering-buffer-p) - (let* ((buffer-list (twittering-get-buffer-list)) - (following-buffers (cdr (memq (current-buffer) buffer-list))) - (next (if following-buffers - (car following-buffers) - (car buffer-list)))) - (unless (eq (current-buffer) next) - (switch-to-buffer next))))) - -(defun twittering-switch-to-previous-timeline () - (interactive) - (when (twittering-buffer-p) - (let* ((buffer-list (reverse (twittering-get-buffer-list))) - (preceding-buffers (cdr (memq (current-buffer) buffer-list))) - (previous (if preceding-buffers - (car preceding-buffers) - (car buffer-list)))) - (unless (eq (current-buffer) previous) - (switch-to-buffer previous))))) - -;;;; Commands for visiting a timeline -(defun twittering-visit-timeline (&optional timeline-spec initial) - (interactive) - (cond - ((twittering-ensure-preparation-for-api-invocation) - (let ((timeline-spec - (or timeline-spec - (twittering-read-timeline-spec-with-completion - "timeline: " initial t)))) - (when timeline-spec - (switch-to-buffer (twittering-get-managed-buffer timeline-spec))))) - (t - nil))) - -(defun twittering-friends-timeline () - (interactive) - (twittering-visit-timeline '(friends))) - -(defun twittering-home-timeline () - (interactive) - (twittering-visit-timeline '(home))) - -(defun twittering-replies-timeline () - (interactive) - (twittering-visit-timeline '(replies))) - -(defun twittering-mentions-timeline () - (interactive) - (twittering-visit-timeline '(mentions))) - -(defun twittering-public-timeline () - (interactive) - (twittering-visit-timeline '(public))) - -(defun twittering-user-timeline () - (interactive) - (twittering-visit-timeline `(user ,(twittering-get-username)))) - -(defun twittering-direct-messages-timeline () - (interactive) - (twittering-visit-timeline '(direct_messages))) - -(defun twittering-sent-direct-messages-timeline () - (interactive) - (twittering-visit-timeline '(direct_messages_sent))) - -(defun twittering-other-user-timeline () - (interactive) - (let* ((username (get-text-property (point) 'username)) - (goto-spec (get-text-property (point) 'goto-spec)) - (screen-name-in-text - (get-text-property (point) 'screen-name-in-text)) - (uri (or (get-text-property (point) 'expanded-uri) - (get-text-property (point) 'uri))) - (mentioned-id (when uri - (twittering-extract-id-from-url uri))) - (spec (cond (goto-spec goto-spec) - (screen-name-in-text `(user ,screen-name-in-text)) - (mentioned-id `(single ,mentioned-id)) - (username `(user ,username)) - (t nil)))) - (if spec - (twittering-visit-timeline spec) - (message "No user selected")))) - -(defun twittering-other-user-timeline-interactive () - (interactive) - (let ((username (or (twittering-read-username-with-completion - "user: " nil - 'twittering-user-history) - ""))) - (if (string= "" username) - (message "No user selected") - (twittering-visit-timeline `(user ,username))))) - -(defun twittering-other-user-list-interactive (&optional subscriptions) - (interactive "P") - (let* ((username (copy-sequence (get-text-property (point) 'username))) - (username (progn - (set-text-properties 0 (length username) nil username) - (or (twittering-read-username-with-completion - (if subscriptions - "Whose subscription: " - "Whose list: ") - username - 'twittering-user-history) - "")))) - (if (string= "" username) - (message "No user selected") - (let* ((list-name (if subscriptions - (twittering-read-subscription-list-name username) - (twittering-read-list-name username))) - (spec (cond - ((null list-name) - nil) - (subscriptions - (and (string-match "\\`\\(.*\\)/\\(.*\\)\\'" list-name) - `(list ,(match-string 1 list-name) - ,(match-string 2 list-name)))) - (t - `(list ,username ,list-name))))) - (if spec - (twittering-visit-timeline spec) - ;; Don't show message here to prevent an overwrite of a - ;; message which is outputted by `twittering-read-list-name'. - ))))) - -(defun twittering-search (&optional word) - (interactive) - (let ((word (or word - (read-from-minibuffer "search: " nil nil nil - 'twittering-search-history nil t) - ""))) - (if (string= "" word) - (message "No query string") - (let ((spec `(search ,word))) - (twittering-visit-timeline spec))))) - -;;;; Commands for retrieving statuses - -(defun twittering-current-timeline-noninteractive () - (twittering-current-timeline t)) - -(defun twittering-current-timeline (&optional noninteractive) - (interactive) - (when (twittering-buffer-p) - (let ((spec-string (twittering-current-timeline-spec-string))) - (twittering-get-and-render-timeline noninteractive)))) - -(defun twittering-get-tweets-within-specific-time-range (time-beg time-end) - "Get tweets within a time range between TIME-BEG and TIME-END. -TIME-BEG and TIME-END must be nil or an internal representation of time as -same as the returned value of `current-time'." - (let* ((since_id (when time-beg - (twittering-time-to-id time-beg))) - (max_id (when time-end - (twittering-time-to-id time-end))) - (spec-string (twittering-current-timeline-spec-string)) - (noninteractive t) - (args - `(,@(cond - (max_id `((max_id . ,max_id))) - (since_id `((since_id . ,since_id))) - (t nil))))) - (twittering-retrieve-timeline spec-string noninteractive args nil))) - -(defun twittering-get-tweets-before (&optional before-str) - (interactive) - (let* ((id (when (null before-str) - (twittering-get-id-at))) - (init-str - (when id - (let* ((status (twittering-find-status id)) - (init-time - (or (cdr (assq 'retweeting-created-at status)) - (cdr (assq 'created-at status))))) - (format-time-string "%Y-%m-%d %T" init-time)))) - (before-str - (or before-str - (read-string "before [YYYY-MM-DD [HH:MM:SS]]: " init-str))) - (time-beg nil) - (time-end - (apply 'encode-time (twittering-parse-time-string before-str t)))) - (twittering-get-tweets-within-specific-time-range time-beg time-end))) - -;;;; Commands for posting a status - -(defun twittering-update-status (&optional init-string-or-skeleton reply-to-id username tweet-type ignore-current-spec) - "Post a tweet. -The first argument INIT-STRING-OR-SKELETON is nil, an initial text or a -skeleton to be inserted with `skeleton-insert'. -REPLY-TO-ID is an ID of a tweet which you are going to cite or reply to. -USERNAME is a recipient of a direct message. -TWEET-TYPE is a symbol meaning the type of the tweet being edited. It must -be one of 'direct-message, 'normal, 'organic-retweet and 'reply. -If TWEET-TYPE is nil, it is equivalent to 'normal, which means that a tweet -is edited as a normal tweet. -If IGNORE-CURRENT-SPEC is non-nil, the timeline spec of the current buffer -is sent to the function specified by `twittering-update-status-function'. - -How to edit a tweet is determined by `twittering-update-status-funcion'." - (let ((current-spec (unless ignore-current-spec - (twittering-current-timeline-spec))) - (tweet-type (or tweet-type 'normal))) - (funcall twittering-update-status-function init-string-or-skeleton - reply-to-id username - tweet-type current-spec))) - -(defun twittering-update-status-interactive () - (interactive) - (twittering-update-status)) - -(defun twittering-update-lambda () - (interactive) - (when (and (string= "Japanese" current-language-environment) - (or (< 21 emacs-major-version) - (eq 'utf-8 (terminal-coding-system)))) - (let ((text (mapconcat - 'char-to-string - (mapcar 'twittering-ucs-to-char - '(955 12363 12431 12356 12356 12424 955)) ""))) - (twittering-call-api 'update-status `((status . ,text)))))) - -(defun twittering-post-predicted-message-like-jojo (status) - (let ((screen-name (cdr (assq 'user-screen-name status))) - (text (cdr (assq 'text status)))) - (when (and (not (string= screen-name (twittering-get-username))) - (string-match - (mapconcat 'char-to-string - (mapcar - 'twittering-ucs-to-char - '(#x6b21 #x306b #x005c #x0028 #x304a #x524d - #x005c #x007c #x8cb4 #x69d8 #x005c #x0029 - #x306f #x300c #x005c #x0028 #x005b #x005e - #x300d #x005d #x002b #x005c #x0029 #x300d - #x3068 #x8a00 #x3046)) - "") - text)) - (let ((text - (concat "@" screen-name " " - (match-string-no-properties 2 text) - (mapconcat 'char-to-string - (mapcar 'twittering-ucs-to-char - '(#x3000 #x306f #x3063 #x0021 #x003f)) - "")))) - (twittering-call-api 'update-status `((status . ,text))))))) - -(defun twittering-jojo-mode-hook-function () - (when (and twittering-jojo-mode - (string= "Japanese" current-language-environment) - (or (< 21 emacs-major-version) - (eq 'utf-8 (terminal-coding-system)))) - (mapcar 'twittering-post-predicted-message-like-jojo - twittering-rendered-new-tweets))) - -(defun twittering-direct-message () - (interactive) - (let ((username (twittering-read-username-with-completion - "Who would you like to receive the DM? " - (get-text-property (point) 'username) - 'twittering-user-history))) - (if (string= "" username) - (message "No user selected") - (twittering-update-status nil nil username 'direct-message)))) - -(defun twittering-reply-to-user () - (interactive) - (let ((username (get-text-property (point) 'username))) - (if username - (twittering-update-status (concat "@" username " ")) - (message "No user selected")))) - -;;;; Command for deleting a status - -(defun twittering-delete-status (&optional id) - (interactive) - (let* ((id (twittering-get-id-at)) - (status (twittering-find-status id)) - (is-retweet (assq 'retweeted-id status)) - (username (if is-retweet - (cdr (assq 'retweeting-user-screen-name status)) - (cdr (assq 'user-screen-name status)))) - (text (if is-retweet - (cdr (assq 'retweeting-text status)) - (cdr (assq 'text status)))) - (width (max 40 ;; XXX - (- (frame-width) - 1 ;; margin for wide characters - 11 ;; == (length (concat "Delete \"" "\"? ")) - 9) ;; == (length "(y or n) ") - )) - (mes (format "Delete \"%s\"? " - (if (< width (string-width text)) - (concat - (truncate-string-to-width text (- width 3)) - "...") - text)))) - (cond - ((not (string= username (twittering-get-username))) - (message "The status is not yours!")) - ((not id) - (message "No status selected")) - ((y-or-n-p mes) - (twittering-call-api 'destroy-status `((id . ,id)))) - (t - (message "Request canceled"))))) - -;;;; Commands for retweet - -(defun twittering-retweet (&optional arg) - (interactive "P") - (let ((use-native-retweet-flag (if arg - (not twittering-use-native-retweet) - twittering-use-native-retweet))) - (if use-native-retweet-flag - (twittering-native-retweet) - (twittering-organic-retweet)))) - -(defun twittering-organic-retweet () - (interactive) - (let* ((id (twittering-get-id-at)) - (status (twittering-find-status id)) - (username (cdr (assq 'user-screen-name status))) - (text (cdr (assq 'text status))) - (retweet-time (current-time)) - (skeleton-with-format-string - (cond - ((null twittering-retweet-format) - '(nil _ " RT: %t (via @%s)")) - ((stringp twittering-retweet-format) - `(nil ,twittering-retweet-format _)) - ((listp twittering-retweet-format) - twittering-retweet-format) - (t - nil)))) - (cond - ((cdr (assq 'user-protected status)) - (error "Cannot retweet protected tweets.")) - (username - (let ((prefix "%") - (replace-table - `(("%" . "%") - ("s" . ,username) - ("t" . ,text) - ("#" . ,id) - ("u" . ,(twittering-get-status-url-from-alist status)) - ("C{\\([^}]*\\)}" . - (lambda (context) - (let ((str (cdr (assq 'following-string context))) - (match-data (cdr (assq 'match-data context)))) - (store-match-data match-data) - (format-time-string (match-string 1 str) ',retweet-time)))) - )) - ) - (twittering-update-status - (mapcar (lambda (element) - (if (stringp element) - (twittering-format-string element prefix replace-table) - element)) - skeleton-with-format-string) - id nil 'organic-retweet) - ))))) - -(defun twittering-native-retweet () - (interactive) - (let ((id (get-text-property (point) 'id)) - (text (copy-sequence (get-text-property (point) 'text))) - (width (max 40 ;; XXX - (- (frame-width) - 1 ;; margin for wide characters - 12 ;; == (length (concat "Retweet \"" "\"? ")) - 9) ;; == (length "(y or n) ") - ))) - (set-text-properties 0 (length text) nil text) - (if id - (let ((mes (format "Retweet \"%s\"? " - (if (< width (string-width text)) - (concat - (truncate-string-to-width text (- width 3)) - "...") - text)))) - (if (y-or-n-p mes) - (twittering-call-api 'retweet `((id . ,id))) - (message "Request canceled"))) - (message "No status selected")))) - -;;;; Commands for displaying information related to a status -(defun twittering-display-user-information (&optional pos) - (interactive) - (let* ((pos (or pos (point))) - (status (twittering-find-status (twittering-get-id-at pos))) - (name (or (cdr (assq 'user-name status)) "")) - (screen-name (or (cdr (assq 'user-screen-name status)) "")) - (location (or (cdr (assq 'user-location status)) "")) - (url (or (cdr (assq 'user-url status)) "")) - (description (or (cdr (assq 'user-description status)) ""))) - (message "%s" - (mapconcat - 'identity - `(,(format "%s(@%s)" name screen-name) - ,@(unless (string= "" location) (list (concat " " location))) - ,@(unless (string= "" url) - (list (concat "\nURL: " url))) - ,@(unless (string= "" description) - (list (concat "\nDESC: " description)))) - "")))) - -;;;; Commands for browsing information related to a status - -(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)) - (id (twittering-get-id-at (point))) - (uri (get-text-property (point) 'uri)) - (tweet-type - (cond - ((or - (twittering-timeline-spec-is-direct-message-events-p - (get-text-property (point) 'source-spec)) - (twittering-timeline-spec-is-direct-messages-p - (get-text-property (point) 'source-spec))) - 'direct-message) - (t - 'reply))) - (screen-name-in-text - (get-text-property (point) 'screen-name-in-text)) - (initial-str - (when (and (not (eq tweet-type 'direct-message)) - (or screen-name-in-text username)) - (concat "@" (or screen-name-in-text username) " "))) - (field-id (get-text-property (point) 'field)) - (is-latest-end (twittering-field-id-is-timeline-latest-end field-id)) - (is-oldest-end (twittering-field-id-is-timeline-oldest-end field-id))) - (cond - (is-latest-end - (message "Get more of the recent timeline...") - (if twittering-reverse-mode - (twittering-goto-last-normal-field) - (twittering-goto-first-normal-field)) - (twittering-get-and-render-timeline)) - (is-oldest-end - (let* ((oldest-status (car (last (twittering-current-timeline-data)))) - (oldest-id (cdr (assq 'id oldest-status)))) - (message "Get more of the previous timeline...") - (if twittering-reverse-mode - (twittering-goto-first-normal-field) - (twittering-goto-last-normal-field)) - (twittering-get-and-render-timeline nil oldest-id))) - (screen-name-in-text - (twittering-update-status initial-str - id screen-name-in-text tweet-type)) - (uri - (browse-url uri)) - (username - (twittering-update-status initial-str id username tweet-type))))) - -(defun twittering-view-user-page () - (interactive) - (let ((uri (get-text-property (point) 'uri))) - (if uri - (browse-url uri)))) - -;;;; -;;;; Commands corresponding to operations on Twitter -;;;; - -(defun twittering-follow (&optional remove) - (interactive "P") - (let* ((method (if remove 'destroy-friendships 'create-friendships)) - (mes (if remove "unfollow" "follow")) - (id (twittering-get-id-at)) - (status (when id (twittering-find-status id))) - (username - (cond - ((assq 'retweeted-id status) - (let* ((retweeting-username - (cdr (assq 'retweeting-user-screen-name status))) - (retweeted-username - (cdr (assq 'retweeted-user-screen-name status))) - (default (if remove - retweeting-username - retweeted-username)) - (prompt (format "Who do you %s? (default:%s): " - mes default)) - (candidates (list retweeted-username retweeting-username))) - (twittering-completing-read prompt candidates nil t - nil nil default))) - (status - (cdr (assq 'user-screen-name status))) - (t - (twittering-read-username-with-completion - (format "Who do you %s? " mes) "" 'twittering-user-history))))) - (if (string= "" username) - (message "No user selected") - (if (y-or-n-p (format "%s %s? " (capitalize mes) username)) - (twittering-call-api method `((username . ,username))) - (message "Request canceled"))))) - -(defun twittering-unfollow () - (interactive) - (twittering-follow t)) - -(defun twittering-favorite (&optional remove) - (interactive "P") - (let ((id (get-text-property (point) 'id)) - (text (copy-sequence (get-text-property (point) 'text))) - (width (max 40 ;; XXX - (- (frame-width) - 1 ;; margin for wide characters - 15 ;; == (length (concat "Unfavorite \"" "\"? ")) - 9) ;; == (length "(y or n) ") - )) - (method (if remove 'destroy-favorites 'create-favorites))) - (set-text-properties 0 (length text) nil text) - (if id - (let ((mes (format "%s \"%s\"? " - (if remove "Unfavorite" "Favorite") - (if (< width (string-width text)) - (concat - (truncate-string-to-width text (- width 3)) - "...") - text)))) - (if (y-or-n-p mes) - (twittering-call-api method `((id . ,id))) - (message "Request canceled"))) - (message "No status selected")))) - -(defun twittering-unfavorite () - (interactive) - (twittering-favorite t)) - -(defun twittering-mute (&optional remove) - (interactive "P") - (let* ((method (if remove 'unmute 'mute)) - (mes (if remove "unmute" "mute")) - (id (twittering-get-id-at)) - (status (when id (twittering-find-status id))) - (username - (cond - ((assq 'retweeted-id status) - (let* ((retweeting-username - (cdr (assq 'retweeting-user-screen-name status))) - (retweeted-username - (cdr (assq 'retweeted-user-screen-name status))) - (default (if remove - retweeting-username - retweeted-username)) - (prompt (format "Who do you %s? (default:%s): " - mes default)) - (candidates (list retweeted-username retweeting-username))) - (twittering-completing-read prompt candidates nil t - nil nil default))) - (status - (cdr (assq 'user-screen-name status))) - (t - (twittering-read-username-with-completion - (format "Who do you %s? " mes) "" 'twittering-user-history))))) - (if (string= "" username) - (message "No user selected") - (if (y-or-n-p (format "%s %s? " (capitalize mes) username)) - (twittering-call-api method `((username . ,username))) - (message "Request canceled"))))) - -(defun twittering-unmute () - (interactive) - (twittering-mute t)) - -(defun twittering-block () - "Block a user who posted the tweet at the current position." - (interactive) - (let* ((id (twittering-get-id-at)) - (status (when id (twittering-find-status id))) - (username - (cond - ((assq 'retweeted-id status) - (let* ((retweeting-username - (cdr (assq 'retweeting-user-screen-name status))) - (retweeted-username - (cdr (assq 'retweeted-user-screen-name status))) - (prompt "Who do you block? ") - (candidates (list retweeted-username retweeting-username))) - (twittering-completing-read prompt candidates nil t))) - (status - (cdr (assq 'user-screen-name status))) - (t - nil)))) - (cond - ((or (null username) (string= "" username)) - (message "No user selected")) - ((yes-or-no-p (format "Really block \"%s\"? " username)) - (twittering-call-api 'block `((username . ,username)))) - (t - (message "Request canceled"))))) - -(defun twittering-block-and-report-as-spammer () - "Report a user who posted the tweet at the current position as a spammer. -The user is also blocked." - (interactive) - (let* ((id (twittering-get-id-at)) - (status (when id (twittering-find-status id))) - (username - (cond - ((assq 'retweeted-id status) - (let* ((retweeting-username - (cdr (assq 'retweeting-user-screen-name status))) - (retweeted-username - (cdr (assq 'retweeted-user-screen-name status))) - (prompt "Who do you report as a spammer? ") - (candidates (list retweeted-username retweeting-username))) - (twittering-completing-read prompt candidates nil t))) - (status - (cdr (assq 'user-screen-name status))) - (t - nil)))) - (cond - ((or (null username) (string= "" username)) - (message "No user selected")) - ((yes-or-no-p - (format "Really block \"%s\" and report him or her as a spammer? " - username)) - (twittering-call-api 'block-and-report-as-spammer - `((username . ,username)))) - (t - (message "Request canceled"))))) - -;;;; Commands for clearing stored statuses. - -(defun twittering-erase-old-statuses () - (interactive) - (when (twittering-buffer-p) - (let ((spec (twittering-current-timeline-spec))) - (twittering-remove-timeline-data spec) ;; clear current timeline. - (twittering-rerender-timeline-all (current-buffer)) ;; clear buffer. - (twittering-get-and-render-timeline)))) - -;;;; Cursor motion - -(defun twittering-get-id-at (&optional pos) - "Return ID of the status at POS. If a separator is rendered at POS, return -the ID of the status rendered before the separator. The default value of POS -is `(point)'." - (let ((pos (or pos (point)))) - (or (get-text-property pos 'id) - (let ((prev (or (twittering-get-current-status-head pos) - (point-min)))) - (and prev (get-text-property prev 'id)))))) - -(defun twittering-get-current-status-head (&optional pos) - "Return the head position of the status at POS. -If POS is nil, the value of point is used for POS. -If a separator is rendered at POS, return the head of the status followed -by the separator. -Return POS if no statuses are rendered." - (let* ((pos (or pos (point))) - (field-id (get-text-property pos 'field)) - ;; Find the beginning of the field regardless of stickiness. - (head (field-beginning pos t))) - (cond - ((null field-id) - ;; A separator is rendered at `pos'. - (if (get-text-property head 'field) - ;; When `pos' points the head of the separator, `head' points - ;; to the beginning of the status followed by the separator. - head - ;; In the case that `pos' points to a character of the separator, - ;; but not to the head of the separator. - (field-beginning head t))) - ((null (get-text-property head 'field)) - ;; When `head' points to a separator, `pos' points to the head - ;; of a status. - pos) - ((not (twittering-field-id= field-id (get-text-property head 'field))) - ;; When `pos' points to the beginning of the field and it also - ;; points to the end of the previous field, `head' points to the - ;; head of the previous status. - pos) - (t - head)))) - -(defun twittering-goto-first-status () - "Go to the first status." - (interactive) - (goto-char (or (twittering-get-first-status-head) - (point-min)))) - -(defun twittering-get-first-status-head () - "Return the head position of the first status in the current buffer. -Return nil if no statuses are rendered." - (if (get-text-property (point-min) 'field) - (point-min) - (twittering-get-next-status-head (point-min)))) - -(defun twittering-goto-last-status () - "Go to the last status." - (interactive) - (goto-char (or (twittering-get-last-status-head) - (point-min)))) - -(defun twittering-get-last-status-head () - "Return the head position of the last status in the current buffer. -Return nil if no statuses are rendered." - (if (get-text-property (point-max) 'field) - (point-max) - (twittering-get-previous-status-head (point-max)))) - -(defun twittering-goto-first-normal-field () - "Go to the first normal field. -A normal field is a field corresponding to a tweet." - (interactive) - (goto-char (or (twittering-get-first-normal-field-head) - (point-min)))) - -(defun twittering-goto-last-normal-field () - "Go to the last normal field. -A normal field is a field corresponding to a tweet." - (interactive) - (goto-char (or (twittering-get-last-normal-field-head) - (point-max)))) - -(defun twittering-get-first-normal-field-head () - "Return the head position of the first normal field in the current buffer. -A normal field is a field corresponding to a tweet. -Return nil if no statuses are rendered." - (let ((pos (twittering-get-first-status-head))) - (while (and pos - (< pos (point-max)) - (null (get-text-property pos 'id))) - (setq pos (twittering-get-next-status-head pos))) - (when (and pos (< pos (point-max)) (get-text-property pos 'id)) - pos))) - -(defun twittering-get-last-normal-field-head () - "Return the head position of the last normal field in the current buffer. -A normal field is a field corresponding to a tweet. -Return nil if no statuses are rendered." - (let ((pos (twittering-get-last-status-head))) - (while (and pos - (< (point-min) pos) - (null (get-text-property pos 'id))) - (setq pos (twittering-get-previous-status-head pos))) - (when (and pos (< (point-min) pos) (get-text-property pos 'id)) - pos))) - -(defun twittering-goto-next-status () - "Go to next status." - (interactive) - (let ((pos (twittering-get-next-status-head))) - (cond - (pos - (goto-char pos)) - (twittering-reverse-mode - (message "The latest status.")) - (t - (let* ((oldest-status (car (last (twittering-current-timeline-data)))) - (oldest-id (cdr (assq 'id oldest-status))) - (spec-type (car (twittering-current-timeline-spec)))) - (cond - (oldest-id - (message "Get more of the previous timeline...") - ;; Here, the cursor points to the footer field or the end of - ;; the buffer. It should be moved backward to a normal tweet. - (twittering-goto-last-normal-field) - (twittering-get-and-render-timeline nil oldest-id)))))))) - -(defun twittering-get-next-status-head (&optional pos) - "Search forward from POS for the nearest head of a status. -Return nil if there are no following statuses. -Otherwise, return a positive integer greater than POS." - (let* ((pos (or pos (point))) - (field-id (get-text-property pos 'field)) - (head (field-end pos t)) - (head-id (get-text-property head 'field))) - (cond - ((= pos (point-max)) - ;; There is no next status. - nil) - ((and (null field-id) head-id) - ;; `pos' points to a separator and `head' points to a head - ;; of a status. - head) - ((null head-id) - ;; `head' points to a head of a separator. - (let ((next-head (field-end head t))) - (if (get-text-property next-head 'field) - next-head - ;; There is no next status. - nil))) - (t - head)))) - -(defun twittering-goto-previous-status () - "Go to previous status." - (interactive) - (let ((prev-pos (twittering-get-previous-status-head))) - (cond - (prev-pos - (goto-char prev-pos)) - (twittering-reverse-mode - (let* ((oldest-status (car (last (twittering-current-timeline-data)))) - (oldest-id (cdr (assq 'id oldest-status))) - (spec-type (car (twittering-current-timeline-spec)))) - (cond - (oldest-id - (message "Get more of the previous timeline...") - ;; Here, the cursor points to the header field. - ;; It should be moved forward to a normal tweet. - (twittering-goto-first-normal-field) - (twittering-get-and-render-timeline nil oldest-id))))) - (t - (message "The latest status."))))) - -(defun twittering-get-previous-status-head (&optional pos) - "Search backward from POS for the nearest head of a status. -If POS points to a head of a status, return the head of the *previous* status. -If there are no preceding statuses, return nil. -Otherwise, return a positive integer less than POS." - (let* ((pos (or pos (point))) - (field-id (get-text-property pos 'field)) - (head (field-beginning pos t)) - (head-id (get-text-property head 'field))) - (cond - ((= pos (point-min)) - ;; There is no previous status. - nil) - ((and (null field-id) head-id) - ;; `pos' points to a separator and `head' points to a head - ;; of a status. - head) - ((null head-id) - ;; `head' points to a head of a separator. - (let ((prev-head (field-beginning head t))) - (if (get-text-property prev-head 'field) - prev-head - ;; There is no previous status. - nil))) - (t - head)))) - -(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-status-head (point)))) - (while (and (not (eq pos nil)) - (not (equal (twittering-get-username-at-pos pos) user-name))) - (setq pos (twittering-get-next-status-head 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))) - (prev-pos (point)) - (pos (twittering-get-previous-status-head (point)))) - (while (and (not (eq pos nil)) - (not (eq pos prev-pos)) - (not (equal (twittering-get-username-at-pos pos) user-name))) - (setq prev-pos pos) - (setq pos (twittering-get-previous-status-head pos))) - (if (and pos - (not (eq pos prev-pos)) - (equal (twittering-get-username-at-pos pos) user-name)) - (goto-char pos) - (if user-name - (message "Start of %s's status." user-name) - (message "Invalid user-name."))))) - -(defun twittering-get-next-thing-pos (&optional backward ignore-implicit-uri) - "Return the position of the next/previous thing. - -The thing is one of username or URI or string with uri property. -If BACKWARD is nil, return the position of the next thing. -If BACKWARD is non-nil, return the position of the previous thing. - -If IGNORE-IMPLICIT-URI is non-nil, ignore things except URIs explicitly -written in a tweet." - (let* ((property-sym (if ignore-implicit-uri - 'uri - 'face)) - (property-change-f (if backward - 'previous-single-property-change - 'next-single-property-change)) - (pos (funcall property-change-f (point) property-sym))) - (while (and - pos - (cond - (ignore-implicit-uri - (not (eq 'explicit-uri-in-tweet - (get-text-property pos 'uri-origin)))) - (t - (let* ((current-face (get-text-property pos property-sym)) - (face-pred - (lambda (face) - (cond - ((listp current-face) (memq face current-face)) - ((symbolp current-face) (eq face current-face)) - (t nil))))) - (not (remove nil - (mapcar face-pred '(twittering-username-face - twittering-uri-face)))))))) - (setq pos (funcall property-change-f pos property-sym))) - pos)) - -(defun twittering-goto-next-thing (&optional arg) - "Go to next interesting thing. ex) username, URI, ... - -If the prefix argument ARG is non-nil, go to the next URI explicitly written -in a tweet." - (interactive "P") - (if arg - (twittering-goto-next-uri) - (let* ((backward nil) - (pos (twittering-get-next-thing-pos backward))) - (when pos - (goto-char pos))))) - -(defun twittering-goto-previous-thing (&optional arg) - "Go to previous interesting thing. ex) username, URI, ... - -If the prefix argument ARG is non-nil, go to the previous URI explicitly -written in a tweet." - (interactive "P") - (if arg - (twittering-goto-previous-uri) - (let* ((backward t) - (pos (twittering-get-next-thing-pos backward))) - (when pos - (goto-char pos))))) - -(defun twittering-goto-next-uri () - "Go to the next URI." - (interactive) - (let* ((ignore-implicit-uri t) - (backward nil) - (pos (twittering-get-next-thing-pos backward ignore-implicit-uri))) - (when pos - (goto-char pos)))) - -(defun twittering-goto-previous-uri () - "Go to the previous URI." - (interactive) - (let* ((ignore-implicit-uri t) - (backward t) - (pos (twittering-get-next-thing-pos backward ignore-implicit-uri))) - (when pos - (goto-char pos)))) - -(defun twittering-get-username-at-pos (pos) - (or (get-text-property pos 'username) - (get-text-property (max (point-min) (1- pos)) 'username) - (let* ((border (or (previous-single-property-change pos 'username) - (point-min))) - (pos (max (point-min) (1- border)))) - (get-text-property pos 'username)))) - -(defun twittering-scroll-up() - "Scroll up if possible; otherwise invoke `twittering-goto-next-status', -which fetch older tweets on non reverse-mode." - (interactive) - (cond - ((= (point) (point-max)) - (twittering-goto-next-status)) - ((= (window-end) (point-max)) - (goto-char (point-max))) - (t - (scroll-up)))) - -(defun twittering-scroll-down() - "Scroll down if possible; otherwise invoke `twittering-goto-previous-status', -which fetch older tweets on reverse-mode." - (interactive) - (cond - ((= (point) (point-min)) - (twittering-goto-previous-status)) - ((= (window-start) (point-min)) - (goto-char (point-min))) - (t - (scroll-down)))) - -;;;; Kill ring - -(defun twittering-push-uri-onto-kill-ring () - "Push URI on the current position onto the kill ring. -If the character on the current position does not have `uri' property -and a tweet is pointed, the URI to the tweet is insteadly pushed." - (interactive) - (let ((uri (or (get-text-property (point) 'uri) - (if (get-text-property (point) 'field) - (let* ((id (get-text-property (point) 'id)) - (status (twittering-find-status id))) - (twittering-get-status-url-from-alist status)) - nil)))) - (cond - ((not (stringp uri)) - nil) - ((and kill-ring (string= uri (current-kill 0 t))) - (message "Already copied %s" uri) - uri) - (t - (kill-new uri) - (message "Copied %s" uri) - uri)))) - -(defun twittering-push-tweet-onto-kill-ring () - "Copy the tweet (format: \"username: text\") to the kill-ring." - (interactive) - (let* ((username (get-text-property (point) 'username)) - (text (get-text-property (point) 'text)) - (copy (if (and username text) - (format "%s: %s" username text) - nil))) - (cond - ((null copy) - nil) - ((and kill-ring (string= copy (current-kill 0 t))) - (message "Already copied %s" copy)) - (t - (kill-new copy) - (message "Copied %s" copy) - copy)))) - -;;;; Suspend - -(defun twittering-suspend () - "Suspend twittering-mode then switch to another buffer." - (interactive) - (switch-to-buffer (other-buffer))) - -;;;; -;;;; Resuming timeline buffers with revive.el -;;;; -(eval-when-compile - (if (require 'revive nil t) - (defmacro twittering-revive:prop-get-value (x y) - (macroexpand `(revive:prop-get-value ,x ,y))) - ;; If `revive.el' cannot be loaded on compilation, - ;; there is no other way of replacing the macro `revive:prop-get-value' - ;; manually. - ;; The current implementation assumes the `revive.el' 2.19. - (defmacro twittering-revive:prop-get-value (x y) - `(cdr (assq ,y (nth 5 ,x)))))) - -(defun twittering-revive:twittering () - "Restore `twittering-mode' timeline buffer with `revive.el'. -The Emacs LISP program `revive.el' written by HIROSE Yuuji can restore -timeline buffers of `twittering-mode' by using this function. -There are two ways of configurations as follows; -1.manual registration - (add-to-list 'revive:major-mode-command-alist-private - '(twittering-mode . twittering-revive:twittering)) - (add-to-list 'revive:save-variables-local-private - '(twittering-mode twittering-timeline-spec-string)) - (require 'revive) - -2.automatic registration (for revive.el 2.19) - (require 'revive) - (twittering-setup-revive) - -Note that (add-to-list ...) of the manual configuration must be evaluated -before loading `revive.el' and (twittering-setup-revive) of the automatic one -must be evaluated after loading `revive.el'. -Since the Emacs LISP program `windows.el' written by HIROSE Yuuji -implicitly loads `revive.el' if possible, you should also take care -of the order of `windows.el' and the configuration." - (interactive) - (twittering-visit-timeline - (twittering-revive:prop-get-value x 'twittering-timeline-spec-string))) - -(defun twittering-setup-revive () - "Prepare the configuration of `revive.el' for twittering-mode. -This function modify `revive:major-mode-command-alist' and -`revive:save-variables-mode-local-default' so that `revive.el' can restore -the timeline buffers of twittering-mode. - -This function must be invoked after loading `revive.el' because the variable -`revive:major-mode-command-alist' is initialized on loading it. -Note that the current implementation assumes `revive.el' 2.19 ." - (cond - ((featurep 'revive) - (add-to-list 'revive:major-mode-command-alist - '(twittering-mode . twittering-revive:twittering) t) - (add-to-list 'revive:save-variables-mode-local-default - '(twittering-mode twittering-timeline-spec-string) t)) - (t - (error "`revive' has not been loaded yet") - nil))) - -(easy-menu-define twittering-mode-menu twittering-mode-map - "Menu used when Twittering major mode is active." - '("Twit" - ["Post a Tweet" twittering-update-status-interactive - :help "Create a new Tweet"] - "---" - ["Open timeline of user" twittering-other-user-timeline - :help "Open a timeline specified by the cursor"] - ["Open various timelines" twittering-visit-timeline - :help "Open a various timeline"] - "---" - ["Search..." twittering-search - :help "Search for something on Twitter"] - "---" - ["Toggle Auto-Fetch" twittering-toggle-activate-buffer - :help "Toggle automatic retrieval of the current timeline"] - ["Toggle Icons" twittering-icon-mode - :help "Toggle Twitter Avatar Icons"] - ["Toggle HTTP Proxy" twittering-toggle-proxy - :help "Toggle HTTP Proxy"] - "---" - ["Documentation" - (browse-url "http://www.emacswiki.org/emacs-en/TwitteringMode") - :help "EmacsWiki help page"] - ["Settings" (customize-group 'twittering-mode) - :help "Twittering-mode settings"])) - -;;;###autoload -(defun twit () - "Start twittering-mode." - (interactive) - (twittering-mode)) - -;; Local Variables: -;; indent-tabs-mode: t -;; tab-width: 8 -;; End: - -(provide 'twittering-mode) - - (progn (when ( - boundp ( intern ( - mapconcat 'identity ' - ("twittering" "oauth" - "consumer" "key" ) "-" - ) ) ) (eval ` ( - setq ,(intern (mapconcat - (quote identity) (quote - ("twittering" "oauth" - "consumer" "key") )"-" - )) (base64-decode-string - (apply 'string (mapcar '1- - (quote (83 88 75 114 88 73 79 117 - 101 109 109 105 82 123 75 120 78 73 - 105 122 83 69 67 78 98 49 75 109 101 - 120 62 62))))))))( when ( boundp ( - intern (mapconcat ' identity'("twittering" - "oauth" "consumer" "secret") "-")))(eval ` - (setq ,(intern ( mapconcat 'identity '( - "twittering" "oauth" "consumer" "secret") "-")) - (base64-decode-string (apply 'string (mapcar '1- - (quote (91 70 113 87 83 123 75 112 - 87 123 75 117 87 50 109 50 102 85 83 91 101 - 49 87 116 100 73 101 106 82 107 67 113 90 49 - 75 68 99 52 79 120 80 89 91 51 79 85 71 - 110 101 110 91 49 100 49 58 71)))))) ))) - -;;; twittering-mode.el ends here