emacs/gist.el

   1 ;; gist.el --- Emacs integration for gist.github.com
   2
   3 ;; Author: Christian Neukirchen <purl.org/net/chneukirchen>
   4 ;; Maintainer: Chris Wanstrath <chris@ozmm.org>
   5 ;; Contributors:
   6 ;; Will Farrington <wcfarrington@gmail.com>
   7 ;; Michael Ivey
   8 ;; Phil Hagelberg
   9 ;; Dan McKinley
  10 ;; Version: 0.4
  11 ;; Created: 21 Jul 2008
  12 ;; Keywords: gist git github paste pastie pastebin
  13
  14 ;; This file is NOT part of GNU Emacs.
  15
  16 ;; This is free software; you can redistribute it and/or modify it under
  17 ;; the terms of the GNU General Public License as published by the Free
  18 ;; Software Foundation; either version 2, or (at your option) any later
  19 ;; version.
  20 ;;
  21 ;; This is distributed in the hope that it will be useful, but WITHOUT
  22 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  23 ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  24 ;; for more details.
  25 ;;
  26 ;; You should have received a copy of the GNU General Public License
  27 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  28 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
  29 ;; MA 02111-1307, USA.
  30
  31 ;;; Commentary:
  32
  33 ;; Uses your local GitHub config if it can find it.
  34 ;; See http://github.com/blog/180-local-github-config
  35
  36 ;;; Code:
  37
  38 (eval-when-compile (require 'cl))
  39 (require 'xml)
  40
  41 (defvar github-user nil
  42   "If non-nil, will be used as your GitHub username without checking
  43 git-config(1).")
  44 (defvar github-token nil
  45   "If non-nil, will be used as your GitHub token without checking
  46 git-config(1).")
  47
  48 (defvar gist-view-gist nil
  49   "If non-nil, automatically use `browse-url' to view gists after they're
  50 posted.")
  51
  52 (defvar gist-supported-modes-alist '((action-script-mode . "as")
  53                                      (c-mode . "c")
  54                                      (c++-mode . "cpp")
  55                                      (clojure-mode . "clj")
  56                                      (common-lisp-mode . "lisp")
  57                                      (css-mode . "css")
  58                                      (diff-mode . "diff")
  59                                      (emacs-lisp-mode . "el")
  60                                      (erlang-mode . "erl")
  61                                      (haskell-mode . "hs")
  62                                      (html-mode . "html")
  63                                      (io-mode . "io")
  64                                      (java-mode . "java")
  65                                      (javascript-mode . "js")
  66                                      (jde-mode . "java")
  67                                      (js2-mode . "js")
  68                                      (lua-mode . "lua")
  69                                      (ocaml-mode . "ml")
  70                                      (objective-c-mode . "m")
  71                                      (perl-mode . "pl")
  72                                      (php-mode . "php")
  73                                      (python-mode . "py")
  74                                      (ruby-mode . "rb")
  75                                      (text-mode . "txt")
  76                                      (scala-mode . "scala")
  77                                      (sql-mode . "sql")
  78                                      (scheme-mode . "scm")
  79                                      (smalltalk-mode . "st")
  80                                      (sh-mode . "sh")
  81                                      (tcl-mode . "tcl")
  82                                      (tex-mode . "tex")
  83                                      (xml-mode . "xml")))
  84
  85
  86
  87 (defun* gist-request (url callback &optional params)
  88   "Makes a request to `url' asynchronously, notifying `callback' when
  89 complete. The github parameters are included in the request. Optionally
  90 accepts additional POST `params' as a list of (key . value) conses."
  91   (github-with-auth-info login token
  92     (let ((url-request-data (gist-make-query-string
  93                              `(("login" . ,login)
  94                                ("token" . ,token) ,@params)))
  95           (url-max-redirecton 5)
  96           (url-request-method "POST"))
  97       (url-retrieve url callback))))
  98
  99 ;;;###autoload
 100 (defun gist-region (begin end &optional private &optional callback)
 101   "Post the current region as a new paste at gist.github.com
 102 Copies the URL into the kill ring.
 103
 104 With a prefix argument, makes a private paste."
 105   (interactive "r\nP")
 106   (let* ((file (or (buffer-file-name) (buffer-name)))
 107          (name (file-name-nondirectory file))
 108          (ext (or (cdr (assoc major-mode gist-supported-modes-alist))
 109                   (file-name-extension file)
 110                   "txt")))
 111     (gist-request
 112      "http://gist.github.com/gists"
 113      (or callback 'gist-created-callback)
 114      `(,@(if private '(("action_button" . "private")))
 115        ("file_ext[gistfile1]" . ,(concat "." ext))
 116        ("file_name[gistfile1]" . ,name)
 117        ("file_contents[gistfile1]" . ,(buffer-substring begin end))))))
 118
 119 (defun gist-created-callback (status)
 120   (let ((location (cadr status)))
 121     (message "Paste created: %s" location)
 122     (when gist-view-gist
 123       (browse-url location))
 124     (kill-new location)
 125     (kill-buffer (current-buffer))))
 126
 127 (defun gist-make-query-string (params)
 128   "Returns a query string constructed from PARAMS, which should be
 129 a list with elements of the form (KEY . VALUE). KEY and VALUE
 130 should both be strings."
 131   (mapconcat
 132    (lambda (param)
 133      (concat (url-hexify-string (car param)) "="
 134              (url-hexify-string (cdr param))))
 135    params "&"))
 136
 137 ;;;###autoload
 138 (defun gist-region-private (begin end)
 139   "Post the current region as a new private paste at gist.github.com
 140 Copies the URL into the kill ring."
 141   (interactive "r")
 142   (gist-region begin end t))
 143
 144 (defun github-config (key)
 145   "Returns a GitHub specific value from the global Git config."
 146   (let ((strip (lambda (string)
 147                  (if (> (length string) 0)
 148                      (substring string 0 (- (length string) 1)))))
 149         (git (executable-find "git")))
 150   (funcall strip (shell-command-to-string
 151                   (concat git " config --global github." key)))))
 152
 153 (defun github-set-config (key value)
 154   "Sets a GitHub specific value to the global Git config."
 155   (let ((git (executable-find "git")))
 156     (shell-command-to-string
 157      (format git " config --global github.%s %s" key value))))
 158
 159 (defun github-auth-info ()
 160   "Returns the user's GitHub authorization information.
 161 Searches for a GitHub username and token in the global git config,
 162 and returns (USERNAME . TOKEN). If nothing is found, prompts
 163 for the info then sets it to the git config."
 164   (interactive)
 165
 166   ;; If we've been called within a scope that already has this
 167   ;; defined, don't take the time to get it again.
 168   (if (boundp '*github-auth-info*)
 169       *github-auth-info*
 170
 171     (let* ((user (or github-user (github-config "user")))
 172            (token (or github-token (github-config "token"))))
 173
 174       (when (not user)
 175         (setq user (read-string "GitHub username: "))
 176         (github-set-config "user" user))
 177
 178       (when (not token)
 179         (setq token (read-string "GitHub API token: "))
 180         (github-set-config "token" token))
 181
 182       (cons user token))))
 183
 184 (defmacro github-with-auth-info (login token &rest body)
 185   "Binds the github authentication credentials to `login' and `token'.
 186 The credentials are retrieved at most once within the body of this macro."
 187   (declare (indent 2))
 188   `(let ((*github-auth-info* (github-auth-info)))
 189      (destructuring-bind (,login . ,token) *github-auth-info*
 190        ,@body)))
 191
 192 ;;;###autoload
 193 (defun gist-buffer (&optional private)
 194   "Post the current buffer as a new paste at gist.github.com.
 195 Copies the URL into the kill ring.
 196
 197 With a prefix argument, makes a private paste."
 198   (interactive "P")
 199   (gist-region (point-min) (point-max) private))
 200
 201 ;;;###autoload
 202 (defun gist-buffer-private ()
 203   "Post the current buffer as a new private paste at gist.github.com.
 204 Copies the URL into the kill ring."
 205   (interactive)
 206   (gist-region-private (point-min) (point-max)))
 207
 208 ;;;###autoload
 209 (defun gist-region-or-buffer (&optional private)
 210   "Post either the current region, or if mark is not set, the current buffer as a new paste at gist.github.com
 211 Copies the URL into the kill ring.
 212
 213 With a prefix argument, makes a private paste."
 214   (interactive "P")
 215   (condition-case nil
 216       (gist-region (point) (mark) private)
 217       (mark-inactive (gist-buffer private))))
 218
 219 ;;;###autoload
 220 (defun gist-region-or-buffer-private ()
 221   "Post either the current region, or if mark is not set, the current buffer as a new private paste at gist.github.com
 222 Copies the URL into the kill ring."
 223   (interactive)
 224   (condition-case nil
 225       (gist-region-private (point) (mark))
 226       (mark-inactive (gist-buffer-private))))
 227
 228 (defvar gist-fetch-url "http://gist.github.com/%d.txt"
 229   "Raw Gist content URL format")
 230
 231 ;;;###autoload
 232 (defun gist-list ()
 233   "Displays a list of all of the current user's gists in a new buffer."
 234   (interactive)
 235   (message "Retrieving list of your gists...")
 236   (github-with-auth-info login token
 237     (gist-request
 238      (format "http://gist.github.com/api/v1/xml/gists/%s" login)
 239      'gist-lists-retrieved-callback)))
 240
 241 (defun gist-lists-retrieved-callback (status)
 242   "Called when the list of gists has been retrieved. Parses the result
 243 and displays the list."
 244   (goto-char (point-min))
 245   (search-forward "<?xml")
 246   (let ((gists (gist-xml-cleanup
 247                      (xml-parse-region (match-beginning 0) (point-max)))))
 248     (kill-buffer (current-buffer))
 249     (with-current-buffer (get-buffer-create "*gists*")
 250       (goto-char (point-min))
 251       (save-excursion
 252         (kill-region (point-min) (point-max))
 253         (gist-insert-list-header)
 254         (mapc 'gist-insert-gist-link (xml-node-children (car gists)))
 255
 256         ;; remove the extra newline at the end
 257         (delete-backward-char 1))
 258
 259       ;; skip header
 260       (forward-line)
 261       (toggle-read-only t)
 262       (set-window-buffer nil (current-buffer)))))
 263
 264 (defun gist-insert-list-header ()
 265   "Creates the header line in the gist list buffer."
 266   (save-excursion
 267     (insert "  ID          Created                        "
 268             "Visibility  Description \n"))
 269   (let ((ov (make-overlay (line-beginning-position) (line-end-position))))
 270     (overlay-put ov 'face 'header-line))
 271   (forward-line))
 272
 273 (defun gist-insert-gist-link (gist)
 274   "Inserts a button that will open the given gist when pressed."
 275   (let* ((data (gist-parse-gist gist))
 276          (repo (string-to-number (car data))))
 277     (mapc '(lambda (x) (insert (format "  %s    " x))) data)
 278     (make-text-button (line-beginning-position) (line-end-position)
 279                       'repo repo
 280                       'action 'gist-fetch-button
 281                       'face 'default))
 282   (insert "\n"))
 283
 284 (defun gist-fetch-button (button)
 285   "Called when a gist button has been pressed. Fetches and displays the gist."
 286   (gist-fetch (button-get button 'repo)))
 287
 288 (defun gist-parse-gist (gist)
 289   "Returns a list of the gist's attributes for display, given the xml list
 290 for the gist."
 291   (let ((repo (gist-child-text 'repo gist))
 292         (created-at (gist-child-text 'created-at gist))
 293         (description (gist-child-text 'description gist))
 294         (public (if (string= (gist-child-text 'public gist) "true")
 295                     "public"
 296                   "private")))
 297     (list repo created-at public description)))
 298
 299 (defun gist-child-text (sym node)
 300   "Retrieves the text content of a child of a <gist> element."
 301   (let* ((children (xml-node-children node)))
 302     (car (xml-node-children (assq sym children)))))
 303
 304 (defun gist-xml-cleanup (xml-list)
 305   "Removes empty strings or whitespace nodes from the `xml-list'.
 306 Borrowed from rss.el."
 307   (mapcar 'gist-xml-cleanup-node xml-list))
 308
 309 (defun gist-xml-cleanup-node (node)
 310   "Recursively removes whitespace and empty strings from the given xml `node'.
 311 Borrowed from rss.el."
 312   (apply 'list
 313          (xml-node-name node)
 314          (xml-node-attributes node)
 315          (let (new)
 316            (dolist (child (xml-node-children node))
 317              (if (stringp child)
 318                  (or (string-match "\\`[ \t\n]+\\'" child)
 319                      (push child new))
 320                (push (gist-xml-cleanup-node child) new)))
 321            (nreverse new))))
 322
 323 ;;;###autoload
 324 (defun gist-fetch (id)
 325   "Fetches a Gist and inserts it into a new buffer
 326 If the Gist already exists in a buffer, switches to it"
 327   (interactive "nGist ID: ")
 328
 329   (let* ((gist-buffer-name (format "*gist %d*" id))
 330          (gist-buffer (get-buffer gist-buffer-name)))
 331     (if (bufferp gist-buffer)
 332       (switch-to-buffer-other-window gist-buffer)
 333       (progn
 334         (message "Fetching Gist %d..." id)
 335         (setq gist-buffer
 336               (url-retrieve-synchronously (format gist-fetch-url id)))
 337         (with-current-buffer gist-buffer
 338           (rename-buffer gist-buffer-name t)
 339           (goto-char (point-min))
 340           (search-forward-regexp "\n\n")
 341           (delete-region (point-min) (point))
 342           (set-buffer-modified-p nil))
 343         (switch-to-buffer-other-window gist-buffer)))))
 344
 345 (provide 'gist)
 346 ;;; gist.el ends here.