Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Add cheat.el and lisppaste.el; clean up init.el.

Move autoloads into libraries instead of init.el; move regen-autoloads to defuns file.
  • Loading branch information...
commit 420ef86d1551dd55be79f9f4b9a249f9c4289347 1 parent 025b85e
@technomancy authored
View
275 elpa-to-submit/cheat.el
@@ -0,0 +1,275 @@
+;; cheat.el
+;; Time-stamp: <2007-08-22 10:00:04 sjs>
+;;
+;; Copyright (c) 2007 Sami Samhuri <sami.samhuri@gmail.com>
+;;
+;; See http://sami.samhuri.net/2007/08/10/cheat-from-emacs for updates.
+;;
+;; License
+;;
+;; This program 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
+;; of the License, or (at your option) any later version.
+;;
+;; This program 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 this program; if not, write to the Free Software
+;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+;;
+;;
+;; Provide a handy interface to cheat.
+;; See http://cheat.errtheblog.com for details on cheat itself.
+;;
+;; sjs 2007.08.21
+;; * Cache the list of cheat sheets, update it once a day (configurable).
+;; * Strictly complete cheat sheet names.
+;;
+;; TODO: make sure all functions are namespaced under cheat-
+;;
+
+
+(defvar *cheat-host* "cheat.errtheblog.com")
+(defvar *cheat-port* "80")
+(defvar *cheat-uri* (concat *cheat-host* ":" *cheat-port*))
+
+(defvar *cheat-directory* "~/.cheat")
+(defvar *cheat-sheets-cache-file* (concat *cheat-directory* "/sheets"))
+
+(defvar *cheat-last-sheet* nil
+ "Name of the most recently viewed cheat sheet.")
+
+(defvar *cheat-sheet-history* nil
+ "List of the most recently viewed cheat sheets.")
+
+(defconst +seconds-per-day+ 86400)
+
+(defvar *cheat-cache-ttl* +seconds-per-day+
+ "The minimum age of a stale cache file, in seconds.")
+
+
+;;; interactive functions
+
+;;;###autoload
+(defun cheat (name &optional silent)
+ "Show the specified cheat sheet.
+
+If SILENT is non-nil then do not print any output, but return it
+as a string instead."
+ (interactive (list (cheat-read-sheet-name)))
+ (if silent
+ (cheat-command-silent name)
+ (cheat-command name)))
+
+(defun cheat-sheets ()
+ "List all cheat sheets."
+ (interactive)
+ (cheat-command "sheets"))
+
+(defun cheat-recent ()
+ "Show recently added cheat sheets."
+ (interactive)
+ (cheat-command "recent"))
+
+(defun cheat-clear-cache ()
+ "Clear the local cheat cache, located in ~/.cheat."
+ (interactive)
+ (cheat-command "--clear-cache")
+ (make-directory *cheat-directory*))
+
+(defun cheat-versions (name)
+ "Version history of the specified cheat sheet."
+ (interactive (list (cheat-read-sheet-name)))
+ (cheat-command name "--versions"))
+
+(defun cheat-diff (name version)
+ "Show the diff between the given version and the current version of the named
+ cheat.
+If VERSION is of the form m:n then show the diff between versions m and n."
+ (interactive (list (cheat-read-sheet-name)
+ (read-string "Cheat version(s): ")))
+ (cheat-command name "--diff" version))
+
+(defun cheat-add-current-buffer (name)
+ "Add a new cheat with the specified name and the current buffer as the body."
+ (interactive "sCheat name: \n")
+ (post-cheat name (buffer-string) t)
+ (if (interactive-p)
+ (print (concat "Cheat added (" name ")"))))
+
+(defun cheat-edit (name)
+ "Fetch the named cheat and open a buffer containing its body.
+The cheat can be saved with `cheat-save-current-buffer'."
+ (interactive (list (cheat-read-sheet-name)))
+ (cheat-clear-cache name) ; make sure we're working with the latest version
+ (switch-to-buffer (get-buffer-create (cheat->buffer name)))
+ (insert (cheat-body name))
+ (if (interactive-p)
+ (print "Run `cheat-save-current-buffer' when you're done editing.")))
+
+(defun cheat-save-current-buffer ()
+ "Save the current buffer using the buffer name for the title and the contents
+ as the body."
+ (interactive)
+ (let ((name (buffer->cheat (buffer-name (current-buffer)))))
+ (post-cheat name (buffer-string))
+ ;; TODO check for errors and kill the buffer on success
+ (if (interactive-p)
+ (print (concat "Cheat saved (" name ")")))
+ (cheat-clear-cache name)
+ (cheat name)))
+
+
+;;; helpers
+
+;; this is from rails-lib.el in the emacs-rails package
+(defun string-join (separator strings)
+ "Join all STRINGS using SEPARATOR."
+ (mapconcat 'identity strings separator))
+
+(defun blank (thing)
+ "Return T if THING is nil or an empty string, otherwise nil."
+ (or (null thing)
+ (and (stringp thing)
+ (= 0 (length thing)))))
+
+(defun cheat-command (&rest rest)
+ "Run the cheat command with the given arguments, display the output."
+ (interactive "sArguments for cheat: \n")
+ (let* ((cmd (string-join " " rest))
+ (buffer (get-buffer-create
+ (concat "*Cheat: " cmd "*"))))
+ (shell-command (concat "cheat " cmd) buffer)))
+
+(defun cheat-command-to-string (&rest rest)
+ "Run the cheat command with the given arguments and return the output as a
+ string. Display nothing."
+ (shell-command-to-string (concat "cheat " (string-join " " rest))))
+
+(defalias 'cheat-command-silent 'cheat-command-to-string)
+
+(defun cheat-read-sheet-name (&optional prompt)
+ "Get the name of an existing cheat sheet, prompting with completion and
+ history.
+
+The name of the sheet read is stored in *cheat-last-sheet* unless it was blank."
+ (let* ((default (when (blank prompt) *cheat-last-sheet*))
+ (prompt (or prompt
+ (if (not (blank default))
+ (concat "Cheat name (default: " default "): ")
+ "Cheat name: ")))
+ (name (completing-read prompt
+ (cheat-sheets-list t)
+ nil
+ t
+ nil
+ '*cheat-sheet-history*
+ default)))
+ (when (not (blank name))
+ (setq *cheat-last-sheet* name))
+ name))
+
+(defun cheat-sheets-list (&optional fetch-if-missing-or-stale)
+ "Get a list of all cheat sheets.
+
+Return the cached list in *cheat-sheets-cache-file* if it's
+readable and `cheat-cache-stale-p' returns nil.
+
+When there is no cache or a stale cache, and
+FETCH-IF-MISSING-OR-STALE is non-nil, cache the list and then
+return it.
+
+Otherwise return nil."
+ (cond ((and (file-readable-p *cheat-sheets-cache-file*)
+ (not (cheat-cache-stale-p)))
+ (save-excursion
+ (let* ((buffer (find-file *cheat-sheets-cache-file*))
+ (sheets (split-string (buffer-string))))
+ (kill-buffer buffer)
+ sheets)))
+ (fetch-if-missing-or-stale
+ (cheat-cache-list)
+ (cheat-sheets-list))
+ (t nil)))
+
+(defun cheat-fetch-list ()
+ "Fetch a fresh list of all cheat sheets."
+ (nthcdr 3 (split-string (cheat-command-to-string "sheets"))))
+
+(defun cheat-cache-list ()
+ "Cache the list of cheat sheets in *cheat-sheets-cache-file*. Return the
+ list."
+ (when (not (file-exists-p *cheat-directory*))
+ (make-directory *cheat-directory*))
+ (save-excursion
+ (let ((buffer (find-file *cheat-sheets-cache-file*))
+ (sheets (cheat-fetch-list)))
+ (insert (string-join "\n" sheets))
+ (basic-save-buffer)
+ (kill-buffer buffer)
+ sheets)))
+
+(defun cheat-cache-stale-p ()
+ "Non-nil if the cache in *cheat-sheets-cache-file* is more than
+ *cheat-cache-ttl* seconds old.q
+
+If the cache file does not exist then it is considered stale.
+
+Also see `cheat-cache-sheets'."
+ (or (null (file-exists-p *cheat-sheets-cache-file*))
+ (let* ((now (float-time (current-time)))
+ (last-mod (float-time (sixth (file-attributes
+ *cheat-sheets-cache-file*))))
+ (age (- now last-mod)))
+ (> age *cheat-cache-ttl*))))
+
+(defun cheat-body (name)
+ "Call out to Ruby to load the YAML and return just the body."
+ (shell-command-to-string
+ (concat "ruby -ryaml -e '"
+ "puts YAML.load_file(File.expand_path(\"~/.cheat/"
+ name ".yml\")).to_a[0][-1]'")))
+
+(defun url-http-post (url args)
+ "Send ARGS to URL as a POST request."
+ (let ((url-request-method "POST")
+ (url-request-extra-headers
+ '(("Content-Type" . "application/x-www-form-urlencoded")))
+ (url-request-data
+ (concat (mapconcat (lambda (arg)
+ (concat (url-hexify-string (car arg))
+ "="
+ (url-hexify-string (cdr arg))))
+ args
+ "&")
+ "\r\n")))
+ ;; `kill-url-buffer' to discard the result
+ ;; `switch-to-url-buffer' to view the results (debugging).
+ (url-retrieve url 'kill-url-buffer)))
+
+(defun kill-url-buffer (status)
+ "Kill the buffer returned by `url-retrieve'."
+ (kill-buffer (current-buffer)))
+
+(defun switch-to-url-buffer (status)
+ "Switch to the buffer returned by `url-retreive'.
+ The buffer contains the raw HTTP response sent by the server."
+ (switch-to-buffer (current-buffer)))
+
+(defun post-cheat (title body &optional new)
+ (let ((uri (concat "http://" *cheat-uri* "/w/" (if new "" title))))
+ (url-http-post uri `(("sheet_title" . ,title)
+ ("sheet_body" . ,body)
+ ("from_gem" . "1")))))
+
+(defun buffer->cheat (name)
+ (substring name 7 (- (length name) 1)))
+
+(defun cheat->buffer (name)
+ (concat "*cheat-" name "*"))
+
+(provide 'cheat)
View
484 elpa-to-submit/lisppaste.el
@@ -0,0 +1,484 @@
+;;; lisppaste.el --- Interact with the lisppaste pastebot via XML-RPC.
+
+;; Copyright (C) 2004, 2005, 2006, 2007, 2008 Lawrence Mitchell <wence@gmx.li>
+;; File: lisppaste.el
+;; Author: Lawrence Mitchell <wence@gmx.li>
+;; Created: 2004-04-25
+;; Version: 1.4
+;; Keywords: IRC xml rpc network
+;; URL: http://purl.org/NET/wence/lisppaste.el
+;; Package-Requires: ((xml-rpc "1.6.4"))
+
+;;; Commentary:
+;; This file provide an Emacs interface to the lisppaste bot running
+;; on the Freenode IRC network (http://freenode.net).
+;; A number of commands are provided.
+;;
+;; Pasting a region may be carried out using `lisppaste-region'.
+;; A top-level entry point to all of lisppaste's functionality is
+;; provided via the `lisppaste' command. If you want to intercept
+;; lisppaste urls and display them in Emacs, you can do so by
+;; modifying `browse-url-browser-function' as described in
+;; `lisppaste-browse-url'.
+;;
+;; Interacting with lisppaste requires xml-rpc.el which you can find
+;; a link for at <URL: http://www.emacswiki.org/cgi-bin/wiki/XmlRpc>.
+
+;;; Code:
+
+(require 'cl)
+(require 'xml-rpc)
+
+(defconst lisppaste-url "http://common-lisp.net:8185/RPC2")
+
+(defun lisppaste-send-command (command &rest stuff)
+ "Send COMMAND to the lisppaste bot with STUFF as arguments."
+ (let ((xml-entity-alist nil)) ; defeat xml.el encoding of entities
+ (apply #'xml-rpc-method-call lisppaste-url command stuff)))
+
+(defun lisppaste-new-paste (channel nick title content &optional annotate)
+ "Create a new paste with the specified arguments.
+CHANNEL is the channel the paste will appear in.
+NICK is the nickname the paste will appear to be from.
+TITLE is the paste's title.
+CONTENT is the paste content.
+If ANNOTATE is non-nil, annotate that paste."
+ (lisppaste-check-channel channel)
+ (lisppaste-send-command 'newpaste channel nick title content annotate))
+
+(defun lisppaste-get-paste (paste &optional n)
+ "Fetch PASTE.
+
+If N is non-nil, fetch the Nth annotation."
+ (lisppaste-send-command 'pastedetails paste n))
+
+(defun lisppaste-list-annotations (paste)
+ "List the annotations for PASTE."
+ (lisppaste-send-command 'pasteannotationheaders paste))
+
+(defun lisppaste-list-pastes (n &optional start channel)
+ "Fetch the most recent N pastes.
+
+If START is non-nil return the most recent N pastes from the STARTth
+paste.
+If CHANNEL is non-nil, only return pastes from that channel."
+ (and start (zerop start) (setq start nil))
+ (if (and channel
+ (not (string= channel "")))
+ (progn (lisppaste-check-channel channel)
+ (lisppaste-send-command 'pasteheadersbychannel channel n start))
+ (lisppaste-send-command 'pasteheaders n start)))
+
+(defun lisppaste-channels ()
+ "Return which channels the lisppaste bot runs on."
+ (lisppaste-send-command 'listchannels))
+
+(defvar lisppaste-channels nil
+ "Cached value of the channels lisppaste is running on.
+
+Initialised using the function `lisppaste-channels'.")
+
+(defsubst lisppaste-check-channel (channel)
+ "Check that CHANNEL is supported by lisppaste.
+
+Checks the cached value of the variable `lisppaste-channels' before
+requesting a new list."
+ (or lisppaste-channels (setq lisppaste-channels (lisppaste-channels)))
+ (unless (member channel lisppaste-channels)
+ (error "%s not a valid channel. Try M-: (setq lisppaste-channels nil) RET"
+ channel)))
+
+(defsubst lisppaste-all-channels ()
+ ;; Retardedness due to completing read requiring an alist.
+ (mapcar #'list
+ (or lisppaste-channels
+ (setq lisppaste-channels (lisppaste-channels)))))
+
+(defvar lisppaste-default-nick nil
+ "*The default nick for pastes.
+
+See also the function `lisppaste-default-nick'.")
+
+(defsubst lisppaste-default-nick (channel)
+ "Return the default nick for CHANNEL.
+
+If ERC is loaded, try and find a nick by looking for
+`erc-current-nick' in CHANNEL's buffer.
+
+If that returns nil, return the value of the variable
+`lisppaste-default-nick'."
+ (or (when (featurep 'erc)
+ (erc-with-buffer ((get-buffer channel))
+ (erc-current-nick)))
+ lisppaste-default-nick))
+
+(defsubst lisppaste-paste (p)
+ (plist-get p 'lisppaste-paste))
+(defsubst lisppaste-annotation (p)
+ (plist-get p 'lisppaste-annotation))
+(defsubst lisppaste-channel (p)
+ (plist-get p 'lisppaste-channel))
+(defsubst lisppaste-annotations (p)
+ (plist-get p 'lisppaste-annotations))
+
+(defsubst lisppaste-read-number (prompt &optional annotation)
+ "Read a number prompting with PROMPT.
+
+Default values are picked up from the text-properties around `point'.
+If ANNOTATION is non-nil, look for annotation text-properties."
+ (let* ((p (text-properties-at (point)))
+ (num (lisppaste-paste p))
+ (ann (lisppaste-annotation p)))
+ (string-to-number
+ (if annotation
+ (read-from-minibuffer prompt
+ (and ann
+ (number-to-string ann)))
+ (read-from-minibuffer prompt
+ (and num
+ (number-to-string num)))))))
+
+(defsubst lisppaste-read-channel ()
+ "Read a channel name."
+ (completing-read "Channel: " (lisppaste-all-channels)))
+
+(defsubst lisppaste-read-nick (c)
+ "Read a nick.
+
+C is the default channel to look for a nick in with `lisppaste-default-nick'."
+ (read-string "Nick: " (lisppaste-default-nick c)))
+
+(defsubst lisppaste-read-title ()
+ "Read a paste title."
+ (read-string "Title: "))
+
+(defun lisppaste-clean-returned-paste (paste)
+ "Clean PASTE of HTML character entities."
+ (with-temp-buffer
+ (insert (format "%s" paste))
+ (goto-char (point-min))
+ ;; Remove spurious ^M's
+ (save-excursion (while (search-forward "&#xD;" nil t)
+ (replace-match "")))
+ (while (re-search-forward "&\\(#x[^;]+\\);" nil t)
+ (insert (read (match-string 1)))
+ (replace-match ""))
+ (buffer-substring-no-properties (point-min) (point-max))))
+
+(defun lisppaste-clean-time-string (time)
+ "Clean an iso8601 TIME string to return YYYY-MM-DD.
+
+Not very robust."
+ (if (string-match "^\\(....\\)\\(..\\)\\(..\\)T..:..:..$" time)
+ (format "%s-%s-%s" (match-string 1 time)
+ (match-string 2 time)
+ (match-string 3 time))
+ (error "Invalid time format `%s'" time)))
+
+(defvar lisppaste-creation-help
+ (concat ";; Enter your paste below, and press C-c C-c to send.\n"
+ ";; Press C-c C-d to cancel this paste.\n\n")
+ "Paste creation help text.")
+
+(defsubst lisppaste-buffer-substring (beg end)
+ "Return part of the current buffer as a string.
+
+BEG and END delimit the part of the buffer to return.
+
+The string is returned with all tabs replaced by spaces. See also
+`untabify'."
+ (let* ((inhibit-read-only t)
+ (s (buffer-substring-no-properties beg end))
+ (tw tab-width))
+ (with-temp-buffer
+ (let ((tab-width tw))
+ (insert s)
+ (untabify (point-min) (point-max))
+ (buffer-substring-no-properties (point-min) (point-max))))))
+
+;;;###autoload
+(defun lisppaste-paste-region (beg end)
+ "Send the region between BEG and END as a paste."
+ (interactive "r")
+ (let* ((annotate (if (y-or-n-p "Send this region as an annotation? ")
+ (lisppaste-read-number "Paste to annotate: ")))
+ (channel (lisppaste-read-channel))
+ (nick (lisppaste-read-nick channel))
+ (title (lisppaste-read-title))
+ (content (lisppaste-buffer-substring beg end)))
+ (lisppaste-check-channel channel)
+ (lisppaste-new-paste channel nick title content annotate)))
+
+
+(defun lisppaste-browse-url (url &rest ignore)
+ "Display a paste URL as a paste in Emacs.
+
+To use this, modify `browse-url-browser-function' in the following way:
+
+ (setq browse-url-browser-function
+ '((\"^http://paste\\\\.lisp\\\\.org/display\" . lisppaste-browse-url)
+ (\".\" . whatever-you-want-the-default-browse-url-function-to-be)))"
+ (when (string-match
+ "http://paste\\.lisp\\.org/display/\\([0-9]+\\)\\(?:#\\([0-9]+\\)\\)?"
+ url)
+ (let ((paste (string-to-number (match-string 1 url)))
+ (ann (match-string 2 url)))
+ (lisppaste-display-paste paste (if ann (string-to-number ann))))))
+
+(defun lisppaste-display-paste (paste &optional n)
+ "Display PASTE.
+
+If N is non-nil, display PASTE's Nth annotation."
+ (interactive
+ (list (lisppaste-read-number "Paste number: ")))
+ (when current-prefix-arg
+ (setq n (lisppaste-read-number "Annotation number: " t)))
+ (multiple-value-bind (num time user channel title annotations
+ content) (lisppaste-get-paste paste n)
+ (switch-to-buffer (get-buffer-create
+ (format "*Paste %s%s*" paste
+ (if n
+ (format " annotation %s"
+ n)
+ ""))))
+ (setq buffer-read-only nil)
+ (erase-buffer)
+ (insert (format "Paste number: %s%s\nUser: %s\nChannel: %s\nTitle: %s\nDate: %s\nAnnotations: %s\n\n"
+ paste (if n
+ (format "\nAnnotation: %s" n)
+ "")
+ user channel title
+ (lisppaste-clean-time-string time)
+ annotations))
+ (insert (lisppaste-clean-returned-paste content))
+ (set-text-properties (point-min)
+ (point-max)
+ `(lisppaste-user ,user
+ lisppaste-title ,title
+ lisppaste-time ,time
+ lisppaste-paste ,paste
+ lisppaste-annotation ,n
+ lisppaste-annotations ,annotations
+ lisppaste-channel ,channel)))
+ (lisppaste-mode))
+
+(defun lisppaste-list-paste-annotations (paste)
+ "List PASTE's annotations."
+ (interactive
+ (list (lisppaste-read-number
+ "List annotations for paste number: ")))
+ (let ((result (lisppaste-list-annotations paste))
+ (buffer-read-only nil))
+ (unless result
+ (error "Paste %s has no annotations" paste))
+ (switch-to-buffer (get-buffer-create
+ (format "*Paste %s Annotations*" paste)))
+ (erase-buffer)
+ (loop for (num time user channel title annotations) in result
+ do (insert
+ (propertize (format
+ "Annotation number: %s\nUser: %s\nchannel: %s\nTitle: %s\nDate: %s\n"
+ num user channel title
+ (lisppaste-clean-time-string time))
+ 'lisppaste-user user
+ 'lisppaste-time time
+ 'lisppaste-paste paste
+ 'lisppaste-annotation num
+ 'lisppaste-channel channel
+ 'lisppaste-annotations annotations)
+ (make-string 75 ?=)
+ "\n"))
+ (lisppaste-mode)))
+
+(defun lisppaste-list-recent-pastes (n &optional start channel)
+ "List the most recent N pastes.
+
+If START is non-nil, list the most recent N pastes prior to and
+including START.
+If CHANNEL is non-nil, only list pastes for that channel."
+ (interactive "nNumber of pastes to get: ")
+ (if current-prefix-arg
+ (setq start (lisppaste-read-number "Start paste: ")
+ channel (lisppaste-read-channel)))
+ (let ((result (lisppaste-list-pastes n start channel)))
+ (unless result
+ (error "No pastes returned"))
+ (switch-to-buffer (get-buffer-create
+ (format "*Paste list%s*"
+ (if (and channel (not (string= channel "")))
+ (format " for %s" channel)
+ ""))))
+ (setq buffer-read-only nil)
+ (erase-buffer)
+ (loop for (num time user channel title annotations) in result
+ do (insert
+ (propertize (format
+ "Paste number: %s\nUser: %s\nChannel: %s\nTitle: %s\nDate: %s\nAnnotations: %s\n"
+ num user channel title (lisppaste-clean-time-string time)
+ annotations)
+ 'lisppaste-user user
+ 'lisppaste-title title
+ 'lisppaste-time time
+ 'lisppaste-paste num
+ 'lisppaste-channel channel
+ 'lisppaste-annotations annotations)
+ (make-string 75 ?=)
+ "\n"))
+ (lisppaste-mode)))
+
+(defun lisppaste-create-paste (callback-fn)
+ "Create a new paste.
+
+CALLBACK-FN should be a function accepting one argument to send the
+paste. See also `lisppaste-send-paste'."
+ (switch-to-buffer (get-buffer-create "*paste*"))
+ (erase-buffer)
+ (insert lisppaste-creation-help)
+ (local-set-key (kbd "C-c C-d") #'lisppaste-quit)
+ (local-set-key (kbd "C-c C-c") `(lambda ()
+ (interactive)
+ (lisppaste-send-paste ,callback-fn))))
+
+(defun lisppaste-send-paste (callback-fn)
+ "Send a paste via CALLBACK-FN.
+
+CALLBACK-FN is called with one argument, the contents of the
+`current-buffer' from the end of `lisppaste-creation-help' to
+`point-max'."
+ (goto-char (point-min))
+ (search-forward lisppaste-creation-help)
+ (funcall callback-fn (buffer-substring-no-properties
+ (match-end 0) (point-max)))
+ (kill-this-buffer))
+
+(defun lisppaste-create-new-paste (&optional channel nick title)
+ "Interactively create a new paste.
+
+CHANNEL, NICK and TITLE are defaults for the paste's channel, nick
+and title arguments respectively."
+ (interactive)
+ (let* ((channel (or channel (lisppaste-read-channel)))
+ (nick (or nick (lisppaste-read-nick channel)))
+ (title (or title (lisppaste-read-title))))
+ (lisppaste-check-channel channel)
+ (lisppaste-create-paste `(lambda (x)
+ (lisppaste-new-paste ,channel ,nick
+ ,title x)))))
+
+(defun lisppaste-create-new-annotation (&optional channel nick title n)
+ "Interactively annotate a paste.
+
+CHANNEL, NICK, TITLE and N are defaults for the annotations's
+channel, nick, title, and paste to annotate respectively."
+ (interactive)
+ (let* ((channel (or channel (lisppaste-read-channel)))
+ (nick (or nick (lisppaste-read-nick channel)))
+ (title (or title (lisppaste-read-title)))
+ (n (or n (lisppaste-read-number "Paste to annotate: "))))
+ (lisppaste-check-channel channel)
+ (lisppaste-create-paste `(lambda (x)
+ (lisppaste-new-paste ,channel ,nick
+ ,title x ,n)))))
+
+(defun lisppaste-dwim ()
+ "Display either the paste or annotation at `point'."
+ (interactive)
+ (let ((props (text-properties-at (point))))
+ (unless (lisppaste-paste props)
+ (error "No paste at point"))
+ (if (lisppaste-annotation props)
+ (lisppaste-display-paste (lisppaste-paste props)
+ (lisppaste-annotation props))
+ (lisppaste-display-paste (lisppaste-paste props)))))
+
+(defun lisppaste-quit ()
+ "Quit the current paste buffer."
+ (interactive)
+ (set-buffer-modified-p nil)
+ (kill-this-buffer))
+
+(defun lisppaste-annotate ()
+ "Annotate the paste at `point'."
+ (interactive)
+ (let ((props (text-properties-at (point))))
+ (lisppaste-create-new-annotation (lisppaste-channel props)
+ nil
+ nil
+ (lisppaste-paste props))))
+
+(defun lisppaste-display-supported-channels ()
+ "Display the channels that lisppaste is running in.
+
+As a side-effect, this updates the channel list stored in the
+variable `lisppaste-channels'."
+ (interactive)
+ (switch-to-buffer (get-buffer-create "*Lisppaste channels*"))
+ (erase-buffer)
+ (insert "Lisppaste is running on the following channels.\n\n")
+ (mapc #'(lambda (c) (insert c "\n"))
+ (setq lisppaste-channels (lisppaste-channels))))
+
+(defvar lisppaste-help
+ (concat
+ "Commands:\n"
+ "`a' -- lisppaste-annotate\n"
+ " Annotate the paste at point. With prefix arg, prompt\n"
+ " for a paste number to annotate.\n"
+ "`c' -- lisppaste-display-supported-channels\n"
+ " Display channels lisppaste is running on.\n"
+ "`d' -- lisppaste-display-paste\n"
+ " Fetch a paste. With prefix arg, fetch an annotation.\n"
+ "`h' -- lisppaste-help\n"
+ " Show this help.\n"
+ "`l a' -- lisppaste-list-paste-annotations\n"
+ " List a paste's annotations.\n"
+ "`l p' -- lisppaste-list-recent-pastes\n"
+ " List recent pastes. With prefix arg, prompt for\n"
+ " channel and start paste.\n"
+ "`n' -- lisppaste-create-new-paste\n"
+ " Create a new paste.\n"
+ "RET -- lisppaste-dwim\n"
+ " Fetch either the paste or the annotation at point.\n"
+ "SPC -- scroll-up\n"
+ "`q' -- lisppaste-quit\n"
+ " Quit the paste display.\n"))
+
+(defun lisppaste-help ()
+ "Show some help for `lisppaste-mode'."
+ (interactive)
+ (with-output-to-temp-buffer "*Lisppaste Help*"
+ (princ lisppaste-help)))
+
+(defun lisppaste ()
+ "Top-level interface to lisppaste."
+ (interactive)
+ (switch-to-buffer (get-buffer-create "*Lisppaste*"))
+ (setq buffer-read-only nil)
+ (erase-buffer)
+ (insert "Top-level interface to lisppaste\n\n"
+ lisppaste-help)
+ (lisppaste-mode))
+
+(defvar lisppaste-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "a" #'lisppaste-annotate)
+ (define-key map "c" #'lisppaste-display-supported-channels)
+ (define-key map "d" #'lisppaste-display-paste)
+ (define-key map "h" #'lisppaste-help)
+ (define-key map (kbd "l a") #'lisppaste-list-paste-annotations)
+ (define-key map (kbd "l p") #'lisppaste-list-recent-pastes)
+ (define-key map "n" #'lisppaste-create-new-paste)
+ (define-key map (kbd "RET") #'lisppaste-dwim)
+ (define-key map (kbd "SPC") #'scroll-up)
+ (define-key map "q" #'lisppaste-quit)
+ map)
+ "Keymap for `lisppaste-mode'.")
+
+(define-derived-mode lisppaste-mode fundamental-mode "Lisppaste"
+ "Major mode for viewing and creating IRC pastes via the lisppaste pastebot."
+ (setq buffer-read-only t)
+ (goto-char (point-min)))
+
+(provide 'lisppaste)
+
+;;; lisppaste.el ends here
View
1  elpa-to-submit/magit.el
@@ -1512,6 +1512,7 @@ in log buffer."
(when remote
(magit-insert-unpushed-commits remote branch))))))
+;;;###autoload
(defun magit-status (dir)
(interactive (list (magit-read-top-dir)))
(save-some-buffers)
View
630 elpa-to-submit/xml-rpc.el
@@ -0,0 +1,630 @@
+;;; xml-rpc.el -- An elisp implementation of clientside XML-RPC
+
+;; Copyright (C) 2001 CodeFactory AB.
+;; Copyright (C) 2001 Daniel Lundin.
+;; Parts Copyright (C) 2002-2005 Mark A. Hershberger
+
+;; Author: Daniel Lundin <daniel@codefactory.se>
+;; Maintainer: Mark A. Hershberger <mah@everybody.org>
+;; Version: 1.6.4
+;; Created: May 13 2001
+;; Keywords: xml rpc network
+;; URL: http://elisp.info/package/xml-rpc/
+
+;; This file is NOT (yet) part of GNU Emacs.
+
+;; This 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 software 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:
+
+;; This is an XML-RPC client implementation in elisp, capable of both
+;; synchronous and asynchronous method calls (using the url package's async
+;; retrieval functionality).
+;; XML-RPC is remote procedure calls over HTTP using XML to describe the
+;; function call and return values.
+
+;; xml-rpc.el represents XML-RPC datatypes as lisp values, automatically
+;; converting to and from the XML datastructures as needed, both for method
+;; parameters and return values, making using XML-RPC methods fairly
+;; transparent to the lisp code.
+
+;; Requirements
+;; ------------
+
+;; xml-rpc.el uses the url package for http handling and xml.el for XML
+;; parsing. url is a part of the W3 browser package (but now as a separate
+;; module in the CVS repository).
+;; xml.el is a part of GNU Emacs 21, but can also be downloaded from
+;; here: <URL:ftp://ftp.codefactory.se/pub/people/daniel/elisp/xml.el>
+
+
+;; XML-RPC datatypes are represented as follows
+;; --------------------------------------------
+
+;; int: 42
+;; float/double: 42.0
+;; string: "foo"
+;; array: '(1 2 3 4) '(1 2 3 (4.1 4.2))
+;; struct: '(("name" . "daniel") ("height" . 6.1))
+
+
+;; Examples
+;; ========
+;; Here follows some examples demonstrating the use of xml-rpc.el
+
+;; Normal synchronous operation
+;; ----------------------------
+
+;; (xml-rpc-method-call "http://localhost:80/RPC" 'foo-method foo bar zoo)
+
+;; Asynchronous example (cb-foo will be called when the methods returns)
+;; ---------------------------------------------------------------------
+
+;; (defun cb-foo (foo)
+;; (print (format "%s" foo)))
+
+;; (xml-rpc-method-call-async 'cb-foo "http://localhost:80/RPC"
+;; 'foo-method foo bar zoo)
+
+
+;; Some real world working examples for fun and play
+;; -------------------------------------------------
+
+;; Check the temperature (celsius) outside jonas@codefactory.se's apartment
+
+;; (xml-rpc-method-call
+;; "http://flint.bengburken.net:80/xmlrpc/onewire_temp.php"
+;; 'onewire.getTemp)
+
+
+;; Fetch the latest NetBSD news the past 5 days from O'reillynet
+
+;; (xml-rpc-method-call "http://www.oreillynet.com/meerkat/xml-rpc/server.php"
+;; 'meerkat.getItems
+;; '(("channel" . 1024)
+;; ("search" . "/NetBSD/")
+;; ("time_period" . "5DAY")
+;; ("ids" . 0)
+;; ("descriptions" . 200)
+;; ("categories" . 0)
+;; ("channels" . 0)
+;; ("dates" . 0)
+;; ("num_items" . 5)))
+
+
+;;; History:
+
+;; 1.6.2 - Fix whitespace issues to work better with new xml.el
+;; Fix bug in string handling.
+;; Add support for gzip-encoding when needed.
+
+;; 1.6.1 - base64 support added.
+;; url-insert-entities-in-string done on string types now.
+
+;; 1.6 - Fixed dependencies (remove w3, add cl).
+;; Move string-to-boolean and boolean-to-string into xml-rpc namespace.
+;; Fix bug in xml-rpc-xml-to-response where non-existent var was.
+;; More tweaking of "Connection: close" header.
+;; Fix bug in xml-rpc-request-process-buffer so that this works with
+;; different mixes of the url.el code.
+
+;; 1.5.1 - Added Andrew J Cosgriff's patch to make the
+;; xml-rpc-clean-string function work in XEmacs.
+
+;; 1.5 - Added headers to the outgoing url-retreive-synchronously
+;; so that it would close connections immediately on completion.
+
+;; 1.4 - Added conditional debugging code. Added version tag.
+
+;; 1.2 - Better error handling. The documentation didn't match
+;; the code. That was changed so that an error was
+;; signaled. Also, better handling of various and
+;; different combinations of xml.el and url.el.
+
+;; 1.1 - Added support for boolean types. If the type of a
+;; returned value is not specified, string is assumed
+
+;; 1.0 - First version
+
+
+;;; Code:
+
+(defun xml-rpc-clean-string (s)
+ (if (string-match "\\`[ \t\n\r]*\\'" s)
+ ;"^[ \t\n]*$" s)
+ nil
+ s))
+
+(require 'custom)
+(require 'xml)
+(require 'url)
+(eval-when-compile
+ (require 'cl))
+
+(defcustom xml-rpc-load-hook nil
+ "*Hook run after loading xml-rpc."
+ :type 'hook :group 'xml-rpc)
+
+(defcustom xml-rpc-base64-encode-unicode t
+ "If non-nil, then strings with non-ascii characters will be turned
+into Base64."
+ :type 'boolean :group 'xml-rpc)
+
+(defcustom xml-rpc-base64-decode-unicode t
+ "If non-nil, then base64 strings will be decoded using the
+utf-8 coding system."
+ :type 'boolean :group 'xml-rpc)
+
+(defcustom xml-rpc-debug 0
+ "Set this to 1 or greater to avoid killing temporary buffers.
+Set it higher to get some info in the *Messages* buffer")
+
+(defconst xml-rpc-version "1.6"
+ "Current Version of xml-rpc.el")
+
+;;
+;; Value type handling functions
+;;
+
+(defun xml-rpc-value-intp (value)
+ "Return t if VALUE is an integer."
+ (integerp value))
+
+(defun xml-rpc-value-doublep (value)
+ "Return t if VALUE is a double precision number."
+ (floatp value))
+
+(defun xml-rpc-value-stringp (value)
+ "Return t if VALUE is a string."
+ (stringp value))
+
+(defun xml-rpc-value-booleanp (value)
+ "Return t if VALUE is a boolean"
+ (or (eq value nil)
+ (eq value t)))
+
+(defun xml-rpc-string-to-boolean (value)
+ "Return t if VALUE is a boolean"
+ (or (string-equal value "true") (string-equal value "1")))
+
+(defun xml-rpc-caddar-safe (list)
+ (car-safe (cdr-safe (cdr-safe (car-safe list)))))
+
+;; An XML-RPC struct is a list where every car is a list of length 1 or 2 and
+;; has a string for car.
+(defsubst xml-rpc-value-structp (value)
+ "Return t if VALUE is an XML-RPC struct."
+ (and (listp value)
+ (let ((vals value)
+ (result t)
+ curval)
+ (while (and vals result)
+ (setq result (and
+ (setq curval (car-safe vals))
+ (memq (safe-length curval) '(1 2))
+ (stringp (car-safe curval))))
+ (setq vals (cdr-safe vals)))
+ result)))
+
+;; A somewhat lazy predicate for arrays
+(defsubst xml-rpc-value-arrayp (value)
+ "Return t if VALUE is an XML-RPC struct."
+ (and (listp value)
+ (not (xml-rpc-value-structp value))))
+
+(defun xml-rpc-xml-list-to-value (xml-list)
+ "Convert an XML-RPC structure in an xml.el style XML-LIST to an elisp list, \
+interpreting and simplifying it while retaining its structure."
+ (cond
+ ((and (xml-rpc-caddar-safe xml-list)
+ (listp (car-safe (cdr-safe (cdr-safe (car-safe xml-list))))))
+
+ (setq valtype (car (caddar xml-list))
+ valvalue (caddr (caddar xml-list)))
+ (cond
+ ;; Base64
+ ((eq valtype 'base64)
+ (if xml-rpc-base64-decode-unicode
+ (decode-coding-string (base64-decode-string valvalue) 'utf-8)
+ (base64-decode-string valvalue)))
+ ;; Boolean
+ ((eq valtype 'boolean)
+ (xml-rpc-string-to-boolean valvalue))
+ ;; String
+ ((eq valtype 'string)
+ valvalue)
+ ;; Integer
+ ((eq valtype 'int)
+ (string-to-int valvalue))
+ ;; Double/float
+ ((eq valtype 'double)
+ (string-to-number valvalue))
+ ;; Struct
+ ((eq valtype 'struct)
+ (mapcar (lambda (member)
+ (let ((membername (cadr (cdaddr member)))
+ (membervalue (xml-rpc-xml-list-to-value (cdddr member))))
+ (cons membername membervalue)))
+ (cddr (caddar xml-list))))
+ ;; Fault
+ ((eq valtype 'fault)
+ (let* ((struct (xml-rpc-xml-list-to-value (list valvalue)))
+ (fault-string (cdr (assoc "faultString" struct)))
+ (fault-code (cdr (assoc "faultCode" struct))))
+ (list 'fault fault-code fault-string)))
+ ;; DateTime
+ ((eq valtype 'dateTime\.iso8601)
+ valvalue)
+ ;; Array
+ ((eq valtype 'array)
+ (mapcar (lambda (arrval)
+ (xml-rpc-xml-list-to-value (list arrval)))
+ (cddr valvalue)))))
+ ((xml-rpc-caddar-safe xml-list))))
+
+(defun xml-rpc-boolean-to-string (value)
+ "Convert a boolean value to a string"
+ (if value
+ "1"
+ "0"))
+
+(defun xml-rpc-value-to-xml-list (value)
+ "Return XML representation of VALUE properly formatted for use with the \
+functions in xml.el."
+ (cond
+ ; ((not value)
+ ; nil)
+ ((xml-rpc-value-booleanp value)
+ `((value nil (boolean nil ,(xml-rpc-boolean-to-string value)))))
+ ((listp value)
+ (let ((result nil)
+ (xmlval nil))
+ (if (xml-rpc-value-structp value)
+ ;; Value is a struct
+ (progn
+ (while (setq xmlval `((member nil (name nil ,(caar value))
+ ,(car (xml-rpc-value-to-xml-list
+ (cdar value)))))
+ result (if t (append result xmlval) (car xmlval))
+ value (cdr value)))
+ `((value nil ,(append '(struct nil) result))))
+ ;; Value is an array
+ (while (setq xmlval (xml-rpc-value-to-xml-list (car value))
+ result (if result (append result xmlval)
+ xmlval)
+ value (cdr value)))
+ `((value nil (array nil ,(append '(data nil) result)))))))
+ ;; Value is a scalar
+ ((xml-rpc-value-intp value)
+ `((value nil (int nil ,(int-to-string value)))))
+ ((xml-rpc-value-stringp value)
+ (let ((charset-list (find-charset-string value)))
+ (if (or (and (eq 1 (length charset-list))
+ (eq 'ascii (car charset-list)))
+ (not xml-rpc-base64-encode-unicode))
+ `((value nil (string nil ,(url-insert-entities-in-string value))))
+ `((value nil (base64 nil ,(base64-encode-string
+ (encode-coding-string value 'utf-8))))))))
+ ((xml-rpc-value-doublep value)
+ `((value nil (double nil ,(number-to-string value)))))
+ (t
+ `((value nil (base64 nil ,(base64-encode-string value)))))))
+
+(defun xml-rpc-xml-to-string (xml)
+ "Return a string representation of the XML tree as valid XML markup."
+ (let ((tree (xml-node-children xml))
+ (result (concat "<" (symbol-name (xml-node-name xml)) ">")))
+ (while tree
+ (cond
+ ((listp (car tree))
+ (setq result (concat result (xml-rpc-xml-to-string (car tree)))))
+ ((stringp (car tree))
+ (setq result (concat result (car tree))))
+ (t
+ (error "Invalid XML tree")))
+ (setq tree (cdr tree)))
+ (setq result (concat result "</" (symbol-name (xml-node-name xml)) ">"))
+ result))
+
+;;
+;; Response handling
+;;
+
+(defsubst xml-rpc-response-errorp (response)
+ "An 'xml-rpc-method-call' result value is always a list, where the first \
+element in RESPONSE is either nil or if an error occured, a cons pair \
+according to (errnum . \"Error string\"),"
+ (eq 'fault (car-safe (caddar response))))
+
+(defsubst xml-rpc-response-error-code (response)
+ "Return the error code from RESPONSE."
+ (and (xml-rpc-response-errorp response)
+ (nth 1 (xml-rpc-xml-list-to-value response))))
+
+(defsubst xml-rpc-response-error-string (response)
+ "Return the error code from RESPONSE."
+ (and (xml-rpc-response-errorp response)
+ (nth 2 (xml-rpc-xml-list-to-value response))))
+
+(defun xml-rpc-xml-to-response (xml)
+ "Convert an XML list to a method response list. An error is
+signaled if there is a fault or if the response does not appear
+to be an XML-RPC response (i.e. no methodResponse). Otherwise,
+the parsed XML response is returned."
+ ;; Check if we have a methodResponse
+ (cond
+ ((not (eq (car-safe (car-safe xml)) 'methodResponse))
+ (error "No methodResponse found"))
+
+ ;; Did we get a fault response
+ ((xml-rpc-response-errorp xml)
+ (let ((resp (xml-rpc-xml-list-to-value xml)))
+ (setq xml-rpc-fault-string (nth 2 resp))
+ (setq xml-rpc-fault-code (nth 1 resp))
+ (error "XML-RPC fault `%s'" xml-rpc-fault-string)))
+
+ ;; Interpret the XML list and produce a more useful data structure
+ (t
+ (let ((valpart (cdr (cdaddr (caddar xml)))))
+ (xml-rpc-xml-list-to-value valpart)))))
+
+;;
+;; Misc
+;;
+
+(defun xml-rpc-get-temp-buffer-name ()
+ "Get a working buffer name such as ` *XML-RPC-<i>*' without a live process \
+and empty it"
+ (let ((num 1)
+ name buf)
+ (while (progn (setq name (format " *XML-RPC-%d*" num)
+ buf (get-buffer name))
+ (and buf (or (get-buffer-process buf)
+ (save-excursion (set-buffer buf)
+ (> (point-max) 1)))))
+ (setq num (1+ num)))
+ name))
+
+
+
+;;
+;; Method handling
+;;
+
+(defun xml-rpc-request (server-url xml &optional async-callback-function)
+ "Perform http post request to SERVER-URL using XML.
+
+If ASYNC-CALLBACK-FUNCTION is non-nil, the request will be performed
+asynchronously and ASYNC-CALLBACK-FUNCTION should be a callback function to
+be called when the reuest is finished. ASYNC-CALLBACK-FUNCTION is called with
+a single argument being an xml.el style XML list.
+
+It returns an XML list containing the method response from the XML-RPC server,
+or nil if called with ASYNC-CALLBACK-FUNCTION."
+ (unwind-protect
+ (save-excursion
+ (let ((url-working-buffer (get-buffer-create
+ (xml-rpc-get-temp-buffer-name)))
+ (url-request-method "POST")
+ (url-package-name "xml-rpc.el")
+ (url-package-version xml-rpc-version)
+ (url-request-data (concat "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n"
+ (with-temp-buffer
+ (xml-print xml)
+ (buffer-string))))
+ (url-request-coding-system 'utf-8)
+ (url-http-attempt-keepalives nil)
+ (url-request-extra-headers (list
+ (cons "Content-Type" "text/xml; charset=utf-8"))))
+ (if (> xml-rpc-debug 1)
+ (print url-request-data (create-file-buffer "request-data")))
+ (set-buffer url-working-buffer)
+
+ (cond ((boundp 'url-be-asynchronous) ; Sniff for w3 lib capability
+ (if async-callback-function
+ (setq url-be-asynchronous t
+ url-current-callback-data (list
+ async-callback-function
+ (current-buffer))
+ url-current-callback-func 'xml-rpc-request-callback-handler)
+ (setq url-be-asynchronous nil))
+ (url-retrieve server-url t)
+
+ (if url-be-asynchronous
+ nil
+ (let ((result (xml-rpc-request-process-buffer
+ url-working-buffer)))
+ (if (> xml-rpc-debug 1)
+ (save-excursion
+ (set-buffer (create-file-buffer "result-data"))
+ (insert result)))
+ (if (< xml-rpc-debug 1)
+ (kill-buffer (current-buffer)))
+ result)))
+ (t ; Post emacs20 w3-el
+ (if async-callback-function
+ (url-retrieve server-url async-callback-function)
+ (let ((buffer (url-retrieve-synchronously server-url))
+ result)
+ (set-buffer buffer)
+ (url-http-parse-headers)
+ (if (> url-http-response-status 299)
+ (error "Error during request: %s"
+ url-http-response-status))
+ (url-extract-mime-headers)
+ (setq result (xml-rpc-request-process-buffer buffer))
+ (if (< xml-rpc-debug 1)
+ (kill-buffer buffer))
+ result))))))))
+
+
+(defun xml-rpc-clean (l)
+ (cond
+ ((listp l)
+ (let ((remain l)
+ elem
+ (result nil))
+ (while l
+ ; iterate
+ (setq elem (car l)
+ l (cdr l))
+ ; test the head
+ (cond
+ ; a string, so clean it.
+ ((stringp elem)
+ (let ((tmp (xml-rpc-clean-string elem)))
+ (if tmp
+ (setq result (append result (list tmp)))
+ result)))
+ ; a list, so recurse.
+ ((listp elem)
+ (setq result (append result (list (xml-rpc-clean elem)))))
+
+ ; everthing else, as is.
+ (t
+ (setq result (append result (list elem))))))
+ result))
+
+ ((stringp l) ; will returning nil be acceptable ?
+ elem)
+
+ (t
+ l)))
+
+(defun xml-rpc-request-process-buffer (xml-buffer)
+ "Process buffer XML-BUFFER."
+ (unwind-protect
+ (save-excursion
+ (set-buffer xml-buffer)
+ (when (fboundp 'url-uncompress)
+ (url-uncompress))
+ (goto-char (point-min))
+ (search-forward-regexp "<\\?xml" nil t)
+ (move-to-column 0)
+ ;; Gather the results
+ (let* ((status url-http-response-status)
+ (result (cond
+ ;; A probable XML response
+ ((looking-at "<\\?xml ")
+ (xml-rpc-clean (xml-parse-region (point-min) (point-max))))
+
+ ;; No HTTP status returned
+ ((not status)
+ (let ((errstart
+ (search-forward "\n---- Error was: ----\n")))
+ (and errstart
+ (buffer-substring errstart (point-max)))))
+
+ ;; Maybe they just gave us an the XML w/o PI?
+ ((search-forward "<methodResponse>" nil t)
+ (xml-rpc-clean (xml-parse-region (match-beginning 0)
+ (point-max))))
+
+ ;; Valid HTTP status
+ (t
+ (int-to-string status)))))
+ result))))
+
+
+(defun xml-rpc-request-callback-handler (callback-fun xml-buffer)
+ "Marshall a callback function request to CALLBACK-FUN with the results \
+handled from XML-BUFFER."
+ (let ((xml-response (xml-rpc-request-process-buffer xml-buffer)))
+ (if (< xml-rpc-debug 1)
+ (kill-buffer xml-buffer))
+ (funcall callback-fun (xml-rpc-xml-to-response xml-response))))
+
+
+(defun xml-rpc-method-call-async (async-callback-func server-url method
+ &rest params)
+ "Call an XML-RPC method asynchronously at SERVER-URL named METHOD with \
+PARAMS as parameters. When the method returns, ASYNC-CALLBACK-FUNC will be \
+called with the result as parameter."
+ (let* ((m-name (if (stringp method)
+ method
+ (symbol-name method)))
+ (m-params (mapcar '(lambda (p)
+ `(param nil ,(car (xml-rpc-value-to-xml-list
+ p))))
+ (if async-callback-func
+ params
+ (car-safe params))))
+ (m-func-call `((methodCall nil (methodName nil ,m-name)
+ ,(append '(params nil) m-params)))))
+ (if (> xml-rpc-debug 1)
+ (print m-func-call (create-file-buffer "func-call")))
+ (xml-rpc-request server-url m-func-call async-callback-func)))
+
+(defun xml-rpc-method-call (server-url method &rest params)
+ "Call an XML-RPC method at SERVER-URL named METHOD with PARAMS as \
+parameters."
+ (let ((response
+ (xml-rpc-method-call-async nil server-url method params)))
+ (cond ((stringp response)
+ (list (cons nil (concat "URL/HTTP Error: " response))))
+ (t
+ (xml-rpc-xml-to-response response)))))
+
+(eval-when-compile
+ (unless (fboundp 'xml-print)
+ (defun xml-debug-print (xml &optional indent-string)
+ "Outputs the XML in the current buffer.
+XML can be a tree or a list of nodes.
+The first line is indented with the optional INDENT-STRING."
+ (setq indent-string (or indent-string ""))
+ (dolist (node xml)
+ (xml-debug-print-internal node indent-string)))
+
+ (defalias 'xml-print 'xml-debug-print)
+
+ (defun xml-debug-print-internal (xml indent-string)
+ "Outputs the XML tree in the current buffer.
+The first line is indented with INDENT-STRING."
+ (let ((tree xml)
+ attlist)
+ (insert indent-string ?< (symbol-name (xml-node-name tree)))
+
+ ;; output the attribute list
+ (setq attlist (xml-node-attributes tree))
+ (while attlist
+ (insert ?\ (symbol-name (caar attlist)) "=\"" (cdar attlist) ?\")
+ (setq attlist (cdr attlist)))
+
+ (setq tree (xml-node-children tree))
+
+ (if (null tree)
+ (insert ?/ ?>)
+ (insert ?>)
+
+ ;; output the children
+ (dolist (node tree)
+ (cond
+ ((listp node)
+ (insert ?\n)
+ (xml-debug-print-internal node (concat indent-string " ")))
+ ((stringp node) (insert node))
+ (t
+ (error "Invalid XML tree"))))
+
+ (when (not (and (null (cdr tree))
+ (stringp (car tree))))
+ (insert ?\n indent-string))
+ (insert ?< ?/ (symbol-name (xml-node-name xml)) ?>))))))
+
+(provide 'xml-rpc)
+
+;;; xml-rpc.el ends here
View
36 init.el
@@ -9,45 +9,15 @@
;; and brighter; it simply makes everything else vanish."
;; -Neal Stephenson, "In the Beginning was the Command Line"
-;; Temporary debugging stuff:
+;; Load path etc:
-(toggle-debug-on-error)
-;;; Fix for a bug in CVS Emacs 2 April 08; remove when fixed upstream:
-(require 'cl)
-(defun handle-shift-selection (&rest args))
-
-;; Load path
(setq dotfiles-dir (file-name-directory
(or (buffer-file-name) load-file-name)))
(add-to-list 'load-path dotfiles-dir)
(add-to-list 'load-path (concat dotfiles-dir "/elpa"))
(add-to-list 'load-path (concat dotfiles-dir "/elpa-to-submit"))
-
-;; Autoloads can be regenerated for you automatically if the file is
-;; too old:
-
(setq autoload-file (concat dotfiles-dir "loaddefs.el"))
-(defun regen-autoloads ()
- "Regenerate the autoload definitions file and load it."
- (interactive)
- (if (or (not (file-exists-p autoload-file))
- ;; TODO: make this more readable
- (< (+ (car (nth 5 (file-attributes autoload-file))) 20)
- (car (current-time))))
- (let ((generated-autoload-file autoload-file))
- (message "Updating autoloads...")
- (update-directory-autoloads dotfiles-dir
- (concat dotfiles-dir "/elpa-to-submit"))))
- (load autoload-file))
-
-;; Some libraries don't have the necessary autoloads set up.
-
-(autoload 'lisppaste-paste-region "lisppaste" "" t)
-(autoload 'jabber-connect "jabber" "" t)
-(autoload 'cheat "cheat" "" t)
-(autoload 'magit-status "magit" "" t)
-
;; These should be loaded on startup rather than autoloaded on demand
;; since they are likely to be used in every session:
@@ -58,7 +28,7 @@
(require 'ansi-color)
(require 'recentf)
-;; Load up ELPA:
+;; Load up ELPA, the package manager:
(require 'package)
(package-initialize)
@@ -73,6 +43,8 @@
(require 'starter-kit-eshell)
(require 'starter-kit-ruby)
+(regen-autoloads)
+
;; You can keep system-specific customizations here:
(setq system-specific-config
View
17 starter-kit-defuns.el
@@ -107,6 +107,19 @@
(interactive)
(byte-recompile-directory (expand-file-name "~/.emacs.d") 0))
+(defun regen-autoloads ()
+ "Regenerate the autoload definitions file if necessary and load it."
+ (interactive)
+ (if (or (not (file-exists-p autoload-file))
+ ;; TODO: make this more readable
+ (< (+ (car (nth 5 (file-attributes autoload-file))) 20)
+ (car (current-time))))
+ (let ((generated-autoload-file autoload-file))
+ (message "Updating autoloads...")
+ (update-directory-autoloads dotfiles-dir
+ (concat dotfiles-dir "/elpa-to-submit"))))
+ (load autoload-file))
+
;; TODO: fix this
(defun sudo-edit (&optional arg)
(interactive "p")
@@ -133,5 +146,9 @@
(switch-to-buffer buffer)
(funcall function))))
+(if (eq window-system 'x)
+ (defun handle-shift-selection (&rest args)
+ "Fix a bug that occurs when caps-lock is remapped to ctrl in X."))
+
(provide 'starter-kit-defuns)
;;; starter-kit-defuns.el ends here
Please sign in to comment.
Something went wrong with that request. Please try again.