--- /dev/null
+####
+# This file is used to ignore certain files in the repo, such as
+# anything that is generated by the build, etc.
+#
+# This project uses a single .gitignore, so please DO NOT add
+# any .gitignore files to any of the sub directories.
+#
+# NOTE! Please use 'git ls-files -i --exclude-standard' command after
+# changing this file, to see if there are any tracked files which get
+# ignored after the change.
+####
+
+## Standard stuff
+*~
+*.orig
+*.rej
+*.bak
+\#*#
+*.o
+*.a
+*.i
+
+## Elisp
+*.elc
+auto-autoloads.el
+custom-load.el
+custom-defines.el
+
+## Because I'm so used to arch (tla)
+,,*
+++*
+=build
+
--- /dev/null
+-*- text -*-
+
+Here is a small collection of (mostly) my hacks. Some of which are
+even useful.
+
+dired-tar.el -- Handle tarballs in Dired. Updated to support
+ bzip2.
+ges-post.el -- Ease sending lisp to gnu.emacs.sources
+google-query.el -- Search Google from within (S)XEmacs
+linux-kernel.el -- Check the lastest Linux kernel release
+lj.el -- Post entries to a LiveJournal blog
+mozmail.el -- Compose mail in a emacs MUA from mailto links in
+ Mozilla
+patch-keywords.el -- An aid for XEmacs patch reviewers
+pkg-build.el -- Automate the drudgery of the XEmacs Packages
+ Release Manager
+pui-update.el -- Update XEmacs packages from cron
+sxell.el -- SXEmacs interface to the Emacs Lisp List
+snap.el -- An updated version of snap.el (from the howm
+ guy). This one supports (S)XEmacs.
+
+
+Installation:
+============
+Basically, put it in you load-path, optionally byte-compile it, add
+(require '<libname>) in your `user-init-file'.
+
+See the comments in each file for any idiosyncrasies or unusual set up
+procedures.
--- /dev/null
+;;;; dired-tar.el - extensions to dired to create and unpack tar files.
+
+;;;; Originally by: Jim Blandy <jimb@cyclic.com> --- June 1995
+;;;; Adapted to use bzip2 as well as gzip by Steve Youngs <steve@sxemacs.org>
+;;;; Copyright (C) 1995 Jim Blandy
+;;;; Copyright (C) 2005 Steve Youngs
+
+;; Author: Jim Blandy <jimb@cyclic.com>
+;; Maintainer: Jim Blandy <jimb@cyclic.com>
+;; Created: Mon 6 Sep 1993
+;; Updated: Sun 3 Jul 2005
+;; Version: 1.8
+;; Keywords: unix
+
+;;; Commentary:
+
+;;; dired-tar adds a command to dired-mode for creating and unpacking
+;;; tar files. When using this package, typing `M-t' on a tar file in a
+;;; dired listing unpacks the tar file, uncompressing it if necessary.
+;;; Typing `M-t' on a directory packs up that directory into a gzipped,
+;;; or bzip2'd tar file named DIRNAME.tar.gz (DIRNAME.tar.bz2 for bzip2).
+;;;
+;;; To use this package, just place it in a directory in your Emacs
+;;; lisp load path, byte-compile it, and put the line
+;;; (require 'dired-tar)
+;;; in your .emacs.
+;;;
+;;; This file defines the following function:
+;;;
+;;; dired-tar-pack-unpack - If the file on the current line is a tar
+;;; file, or a gzipped or compressed tar file, unpack it. If the
+;;; file on the current line is a directory, build a tar file for
+;;; it, and gzip it.
+;;;
+;;; It also declares the following variables:
+;;;
+;;; dired-tar-compress-with - If the symbol `gzip', compress created tars
+;;; with gzip, if `bzip2', compress with bzip2, if nil, don't compress
+;;; tars.
+;;;
+;;; dired-tar-command-switches - flags to pass to the tar program.
+;;; This is concatenated with command characters ("x" or "c" or
+;;; whatever). The default is 'vf'; I'm told Windows users
+;;; should use "mvf".
+;;;
+;;; dired-tar-gzip-extension - extension to use for gzipped tar files.
+;;; Defaults to ".tar.gz", but ".tgz" may be a useful value in
+;;; some circumstances.
+;;;
+;;; dired-tar-bzip2-extension - extension to use for bzipped tar files.
+;;; Defaults to ".tar.bz2", but ".tbz" or ".tbz2" may be a useful value in
+;;; some circumstances.
+;;;
+;;; dired-tar-gzip-command - a shell command which gzips its
+;;; standard input to its standard output.
+;;;
+;;; dired-tar-ungzip-command - a shell command which ungzips
+;;; its standard input to its standard output.
+;;;
+;;; dired-tar-bzip2-command - a shell command which bzips its
+;;; standard input to its standard output.
+;;;
+;;; dired-tar-unbzip2-command - a shell command which unbzips
+;;; its standard input to its standard output.
+;;;
+;;; dired-tar-shell-file-name - name of the shell to use to run the
+;;; tar command. The default is `shell-file-name'.
+
+;;; Changes since 1.7:
+;;; - From Steve Youngs <steve@sxemacs.org>:
+;;; - Add support for bzip2 tarfiles
+;;; - Convert user variables to defcustom's
+;;; - Change key binding to `M-t' (`T' is `dired-do-total-size')
+;;; Changes since 1.6:
+;;; - recognize files with extension .tgz as gzipped tarfiles; let user
+;;; configure what we name compressed tar files we create.
+;;; Changes since 1.5:
+;;; - (dired-tar-pack): Changes from Cord Kielhorn: name files correctly
+;;; when dired-tar-should-gzip is false.
+;;;
+;;; Changes since 1.4:
+;;; - added dired-tar-shell-file-name and dired-tar-command-switches;
+;;; thanks to Cristian Ionescu-Idbohrn <cii@kcs.se>!
+
+;;; Code:
+
+(require 'compile)
+(eval-when-compile (load "cl-macs"))
+
+\f
+;;;; Variables.
+
+(defgroup dired-tar nil
+ "Extensions to Dired for handling tarfiles."
+ :prefix "dired-tar-"
+ :group 'dired)
+
+(defcustom dired-tar-compress-with 'gzip
+ "*Compression program to use when creating tarfiles.
+
+Can either be the symbols `gzip' or `bzip2' for those respective
+compression programs, or nil for no compression."
+ :type '(choice
+ (item :tag "Use Gzip" gzip)
+ (item :tag "Use Bzip2" bzip2)
+ (item :tag "No compression" nil))
+ :group 'dired-tar)
+
+(defcustom dired-tar-gzip-extension ".tar.gz"
+ "*File name extension to use for creating gzipped tar files.
+
+By default, this is \".tar.gz\", but some people may like to use
+\".tgz\".
+
+NOTE: this variable is only for _creating_ gzipped tarfiles, it isn't
+used for unpacking existing tarfiles."
+ :type 'string
+ :group 'dired-tar)
+
+(defcustom dired-tar-bzip2-extension ".tar.bz2"
+ "*File name extension to use for bzip2'd tar files.
+
+By default, this is \".tar.bz2\", but some people may like to use
+\".tbz\" or \".tbz2\".
+
+NOTE: this variable is only for _creating_ bzipped tarfiles, it isn't
+used for unpacking existing tarfiles."
+ :type 'string
+ :group 'dired-tar)
+
+(defcustom dired-tar-gzip-command "gzip --best --stdout"
+ "*A shell command which gzips its stdin to its stdout."
+ :type 'string
+ :group 'dired-tar)
+
+(defcustom dired-tar-bzip2-command "bzip2 --best --stdout"
+ "*A shell command which bzip2's its stdin to its stdout."
+ :type 'string
+ :group 'dired-tar)
+
+(defcustom dired-tar-ungzip-command "gzip --decompress --stdout"
+ "*A shell command which ungzips its stdin to its stdout."
+ :type 'string
+ :group 'dired-tar)
+
+(defcustom dired-tar-unbzip2-command "bzip2 --decompress --stdout"
+ "*A shell command which unbzip2's its stdin to its stdout."
+ :type 'string
+ :group 'dired-tar)
+
+(defcustom dired-tar-shell-file-name shell-file-name
+ "*The name of the shell to use to run the tar command."
+ :type '(file :must-match t)
+ :group 'dired-tar)
+
+(defcustom dired-tar-command-switches "vf"
+ "Flags to pass to the tar program, in addition to the command charcaters.
+
+This is concatenated with command characters (\"x\" or \"c\" or
+whatever). The default is 'vf'; I'm told Windows users should use
+\"mvf\"."
+ :type 'string
+ :group 'dired-tar)
+
+(defvar dired-tar-result nil
+ "For internal use by dired-tar functions.
+This variable is made local to the buffer in which we run the tar
+process, and holds the name of the file created or affected. The
+process-termination sentinal uses this to update the dired listing
+when the process completes its work, or dies.")
+
+\f
+;;;; Internal functions.
+
+(defun dired-tar-run-command (command directory result)
+ "Internal function for use by the dired-tar package.
+Run COMMAND asynchronously in its own window, like a compilation.
+Use DIRECTORY as the default directory for the command's execution.
+RESULT is the name of the tar file which will be created, or the
+name of the directory into which the tar file was unpacked."
+ (let ((buf (dired-tar-get-buffer)))
+ (save-excursion
+ (set-buffer buf)
+ (setq buffer-read-only nil)
+ (widen)
+ (erase-buffer)
+ (goto-char (point-min))
+ (insert "cd " directory)
+ (newline)
+ (insert command)
+ (newline)
+
+ (setq buffer-read-only t
+ mode-name "Tar-Output"
+ default-directory directory)
+
+ (set (make-local-variable 'dired-tar-result)
+ result)
+ (set (make-local-variable 'mode-line-process)
+ '(": %s"))
+ (set (make-local-variable 'compilation-finish-function)
+ 'dired-tar-operation-done)
+
+ (let ((process
+ ;; Chris Moore <Chris.Moore@src.bae.co.uk> says that the
+ ;; tar commands barf using his version of the zsh. We
+ ;; don't need anything but the Bourne shell here; that's
+ ;; the default value for dired-tar-shell-file-name.
+ (let ((shell-file-name dired-tar-shell-file-name))
+ (start-process-shell-command "*Tar*" buf command))))
+ (set-process-sentinel process 'compilation-sentinel))
+ (display-buffer buf))))
+
+(defun dired-tar-get-buffer ()
+ "Choose a buffer to run a tar process in.
+Tar output buffers have names like *Tar*, *Tar*<2>, *Tar*<3>, ...
+We return the lowest-numbered buffer that doesn't have a live tar
+process in it. We delete any other buffers whose processes have
+deleted."
+
+ ;; Kill all completed tar buffers.
+ (let ((number 1))
+ (while number
+ (let* ((name (if (<= number 1) "*Tar*"
+ (format "*Tar*<%d>" number)))
+ (buf (get-buffer name)))
+ (if (null buf) (setq number nil)
+ (save-excursion
+ (set-buffer buf)
+ (if (let ((process (get-buffer-process buf)))
+ (not (and process (eq (process-status process) 'run))))
+ (kill-buffer buf)))
+ (setq number (1+ number))))))
+
+ ;; Make us a fresh buffer.
+ (generate-new-buffer "*Tar*"))
+
+
+(defun dired-tar-operation-done (buf message)
+ "Internal function for use by the dired-tar package.
+This function is run when the tar operation completes. It tries to
+update the dired listing by looking at dired-tar-result."
+ (cond
+ ((null dired-tar-result))
+
+ ((file-directory-p dired-tar-result)
+ (save-excursion
+ (mapcar
+ (function (lambda (buf)
+ (set-buffer buf)
+ (dired-revert)))
+ (dired-buffers-for-dir dired-tar-result))))
+
+ ((file-exists-p dired-tar-result)
+ (dired-relist-file dired-tar-result))
+
+ ;; Otherwise, I guess the tar operation must have failed somehow.
+ ))
+
+(defun dired-tar-pack (directory prefix-arg)
+ "Internal function for use by the dired-tar package.
+
+Create a tar file from the contents of DIRECTORY, compressed with
+`dired-tar-compress-with'. The archive is named after the directory,
+and the files are stored in the archive with names relative to
+DIRECTORY's parent.
+
+If `dired-tar-compress-with' is nil, the tar file will not be compressed.
+
+We use `dired-tar-gzip-extension' or `dired-tar-bzip2-extension' as
+the suffix for the filenames we create. Or just \".tar\" if the tar
+file is not compressed.
+
+For example, (dired-tar-pack \"/home/blandy/womble/\") could produce a
+tar file named \"/home/blandy/womble.tar.gz\", whose contents had
+names like \"womble/foo\", \"womble/bar\", etcetera.
+
+The second argument PREFIX-ARG is ignored."
+ (let* ((dir-file (directory-file-name directory))
+ (tar-file-name
+ (case dired-tar-compress-with
+ (gzip (concat dir-file dired-tar-gzip-extension))
+ (bzip2 (concat dir-file dired-tar-bzip2-extension))
+ (otherwise (format "%s.tar" dir-file))))
+ (parent-name (file-name-directory dir-file))
+ (content-name (file-name-nondirectory dir-file)))
+ (dired-tar-run-command
+ (case dired-tar-compress-with
+ (gzip (format "tar cvf - %s | %s > %s"
+ content-name
+ dired-tar-gzip-command
+ tar-file-name))
+ (bzip2 (format "tar cvf - %s | %s > %s"
+ content-name
+ dired-tar-bzip2-command
+ tar-file-name))
+ (otherwise (format "tar cvf %s %s"
+ tar-file-name
+ content-name)))
+ parent-name
+ tar-file-name)))
+
+(defconst dired-tar-tarfile-regexp
+ (format "\\(%s\\)\\'"
+ (mapconcat 'regexp-quote
+ '(".tar" ".tar.z" ".tar.gz" ".tar.Z" ".tgz" ".tar.bz2"
+ ".tbz" ".tbz2")
+ "\\|"))
+ "Regular expression matching plausible filenames for tar files.")
+
+(defconst dired-tar-gzipped-tarfile-regexp
+ (format "\\(%s\\)\\'"
+ (mapconcat 'regexp-quote
+ '(".tar.z" ".tar.gz" ".tar.Z" ".tgz")
+ "\\|"))
+ "Regular expression matching plausible filenames for gzip compressed tar files.")
+
+(defconst dired-tar-bzipped-tarfile-regexp
+ (format "\\(%s\\)\\'"
+ (mapconcat 'regexp-quote
+ '(".tar.bz2" ".tbz" ".tbz2")
+ "\\|"))
+ "Regular expression matching plausible filenames for bzip2 compressed tar files.")
+
+(defun dired-tar-unpack (tar-file prefix-arg)
+ "Internal function for use by the dired-tar package.
+Unpack TAR-FILE into the directory containing it.
+If PREFIX-ARG is non-nil, just list the archive's contents without
+unpacking it."
+
+ (let ((tar-file-dir (file-name-directory tar-file))
+ (action (if prefix-arg "t" "x")))
+ (dired-tar-run-command
+ (cond
+
+ ;; Does this look like a tar file at all?
+ ((not (string-match dired-tar-tarfile-regexp tar-file))
+ (error
+ "bug: dired-tar-unpack should only be passed tar file names."))
+
+ ;; Does it look like a compressed tar file?
+ ((string-match dired-tar-gzipped-tarfile-regexp tar-file)
+ (format "%s < %s | tar %s%s -"
+ dired-tar-ungzip-command
+ tar-file
+ action
+ dired-tar-command-switches))
+
+ ;; Does it look like a bzip2 compressed tar file?
+ ((string-match dired-tar-bzipped-tarfile-regexp tar-file)
+ (format "%s < %s | tar %s%s -"
+ dired-tar-unbzip2-command
+ tar-file
+ action
+ dired-tar-command-switches))
+
+ ;; Okay, then it must look like an uncompressed tar file.
+ (t
+ (format "tar %svf %s" action tar-file)))
+ tar-file-dir
+
+ ;; If we're just unpacking the archive, don't bother updating the
+ ;; dired listing.
+ (if prefix-arg nil tar-file-dir))))
+
+\f
+;;;; User-visible functions.
+
+;;;###autoload
+(defun dired-tar-pack-unpack (prefix-arg)
+ "Create or unpack a tar archive for the file on the current line.
+
+If the file on the current line is a directory, make a gzipped tar
+file out of its contents.
+
+If the file on the current line is a tar archive, unpack it. If the
+archive appears to be gzipped or compressed, expand it first. With a
+prefix argument, just list the tar archive's contents, and don't unpack
+it. The file's name must end in \".tar\", \".tar.gz\", \".tar.Z\",
+\".tar.bz2\", \".tbz\", or \".tbz2\" or else this command will assume
+it's not a tar file."
+ (interactive "P")
+
+ (let ((filename (dired-get-filename)))
+ (cond
+ ((file-directory-p filename)
+ (dired-tar-pack filename prefix-arg))
+
+ ((string-match dired-tar-tarfile-regexp filename)
+ (dired-tar-unpack filename prefix-arg))
+
+ (t
+ (error "%s is neither a tar file nor a directory" filename)))))
+
+\f
+;;;; Hooking this into dired mode.
+
+(add-hook 'dired-mode-hook
+ (lambda ()
+ (define-key dired-mode-map [(meta ?t)] 'dired-tar-pack-unpack)))
+
+\f
+(provide 'dired-tar)
+
+;;; dired-tar.el ends here
--- /dev/null
+;; ffi-mpd.el --- elisp binding into libmpd (Music Playing Daemon) -*- Emacs-Lisp -*-
+
+;; Copyright (C) 2008 Steve Youngs
+
+;; Author: Steve Youngs <steve@sxemacs.org>
+;; Maintainer: Steve Youngs <steve@sxemacs.org>
+;; Created: <2008-06-05>
+;; Time-stamp: <Friday Jun 6, 2008 01:37:21 steve>
+;; Homepage:
+;; Keywords: FFI, music
+
+;; This file is part of nothing yet.
+
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions
+;; are met:
+;;
+;; 1. Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; 2. Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;;
+;; 3. Neither the name of the author nor the names of any contributors
+;; may be used to endorse or promote products derived from this
+;; software without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR
+;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+;; DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
+;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
+;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
+;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
+;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+;;; Commentary:
+;;
+;; Interact directly with mpd (Music Playing Daemon) via libmpd.so
+;; with FFI.
+
+;;; Todo:
+;;
+;;
+
+;;; Code:
+(require 'ffi)
+(ffi-load "libmpd")
+
+;; Data structures and types
+(define-ffi-struct mpd_Song
+ '((:file '(pointer char))
+ (:artist '(pointer char))
+ (:title '(pointer char))
+ (:album '(pointer char))
+ (:track '(pointer char))
+ (:name '(pointer char))
+ (:date '(pointer char))
+ (:genre '(pointer char))
+ (:composer '(pointer char))
+ (:performer '(pointer char))
+ (:disc '(pointer char))
+ (:comment '(pointer char))
+ (:time 'int)
+ (:pos 'int)
+ (:id 'int)))
+
+(define-ffi-type MpdObj (struct _MpdObj))
+
+(defvar mpd_new_default
+ (ffi-defun '(function MpdObj) "mpd_new_default")
+ "FFI object for libmpd's mpd_new_default().")
+
+(defun mpd:new_default ()
+ "Open new connection to mpd with default settings."
+ (ffi-call-function mpd_new_default))
+
+;; Playlist
+(defvar mpd_playlist_get_playlist_id
+ (ffi-defun '(function '(long long) MpdObj)
+ "mpd_playlist_get_playlist_id")
+ "FFI function object mpd_playlist_get_playlist_id(MpdObj *mi).")
+
+(provide 'ffi-mpd)
+;;; ffi-mpd.el ends here
--- /dev/null
+;;; ges-post.el --- post elisp files to gnu.emacs.sources using Gnus
+
+;; Copyright (C) 2004 Michael Schierl
+;; Copyright (C) 2004 Steve Youngs
+
+;; RCS: $Id: ges-post.el,v 0.6 2004-03-21 11:56:13+10 steve Exp $
+;; Author: Michael Schierl <schierlm-public@gmx.de>
+;; Steve Youngs <sryoungs@bigpond.net.au>
+;; Maintainer: Steve Youngs <sryoungs@bigpond.net.au>
+;; Created: <2004-03-14>
+;; Last-Modified: <2004-03-21 11:50:28 (steve)>
+;; Homepage: None. Contact maintainer for the latest version.
+;; Keywords: gnu.emacs.sources posting Gnus news
+;; Version: $Revision: 0.6 $
+
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions
+;; are met:
+;;
+;; 1. Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; 2. Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;;
+;; 3. Neither the name of the author nor the names of any contributors
+;; may be used to endorse or promote products derived from this
+;; software without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR
+;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+;; DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
+;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
+;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
+;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
+;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+;;; Commentary:
+;;
+;; gnu.emacs.sources is a newsgroup to post Elisp sources to. Since
+;; the job of creating such postings is quite repetitive, Emacs can
+;; help you with it. After having loaded the source file just type M-x
+;; ges-post-current-buffer RET and a Gnus message buffer will be
+;; prepared for you containing the full source and a default subject
+;; (file name, version number (if detectable) and summary line). You
+;; will be asked for a group (just hit RET for gnu.emacs.sources) and
+;; whether you want to send the article directly. Otherwise point is
+;; placed before the first line, so you can easily add a comment there
+;; if you want to.
+
+;; you can customize `ges-post-use-mime' to send files as a MIME
+;; attachment (default is no for backwards compatibility) or
+;; `ges-post-gnus-plugged' if you want to start Gnus unplugged when it
+;; is not started yet.
+
+;;; History:
+;; $Log: ges-post.el,v $
+;; Revision 0.6 2004-03-21 11:56:13+10 steve
+;; Fix a couple of bytecompiler warnings.
+;;
+;; Revision 0.5 2004-03-21 11:40:42+10 steve
+;; First release by Steve Youngs
+;;
+;; Version 0.4 was Michael's final release as maintainer. From
+;; this point on Steve Youngs is maintaining ges-post.
+;;
+;; - Switch to BSD license.
+;; - Set a Followup-To header.
+;; - Add `ges-post-file'.
+;; - A few cosmetic changes.
+
+;; 2004-03-19 Suggestion by Reiner Steib <reiner.steib@gmx.de>
+;; - Moved defgroup "ges-post" below "gnus-message"
+
+;; 2004-03-17 Patch by Steve Youngs <sryoungs@bigpond.net.au>
+;; - Added a defgroup "ges-post", a subgroup of "gnus-fun".
+;; - Made the defcustoms use it
+;; - Added a keybinding
+;; - Added a convenience alias `ges-post -> ges-post-current-buffer'
+;; - Added an autoload so that entering emacs-lisp-mode will load ges-post
+;; - I figure there's no harm in a bit of advertising...
+
+;; 2004-03-16 Patch by Steve Youngs <sryoungs@bigpond.net.au>:
+;; - start Gnus automatically if needed
+;; - ask for group name
+;; - use lisp-mnt functions to determine summary and version
+;; - optionally post as a MIME attachment
+;; - send article automatically if desired
+
+;; 2004-03-14 First "release" in gnu.emacs.sources
+
+;;; Code:
+
+(require 'gnus-msg)
+(require 'lisp-mnt)
+
+(eval-when-compile
+ (autoload 'with-electric-help "ehelp")
+ (autoload 'font-lock-fontify-buffer "font-lock" nil t))
+
+;;; Custom
+(defgroup ges-post nil
+ "Customisations for ges-post."
+ :prefix "ges-post-"
+ :group 'gnus-message)
+
+(defcustom ges-post-use-mime nil
+ "*When non-nil post as a MIME attachment."
+ :group 'ges-post
+ :type 'boolean)
+
+(defcustom ges-post-gnus-plugged t
+ "*When non-nil, start Gnus in \"plugged\" mode."
+ :group 'ges-post
+ :type 'boolean)
+
+(defcustom ges-post-advertise t
+ "*When non-nil advertise how the post was generated.
+
+This inserts a line at the top of the article body advertising the
+fact that the post was generated with `ges-post'. Simply set this to
+`nil' to turn this feature off."
+ :type 'boolean
+ :group 'ges-post)
+
+(defcustom ges-post-use-followup-to-header t
+ "*When non-nil, use a Followup-To header.
+
+Sending followups to g.e.s if frowned upon. That group is purely for
+sending source code. For that reason it is recommended that this
+variable be left at its default value."
+ :type 'boolean
+ :group 'ges-post)
+
+(defcustom ges-post-default-followup 'auto
+ "What to set the Followup-To header to on posts to g.e.s.
+
+Sending followups to g.e.s is frowned upon. That group is purely for
+sending source code. Use this variable to set an appropriate group
+for followups to your posts.
+
+The default value auto causes ges-post to use one of the groups in
+`ges-post-possible-followup-groups'. It uses the first one in that
+list that you are subscribed to. If you are not subscribe d to any of
+those groups then a Followup-To header will not be set."
+ :type '(choice
+ (symbol :tag "Automatic" auto)
+ (string :tag "gnu.emacs.help" :value "gnu.emacs.help")
+ (string :tag "gnu.emacs.gnus" :value "gnu.emacs.gnus")
+ (string :tag "comp.emacs.xemacs" :value "comp.emacs.xemacs")
+ (string :tag "Followups to yourself" :value "poster")
+ (string :tag "Stop it! You'll go blind." :value "gnu.emacs.sex")
+ (string :tag "Other"))
+ :group 'ges-post)
+
+;;;###autoload
+(defun ges-post-version (&optional arg)
+ "Return the current version info for ges-post.
+
+With optional argument ARG, insert version info at point in the current
+buffer."
+ (interactive "P")
+ (let (ver)
+ (with-temp-buffer
+ (erase-buffer)
+ (insert-file (locate-library "ges-post.el"))
+ (setq ver (lm-version)))
+ (if (interactive-p)
+ (if arg
+ (insert (format "ges-post v%s" ver))
+ (message "ges-post v%s" ver))
+ ver)))
+
+;;;###autoload
+(defun ges-post-commentary ()
+ "*Display the commentary section of ges-post.el."
+ (interactive)
+ (with-electric-help
+ '(lambda ()
+ (insert
+ (with-temp-buffer
+ (erase-buffer)
+ (insert (lm-commentary (locate-library "ges-post.el")))
+ (goto-char (point-min))
+ (while (re-search-forward "^;+ ?" nil t)
+ (replace-match "" nil nil))
+ (buffer-string (current-buffer)))))
+ "*ges-post Commentary*"))
+
+;;;###autoload
+(defun ges-post-copyright ()
+ "*Display the copyright notice for ges-post."
+ (interactive)
+ (with-electric-help
+ '(lambda ()
+ (insert
+ (with-temp-buffer
+ (erase-buffer)
+ (insert-file-contents (locate-library "ges-post.el"))
+ (goto-char (point-min))
+ (re-search-forward ";;; Commentary" nil t)
+ (beginning-of-line)
+ (narrow-to-region (point-min) (point))
+ (while (re-search-backward "^;+ ?" nil t)
+ (replace-match "" nil nil))
+ (buffer-string (current-buffer)))))
+ "*ges-post Copyright Notice*"))
+
+(defconst ges-post-advertising-blurb
+ (concat
+ "(Automatically generated with ges-post.el, version "
+ (ges-post-version)
+ ")\n\n")
+ "Blowing our own trumpet.")
+
+(defconst ges-post-possible-followup-groups '("gnu.emacs.help"
+ "gnu.emacs.gnus"
+ "comp.emacs.xemacs")
+ "List of groups that are possible candidates for Followup-To header.
+
+As used in ges-post articles.")
+
+(defun ges-post-compute-followup-header ()
+ "Compute a value for the Followup-To header.
+
+If `ges-post-default-followup' is non-nil, use that value. Otherwise
+use the first group in `ges-post-possible-followup-groups' that you
+are subscribed to.
+
+Returns either a name of a group as a string, or `nil'."
+ (let* ((possibles ges-post-possible-followup-groups)
+ (default ges-post-default-followup)
+ (method (gnus-find-method-for-group "gnu.emacs.sources"))
+ (known-groups (gnus-groups-from-server method))
+ result done)
+ (if (not (eq default 'auto))
+ (progn
+ (setq result default)
+ (when (and (not (string= default "poster"))
+ (not (member default known-groups)))
+ (unless (y-or-n-p (format "You are not subscribed to %s, use anyway? "
+ default))
+ (setq result nil)))
+ result)
+ (while (and possibles (not done))
+ (when (member (car possibles) known-groups)
+ (setq result (car possibles)
+ done t))
+ (setq possibles (cdr possibles)))
+ result)))
+
+(defun ges-post-current-buffer ()
+ "Prepare a posting of current buffer to gnu.emacs.sources.
+Point will be placed before first line so that you can add some
+comments."
+ (interactive)
+ (let* ((mybuf (current-buffer))
+ (name (or (lm-get-package-name)
+ (read-string "Package name: ")))
+ (summary (or (lm-summary)
+ (read-string "Short one-line description of package: ")))
+ (version (or (lm-version)
+ (read-string "Package version: ")))
+ (shortname (file-name-sans-extension name))
+ (subject (concat shortname " " version " -- " summary)))
+ ;; If Gnus isn't running, start it.
+ (unless (gnus-alive-p)
+ (if ges-post-gnus-plugged
+ (gnus)
+ (gnus-unplugged)))
+ (gnus-group-post-news 1)
+ (unless (message-field-value "Newsgroups")
+ (message-goto-newsgroups)
+ (insert "gnu.emacs.sources"))
+ (message-goto-subject)
+ (insert subject)
+ (when (and (ges-post-compute-followup-header)
+ (not (message-field-value "Followup-To"))
+ ges-post-use-followup-to-header)
+ (message-goto-followup-to)
+ (insert (format "%s" (ges-post-compute-followup-header))))
+ (message-goto-body)
+ (if ges-post-use-mime
+ (mml-insert-empty-tag 'part
+ 'type "application/emacs-lisp"
+ 'buffer (buffer-name mybuf)
+ 'disposition "inline"
+ 'description name)
+ (insert-buffer mybuf))
+ (when ges-post-advertise
+ (message-goto-body)
+ (insert ges-post-advertising-blurb))
+ (when (featurep 'font-lock) (font-lock-fontify-buffer))
+ (if (y-or-n-p "Do you wish to add/alter anything before sending? ")
+ (message-goto-body)
+ (message-send-and-exit))))
+
+(defalias 'ges-post 'ges-post-current-buffer)
+
+;;;###autoload
+(defun ges-post-file (file)
+ "Post an emacs lisp file to gnu.emacs.sources via Gnus."
+ (interactive "fEmacs lisp file to post to g.e.s: ")
+ (let ((buf (find-file-noselect file)))
+ (set-buffer buf)
+ (ges-post)
+ (kill-buffer buf)))
+
+(define-key emacs-lisp-mode-map "\M-\C-g" 'ges-post-current-buffer)
+
+;;;###autoload(add-hook 'emacs-lisp-mode-hook '(lambda () (require 'ges-post)))
+
+(provide 'ges-post)
+
+;;; ges-post.el ends here
+
+;Local Variables:
+;time-stamp-start: "Last-Modified:[ ]+\\\\?[\"<]+"
+;time-stamp-end: "\\\\?[\">]"
+;time-stamp-line-limit: 15
+;time-stamp-format: "%4y-%02m-%02d %02H:%02M:%02S (%u)"
+;End:
--- /dev/null
+;; google-query.el --- Query Google from within XEmacs. -*- Emacs-Lisp -*-
+
+;; Copyright (C) 2003, 2004 Steve Youngs
+
+;; Author: Steve Youngs <sryoungs@bigpond.net.au>
+;; Maintainer: Steve Youngs <sryoungs@bigpond.net.au>
+;; Created: <2003-12-16>
+;; Keywords: web google search query
+
+;; This file is part of google-query.
+
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions
+;; are met:
+;;
+;; 1. Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; 2. Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;;
+;; 3. Neither the name of the author nor the names of any contributors
+;; may be used to endorse or promote products derived from this
+;; software without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR
+;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+;; DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
+;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
+;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
+;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
+;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+;;; Commentary:
+;;
+;; I got the idea for this from Erik Arneson's `google-search.el'
+;; which you can get from <http://erik.arneson.org/google-search.el>
+;;
+;; There are 2 entry points here, `google-query' and
+;; `google-query-region'. The former will prompt for a string to
+;; query Google for, and the latter will query Google for whatever
+;; text is in the active region in the current buffer. Bind these
+;; functions to some global keys for convenience.
+;;
+;; Once the query completes XEmacs pops up a buffer containing
+;; the query results, sans all the cruft an advertising you get
+;; from Google. Hitting button2 or RET on a URL will fire up your
+;; default browser with that URL.
+
+;;; Todo:
+;;
+;;
+
+;;; ChangeLog:
+;;
+;; From this point on, `google-query.el' is in the XEmacs packages
+;; CVS repository. For further changes please consult
+;; ./xemacs-packages/net-utils/ChangeLog.
+;;
+;; Revision 1.4 2003-12-16 23:15:46+10 steve
+;; Deactivate the region after sending the query from
+;; `google-query-region' because processing the results works on
+;; regions.
+;;
+;; Revision 1.3 2003-12-16 18:38:10+10 steve
+;; Rename `google-search-version' to `google-query-version'.
+;;
+;; Revision 1.2 2003-12-16 18:24:50+10 steve
+;; Fix a couple of byte-compiler warnings.
+;;
+;; Revision 1.1 2003-12-16 17:10:03+10 steve
+;; Initial revision
+;;
+
+;;; Code:
+(defconst google-query-version 1.9
+ "Version number of google-query.el.")
+
+(defun google-query-version (&optional arg)
+ "Return the current version info for google-query.
+
+With optional argument ARG, insert version info at point in the current
+buffer."
+ (interactive "P")
+ (let ((ver google-query-version))
+ (if (interactive-p)
+ (if arg
+ (insert (format "Google Query v%.1f" ver))
+ (message "Google Query v%.1f" ver))
+ ver)))
+
+(eval-and-compile
+ (autoload 'with-electric-help "ehelp")
+ (autoload 'browse-url "browse-url" nil t))
+
+(defgroup google nil
+ "Why leave XEmacs just to search Google..."
+ :prefix "google-"
+ :group 'hypermedia)
+
+(defcustom google-query-maxlen 100
+ "Maximum string length of query string.
+
+This prevents you from accidentally sending a five megabyte query
+string to Google.
+
+You can set this reasonably high, all the same. I think the maximum
+length that Google can take is 2048 characters."
+ :type 'number
+ :group 'google)
+
+(defcustom google-query-result-count 10
+ "Max number of results to return from a `google-query'."
+ :type 'number
+ :group 'google)
+
+(defcustom google-query-mirror "www.google.com"
+ "*Your favourite Google mirror.
+
+Omit the \"http://\" part, all we want here is a domain."
+ :type 'string
+ :group 'google)
+
+(defcustom google-query-debug nil
+ "When non-nil keep the process buffer around."
+ :type 'boolean
+ :group 'google)
+
+(defun google-query-commentary ()
+ "*Display the commentary section of google-query.el."
+ (interactive)
+ (with-electric-help
+ '(lambda ()
+ (insert
+ (with-temp-buffer
+ (erase-buffer)
+ (insert (lm-commentary (locate-library "google-query.el")))
+ (goto-char (point-min))
+ (while (re-search-forward "^;+ ?" nil t)
+ (replace-match "" nil nil))
+ (buffer-string (current-buffer)))))
+ "*Google-query Commentary*"))
+
+(defun google-query-copyright ()
+ "*Display the copyright notice for google-query."
+ (interactive)
+ (with-electric-help
+ '(lambda ()
+ (insert
+ (with-temp-buffer
+ (erase-buffer)
+ (insert-file-contents (locate-library "google-query.el"))
+ (goto-char (point-min))
+ (re-search-forward ";;; Commentary" nil t)
+ (beginning-of-line)
+ (narrow-to-region (point-min) (point))
+ (while (re-search-backward "^;+ ?" nil t)
+ (replace-match "" nil nil))
+ (buffer-string (current-buffer)))))
+ "*Google-query Copyright Notice*"))
+
+;; Ripped from thingatpt.el
+(defconst google-query-url-regexp
+ (concat
+ "\\(https?://\\|ftp://\\|gopher://\\|telnet://\\|wais://\\|file:/\\|s?news:\\|mailto:\\)"
+ "[^]\t\n \"'()<>[^`{}]*[^]\t\n \"'()<>[^`{}.,;]+")
+ "A regular expression matching URLs.")
+
+(defun google-query-url-at-point ()
+ "Browse to a URL from the google-query buffer."
+ (interactive)
+ (when (extentp (extent-at (point)))
+ (browse-url (extent-string (extent-at (point))))))
+
+(defun google-query-url-at-mouse (event)
+ "Browse to a URL at EVENT via the mouse from the google-query buffer."
+ (interactive "e")
+ (when (extentp (extent-at-event event))
+ (browse-url (extent-string (extent-at-event event)))))
+
+(defun google-query-kill-buffer ()
+ (interactive)
+ (kill-buffer nil))
+
+(defconst google-query-mode-map
+ (let* ((map (make-sparse-keymap 'google-query-mode-map)))
+ (define-key map [space] 'scroll-up)
+ (define-key map [delete] 'scroll-down)
+ (define-key map [q] 'bury-buffer)
+ (define-key map [Q] 'google-query-kill-buffer)
+ map)
+ "A keymap for the google query buffer.")
+
+(defconst google-query-ext-map
+ (let* ((map (make-sparse-keymap 'google-query-ext-map)))
+ (define-key map [button2] 'google-query-url-at-mouse)
+ (define-key map [return] 'google-query-url-at-point)
+ map)
+ "A keymap for the extents in google query results buffer.")
+
+;; Unashamedly stolen from Bill Perry's URL package.
+(defconst google-query-unreserved-chars
+ '(?a ?b ?c ?d ?e ?f ?g ?h ?i ?j ?k ?l ?m ?n ?o ?p ?q ?r ?s ?t ?u ?v ?w ?x ?y ?z
+ ?A ?B ?C ?D ?E ?F ?G ?H ?I ?J ?K ?L ?M ?N ?O ?P ?Q ?R ?S ?T ?U ?V ?W ?X ?Y ?Z
+ ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9
+ ?- ?_ ?. ?! ?~ ?* ?' ?\( ?\))
+ "A list of characters that are _NOT_ reserved in the URL spec.
+This is taken from RFC 2396.")
+
+;; Unashamedly stolen from Bill Perry's URL package.
+(defun google-query-hexify-string (str)
+ "Escape characters STR so STR can be used in a URL."
+ (mapconcat
+ (lambda (char)
+ ;; Fixme: use a char table instead.
+ (if (not (memq char google-query-unreserved-chars))
+ (if (< char 16)
+ (format "%%0%X" char)
+ (if (> char 255)
+ (error "Hexifying multibyte character %s" str))
+ (format "%%%X" char))
+ (char-to-string char)))
+ str ""))
+
+(defun google-query-make-url-extents ()
+ "Create extent objects for all the URLs in the buffer."
+ (goto-char (point-min))
+ (save-excursion
+ (while (re-search-forward google-query-url-regexp nil t)
+ (let ((extent (make-extent (match-beginning 0) (match-end 0)))
+ (echo "RET or Button2 to visit this URL."))
+ (set-extent-property extent 'face 'bold)
+ (set-extent-property extent 'mouse-face 'highlight)
+ (set-extent-property extent 'keymap google-query-ext-map)
+ (set-extent-property extent 'help-echo echo)
+ (set-extent-property extent 'balloon-help echo)
+ (set-extent-property extent 'duplicable t)))))
+
+(defun google-query-mode ()
+ "Major mode for google-query results buffer.
+\\{google-query-mode-map}"
+ (interactive)
+ (kill-all-local-variables)
+ (use-local-map google-query-mode-map)
+ (setq mode-name "Google")
+ (setq major-mode 'google-query-mode))
+
+(defun google-query-process-results (results)
+ "Process the RESULTS of `google-query'."
+ (let ((buf (get-buffer-create "*google-query-results*"))
+ matches
+ titles)
+ (switch-to-buffer buf)
+ (google-query-mode)
+ (erase-buffer)
+ (insert results)
+ ;; Collect the stuff we want.
+ (goto-char (point-max))
+ (while (re-search-backward "<a href=\"\\(.*\\)\" class=l>\\(.*\\)</a>" nil t)
+ (setq matches (push (match-string 1) matches)
+ titles (push (match-string 2) titles)))
+ ;; Replace the contents of the buffer with our matches.
+ (erase-buffer)
+ (insert "Google Query Results\n====================\n\n")
+ (while matches
+ (insert (car titles) "\n" (car matches))
+ (insert "\n\n")
+ (setq titles (cdr titles)
+ matches (cdr matches)))
+ (goto-char (point-min))
+ (center-line 2)
+ (mapcar
+ #'(lambda (x) (save-excursion (eval x)))
+ '((replace-string "<b>" " ")
+ (replace-string "</b>" "")
+ (replace-regexp "<.*>" " ")
+ (replace-string ">" " ")))
+ (save-excursion
+ (fill-region (point) (point-max)))
+ (google-query-make-url-extents)))
+
+;;;###autoload
+(defun google-query (string)
+ "Query google for STRING."
+ (interactive "sQuery Google for: ")
+ (let* ((host google-query-mirror)
+ (user-agent (concat (if (featurep 'sxemacs)
+ "SXEmacs-"
+ "XEmacs-")
+ emacs-program-version))
+ (str (google-query-hexify-string
+ (truncate-string-to-width string google-query-maxlen)))
+ (query (concat "search?&q=" str
+ "&num=" (format "%d" google-query-result-count)))
+ (coding-system-for-read 'binary)
+ (coding-system-for-write 'binary)
+ (google (open-network-stream
+ "google-query"
+ " *google-query-proc*"
+ host
+ 80))
+ (pbuf (process-buffer google)))
+ (process-send-string
+ google
+ (concat "GET /" query " HTTP/1.1\r\n"
+ "MIME-Version: 1.0\r\n"
+ "Connection: close\r\n"
+ "Host: " host "\r\n"
+ "Accept: */*\r\n"
+ "User-Agent: " user-agent "\r\n\r\n"))
+ (message "Talking to Google, please wait...")
+ (while (eq (process-status google) 'open)
+ (sleep-for 0.05))
+ (google-query-process-results (buffer-string pbuf))
+ (unless google-query-debug
+ (kill-buffer pbuf))))
+
+;;;###autoload
+(defun google-query-region (beg end)
+ "Query google for the string BEG END."
+ (interactive "r")
+ (let ((str (buffer-substring-no-properties beg end)))
+ (zmacs-deactivate-region)
+ (google-query str)))
+
+(provide 'google-query)
+;;; google-query.el ends here
--- /dev/null
+;; hddtemp.el --- Display hard disc temperatures -*- Emacs-Lisp -*-
+
+;; Copyright (C) 2008 Steve Youngs
+
+;; Author: Steve Youngs <steve@sxemacs.org>
+;; Maintainer: Steve Youngs <steve@sxemacs.org>
+;; Created: <2008-08-13>
+;; Time-stamp: <Wednesday Aug 13, 2008 16:39:01 steve>
+;; Homepage:
+;; Keywords: sensor
+
+;; This file is part of hddtemp.
+
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions
+;; are met:
+;;
+;; 1. Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; 2. Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;;
+;; 3. Neither the name of the author nor the names of any contributors
+;; may be used to endorse or promote products derived from this
+;; software without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR
+;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+;; DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
+;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
+;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
+;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
+;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+;;; Commentary:
+;;
+;; Just a bit of fun hacking to display hard disc temperatures. This
+;; requires a util called "hddtemp" to be running in daemon mode. You
+;; can get it from <http://savannah.nongnu.org/projects/hddtemp/>.
+
+;;; Todo:
+;;
+;; o Clean up the butt-ugly let form in #'hddtemp
+
+;;; Code:
+(require 'cl-loop)
+(put 'cl:dotimes 'lisp-indent-function 'defun)
+
+(defvar hddtemp-hash (make-hash-table :test #'equal :size 4)
+ "A hash-table to hold the temp values.")
+
+(defun hddtemp-filt (proc string)
+ "Process the output from `hddtemp-proc'."
+ (let* ((data (remove "" (split-string-by-char string ?|)))
+ (iterations (/ (length data) 4)))
+ (cl:dotimes (i (declare-boundp iterations))
+ (setq i (number-to-string i))
+ (puthash (concat "dev-" i) (car data) hddtemp-hash)
+ (puthash (concat "mod-" i) (cadr data) hddtemp-hash)
+ (puthash (concat "tmp-" i) (caddr data) hddtemp-hash)
+ (puthash (concat "c/f-" i) (cadddr data) hddtemp-hash)
+ (setq data (cddddr data)))))
+
+(defun hddtemp-proc ()
+ "Connect to the hddtemp daemon."
+ (let ((proc (open-network-stream "hdt" nil "localhost" 7634)))
+ (set-process-filter proc #'hddtemp-filt)))
+
+(defun hddtemp-init ()
+ "Initialise an itimer to perodically grab hd temps."
+ (let ((htimer (get-itimer "hddtemp")))
+ (and htimer (delete-itimer htimer))
+ (start-itimer "hddtemp" #'hddtemp-proc 60 60)))
+
+(defun hddtemp (&optional disc)
+ "Display the current temperature of DISC.
+
+Argument DISC is a numeric prefix arg, if omitted the first hard disc
+temp is displayed. Counting begins at zero."
+ (interactive "p")
+ (let* ((disc (if (interactive-p)
+ (or (and (eq disc 1) (null current-prefix-arg)
+ "0")
+ (and current-prefix-arg
+ (number-to-string current-prefix-arg)))
+ (if disc
+ (number-to-string disc)
+ "0")))
+ (dev (concat "dev-" disc))
+ (mod (concat "mod-" disc))
+ (tmp (concat "tmp-" disc))
+ (c/f (concat "c/f-" disc))
+ (msg (format "%s (%s): %s°%s"
+ (gethash dev hddtemp-hash)
+ (gethash mod hddtemp-hash)
+ (gethash tmp hddtemp-hash)
+ (gethash c/f hddtemp-hash))))
+ (unless (gethash dev hddtemp-hash)
+ (error 'invalid-argument (format "No such disc: %s" disc)))
+ (if (interactive-p)
+ (message msg)
+ (list (gethash dev hddtemp-hash)
+ (gethash mod hddtemp-hash)
+ (gethash tmp hddtemp-hash)
+ (gethash c/f hddtemp-hash)))))
+
+
+(provide 'hddtemp)
+
+;; On-load actions
+(hddtemp-proc)
+(hddtemp-init)
+
+;;; hddtemp.el ends here
--- /dev/null
+;; linux-kernel.el --- Linux kernel related bits 'n' pieces -*- Emacs-Lisp -*-
+
+;; Copyright (C) 2003 Steve Youngs
+
+;; RCS: $Id: linux-kernel.el,v 1.1 2003-12-15 08:39:02+10 steve Exp $
+;; Author: Steve Youngs <sryoungs@bigpond.net.au>
+;; Maintainer: Steve Youngs <sryoungs@bigpond.net.au>
+;; Created: <2003-12-15>
+;; Last-Modified: <2003-12-15 08:38:58 (steve)>
+;; Homepage: None
+;; Keywords: kernel linux
+
+;; This file is part of linux-kernel.
+
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions
+;; are met:
+;;
+;; 1. Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; 2. Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;;
+;; 3. Neither the name of the author nor the names of any contributors
+;; may be used to endorse or promote products derived from this
+;; software without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR
+;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+;; DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
+;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
+;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
+;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
+;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+;;; Commentary:
+;;
+;; Here is a collection of things I find useful in the land of Linux
+;; kernels.
+;;
+;; Currently implemented features:
+;;
+;; - Check the latest kernel versions `linux-kernel-check-latest'
+
+;;; Todo:
+;;
+;; o View kernel ChangeLog-<version> files.
+;;
+;; o Download official kernel patches (possibly entire kernels
+;; too).
+;;
+;; o Apply/revert patches to local workspace.
+;;
+;; o Create a TAGS table file that will actually work in XEmacs
+;; (the kernel's `make tags' doesn't work for me and my XEmacs
+;; :-( ).
+;;
+;; o Ensure that cc-mode is set up the way Linus likes when hacking
+;; the kernel.
+;;
+;; o Configure the kernel from within XEmacs
+;; (`make ([xg]|menu)?config').
+
+;;; ChangeLog:
+;;
+;; $Log: linux-kernel.el,v $
+;; Revision 1.1 2003-12-15 08:39:02+10 steve
+;; Initial revision
+;;
+
+;;; Code:
+(eval-and-compile
+ (require 'working)
+ (autoload 'with-electric-help "ehelp"))
+
+;;;###autoload
+(defun linux-kernel-commentary ()
+ "*Display the commentary section of linux-kernel.el."
+ (interactive)
+ (with-electric-help
+ '(lambda ()
+ (insert
+ (with-temp-buffer
+ (erase-buffer)
+ (insert (lm-commentary (locate-library "linux-kernel.el")))
+ (goto-char (point-min))
+ (while (re-search-forward "^;+ ?" nil t)
+ (replace-match "" nil nil))
+ (buffer-string (current-buffer)))))
+ "*Linux-Kernel Commentary*"))
+
+;;;###autoload
+(defun linux-kernel-copyright ()
+ "*Display the copyright notice for Linux-Kernel."
+ (interactive)
+ (with-electric-help
+ '(lambda ()
+ (insert
+ (with-temp-buffer
+ (erase-buffer)
+ (insert-file-contents (locate-library "linux-kernel.el"))
+ (goto-char (point-min))
+ (re-search-forward ";;; Commentary" nil t)
+ (beginning-of-line)
+ (narrow-to-region (point-min) (point))
+ (while (re-search-backward "^;+ ?" nil t)
+ (replace-match "" nil nil))
+ (buffer-string (current-buffer)))))
+ "*Linux-Kernel Copyright Notice*"))
+
+;;;###autoload
+(defun linux-kernel-check-latest ()
+ "Display a list of the latest kernel versions."
+ (interactive)
+ (let* ((host "www.kernel.org")
+ (dir "/kdist/")
+ (file "finger_banner")
+ (path (concat dir file))
+ (coding-system-for-read 'binary)
+ (coding-system-for-write 'binary)
+ (user-agent (concat "XEmacs " emacs-program-version))
+ (http
+ (open-network-stream
+ "latest-kernel-proc"
+ " *kernel-proc-buf*"
+ host
+ 80))
+ (pbuf (process-buffer http))
+ (obuf (get-buffer-create "*Latest Kernels*")))
+ (process-send-string
+ http
+ (concat "GET " path " HTTP/1.1\r\n"
+ "MIME-Version: 1.0\r\n"
+ "Connection: close\r\n"
+ "Extension: Security/Digest Security/SSL\r\n"
+ "Host: " host "\r\n"
+ "Accept: */*\r\n"
+ "User-Agent: " user-agent "\r\n\r\n"))
+ (working-status-forms "Checking Kernel Version: " "Done!"
+ (while (eq (process-status http) 'open)
+ (working-dynamic-status nil)
+ (sleep-for 0.05))
+ (working-dynamic-status t))
+ (with-electric-help
+ '(lambda ()
+ (insert
+ (with-current-buffer pbuf
+ (goto-char (point-min))
+ (while (re-search-forward "\r" nil t) nil)
+ (kill-region (point-min) (point))
+ (insert "The Latest Linux Kernels\n========================\n\n")
+ (goto-char (point-min))
+ (center-line 2)
+ (re-search-forward "^Process.*$" nil t)
+ (replace-match "")
+ (buffer-string (current-buffer)))))
+ obuf)
+ (kill-buffer pbuf)))
+
+(provide 'linux-kernel)
+;;; linux-kernel.el ends here
+
+;Local Variables:
+;time-stamp-start: "Last-Modified:[ ]+\\\\?[\"<]+"
+;time-stamp-end: "\\\\?[\">]"
+;time-stamp-line-limit: 10
+;time-stamp-format: "%4y-%02m-%02d %02H:%02M:%02S (%u)"
+;End:
--- /dev/null
+;; lj.el --- LiveJournal meets SXEmacs -*- Emacs-Lisp -*-
+
+;; Copyright (C) 2008, 2009 Steve Youngs
+
+;; Author: Steve Youngs <steve@sxemacs.org>
+;; Maintainer: Steve Youngs <steve@sxemacs.org>
+;; Created: <2008-06-15>
+;; Based On: jwz-lj.el by Jamie Zawinski <jwz@jwz.org>
+;; Keywords: blog, lj, livejournal
+;; Homepage: <http://www.sxemacs.org/~steve/lj/lj.el>
+
+;; This file is part of SLH (Steve's Lisp Hacks).
+
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions
+;; are met:
+;;
+;; 1. Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; 2. Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;;
+;; 3. Neither the name of the author nor the names of any contributors
+;; may be used to endorse or promote products derived from this
+;; software without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR
+;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+;; DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
+;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
+;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
+;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
+;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+;;; Commentary:
+;;
+;; First up, let me say that this would not have been possible if
+;; it weren't for JWZ's jwz-lj.el. In fact, large portions of
+;; lj.el were lifted directly from jwz-lj.el. So, thank you very
+;; much, Jamie!
+;;
+;;; *** IMPORTANT BIT ***
+;;
+;; You MUST compose your LJ posts in raw HTML (XHTML 1.0 Transitional
+;; if you plan on validating the markup before you submit the post).
+;; Don't bitch and complain about how hard or inconvenient that is.
+;; I'm not listening. The buffer where you write your posts is in a
+;; derivative of html-mode so you've got everything you need right at
+;; your fingertips. And anyway, writing your LJ posts in raw HTML
+;; gives you much more control over what the finished post will look
+;; like.
+;;
+;; Another important step before you can use lj.el is to log into
+;; your LiveJournal a/c with your web browser and check the "remember
+;; me" box on the login page. This is the only way to have your
+;; password stored in your cookies. Don't worry, it is encrypted.
+;;
+;;; Install/Set Up:
+;;
+;; Whack this lib into your load-path somewhere and...
+;; (require 'lj)
+;; (setq lj-user-id "your_lj_id")
+;;
+;; When you want to compose a new LJ entry... M-x lj RET
+;;
+;; There's nothing hard or overly complicated here. Take a look at
+;; describe-mode (`C-h m') which will show you the keybindings
+;; available. All of the "lj-mode specific" interactive commands
+;; have a binding. There are 3 "global" commands that don't...
+;;
+;; #'lj
+;; #'lj-blog-buffer
+;; #'lj-blog-region
+;;
+;; The only reason they don't have keybindings is that I think it'd
+;; be bad form on my part to set global keys for you. Assign them
+;; to keys if you want.
+;;
+;; All of the "headers" have completion too. A couple of tips
+;; about the completion...
+;;
+;; - By default iso-left-tab (that's shift-tab for the clueless)
+;; will cycle backwards.
+;;
+;; - The trick to getting multiple tags is to type a comma (`,')
+;; plus the first letter or two of the next tag you wanna use
+;; after the last inserted tag.
+;;
+;;; Twitter:
+;;
+;; You can optionally post the subject header of your blog entry as
+;; a status update to Twitter, along with a URL to the entry on
+;; livejournal.com. To do so, you must set...
+;;
+;; `lj-twitter-flag'
+;; `lj-twitter-username'
+;; `lj-twitter-password'
+;;
+;; The down side to this is that your twitter username and password
+;; are stored in clear text. I'll work on a way to make that safer
+;; later.
+;;
+;; Have fun with it!
+
+;;; Todo:
+;;
+;; o Make "Writer's Block" a bit friendlier. Add the ability to
+;; choose different qotd's after one has been selected. Also, be
+;; able to view older qotd's.
+;;
+;; o Find a way to pre-fill the subject header properly for writer's
+;; block.
+;;
+;; o Find a better way than clear text to store twitter username/passwd.
+;;
+
+;;; Bugs:
+;;
+;; I've tried to make this compatible with XEmacs 21.5 and 21.4,
+;; but I don't have either of those installed so I'm not 100%
+;; certain. As for GNU/Emacs... absolutely no idea, but I'd doubt
+;; that this is anywhere near compatible.
+;;
+;;; History:
+;;
+;; See the tla logs
+;;
+
+;;; Version:
+(defconst lj-version 1.23
+ "Version number of SXEmacs/LJ.")
+
+;;; Code:
+(eval-when-compile
+ (autoload #'html-mode "psgml-html" nil t)
+ (autoload #'executable-find "executable")
+ (autoload #'completing-read-multiple "crm")
+ (autoload #'sgml-indent-or-tab "psgml" nil t)
+ (autoload #'sgml-parse-prolog "psgml-parse" nil t)
+ (autoload #'sgml-validate "psgml" nil t)
+ (autoload #'sgml-default-validate-command "psgml")
+ (autoload #'browse-url-of-buffer "browse-url" nil t)
+ (autoload #'customize-apropos "cus-edit" nil t)
+ (autoload #'customize-group "cus-edit" nil t)
+ (autoload #'regexp-opt "regexp-opt")
+ (autoload #'sqlite-open "ffi-sqlite")
+ (autoload #'sqlite-rows "ffi-sqlite")
+ (autoload #'sqlite-close "ffi-sqlite")
+ (autoload #'url-cookie-retrieve "url-cookie")
+ (autoload #'url-cookie-name "url-cookie")
+ (autoload #'url-cookie-value "url-cookie")
+ (defvar sxemacs-codename)
+ (defvar xemacs-codename)
+ (defvar url-cookie-secure-storage)
+ (defvar url-cookie-file))
+
+(eval-and-compile
+ (require 'hm--html-configuration)
+ (require 'psgml-html)
+ (require 'font-lock)
+ (unless (fboundp #'when-fboundp)
+ (require 'bytedecl))
+ (autoload #'mm-url-insert "mm-url"))
+
+(defgroup lj nil
+ "LiveJournal"
+ :prefix "lj-"
+ :link '(url-link "http://www.livejournal.com/")
+ :group 'hypermedia)
+
+(defgroup lj-twitter nil
+ "LiveJournal meets Twitter"
+ :prefix "lj-twitter-"
+ :link '(url-link "http://www.livejournal.com/")
+ :link '(url-link "http://twitter.com/")
+ :group 'lj)
+
+(defun lj-customise-faces ()
+ "Customise the lj.el faces."
+ (interactive)
+ (customize-apropos "^lj-" 'faces))
+
+(defun lj-customise-group ()
+ "Customise lj.el user options."
+ (interactive)
+ (customize-group "lj"))
+
+(defcustom lj-user-id (user-login-name)
+ "*Your LJ user ID."
+ :type 'string
+ :group 'lj)
+
+(defcustom lj-cookie-flavour 'auto
+ "*The default cookie flavour \(browser\) to search for cookies."
+ :type '(choice
+ (symbol :tag "Automatic" :value auto)
+ (symbol :tag "Chrome" :value chrome)
+ (symbol :tag "Firefox" :value firefox)
+ (symbol :tag "Seamonkey" :value seamonkey)
+ (symbol :tag "Mozilla" :value mozilla)
+ (symbol :tag "Galeon" :value galeon)
+ (symbol :tag "Safari" :value safari)
+ (symbol :tag "Netscape" :value netscape)
+ (symbol :tag "Midori" :value midori)
+ (symbol :tag "Emacs-W3" :value w3))
+ :group 'lj)
+
+(defcustom lj-default-security-level "public"
+ "*The default security level LJ posts will have."
+ :type '(choice
+ (string :tag "Public" :value "public")
+ (string :tag "Private" :value "private")
+ (string :tag "All Friends" :value "usemask")
+ (string :tag "Group..."))
+ :group 'lj)
+
+(defcustom lj-directory (paths-construct-path
+ (list (user-home-directory) ".lj"))
+ "*Directory for storing tags and archiving posts."
+ :type 'directory
+ :group 'lj)
+
+(defcustom lj-tags-file (expand-file-name "ljtags" lj-directory)
+ "*File to store list of LJ tags."
+ :type 'file
+ :group 'lj)
+
+(defcustom lj-groups-file (expand-file-name "ljgrps" lj-directory)
+ "*File to store list of LJ friends groups."
+ :type 'file
+ :group 'lj)
+
+(defcustom lj-moods-file (expand-file-name "ljmoods" lj-directory)
+ "*File to store list of LJ \"moods\"."
+ :type 'file
+ :group 'lj)
+
+(defcustom lj-pickws-file (expand-file-name "pickws" lj-directory)
+ "*File to store list of LJ user picture keywords."
+ :type 'file
+ :group 'lj)
+
+(defcustom lj-userpic-directory
+ (file-name-as-directory
+ (expand-file-name "images" lj-directory))
+ "*Directory to store LJ userpic files."
+ :type 'directory
+ :group 'lj)
+
+(defcustom lj-drafts-directory
+ (file-name-as-directory
+ (expand-file-name "drafts" lj-directory))
+ "*Directory where post drafts are stored."
+ :type 'directory
+ :group 'lj)
+
+(defvar lj-tags nil
+ "A list of LJ tags.")
+
+(defvar lj-groups nil
+ "A list of LJ friends groups.")
+
+(defvar lj-moods nil
+ "LiveJournal \"moods\".")
+
+(defvar lj-pickws nil
+ "A list of LJ userpic keywords.")
+
+(defvar lj-default-pickw nil
+ "The default LJ userpic keyword.")
+
+;; See mpd.el in the same repo as lj.el
+(defvar **mpd-var-Title* nil)
+(defvar **mpd-var-Artist* nil)
+(defun lj-music-mpd ()
+ "Return the current song title/artist from mpd."
+ (let ((song (if **mpd-var-Title*
+ (format "%s --- [%s]"
+ **mpd-var-Title*
+ **mpd-var-Artist*)
+ "The Sounds of Silence --- [Marcel Marceau]")))
+ song))
+
+(defcustom lj-music (and (featurep 'mpd) #'lj-music-mpd)
+ "*A function to retrieve current song for LJ music header.
+This function should return a formatted string, or nil."
+ :type 'function
+ :group 'lj)
+
+(defcustom lj-archive-posts nil
+ "*Keep an archive copy of LJ posts when non-nil."
+ :type 'boolean
+ :group 'lj)
+
+(defcustom lj-archive-directory
+ (file-name-as-directory
+ (expand-file-name "archive" lj-directory))
+ "*Directory where LJ posts are archived."
+ :type 'directory
+ :group 'lj)
+
+(defcustom lj-bcc-address nil
+ "*Email address to send a copy of LJ posts to.
+Set to nil to disable."
+ :type 'sexp
+ :group 'lj)
+
+(defcustom lj-default-location nil
+ "*Default for the Location header."
+ :type 'sexp
+ :group 'lj)
+
+(defcustom lj-before-preview-hook nil
+ "*Hook run before previewing a post."
+ :type 'hook
+ :group 'lj)
+
+(defcustom lj-after-preview-hook nil
+ "*Hook run as the last thing from `lj-preview'."
+ :type 'hook
+ :group 'lj)
+
+(defcustom lj-before-validate-hook nil
+ "*Hook run before validating a post."
+ :type 'hook
+ :group 'lj)
+
+(defcustom lj-after-validate-hook nil
+ "*Hook run as the last thing from `lj-validate'."
+ :type 'hook
+ :group 'lj)
+
+(defcustom lj-init-hook nil
+ "*Hook run before anything else is done when starting lj."
+ :type 'hook
+ :group 'lj)
+
+(defcustom lj-before-post-hook nil
+ "*Hook run before posting."
+ :type 'hook
+ :group 'lj)
+
+(defcustom lj-after-post-hook nil
+ "*Hook run after posting."
+ :type 'hook
+ :group 'lj)
+
+(defcustom lj-cut-hook nil
+ "*Hooks run after inserting an LJ-CUT."
+ :type 'hook
+ :group 'lj)
+
+(defcustom lj-poll-hook nil
+ "*Hooks run after inserting a LJ Poll."
+ :type 'hook
+ :group 'lj)
+
+(defcustom lj-journal-hook nil
+ "*Hooks run after inserting a LJ Journal link."
+ :type 'hook
+ :group 'lj)
+
+(defcustom lj-youtube-hook nil
+ "*Hooks run after inserting a youtube/google video."
+ :type 'hook
+ :group 'lj)
+
+(defcustom lj-twitter-flag nil
+ "*Non-nil means to update your twitter status.
+
+The subject header and a URL to the last blog entry is posted to
+twitter as a status update if this is set."
+ :type 'boolean
+ :group 'lj-twitter)
+
+(defcustom lj-twitter-username (user-login-name)
+ "*Your twitter username."
+ :type 'string
+ :group 'lj-twitter)
+
+(defcustom lj-twitter-password "secret"
+ "*Your twitter password."
+ :type 'string
+ :group 'lj-twitter)
+
+(defconst lj-clientversion
+ (concat (when (featurep 'sxemacs) "S")
+ "XEmacs-"
+ emacs-program-version
+ (format "/LJ: %.2f" lj-version))
+ "Client version string.")
+
+(defconst lj-useragent
+ (concat "("
+ (when (featurep 'sxemacs) "S")
+ "XEmacs/"
+ emacs-program-version
+ (format " [%s]:LJ-%.2f; steve@sxemacs.org)"
+ (if (featurep 'sxemacs)
+ sxemacs-codename
+ xemacs-codename)
+ lj-version))
+ "Useragent string sent to livejournal.com.")
+
+(defconst lj-validate-header
+ "<?xml version=\"1.0\" encoding=\"utf-8\"?>
+<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\"
+ \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">
+
+<html xmlns=\"http://www.w3.org/1999/xhtml\" xml:lang=\"en\" lang=\"en\">
+ <head>
+ <title>LJ Post Preview</title>
+
+ <style type=\"text/css\">
+ div.ljhead {
+ background: rgb(204,204,255);
+ padding: 0.5em;
+ border: ridge;
+ borderwidth: thin;
+ font-family: times new roman, verdana, helvetica, sans-serif;
+ font-size: 12pt;
+ font-weight: bold;
+ }
+ div.lj {
+ background: rgb(255,235,205);
+ padding: 0.5em;
+ border: none;
+ }
+ div.ljpoll {
+ color: red;
+ font-weight: bold;
+ }
+ div.ljcut {
+ background: white;
+ padding: 0.5em;
+ border: solid;
+ borderwidth: thin;
+ }
+ </style>
+
+ </head>
+ <body>
+
+"
+ "Header used to construct HTML doc for previewing and validating LJ posts.")
+
+(defconst lj-validate-footer
+ "
+ </body>
+</html>
+
+<!-- Leave this comment at the end of this file
+Local variables:
+sgml-validate-command:\"onsgmls -E0 -wall -wfully-tagged -wfully-declared -s %s %s\"
+sgml-omittag:nil
+sgml-shorttag:nil
+sgml-namecase-general:nil
+sgml-general-insert-case:lower
+sgml-minimize-attributes:nil
+sgml-always-quote-attributes:t
+sgml-indent-step:2
+sgml-indent-data:t
+sgml-parent-document:nil
+sgml-exposed-tags:nil
+sgml-local-catalogs:nil
+sgml-local-ecat-files:nil
+End:
+-->
+"
+ "Footer used to construct HTML doc for previewing and validating LJ posts.")
+
+(defconst lj-base-url
+ "http://www.livejournal.com/interface/flat"
+ "The base URL where LJ posts are submitted etc.")
+
+(defvar lj-last-entry-btime nil
+ "The date/time of the last posted entry as a big integer.")
+
+(defun lj-parse-time-string (string)
+ "Parse a time STRING of the format \"YYYY-MM-DD HH:MM:SS\".
+
+The seconds field can be ommitted and in that case 0 is used.
+
+Returns a list suitable for passing to `encode-time' or `encode-btime'."
+ (let ((regexp (concat "^\\([12][0-9]+\\)-\\([0-9]+\\)-\\([0-9]+\\)\\s-"
+ "\\([0-9]+\\):\\([0-9]+\\)\\(:\\([0-9]+\\)\\)?$")))
+ (if (string-match regexp string)
+ (let ((year (string-to-int (substring string
+ (match-beginning 1)
+ (match-end 1))))
+ (month (string-to-int (substring string
+ (match-beginning 2)
+ (match-end 2))))
+ (day (string-to-int (substring string
+ (match-beginning 3)
+ (match-end 3))))
+ (hour (string-to-int (substring string
+ (match-beginning 4)
+ (match-end 4))))
+ (min (string-to-int (substring string
+ (match-beginning 5)
+ (match-end 5))))
+ (sec (if (eq (length string) 19)
+ (string-to-int (substring string (match-beginning 7)
+ (match-end 7)))
+ 0)))
+ (unless (and (>= year 1970)
+ (<= year 2099))
+ (error 'invalid-argument year))
+ (unless (and (>= month 1)
+ (<= month 12))
+ (error 'invalid-argument month))
+ (unless (and (>= day 1)
+ (<= day 31))
+ (error 'invalid-argument day))
+ (unless (and (>= hour 0)
+ (<= hour 23))
+ (error 'invalid-argument hour))
+ (unless (and (>= min 0)
+ (<= min 59))
+ (error 'invalid-argument min))
+ (unless (and (>= sec 0)
+ (<= sec 59))
+ (error 'invalid-argument sec))
+ (list sec min hour day month year))
+ (error 'invalid-argument string))))
+
+;; Probably should set up a proper prefix
+(defvar lj-mode-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-name map 'lj-mode-map)
+ (define-key map [(control ?c) (control return)] #'lj-post)
+ (define-key map [(control ?c) ?F] #'lj-customise-faces)
+ (define-key map [(control ?c) ?G] #'lj-customise-group)
+ (define-key map [(control ?c) ?P] #'lj-insert-poll)
+ (define-key map [(control ?c) ?c] #'lj-cut-region)
+ (define-key map [(control ?c) ?j] #'lj-insert-journal)
+ (define-key map [(control ?c) ?p] #'lj-preview)
+ (define-key map [(control ?c) ?w] #'lj-writers-block)
+ (define-key map [(control ?c) ?y] #'lj-insert-youtube)
+ (define-key map [(control ?c) (control ?f) ?M] #'lj-goto-mood)
+ (define-key map [(control ?c) (control ?f) ?S] #'lj-goto-security)
+ (define-key map [(control ?c) (control ?f) ?b] #'lj-goto-bcc)
+ (define-key map [(control ?c) (control ?f) ?c] #'lj-goto-community)
+ (define-key map [(control ?c) (control ?f) ?f] #'lj-goto-fcc)
+ (define-key map [(control ?c) (control ?f) ?l] #'lj-goto-location)
+ (define-key map [(control ?c) (control ?f) ?m] #'lj-goto-music)
+ (define-key map [(control ?c) (control ?f) ?s] #'lj-goto-subject)
+ (define-key map [(control ?c) (control ?f) ?t] #'lj-goto-tags)
+ (define-key map [(control ?c) (control ?f) ?u] #'lj-goto-userpic)
+ (define-key map [(control ?c) (control ?b)] #'lj-goto-body)
+ (define-key map [(control meta ?v)] #'lj-validate)
+ (define-key map [tab] #'lj-sgml-indent-tab-or-complete)
+ (define-key map [iso-left-tab] #'lj-complete-header-backwards)
+ map))
+
+(defvar lj-header-separator "--text follows this line--"
+ "Text to denote the end of the headers and beginning of the message.")
+
+;; Faces (defaults are probably crap for a light background)
+(defun lj-face-p (face)
+ "Call facep on FACE."
+ (facep (find-face face)))
+
+(make-face 'lj-header-name "Face used for LJ headers.")
+(set-face-parent 'lj-header-name (or (and (lj-face-p 'message-header-name)
+ 'message-header-name)
+ (and (lj-face-p 'message-header-name-face)
+ 'message-header-name-face)
+ 'bold))
+
+(make-face 'lj-header-subject "Face used for LJ Subject header content.")
+(set-face-parent 'lj-header-subject
+ (or (and (lj-face-p 'message-header-subject)
+ 'message-header-subject)
+ (and (lj-face-p 'message-header-subject-face)
+ 'message-header-subject-face)
+ 'default))
+
+(make-face 'lj-header-fcc "Face used for LJ FCC header content.")
+(set-face-parent 'lj-header-fcc 'font-lock-comment-face)
+(make-face 'lj-header-bcc "Face used for LJ BCC header content.")
+(set-face-parent 'lj-header-bcc (or (and (lj-face-p 'message-header-cc)
+ 'message-header-cc)
+ (and (lj-face-p 'message-header-cc-face)
+ 'message-header-cc-face)
+ 'lj-header-fcc))
+
+(make-face 'lj-header-security "Face used for LJ Security header content.")
+(set-face-parent 'lj-header-security 'font-lock-warning-face)
+
+(make-face 'lj-header-music "Face used for LJ Music header content.")
+(set-face-parent 'lj-header-music
+ (or (and (lj-face-p 'message-header-xheader)
+ 'message-header-xheader)
+ (and (lj-face-p 'message-header-xheader-face)
+ 'message-header-xheader-face)
+ 'font-lock-builtin-face))
+
+(make-face 'lj-header-mood "Face used for LJ Mood header content.")
+(set-face-parent 'lj-header-mood
+ (or (and (lj-face-p 'message-header-other)
+ 'message-header-other)
+ (and (lj-face-p 'message-header-other-face)
+ 'message-header-other-face)
+ 'font-lock-function-name-face))
+
+(make-face 'lj-header-userpic "Face used for LJ Userpic header content.")
+(set-face-parent 'lj-header-userpic
+ (or (and (lj-face-p 'message-header-other)
+ 'message-header-other)
+ (and (lj-face-p 'message-header-other-face)
+ 'message-header-other-face)
+ 'font-lock-function-name-face))
+
+(make-face 'lj-header-tags "Face used for LJ Tags header content.")
+(set-face-parent 'lj-header-tags
+ (or (and (lj-face-p 'message-header-newsgroups)
+ 'message-header-newsgroups)
+ (and (lj-face-p 'message-header-newsgroups-face)
+ 'message-header-newsgroups-face)
+ 'font-lock-keyword-face))
+
+(make-face 'lj-header-community "Face used for LJ Community header content.")
+(set-face-parent 'lj-header-community 'lj-header-userpic)
+
+(make-face 'lj-header-location "Face used for LJ Location header content.")
+(set-face-parent 'lj-header-location 'lj-header-userpic)
+
+(make-face 'lj-separator "Face used for the LJ header separator.")
+(copy-face 'bold 'lj-separator)
+(set-face-foreground 'lj-separator "red")
+
+;; compatibility hoohar
+(unless (featurep 'sxemacs)
+ (fset #'defregexp #'defvar))
+
+(defun lj-utf-emacs-p ()
+ "Return non-nil if this S?XEmacs has utf-8 coding-system."
+ (and (featurep 'mule)
+ (declare-fboundp (find-coding-system 'utf-8))))
+
+(defregexp lj-header-regexp
+ (let ((headers '("Subject" "FCC" "BCC" "Security" "Community"
+ "Location" "Mood" "Music" "Userpic" "Tags")))
+ (concat (regexp-opt headers t) ":"))
+ "Regular expression matching LJ headers.")
+
+(defvar lj-font-lock-keywords
+ (append
+ `((,lj-header-regexp 0 lj-header-name)
+ ("^Subject: \\(.*$\\)" 1 lj-header-subject)
+ ("^FCC: \\(.*$\\)" 1 lj-header-fcc)
+ ("^BCC: \\(.*$\\)" 1 lj-header-bcc)
+ ("^Security: \\(.*$\\)" 1 lj-header-security)
+ ("^Community: \\(.*$\\)" 1 lj-header-community)
+ ("^Music: \\(.*$\\)" 1 lj-header-music)
+ ("^Mood: \\(.*$\\)" 1 lj-header-mood)
+ ("^Location: \\(.*$\\)" 1 lj-header-location)
+ ("^Userpic: \\(.*$\\)" 1 lj-header-userpic)
+ ("^Tags: \\(.*$\\)" 1 lj-header-tags)
+ (,(regexp-quote lj-header-separator) 0 lj-separator))
+ hm--html-font-lock-keywords
+ html-font-lock-keywords)
+ "Font lock keywords for `lj-mode'.")
+
+;; kill/yank'd from jwz-lj.el
+(defconst lj-entity-table
+ '(("iexcl" . ?\¡) ("cent" . ?\¢) ("pound" . ?\£) ("euro" . ?\~)
+ ("curren" . ?\¤) ("yen" . ?\¥) ("brvbar" . ?\¦) ("sect" . ?\§)
+ ("uml" . ?\¨) ("copy" . ?\©) ("ordf" . ?\ª) ("laquo" . ?\«)
+ ("not" . ?\¬) ("shy" . ?\) ("reg" . ?\®) ("macr" . ?\¯)
+ ("deg" . ?\°) ("plusmn" . ?\±) ("sup2" . ?\²) ("sup3" . ?\³)
+ ("acute" . ?\´) ("micro" . ?\µ) ("para" . ?\¶) ("middot" . ?\·)
+ ("cedil" . ?\¸) ("sup1" . ?\¹) ("ordm" . ?\º) ("raquo" . ?\»)
+ ("frac14" . ?\¼) ("frac12" . ?\½) ("frac34" . ?\¾) ("iquest" . ?\¿)
+ ("Agrave" . ?\À) ("Aacute" . ?\Á) ("Acirc" . ?\Â) ("Atilde" . ?\Ã)
+ ("Auml" . ?\Ä) ("Aring" . ?\Å) ("AElig" . ?\Æ) ("Ccedil" . ?\Ç)
+ ("Egrave" . ?\È) ("Eacute" . ?\É) ("Ecirc" . ?\Ê) ("Euml" . ?\Ë)
+ ("Igrave" . ?\Ì) ("Iacute" . ?\Í) ("Icirc" . ?\Î) ("Iuml" . ?\Ï)
+ ("ETH" . ?\Ð) ("Ntilde" . ?\Ñ) ("Ograve" . ?\Ò) ("Oacute" . ?\Ó)
+ ("Ocirc" . ?\Ô) ("Otilde" . ?\Õ) ("Ouml" . ?\Ö) ("times" . ?\×)
+ ("Oslash" . ?\Ø) ("Ugrave" . ?\Ù) ("Uacute" . ?\Ú) ("Ucirc" . ?\Û)
+ ("Uuml" . ?\Ü) ("Yacute" . ?\Ý) ("THORN" . ?\Þ) ("szlig" . ?\ß)
+ ("agrave" . ?\à) ("aacute" . ?\á) ("acirc" . ?\â) ("atilde" . ?\ã)
+ ("auml" . ?\ä) ("aring" . ?\å) ("aelig" . ?\æ) ("ccedil" . ?\ç)
+ ("egrave" . ?\è) ("eacute" . ?\é) ("ecirc" . ?\ê) ("euml" . ?\ë)
+ ("igrave" . ?\ì) ("iacute" . ?\í) ("icirc" . ?\î) ("iuml" . ?\ï)
+ ("eth" . ?\ð) ("ntilde" . ?\ñ) ("ograve" . ?\ò) ("oacute" . ?\ó)
+ ("ocirc" . ?\ô) ("otilde" . ?\õ) ("ouml" . ?\ö) ("divide" . ?\÷)
+ ("oslash" . ?\ø) ("ugrave" . ?\ù) ("uacute" . ?\ú) ("ucirc" . ?\û)
+ ("uuml" . ?\ü) ("yacute" . ?\ý) ("thorn" . ?\þ) ("yuml" . ?\ÿ)
+ ("plusmn" . ?\±))
+ "HTML entities to Latin1 characters.")
+
+;; adapted from jwz-lj.el
+(defun lj-entify-region (beg end)
+ "Convert non-ASCII chars in the region BEG - END to HTML entities."
+ (let ((regex (if (featurep 'sxemacs)
+ "[^[:ascii:]]"
+ ;; ho-hum, life would be simpler if XEmacs enabled
+ ;; char classes
+ (concat "[" (mapconcat
+ #'(lambda (c)
+ (make-string 1 (cdr c)))
+ lj-entity-table nil)
+ "]")))
+ (case-fold-search nil))
+ (save-excursion
+ (goto-char beg)
+ (setq end (copy-marker end))
+ (while (re-search-forward regex end t)
+ (let* ((char (preceding-char))
+ (entity (or (car (rassq char lj-entity-table))
+ (error "No entity %c" char))))
+ (delete-char -1)
+ (insert-before-markers "&" entity ";")))))
+ (and-fboundp #'charsets-in-region
+ (delq 'ascii (charsets-in-region beg end))
+ (error "Non-ASCII characters exist in this buffer")))
+
+(defconst lj-unreserved-chars
+ '(?a ?b ?c ?d ?e ?f ?g ?h ?i ?j ?k ?l ?m
+ ?n ?o ?p ?q ?r ?s ?t ?u ?v ?w ?x ?y ?z
+ ?A ?B ?C ?D ?E ?F ?G ?H ?I ?J ?K ?L ?M
+ ?N ?O ?P ?Q ?R ?S ?T ?U ?V ?W ?X ?Y ?Z
+ ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9
+ ?- ?_ ?. ?! ?~ ?* ?' ?\( ?\))
+ "A list of characters that are _NOT_ reserved in the URL spec.
+This is taken from RFC 2396.")
+
+(defun lj-hexify-string (str &optional http-entify)
+ "Escape characters STR so STR can be used in a URL.
+
+With non-nil HTTP-ENTIFY, convert non-ASCII characters to HTTP
+entities."
+ (with-temp-buffer
+ (insert str)
+ (and http-entify
+ (lj-entify-region (point-min) (point-max)))
+ (mapconcat
+ #'(lambda (char)
+ (if (not (memq char lj-unreserved-chars))
+ (if (< char 16)
+ (format "%%0%X" char)
+ (if (> char 255)
+ (error "Hexifying multibyte character %s" str))
+ (format "%%%X" char))
+ (char-to-string char)))
+ (buffer-string) "")))
+
+(when-fboundp #'ffi-defun
+ (ignore-errors
+ (require 'ffi-sqlite)
+ (require 'ffi-curl)))
+
+;; adapted from jwz-lj.el
+(defun lj-extract-sql-cookies (file chromep)
+ "Extract LJ cookie data from SQL cookies FILE.
+
+Non-nil CHROMEP forces a Google Chrome compatible sql query."
+ (let ((sql (if chromep
+ ;; chrome sql cookies
+ (concat "SELECT name,value FROM cookies "
+ "WHERE host_key=\".www.livejournal.com\" "
+ "OR host_key=\".livejournal.com\"")
+ ;; mozilla based sql cookies
+ (concat "SELECT name,value FROM moz_cookies "
+ "WHERE host=\".www.livejournal.com\" "
+ "OR host=\".livejournal.com\""))))
+ (if (featurep 'ffi-sqlite)
+ ;; Try SXEmacs' sexy ffi-sqlite if it's available
+ (let* ((db (sqlite-open file))
+ (rows (sqlite-rows db sql)))
+ (sqlite-close db)
+ (when (listp rows)
+ (concat "Cookie: "
+ (mapconcat
+ #'(lambda (c)
+ (concat (car c) "=" (cadr c)))
+ rows "; ")
+ "\r\n")))
+ ;; The old fashioned way
+ (unless (executable-find "sqlite3")
+ (error "Can't find sqlite3"))
+ (let* ((sql (shell-command-to-string
+ (concat "sqlite3 " file "'" sql ";'")))
+ (slist (butlast
+ (split-string-by-char
+ (replace-regexp-in-string "\n" "|" sql) ?|)))
+ cookies)
+ (while slist
+ (push (cons (car slist) (cadr slist)) cookies)
+ (setq slist (cddr slist)))
+ (when cookies
+ (concat "Cookie: "
+ (mapconcat
+ #'(lambda (c)
+ (concat (car c) "=" (cdr c)))
+ (reverse cookies) "; ")
+ "\r\n"))))))
+
+;;; FIXME: redo this with #'xml-parse-file. Just as soon as I can get
+;; me grubby little hands on one of these xml cookie files.
+;; kill/yank'd from jwz-lj.el
+;;; FIXME: this will now be broken!
+(defun lj-extract-xml-cookies (file)
+ "Extract LJ data from XML cookies FILE."
+ (save-excursion
+ (save-restriction
+ (narrow-to-region (point) (point))
+ (insert-file-contents file nil nil nil t)
+ (goto-char (point-min))
+ (search-forward "<dict>")
+ (let ((result "")
+ (start (point))
+ end
+ domain path name value)
+ (while (search-forward "</dict>" nil t)
+ (setq end (point))
+ (goto-char start)
+ (cond
+ ((search-forward "livejournal.com" end t) ; bail fast
+
+ (goto-char start)
+ (re-search-forward (concat "<key>Domain</key>[ \t\n\r]*"
+ "<string>\\([^<>]+\\)</string>")
+ end)
+ (setq domain (match-string 1))
+ (goto-char start)
+ (re-search-forward (concat "<key>Path</key>[ \t\n\r]*"
+ "<string>\\([^<>]+\\)</string>")
+ end)
+ (setq path (match-string 1))
+ (goto-char start)
+ (re-search-forward (concat "<key>Name</key>[ \t\n\r]*"
+ "<string>\\([^<>]+\\)</string>")
+ end)
+ (setq name (match-string 1))
+ (goto-char start)
+ (re-search-forward (concat "<key>Value</key>[ \t\n\r]*"
+ "<string>\\([^<>]+\\)</string>")
+ end)
+ (setq value (match-string 1))
+ (if (string-match "\\blivejournal\\.com$" domain)
+ (setq result
+ (concat domain "\tTRUE\t" path "\tFALSE\t0\t"
+ name "\t" value
+ "\n" result)))))
+ (goto-char end)
+ (setq start end))
+ (delete-region (point-min) (point-max))
+ (insert result))))
+ nil)
+
+(defun lj-extract-text-cookies (file)
+ "Extract LJ data from text based cookies FILE."
+ (let ((host-match "\\.livejournal\\.com$")
+ cookies)
+ (with-temp-buffer
+ (insert-file-contents-literally file)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (when (looking-at (concat "^\\([^\t\r\n]+\\)\t" ; 1 host
+ "\\([^\t\r\n]+\\)\t" ; 2 bool
+ "\\([^\t\r\n]+\\)\t" ; 3 path
+ "\\([^\t\r\n]+\\)\t" ; 4 bool
+ "\\([^\t\r\n]+\\)\t" ; 5 time_t
+ "\\([^\t\r\n]+\\)\t" ; 6 key
+ "\\([^\t\r\n]+\\)$")) ; 7 val
+ (let ((host (match-string 1))
+ (key (match-string 6))
+ (val (match-string 7)))
+ (when (and (string-match host-match host)
+ (not (assoc key cookies)))
+ (setq cookies (cons (cons key val) cookies))))
+ (forward-line 1))))
+ (when cookies
+ (concat "Cookie: "
+ (mapconcat
+ #'(lambda (c)
+ (concat (car c) "=" (cdr c)))
+ (nreverse cookies) "; ")
+ "\r\n"))))
+
+(defun lj-extract-w3-cookies ()
+ "Extract LJ cookie data from Emacs-W3 cookies."
+ (let* ((secure (and url-cookie-secure-storage t))
+ (w3cookies (remove-duplicates
+ (append (url-cookie-retrieve
+ "www.livejournal.com" "/" secure)
+ (url-cookie-retrieve
+ ".livejournal.com" "/" secure))
+ :test #'equal)))
+ (when w3cookies
+ (replace-regexp-in-string
+ "; \r\n" "\r\n"
+ (concat "Cookie: "
+ (mapconcat
+ #'(lambda (c)
+ (unless (string-equal (url-cookie-name c) "HttpOnly")
+ (concat (url-cookie-name c) "=" (url-cookie-value c))))
+ (nreverse w3cookies) "; ")
+ "\r\n")))))
+
+;; adapted from jwz-lj.el, but rewritten from scratch
+(defun lj-get-cookies (flavour)
+ "Return a string of LJ cookie data suitable for HTTP POST'ing.
+
+Argument FLAVOUR specifies which browser's cookies to check. If it is
+the symbol `auto' \(the default\) all browsers will be searched in the
+following order...
+
+Google Chrome, Firefox, SeaMonkey, Mozilla, Galeon, Safari, Nescape,
+Midori, and Emacs-W3 for cookie data."
+ (catch 'found
+ (let (cookies)
+
+ ;; Google Chrome
+ (when (or (eq flavour 'chrome)
+ (eq flavour 'auto))
+ (let ((dir (paths-construct-path
+ '(".config" "google-chrome" "Default")
+ (user-home-directory))))
+ (and (file-exists-p (expand-file-name "Cookies" dir))
+ (setq cookies (lj-extract-sql-cookies
+ (expand-file-name "Cookies" dir) t))))
+ (if cookies
+ (throw 'found cookies)
+ (lj-get-cookies 'auto)))
+
+ ;; Firefox 1-3 (works for sqlite cookies, plain text cookies are
+ ;; untested)
+ (when (or (eq flavour 'firefox)
+ (eq flavour 'auto))
+ (let ((d1 (paths-construct-path
+ '("Library" "Application Support" "Firefox" "Profiles")
+ (user-home-directory)))
+ (d2 (paths-construct-path
+ '(".mozilla" "firefox") (user-home-directory)))
+ dir)
+ (if (file-directory-p d1)
+ (setq dir (car (directory-files d1 t "\\.default$" nil 'dirs)))
+ (setq dir (car (directory-files d2 t "\\.default$" nil 'dirs))))
+ (or (and (file-exists-p (expand-file-name "cookies.txt" dir))
+ (setq cookies (lj-extract-text-cookies
+ (expand-file-name "cookies.txt" dir))))
+ (and (file-exists-p (expand-file-name "cookies.sqlite" dir))
+ (setq cookies (lj-extract-sql-cookies
+ (expand-file-name "cookies.sqlite" dir) nil)))))
+ (if cookies
+ (throw 'found cookies)
+ (lj-get-cookies 'auto)))
+
+ ;; SeaMonkey (untested)
+ (when (or (eq flavour 'seamonkey)
+ (eq flavour 'auto))
+ (when (file-directory-p (expand-file-name ".mozilla/seamonkey"
+ (user-home-directory)))
+ (let ((dir (car (directory-files "~/.mozilla/seamonkey"
+ t "\\.default$" nil 'dirs))))
+ (or (and (file-exists-p (expand-file-name "cookies.txt" dir))
+ (setq cookies (lj-extract-text-cookies
+ (expand-file-name "cookies.txt" dir))))
+ (and (file-exists-p (expand-file-name "cookies.sqlite" dir))
+ (setq cookies (lj-extract-sql-cookies
+ (expand-file-name "cookies.sqlite" dir) nil))))))
+ (if cookies
+ (throw 'found cookies)
+ (lj-get-cookies 'auto)))
+
+ ;; Mozilla (untested)
+ (when (or (eq flavour 'mozilla)
+ (eq flavour 'auto))
+ (when (file-directory-p (expand-file-name ".mozilla"
+ (user-home-directory)))
+ (let ((d1 (paths-construct-path '(".mozilla" "default")
+ (user-home-directory)))
+ (d2 (paths-construct-path `(".mozilla" ,(user-login-name))
+ (user-home-directory)))
+ dir)
+ (if (file-directory-p d1)
+ (setq dir (car (directory-files d1 t "\\.slt$" nil 'dirs)))
+ (setq dir (car (directory-files d2 t "\\.slt$" nil 'dirs))))
+ (and (file-exists-p (expand-file-name "cookies.txt" dir))
+ (setq cookies (lj-extract-text-cookies
+ (expand-file-name "cookies.txt" dir))))))
+ (if cookies
+ (throw 'found cookies)
+ (lj-get-cookies 'auto)))
+
+ ;; Galeon (untested)
+ (when (or (eq flavour 'galeon)
+ (eq flavour 'auto))
+ (let ((dir (paths-construct-path
+ '(".galeon" "mozilla" "galeon") (user-home-directory))))
+ (and (file-exists-p (expand-file-name "cookies.txt" dir))
+ (setq cookies (lj-extract-text-cookies
+ (expand-file-name "cookies.txt" dir)))))
+ (if cookies
+ (throw 'found cookies)
+ (lj-get-cookies 'auto)))
+
+ ;; Safari (untested)
+ (when (or (eq flavour 'safari)
+ (eq flavour 'auto))
+ (let ((dir (paths-construct-path '("Library" "Cookies")
+ (user-home-directory))))
+ (and (file-exists-p (expand-file-name "Cookies.plist" dir))
+ (setq cookies (lj-extract-xml-cookies
+ (expand-file-name "Cookies.plist" dir)))))
+ (if cookies
+ (throw 'found cookies)
+ (lj-get-cookies 'auto)))
+
+ ;; Netscape (untested)
+ (when (or (eq flavour 'netscape)
+ (eq flavour 'auto))
+ (let ((dir (paths-construct-path '(".netscape")
+ (user-home-directory))))
+ (and (file-exists-p (expand-file-name "cookies" dir))
+ (setq cookies (lj-extract-text-cookies
+ (expand-file-name "cookies" dir)))))
+ (if cookies
+ (throw 'found cookies)
+ (lj-get-cookies 'auto)))
+
+ ;; Midori (works, but Midori doesn't take too much care about
+ ;; invalid or broken cookies so YMMV here)
+ (when (or (eq flavour 'midori)
+ (eq flavour 'auto))
+ (let ((dir (paths-construct-path '(".config" "midori")
+ (user-home-directory))))
+ (and (file-exists-p (expand-file-name "cookies.txt" dir))
+ (setq cookies (lj-extract-text-cookies
+ (expand-file-name "cookies.txt" dir)))))
+ (if cookies
+ (throw 'found cookies)
+ (lj-get-cookies 'auto)))
+
+ ;; Emacs-W3 URL (works with W3 in XE packages)
+ (when (or (eq flavour 'w3)
+ (eq flavour 'auto))
+ (and (file-exists-p url-cookie-file)
+ (setq cookies (lj-extract-w3-cookies)))
+ (if cookies
+ (throw 'found cookies)
+ (lj-get-cookies 'auto)))
+
+ ;; Gah! no cookes anywhere!
+ (error 'search-failed "LJ Cookie data"))))
+
+(defvar lj-cookies (lj-get-cookies lj-cookie-flavour)
+ "Alist of cookie data to send to LJ.")
+
+;; adapted from jwz-lj.el
+(defun lj-http-post (url cookies parser)
+ "Sends a HTTP POST to URL with COOKIES.
+
+Argument PARSER is a function to handle parsing the output received."
+ (unless (string-match "\\`https?://\\([^/]+\\)\\([^?&]+\\)\\?\\(.*\\)\\'" url)
+ (error "Unparsable url: %s" url))
+ (let* ((host (match-string 1 url))
+ (port 80)
+ (path (match-string 2 url))
+ (args (match-string 3 url))
+ (post-cmd
+ (concat "POST " path " HTTP/1.0\r\n"
+ "Content-Type: application/x-www-form-urlencoded\r\n"
+ "Content-Length: " (int-to-string (length args)) "\r\n"
+ "Host: " host "\r\n"
+ "X-LJ-Auth: cookie\r\n"
+ cookies
+ "\r\n"
+ args))
+ (buf (generate-new-buffer " *LJ-process*"))
+ proc)
+ (setq proc (open-network-stream "LiveJournal" buf host port))
+ (when (lj-utf-emacs-p)
+ (set-process-coding-system proc 'utf-8 'utf-8))
+ (process-send-string proc post-cmd)
+ (message "HTTP POST sent to %s" host)
+ (while (eq (process-status proc) 'open)
+ (unless (accept-process-output proc 60)
+ (delete-process proc)
+ (error "[LJ] Server error: timeout")))
+ (funcall parser buf)))
+
+(defun lj-proc-success ()
+ "Return t when LJ processes are successful.
+
+By \"successful\" we mean that livejournal.com didn't complain about
+anything we sent it."
+ (let ((regex "^success\n\\(.*$\\)")
+ result)
+ (save-excursion
+ (goto-char (point-min))
+ (if (re-search-forward regex nil t)
+ (setq result (match-string 1))
+ (error "[LJ] Server error: try again later"))
+ (cond ((string= result "OK")
+ t)
+ ((string= result "FAIL")
+ (let ((ereg "^errmsg\n\\(.*$\\)"))
+ (save-excursion
+ (goto-char (point-min))
+ (re-search-forward ereg)
+ (if (string-match "Incorrect time value" (match-string 1))
+ (lj-post 'out-of-order)
+ (error "[LJ]: %s" (match-string 1))))))
+ (t
+ (error "[LJ]: Unknown error"))))))
+
+(defun lj-friends-proc-parser (buf)
+ "Processes the output from `lj-get-friends-groups'.
+Argument BUF is the process buffer used."
+ (let ((regexp "^frgrp_\\([0-9]+\\)_name\n\\(.*$\\)")
+ groups)
+ (with-current-buffer buf
+ (when (lj-proc-success)
+ (goto-char (point-min))
+ (while (re-search-forward regexp nil t)
+ (setq groups
+ (cons (cons (match-string 2) (string-to-int (match-string 1)))
+ groups)))
+ (kill-buffer nil))
+ (when groups
+ (or (file-directory-p lj-directory)
+ (make-directory-path lj-directory))
+ (with-current-buffer (find-file-noselect lj-groups-file)
+ (erase-buffer)
+ (insert ";;; Automatically generated DO NOT EDIT -*- Emacs-Lisp -*-\n"
+ (format "(setq lj-groups (quote %S))" groups))
+ (save-buffer)
+ (eval-current-buffer nil)
+ (kill-buffer nil))))))
+
+(defun lj-get-friends-groups ()
+ "Retrieve an alist of groups/groupids from Livejournal."
+ (let ((cookies (or lj-cookies
+ (error "No LJ cookies found")))
+ (url (concat lj-base-url
+ "?mode=getfriendgroups"
+ "&user=" lj-user-id
+ "&auth_method=cookie"
+ (format "&ver=%d" (if (lj-utf-emacs-p) 1 0)))))
+ (lj-http-post url cookies #'lj-friends-proc-parser)))
+
+(defun lj-tags-proc-parser (buf)
+ "Process the output from `lj-get-tags'.
+Argument BUF is the process buffer used."
+ (let ((regexp "tag_[0-9]+_name\n\\(.*$\\)")
+ tags)
+ (with-current-buffer buf
+ (when (lj-proc-success)
+ (goto-char (point-min))
+ (while (re-search-forward regexp nil t)
+ (push (match-string 1) tags))
+ (kill-buffer nil))
+ (when tags
+ (or (file-directory-p lj-directory)
+ (make-directory-path lj-directory))
+ (with-current-buffer (find-file-noselect lj-tags-file)
+ (erase-buffer)
+ (insert ";;; Automatically generated DO NOT EDIT -*- Emacs-Lisp -*-\n"
+ (format "(setq lj-tags (quote %S))" tags))
+ (save-buffer)
+ (eval-current-buffer nil)
+ (kill-buffer nil))))))
+
+(defun lj-get-tags ()
+ "Retrieve a list of defined tags from Livejournal."
+ (let ((cookies (or lj-cookies
+ (error "No LJ cookies found")))
+ (url (concat lj-base-url
+ "?mode=getusertags"
+ "&user=" lj-user-id
+ "&auth_method=cookie"
+ (format "&ver=%d" (if (lj-utf-emacs-p) 1 0)))))
+ (lj-http-post url cookies #'lj-tags-proc-parser)))
+
+(defun lj-get-userpic-noffi (url file)
+ "Download userpic from URL to FILE."
+ (if (executable-find "curl")
+ (shell-command (concat "curl " url " -so " file) nil)
+ (error 'unimplemented "non-FFI leeching")))
+
+(defun lj-get-userpics ()
+ "Leech your userpics from livejournal.com."
+ (unless (file-directory-p lj-userpic-directory)
+ (make-directory-path lj-userpic-directory))
+ (let ((pics (mapcar #'car lj-pickws)))
+ (mapcar
+ #'(lambda (p)
+ (unless (file-exists-p
+ (expand-file-name p lj-userpic-directory))
+ (let ((file (expand-file-name p lj-userpic-directory))
+ (url (cdr (assoc p lj-pickws))))
+ (if (featurep '(and sxemacs ffi-curl))
+ (declare-fboundp (curl:download url file))
+ (lj-get-userpic-noffi url file)))))
+ pics)))
+
+(defun lj-pickws-proc-parser (buf)
+ "Process the output from `lj-get-pickws'.
+Argument BUF is the process buffer used."
+ (let ((msg "^message\n\\(.*$\\)")
+ defaultk defaultu keywords)
+ (with-current-buffer buf
+ (when (lj-proc-success)
+ (goto-char (point-min))
+ (save-excursion
+ (re-search-forward "defaultpicurl\n\\(.*$\\)")
+ (setq defaultu (match-string 1))
+ (let ((defidx
+ (and
+ (re-search-forward (concat "^pickwurl_\\([0-9]+\\)\n"
+ defaultu) nil t)
+ (match-string 1))))
+ (goto-char (point-min))
+ (re-search-forward (concat "^pickw_" defidx "\n\\(.*$\\)") nil t)
+ (setq defaultk (match-string 1))
+ (setq keywords (cons (cons defaultk defaultu) keywords))))
+ (save-excursion
+ (while (re-search-forward "^pickw_\\([0-9]+\\)\n\\(.*$\\)" nil t)
+ (let* ((key (match-string 2))
+ (url (save-excursion
+ (goto-char (point-min))
+ (and (re-search-forward
+ (concat "pickwurl_"
+ (match-string 1) "\n\\(.*$\\)") nil t)
+ (match-string 1)))))
+ (unless (string= key defaultk)
+ (setq keywords (cons (cons key url) keywords))))))
+ (when (re-search-forward msg nil t)
+ (pop-to-buffer (get-buffer-create "*LJ Message*"))
+ (insert "Important Message From LiveJournal:\n"
+ "==================================\n\n")
+ (insert (match-string 1)))
+ (kill-buffer buf))
+ (when keywords
+ (or (file-directory-p lj-directory)
+ (make-directory-path lj-directory))
+ (with-current-buffer (find-file-noselect lj-pickws-file)
+ (erase-buffer)
+ (insert ";;; Automatically generated DO NOT EDIT -*- Emacs-Lisp -*-\n"
+ (format "(setq lj-pickws (quote %S))" keywords))
+ (insert (format "\n(setq lj-default-pickw %S)" defaultk))
+ (save-buffer)
+ (eval-current-buffer nil)
+ (kill-buffer nil))))
+ (lj-get-userpics)))
+
+(defun lj-get-pickws ()
+ "Retieve an alist of userpic keyword/url pairs."
+ (let ((cookies (or lj-cookies
+ (error "No LJ cookies found")))
+ (url (concat lj-base-url
+ "?mode=login"
+ "&user=" lj-user-id
+ "&auth_method=cookie"
+ (format "&ver=%d" (if (lj-utf-emacs-p) 1 0))
+ "&clientversion=" lj-clientversion
+ "&getpickws=1"
+ "&getpickwurls=1")))
+ (lj-http-post url cookies #'lj-pickws-proc-parser)))
+
+(defun lj-moods-proc-parser (buf)
+ "Process the output from `lj-get-moods'.
+Argument BUF is the process buffer used."
+ (let ((regexp "mood_[0-9]+_id\n\\(.*\\)\nmood_[0-9]+_name\n\\(.*\\)")
+ (msg "^message\n\\(.*$\\)")
+ moods)
+ (with-current-buffer buf
+ (when (lj-proc-success)
+ (goto-char (point-min))
+ (save-excursion
+ (while (re-search-forward regexp nil t)
+ (setq moods (cons (cons (match-string 2)
+ (string-to-int (match-string 1)))
+ moods))))
+ (when (re-search-forward msg nil t)
+ (pop-to-buffer (get-buffer-create "*LJ Message*"))
+ (insert "Important Message From LiveJournal:\n"
+ "==================================\n\n")
+ (insert (match-string 1)))
+ (kill-buffer buf))
+ (or (file-directory-p lj-directory)
+ (make-directory-path lj-directory))
+ (with-current-buffer (find-file-noselect lj-moods-file)
+ (erase-buffer)
+ (insert ";;; Automatically generated DO NOT EDIT -*- Emacs-Lisp -*-\n"
+ (format "(setq lj-moods (quote %S))" moods))
+ (save-buffer)
+ (eval-current-buffer nil)
+ (kill-buffer nil)))))
+
+(defun lj-get-moods ()
+ "Retieve an alist of mood/moodid pairs."
+ (let ((cookies (or lj-cookies
+ (error "No LJ cookies found")))
+ (url (concat lj-base-url
+ "?mode=login"
+ "&user=" lj-user-id
+ "&auth_method=cookie"
+ (format "&ver=%d" (if (lj-utf-emacs-p) 1 0))
+ "&clientversion=" lj-clientversion
+ "&getmoods=0")))
+ (lj-http-post url cookies #'lj-moods-proc-parser)))
+
+(defvar lj-last-user-set-time nil)
+(defvar lj-qotd 0)
+;; adapted from jwz-lj.el
+(defun lj-construct-url (subject body user
+ &optional security tags community
+ auto-format no-comments mood location
+ music pickw date backdated)
+ "Construct a URL to use for posting to LiveJournal.
+
+Argument SUBJECT, a string, which is the title of the post.
+Argument BODY, a string, is the body of the post.
+Argument USER, a string, is the LJ userid to post as.
+
+Optional argument SECURITY, a string, is the security level this post
+will have. The default is `lj-default-security-level'.
+
+Optional argument TAGS, a string, which is a comma delimited list of
+tags to add to this post.
+
+Optional argument COMMUNITY, a string, which is the name of a LJ forum
+to send this post to instead of the user's blog.
+
+Optional argument AUTO-FORMAT, when non-nil request that the LJ server
+automatically formats the post. The default is nil, which means the
+post should NOT be auto formatted by LJ.
+
+Optional argument NO-COMMENTS, when non-nil means to turn off comments
+on the post.
+
+Optional argument MOOD, a string or an integer, is the post's \"mood\"
+header. If it is an integer, it is a \"mood id\" which is mapped to a
+string by LJ.
+
+Optional argument LOCATION, a string, free-form text describing your
+current location. Livejournal turns it into a search URL to google
+maps.
+
+Optional argument MUSIC, a string, of the currently playing mp3/ogg.
+
+Optional argument PICKW, a string, of the userpic keyword to use. If
+omitted, your default LJ userpic will be used.
+
+Optional argument DATE, an internal time value as returned by
+`encode-time'. Used to set a date/time on a post, if omitted the
+current time is used.
+
+Optional boolean argument BACKDATED, causes the \"backdated\" flag to be
+set which will prevent the post from showing up on friends pages."
+ (let* ((friends-mask nil)
+ (tl (split-string-by-char
+ (format-time-string "%Y,%m,%d,%H,%M"
+ (or date (current-time))) ?,))
+ (year (first tl))
+ (month (second tl))
+ (day (third tl))
+ (hour (fourth tl))
+ (minute (fifth tl))
+ (ctime (apply #'encode-btime (lj-parse-time-string
+ (format "%s-%s-%s %s:%s"
+ year month day hour minute))))
+ (ltime (or lj-last-entry-btime (and (lj-get-last-entry-btime)
+ lj-last-entry-btime)))
+ url)
+ ;; save custom date in case something goes wrong
+ (if date
+ (setq lj-last-user-set-time date)
+ (setq lj-last-user-set-time nil))
+ (setq subject (lj-hexify-string subject t))
+ (setq body (lj-hexify-string body t))
+ ;; security level
+ (if (not (string-match "p\\(ublic\\|rivate\\)" security))
+ (if (string= "usemask" security)
+ (setq friends-mask 1)
+ (let* ((groups (or lj-groups (lj-get-friends-groups)))
+ (id (cdr (assoc security groups))))
+ (if id
+ (setq security "usemask"
+ friends-mask (lsh 1 id))
+ (error "Unknown friends group: %s" security)))))
+ (setq security (lj-hexify-string security t))
+ ;; tags
+ (if (> (length tags) 0)
+ (setq tags (lj-hexify-string tags t))
+ (setq tags nil))
+ ;; mood
+ (cond ((cdr (assoc mood lj-moods))
+ (setq mood (cdr (assoc mood lj-moods))))
+ ((and (stringp mood)
+ (> (length mood) 0))
+ (setq mood (lj-hexify-string mood t)))
+ ((integerp mood) nil)
+ (t
+ (setq mood nil)))
+ ;; music
+ (if (> (length music) 0)
+ (setq music (lj-hexify-string music t))
+ (setq music nil))
+ ;; userpic
+ (if (> (length pickw) 0)
+ (setq pickw (lj-hexify-string pickw t))
+ (setq pickw nil))
+ ;; community
+ (if (> (length community) 0)
+ (setq community (lj-hexify-string community t))
+ (setq community nil))
+ ;; location
+ (if (> (length location) 0)
+ (setq location (lj-hexify-string location t))
+ (setq location nil))
+ ;; maybe force opt_backdated
+ (when (> ltime ctime)
+ (setq backdated t))
+ ;; the final url
+ (setq url (concat
+ lj-base-url
+ "?mode=postevent"
+ "&user=" user
+ "&auth_method=cookie"
+ (format "&ver=%d" (if (lj-utf-emacs-p) 1 0))
+ "&subject=" subject
+ "&security=" security
+ (when friends-mask
+ (format "&allowmask=%d" friends-mask))
+ (when tags
+ (format "&prop_taglist=%s" tags))
+ (when community
+ (format "&usejournal=%s" community))
+ "&year=" year
+ "&mon=" month
+ "&day=" day
+ "&hour=" hour
+ "&min=" minute
+ (when mood
+ (if (integerp mood)
+ (format "&prop_current_moodid=%d" mood)
+ (format "&prop_current_mood=%s" mood)))
+ (when music
+ (format "&prop_current_music=%s" music))
+ (when location
+ (format "&prop_current_location=%s" location))
+ (when pickw
+ (format "&prop_picture_keyword=%s" pickw))
+ (unless (zerop lj-qotd)
+ (format "&prop_qotdid=%d" lj-qotd))
+ "&prop_opt_backdated=" (if backdated "1" "0")
+ "&prop_opt_preformatted=" (if auto-format "0" "1")
+ "&prop_opt_nocomments=" (if no-comments "1" "0")
+ "&prop_useragent=" (lj-hexify-string lj-useragent)
+ "&event=" body))
+ url))
+
+(defun lj-cut-toggle-top ()
+ "Toggle view of LJ CUT text."
+ (interactive)
+ (save-excursion
+ (goto-char (point-at-eol))
+ (forward-char 1)
+ (set-extent-property
+ (extent-at (point) nil 'ljcut)
+ 'invisible (not (extent-property
+ (extent-at (point) nil 'ljcut) 'invisible)))))
+
+
+(defun lj-cut-mouse-toggle-top (event)
+ "Toggle view of LJ CUT text under EVENT."
+ (interactive "e")
+ (let ((epoint (event-point event)))
+ (save-excursion
+ (goto-char epoint)
+ (goto-char (point-at-eol))
+ (forward-char 1)
+ (set-extent-property
+ (extent-at (point) nil 'ljcut)
+ 'invisible (not (extent-property
+ (extent-at (point) nil 'ljcut) 'invisible))))))
+
+(defun lj-cut-toggle-bottom ()
+ "Toggle view of LJ CUT text."
+ (interactive)
+ (save-excursion
+ (goto-char (point-at-bol))
+ (backward-char 1)
+ (set-extent-property
+ (extent-at (point) nil 'ljcut)
+ 'invisible (not (extent-property
+ (extent-at (point) nil 'ljcut) 'invisible)))))
+
+(defun lj-cut-mouse-toggle-bottom (event)
+ "Toggle view of LJ CUT text under EVENT."
+ (interactive "e")
+ (let ((epoint (event-point event)))
+ (save-excursion
+ (goto-char epoint)
+ (goto-char (point-at-bol))
+ (backward-char 1)
+ (set-extent-property
+ (extent-at (point) nil 'ljcut)
+ 'invisible (not (extent-property
+ (extent-at (point) nil 'ljcut) 'invisible))))))
+
+(defvar lj-cut-keymap-top
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-name map 'lj-cut-keymap-top)
+ (define-key map [return] #'lj-cut-toggle-top)
+ (define-key map [button2] #'lj-cut-mouse-toggle-top)
+ map)
+ "Keymap for LJ CUT extents.")
+
+(defvar lj-cut-keymap-bottom
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-name map 'lj-cut-keymap-bottom)
+ (define-key map [return] #'lj-cut-toggle-bottom)
+ (define-key map [button2] #'lj-cut-mouse-toggle-bottom)
+ map)
+ "Keymap for LJ CUT extents.")
+
+(defun lj-cut-region (b e)
+ "Mark text in the region B to E as an LJ CUT.
+
+The text that is to be hidden behind the LJ CUT is made invisible in
+the buffer. The visibility can be toggled with Return or Button2 on
+either of the lj-cut delimiters."
+ (interactive "r")
+ (let ((echo "Ret / Button2 Toggle View")
+ ext)
+ (save-restriction
+ (narrow-to-region b e)
+ (lj-text-to-html (point-min) (point-max))
+ (set-extent-properties
+ (setq ext (make-extent (point-min) (point-max)))
+ '(start-open t end-open t invisible t ljcut t))
+ (goto-char (point-min))
+ (set-extent-properties
+ (insert-face "<lj-cut text=\"---More---\">" 'widget-button-face)
+ `(help-echo ,echo
+ balloon-help ,echo
+ keymap ,lj-cut-keymap-top
+ mouse-face font-lock-warning-face))
+ (insert "\n")
+ (goto-char (point-max))
+ (set-extent-properties
+ (insert-face "</lj-cut>" 'widget-button-face)
+ `(help-echo ,echo
+ balloon-help ,echo
+ keymap ,lj-cut-keymap-bottom
+ mouse-face font-lock-warning-face))
+ (insert "\n"))
+ (set-extent-properties
+ ext
+ '(start-open nil end-open nil))
+ (run-hooks 'lj-cut-hook)))
+
+(defvar lj-poll-types '("radio" "check" "drop" "text" "scale")
+ "LJ poll types.")
+
+(defun lj-insert-poll (name type question)
+ "Insert a poll into a LJ post.
+Argument NAME is the title of the poll.
+Argument TYPE is the type of poll \(see `lj-poll-types'\).
+Argument QUESTION is the poll question, or \"topic\"."
+ (interactive
+ (list (read-string "Poll Title: " nil nil "unnamed poll")
+ (completing-read "Poll Type (default \"radio\"): "
+ (mapcar #'list lj-poll-types)
+ nil t nil nil "radio")
+ (read-string "Poll Question: ")))
+ (let ((voters (completing-read "Who can vote (default \"all\"): "
+ (mapcar #'list '("all" "friends"))
+ nil t nil nil "all"))
+ (viewers (completing-read "Who can view results (default \"all\"): "
+ (mapcar #'list '("all" "friends" "none"))
+ nil t nil nil "all"))
+ (p (point)))
+ (insert
+ (format "\n<lj-poll name=\"%s\" whovote=\"%s\" whoview=\"%s\">"
+ name voters viewers)
+ (format "\n<lj-pq type=\"%s\"" type))
+ (cond
+ ((string= "scale" type)
+ (let ((low (read-number "Scale low mark (int): " t "1"))
+ (high (read-number "Scale high mark (int): " t "10"))
+ (step (read-number "Stepping: " t "1")))
+ (insert (format " from=\"%d\" to=\"%d\" by=\"%d\">"
+ low high step)
+ (format "\n%s" question))))
+ ((string= "text" type)
+ (let* ((size (read-number "Text box size: " t "50"))
+ (max (read-number "Max answer length: " t
+ (number-to-string (1- size)))))
+ (insert (format " size=\"%d\" maxlength=\"%d\">" size max)
+ (format "\n%s" question))))
+ (t (insert (format ">\n%s" question))))
+ (unless (string-match "scale\\|text" type)
+ (let ((x "x"))
+ (while (not (zerop (length x)))
+ (setq x (read-string "Poll Answer (RET to finish): "))
+ (or (zerop (length x))
+ (insert (format "\n<lj-pi>%s</lj-pi>" x))))))
+ (insert "\n</lj-pq>"
+ "\n</lj-poll>")
+ (indent-region p (point) nil)
+ (run-hooks 'lj-poll-hook)))
+
+;; Apparantly the _VALID_ markup that this function produces causes
+;; some (all?) versions of M$ Internet Exploiter to buffer the entire
+;; movie before beginning playback. Hey, lets call it a FEATURE!
+(defun lj-insert-youtube (url)
+ "Insert a Google or Youtube video URL into a LJ post."
+ (interactive "sVideo URL: ")
+ (let* ((googlep (string-match "^http://video\\.google\\.com/.*$" url))
+ (youtubep (string-match "^http://\\(www\\.\\)?youtube\\.com/.*$" url))
+ (w (if googlep 420 400))
+ (h (if googlep 352 338))
+ (p (point)))
+ (unless (or googlep youtubep)
+ (error "Invalid Google/Youtube URL: %s" url))
+ (insert (format "\n<object width=\"%d\" height=\"%d\"" w h)
+ "\ntype=\"application/x-shockwave-flash\"")
+ (if googlep
+ (setq url (replace-regexp-in-string "/videoplay\\?"
+ "/googleplayer.swf?" url))
+ (setq url (replace-regexp-in-string "\\(/watch\\)?\\?v=" "/v/" url)))
+ (setq url (replace-regexp-in-string "&.*$" "" url))
+ (insert (format "\ndata=\"%s\">" url)
+ "\n<param name=\"movie\""
+ (format "\nvalue=\"%s\" />" url)
+ "\n</object>")
+ (indent-region p (point) nil)
+ (run-hooks 'lj-youtube-hook)))
+
+(defun lj-insert-journal (name &optional community)
+ "Insert a link to NAME journal or LJ community into an LJ post.
+
+Optional prefix argument, COMMUNITY means the link is to a LJ community
+instead of a LJ user's journal."
+ (interactive "sUser or Community name: \nP")
+ (let ((type (if current-prefix-arg "comm" "user"))
+ (p (point)))
+ (insert (format "\n<lj %s=\"%s\" />\n" type name))
+ (indent-region p (point) nil)
+ (run-hooks 'lj-journal-hook)))
+
+(defvar lj-abbrev-table nil
+ "Abbrev table to use in `lj-mode'.")
+(define-abbrev-table 'lj-abbrev-table ())
+
+(define-derived-mode lj-mode html-mode "LJ"
+ "This is a mode for composing LiveJournal posts.
+Its parent modes are `html-mode' and `sgml-mode' so everything you
+need to construct good clean HTML should be right at your fingertips.
+
+LJ specific bindings:
+
+ \\[lj-post]\tSubmit post to LiveJournal
+ \\[lj-preview]\t\tPreview post in web browser
+ \\[lj-validate]\t\tValidate the markup in the post
+
+ \\[lj-writers-block]\t\tAnswer a LJ \"Writer's Block\" question
+
+ \\[lj-cut-region]\t\tHide text behind a LJ \"cut\"
+ \\[lj-insert-journal]\t\tInsert a journal link
+ \\[lj-insert-poll]\t\tInsert a poll
+ \\[lj-insert-youtube]\t\tInsert a Google or YouTube Video
+
+ \\[lj-goto-subject]\tMove to the Subject header
+ \\[lj-goto-fcc]\tMove to the FCC header
+ \\[lj-goto-bcc]\tMove to the BCC header
+ \\[lj-goto-community]\tMove to the Community header
+ \\[lj-goto-music]\tMove to the Music header
+ \\[lj-goto-security]\tMove to the Security header
+ \\[lj-goto-mood]\tMove to the Mood header
+ \\[lj-goto-location]\tMove to the Location header
+ \\[lj-goto-userpic]\tMove to the Userpic header
+ \\[lj-goto-tags]\tMove to the Tags header
+ \\[lj-goto-body]\tMove to the post body
+
+ \\[lj-customise-faces]\t\tSet the header faces
+ \\[lj-customise-group]\t\tSet the user options
+
+
+General bindings:
+\\{lj-mode-map}"
+ :group 'lj
+ :syntax-table nil
+ :abbrev-table 'lj-abbrev-table
+ (auto-save-mode 1))
+
+(add-hook 'lj-mode-hook #'font-lock-mode)
+
+(defun lj-make-archive-name ()
+ "Compute a filename for archiving LJ posts.
+
+The filenames are of the format... `ljp-YYYYMMDDHHMM'."
+ (let ((file (format-time-string "ljp-%Y%m%d%H%M"))
+ (dir lj-archive-directory))
+ (expand-file-name file dir)))
+
+(defun lj-generate-new-buffer ()
+ "Create a new buffer for writing a new LJ post."
+ (or (file-directory-p lj-drafts-directory)
+ (make-directory-path lj-drafts-directory))
+ (switch-to-buffer
+ (find-file-noselect
+ (expand-file-name (format-time-string "ljd-%Y%m%d%H%M")
+ lj-drafts-directory)))
+ (rename-buffer "*LJ-Post*" 'unique)
+ (when (lj-utf-emacs-p)
+ (set-buffer-file-coding-system 'utf-8))
+ (insert " \n")
+ (make-extent (point-min) (point-at-eol))
+ (insert "Subject: \n")
+ (when lj-archive-posts
+ (or (file-directory-p lj-archive-directory)
+ (make-directory-path lj-archive-directory))
+ (insert (format "FCC: %s\n" (lj-make-archive-name))))
+ (when (stringp lj-bcc-address)
+ (insert (format "BCC: %s\n" lj-bcc-address)))
+ (insert (format "Security: %s\n" lj-default-security-level))
+ (when (stringp lj-default-location)
+ (insert (format "Location: %s\n" lj-default-location)))
+ (when (functionp (symbol-value 'lj-music))
+ (insert (format "Music: %s\n" (funcall lj-music))))
+ (insert "Mood: \n")
+ (when-boundp 'lj-default-pickw
+ (insert (format "Userpic: %s\n" lj-default-pickw))
+ (lj-update-userpic-glyph (expand-file-name lj-default-pickw
+ lj-userpic-directory)))
+ (insert "Tags: \n")
+ ;; fool html mode
+ (set-extent-property
+ (insert-face "</head>\n" 'default) 'invisible t)
+ (insert lj-header-separator "\n")
+ (lj-mode))
+
+(defun lj-goto-subject (&optional nocreate)
+ "Move to the Subject header of an LJ post buffer.
+
+The header is created if it doesn't exist, unless optional argument
+NOCREATE is non-nil."
+ (interactive)
+ (goto-char (point-min))
+ (or (re-search-forward "^Subject: " nil 'missing)
+ (unless nocreate
+ (goto-char (point-min))
+ (insert "Subject: ")
+ (backward-char 1))))
+
+(defun lj-goto-fcc (&optional nocreate)
+ "Move to the FCC header of an LJ post buffer.
+
+The header is created if it doesn't exist, unless optional argument
+NOCREATE is non-nil."
+ (interactive)
+ (goto-char (point-min))
+ (or (re-search-forward "^FCC: " nil 'missing)
+ (unless nocreate
+ (goto-char (point-min))
+ (insert "FCC: \n")
+ (backward-char 1))))
+
+(defun lj-goto-bcc (&optional nocreate)
+ "Move to the BCC header of an LJ post buffer.
+
+The header is created if it doesn't exist, unless optional argument
+NOCREATE is non-nil."
+ (interactive)
+ (goto-char (point-min))
+ (or (re-search-forward "^BCC: " nil 'missing)
+ (unless nocreate
+ (goto-char (point-min))
+ (insert "BCC: \n")
+ (backward-char 1))))
+
+(defun lj-goto-security (&optional nocreate)
+ "Move to the Security header of an LJ post buffer.
+
+The header is created if it doesn't exist, unless optional argument
+NOCREATE is non-nil."
+ (interactive)
+ (goto-char (point-min))
+ (or (re-search-forward "^Security: " nil 'missing)
+ (unless nocreate
+ (goto-char (point-min))
+ (insert "Security: \n")
+ (backward-char 1))))
+
+(defun lj-goto-community (&optional nocreate)
+ "Move to the Community header of an LJ post buffer.
+
+The header is created if it doesn't exist, unless optional argument
+NOCREATE is non-nil."
+ (interactive)
+ (goto-char (point-min))
+ (or (re-search-forward "^Community: " nil 'missing)
+ (unless nocreate
+ (goto-char (point-min))
+ (insert "Community: \n")
+ (backward-char 1))))
+
+(defun lj-goto-location (&optional nocreate)
+ "Move to the Location header of an LJ post buffer.
+
+The header is created if it doesn't exist, unless optional argument
+NOCREATE is non-nil."
+ (interactive)
+ (goto-char (point-min))
+ (or (re-search-forward "^Location: " nil 'missing)
+ (unless nocreate
+ (goto-char (point-min))
+ (insert "Location: \n")
+ (backward-char 1))))
+
+(defun lj-goto-mood (&optional nocreate)
+ "Move to the Mood header of an LJ post buffer.
+
+The header is created if it doesn't exist, unless optional argument
+NOCREATE is non-nil."
+ (interactive)
+ (goto-char (point-min))
+ (or (re-search-forward "^Mood: " nil 'missing)
+ (unless nocreate
+ (goto-char (point-min))
+ (insert "Mood: \n")
+ (backward-char 1))))
+
+(defun lj-goto-music (&optional nocreate)
+ "Move to the Music header of an LJ post buffer.
+
+The header is created if it doesn't exist, unless optional argument
+NOCREATE is non-nil."
+ (interactive)
+ (goto-char (point-min))
+ (or (re-search-forward "^Music: " nil 'missing)
+ (unless nocreate
+ (goto-char (point-min))
+ (insert "Music: \n")
+ (backward-char 1))))
+
+(defun lj-goto-userpic (&optional nocreate)
+ "Move to the Userpic header of an LJ post buffer.
+
+The header is created if it doesn't exist, unless optional argument
+NOCREATE is non-nil."
+ (interactive)
+ (goto-char (point-min))
+ (or (re-search-forward "^Userpic: " nil 'missing)
+ (unless nocreate
+ (goto-char (point-min))
+ (insert "Userpic: \n")
+ (backward-char 1))))
+
+(defun lj-goto-tags (&optional nocreate)
+ "Move to the Tags header of an LJ post buffer.
+The header is created if it doesn't exist unless NOCREATE is non-nil."
+ (interactive)
+ (goto-char (point-min))
+ (or (re-search-forward "^Tags: " nil 'missing)
+ (unless nocreate
+ (goto-char (point-min))
+ (insert "Tags: \n")
+ (backward-char 1))))
+
+(defun lj-goto-body ()
+ "Move to the body of an LJ post buffer."
+ (interactive)
+ (goto-char (point-min))
+ (re-search-forward (regexp-quote lj-header-separator) nil t)
+ (forward-line 1)
+ (goto-char (point-at-bol)))
+
+(defun lj-current-header ()
+ "Return the name of the LJ header on the current line, or nil."
+ (let ((hregex lj-header-regexp)
+ (separator (regexp-quote lj-header-separator)))
+ (if (save-excursion (re-search-forward separator nil t))
+ (save-restriction
+ (narrow-to-region (point-at-bol) (point-at-eol))
+ (string-match hregex (buffer-string))
+ (substring (buffer-string) (match-beginning 1) (match-end 1)))
+ nil)))
+
+(defun lj-header-content (header)
+ "Return the content of HEADER as a string."
+ (let ((goto (intern-soft (concat "lj-goto-" (downcase header)))))
+ (save-excursion
+ (funcall goto 'nocreate)
+ (buffer-substring-no-properties (point) (point-at-eol)))))
+
+(defun lj-update-userpic-glyph (glyph)
+ "Update the userpic, GLYPH, displayed in the LJ-Post buffer."
+ (let ((ext (extent-at (point-min)))
+ (type (if (featurep '(and sxemacs ffi-magic))
+ (downcase (car (split-string-by-char
+ (declare-fboundp
+ (magic:file-type glyph)) ?\ )))
+ (downcase
+ (cadr (split-string-by-char
+ (shell-command-to-string (concat "file " glyph))
+ ?\ ))))))
+ (set-extent-begin-glyph
+ ext (make-glyph
+ (list (vector (intern-soft type)
+ :data (with-temp-buffer
+ (insert-file-contents-literally glyph)
+ (buffer-string))))))))
+
+;; Header completion
+(defvar lj-completion-time 3
+ "Time in seconds before completion list is reset.")
+
+(defvar lj-completion-timer (make-itimer)
+ "Completion timer.")
+
+(defvar lj-completion-list nil
+ "Completion list.")
+
+(defvar lj-header-syntax-table
+ (let ((table (copy-syntax-table text-mode-syntax-table)))
+ (modify-syntax-entry ?~ "w " table)
+ (modify-syntax-entry ?` "w " table)
+ (modify-syntax-entry ?- "w " table)
+ (modify-syntax-entry ?_ "w " table)
+ (modify-syntax-entry ?+ "w " table)
+ (modify-syntax-entry ?{ "w " table)
+ (modify-syntax-entry ?[ "w " table)
+ (modify-syntax-entry ?} "w " table)
+ (modify-syntax-entry ?] "w " table)
+ (modify-syntax-entry ?\\ "w " table)
+ (modify-syntax-entry ?| "w " table)
+ (modify-syntax-entry ?\; "w " table)
+ (modify-syntax-entry ?' "w " table)
+ (modify-syntax-entry ?< "w " table)
+ (modify-syntax-entry ?> "w " table)
+ (modify-syntax-entry ?# "w " table)
+ (modify-syntax-entry ?\ "w " table)
+ (modify-syntax-entry ?. "w " table)
+ table)
+ "Syntax table used in funky header cycling completion.")
+
+(defun lj-init-completion-timer ()
+ "Initialise the completion timer."
+ (let ((timer lj-completion-timer))
+ (set-itimer-function timer #'(lambda ()
+ (setq lj-completion-list nil)))
+ (set-itimer-value timer lj-completion-time)))
+(add-hook 'lj-init-hook #'lj-init-completion-timer)
+
+(defsubst lj-cycle-list (list &optional reverse)
+ "Return a list of head of LIST, and LIST rotated 1 place forward.
+
+If optional argument, REVERSE is non-nil, rotate the list in the other
+direction."
+ (if (featurep 'sxemacs)
+ (let ((list (apply #'dllist list))
+ name)
+ (if reverse
+ (dllist-rrotate list)
+ (dllist-lrotate list))
+ (setq name (dllist-car list))
+ (list name (dllist-to-list list)))
+ ;; XEmacs
+ (if reverse
+ (let* ((name (car (last list)))
+ (l1 (cdr (reverse list)))
+ (l2 (reverse l1)))
+ (push name l2)
+ (list name l2))
+ (let* ((name (cadr list))
+ (oldcar (car list))
+ (list (cdr list))
+ (list (append list (list oldcar))))
+ (list name list)))))
+
+(defsubst lj-set-completion-timer ()
+ "(Re)set completion timer's value."
+ (let ((timer lj-completion-timer))
+ (and (itimerp timer)
+ (set-itimer-value timer lj-completion-time))))
+
+(defun lj-complete-header-backwards ()
+ "Complete header, cycling backwards."
+ (interactive)
+ (and (lj-current-header)
+ (lj-complete-header 'reverse)
+ (when (string-match (lj-current-header) "Userpic")
+ (when (file-exists-p (expand-file-name
+ (lj-header-content "userpic")
+ lj-userpic-directory))
+ (lj-update-userpic-glyph
+ (expand-file-name (lj-header-content "userpic")
+ lj-userpic-directory))))))
+
+(defun lj-complete-header (&optional reverse)
+ "Completion for LJ headers.
+
+This completion does not pop up any completion buffers, instead it
+cycles through the possible completions \"in-place\" with each
+successive TAB.
+
+With non-nil optional argument, REVERSE, the cycling goes in the other
+direction."
+ (interactive)
+ (unless lj-completion-list
+ (unless (itimer-live-p lj-completion-timer)
+ (lj-set-completion-timer)
+ (activate-itimer lj-completion-timer))
+ (let* ((completion-ignore-case t)
+ (type (lj-current-header))
+ (table (cond ((string= type "Security")
+ (let ((groups (copy-sequence
+ (append lj-groups
+ '(("public" . ?a)
+ ("private" . ?b)
+ ("usemask" . ?c))))))
+ (sort* groups #'string-lessp :key #'car)))
+ ((string= type "Mood")
+ (let ((moods (copy-sequence lj-moods)))
+ (sort* moods #'string-lessp :key #'car)))
+ ((string= type "Userpic")
+ (let ((pics (copy-sequence lj-pickws)))
+ (sort* pics #'string-lessp :key #'car)))
+ ((string= type "Tags")
+ (let ((tags (mapcar #'(lambda (e) (cons e ?a))
+ lj-tags)))
+ (sort* tags #'string-lessp :key #'car)))
+ (t (error 'invalid-argument type))))
+ (current (if (string-match (current-word) type)
+ ""
+ (current-word)))
+ (completion (try-completion current table))
+ (all (all-completions current table)))
+ (if (null completion)
+ (message "Can't find completion for \"%s\"" current)
+ (setq lj-completion-list all))))
+ (when lj-completion-list
+ (multiple-value-bind (completion newlist)
+ (lj-cycle-list lj-completion-list reverse)
+ (setq lj-completion-list newlist)
+ (with-syntax-table lj-header-syntax-table
+ (unless (string= "" (current-word))
+ (unless (eolp)
+ (forward-word))
+ (unless (string-match (lj-current-header) (current-word))
+ (backward-delete-word)))
+ (insert " " completion)))
+ (lj-set-completion-timer)))
+
+(defun lj-sgml-indent-tab-or-complete (&optional refresh)
+ "Does completion if in LJ headers, `sgml-indent-or-tab' otherwise.
+
+If point is after the header separator, this function simply calls
+`sgml-indent-or-tab'. If point is in the headers section it will do
+completion relevent to the header on the current line.
+
+Please note that this is \"inline\" completion, that means you won't
+be prompted for anything in the minibuffer. The completions will
+cycle directly in the LJ-post buffer.
+
+The different header completions are:
+
+ Subject: Sweet bugger all. Sorry, haven't perfected read-mind-mode
+ yet.
+
+ FCC: Computes a new archive filename.
+
+ BCC: BBDB email addresses
+
+ Security: Completes valid security levels. With prefix arg REFRESH,
+ update your list of friends groups from livejournal.com
+
+ Community: No completion, just insert a TAB.
+
+ Music: Refreshes to the currently current song
+
+ Mood: Completes moods. With prefix arg REFRESH, update the list
+ of moods from livejournal.com.
+
+ Location: No completion.
+
+ Userpic: Completes list of LJ userpic keywords you have defined.
+ With prefix arg REFRESH, update you list of userpic
+ keywords.
+
+ Tags: Multiple completion from your list of previously used tags.
+ With prefix arg REFRESH, update your list of tags from
+ livejournal.com."
+ (interactive "P")
+ (let ((header (lj-current-header)))
+ (if header
+ (cond ((string= header "Subject")
+ (error "Sorry, me crystal ball is in for repairs"))
+ ((string= header "FCC")
+ (let ((new (lj-make-archive-name)))
+ (goto-char (point-at-bol))
+ (re-search-forward "^FCC: " (point-at-eol))
+ (delete-region (point) (point-at-eol))
+ (insert new)))
+ ((string= header "BCC")
+ (if-fboundp #'bbdb-complete-name
+ (progn
+ (goto-char (point-at-eol))
+ (bbdb-complete-name))
+ (expand-abbrev)))
+ ((string= header "Security")
+ (when (or refresh (not lj-groups))
+ (lj-get-friends-groups))
+ (goto-char (point-at-bol))
+ (re-search-forward "^Security: " (point-at-eol))
+ (lj-complete-header))
+ ((string= header "Community")
+ (goto-char (point-at-eol))
+ (insert "\t"))
+ ((string= header "Music")
+ (let ((current (and (functionp (symbol-value 'lj-music))
+ (funcall lj-music))))
+ (when current
+ (goto-char (point-at-bol))
+ (re-search-forward "^Music: " (point-at-eol))
+ (delete-region (point) (point-at-eol))
+ (insert current))))
+ ((string= header "Mood")
+ (when (or refresh (not lj-moods))
+ (lj-get-moods))
+ (goto-char (point-at-bol))
+ (re-search-forward "^Mood: " (point-at-eol))
+ (lj-complete-header))
+ ((string= header "Location")
+ (error "If you don't know, I can't help you"))
+ ((string= header "Userpic")
+ (when (or refresh (not lj-pickws))
+ (lj-get-pickws))
+ (goto-char (point-at-bol))
+ (re-search-forward "^Userpic: " (point-at-eol))
+ (lj-complete-header)
+ (when (file-exists-p (expand-file-name
+ (lj-header-content "userpic")
+ lj-userpic-directory))
+ (lj-update-userpic-glyph
+ (expand-file-name (lj-header-content "userpic")
+ lj-userpic-directory))))
+ ((string= header "Tags")
+ (when (or refresh (not lj-tags))
+ (lj-get-tags))
+ (lj-complete-header))
+ (t
+ (error "Unknown LJ header: %s" header)))
+ (sgml-indent-or-tab))))
+
+(defregexp lj-url-regexp
+ (concat "\\(https?://\\|s?ftp://\\|gopher://\\|telnet://"
+ "\\|wais://\\|file:/\\|s?news:\\)"
+ "[^]\t\n \"'()<>[^`{}]*[^]\t\n \"'()<>[^`{}.,;\\(>\\)]+")
+ "A regular expression matching URL's.")
+
+(defregexp lj-email-regexp
+ "[-a-zA-Z0-9._]+@\\([-a-zA-z0-9_]+\\.\\)+[a-zA-Z0-9]+"
+ "A regular expression matching email addresses.")
+
+(defun lj-text-to-html (beg end &optional nopbr)
+ "Convert the plain text in the region BEG - END to html.
+
+With optional argument, NOPBR, don't add <p>..</p> or <br /> tags.
+
+This is an extremely basic converter. All it really does is wrap
+paragraphs in <p>...</p>, and add <br /> to the end of each non-blank
+line. It will also convert old 70's style text highlighting to the
+HTML equivalent. e.g. _text_ -> <u>text</u>, *text* -> <b>text</b>.
+It also converts non-ASCII to HTML entities, and converts URL's and
+email addresses to hyperlinks. Email addresses are obfuscated in an
+attempt to protect against spam harvesters.
+
+Apart from the bold, underline, and hyperlink stuff, that's all the
+eye-candy you'll get. Forget fonts, colours, tables, and lists.
+That's not what this is about. The idea is to keep the text as close
+to \"as-is\" without resorting to using <pre>...</pre> tags.
+
+Calling this function on text that contains \"<lj*>\" will break those
+tags. So take note of what you are doing."
+ (let ((replacements '(("&" . "&")
+ ("\\.\\.\\." . "…")
+ ("<" . "<")
+ (">" . ">")
+ ("\"" . """)
+ ("_\\(.*\\)_" . "<u>\\1</u>")
+ ("\\*\\(.*\\)\\*" . "<b>\\1</b>")))
+ (url lj-url-regexp)
+ (email lj-email-regexp))
+ (unless nopbr
+ (add-to-list 'replacements
+ (cons (if (featurep 'sxemacs)
+ "\\([[:alnum:][:punct:]]\\)\n"
+ "\\([a-zA-Z0-9]\\|\\s.\\)\n")
+ "\\1<br />\n") 'append))
+ (save-restriction
+ (narrow-to-region beg end)
+ (goto-char (point-min))
+ ;; html quoting
+ (mapcar
+ #'(lambda (rep)
+ (save-excursion
+ (while (re-search-forward (car rep) nil t)
+ (replace-match (cdr rep) t))))
+ replacements)
+ ;; paragraphs
+ (unless nopbr
+ (save-excursion
+ (while (not (eobp))
+ (save-restriction
+ (mark-paragraph)
+ (narrow-to-region (point) (mark))
+ (goto-char (point-min))
+ (insert "<p>")
+ (goto-char (point-max))
+ (insert "</p>\n"))
+ (forward-paragraph))))
+ ;; urls
+ (save-excursion
+ (while (re-search-forward url nil t)
+ (replace-match "<a href=\"\\&\">\\&</a>")))
+ ;; emails
+ (save-excursion
+ (while (re-search-forward email nil t)
+ (replace-match "<a href=\"mailto:\\&\">\\&</a>"))
+ (while (search-backward "@" nil t)
+ (replace-match "@" nil t)))
+ ;; entities
+ (save-excursion
+ (lj-entify-region (point-min) (point-max))))
+ (when (region-exists-p)
+ (zmacs-deactivate-region))))
+
+(defun lj-ljtags-to-html ()
+ "Convert \"<lj-*>\" tags to something resembling HTML.
+
+This function is used so that the markup in a post can be validated
+before it is submitted, and also so the post can be previewed before
+it is submitted. Do not expect anything fancy."
+ (goto-char (point-min))
+ ;; polls
+ (save-excursion
+ (while (re-search-forward "<lj-\\(poll\\)" nil t)
+ (let ((p (point-at-bol)))
+ (search-forward (concat "</lj-" (match-string 1) ">") nil t)
+ (save-restriction
+ (narrow-to-region p (point))
+ (lj-text-to-html (point-min) (point-max) 'nopbr)
+ (goto-char (point-min))
+ (insert "<div class=\"ljpoll\">\n<pre>\n")
+ (goto-char (point-max))
+ (insert "\n</pre>\n</div>")))))
+ ;; cuts
+ (save-excursion
+ (while (re-search-forward "^</?lj-cut\\( text=\"---More---\"\\)?>$" nil t)
+ (lj-text-to-html (match-beginning 0) (match-end 0) 'nopbr)))
+ (save-excursion
+ (while (re-search-forward "<lj-cut" nil t)
+ (replace-match "<div class=\"ljcut\">\n\\&")
+ (re-search-forward "</lj-cut>" nil t)
+ (replace-match "\\&\n</div>")))
+ ;; journal links
+ (save-excursion
+ (while (re-search-forward "<lj user=\"\\(.*\\)\" />" nil t)
+ (replace-match "<a href=\"http://\\1.livejournal.com/profile\">
+ <img src=\"http://p-stat.livejournal.com/img/userinfo.gif\"
+ alt=\"[info]\" width=\"17\" height=\"17\"
+ style=\"vertical-align: bottom; border: 0; padding-right: 1px;\" />
+</a>
+<a href=\"http://\\1.livejournal.com/\"><b>\\1</b></a>")))
+ ;; writer's block
+ (save-excursion
+ (while (re-search-forward "<lj-template name=\"qotd\" id=\"[0-9]+\" />"
+ nil t)
+ (replace-match "<h3>Writer's Block Answer</h3>" t))))
+
+(defun lj-validate ()
+ "Check the markup in a LJ post.
+
+Please note that livejournal.com is quite forgiving when it comes to
+HTML in journal entries, lj.el, on the other hand... isn't. For
+your entry to pass this validation it needs to be valid XHTML 1.0
+Transitional."
+ (interactive)
+ (run-hooks 'lj-before-validate-hook)
+ (let ((vf (make-temp-name (expand-file-name "LJ-" (temp-directory))))
+ (pb (current-buffer)))
+ (with-current-buffer (get-buffer-create vf)
+ (erase-buffer)
+ (insert lj-validate-header)
+ (insert
+ (save-excursion
+ (set-buffer pb)
+ (lj-goto-body)
+ (save-restriction
+ (narrow-to-region (point) (point-max))
+ (buffer-string))))
+ (insert lj-validate-footer)
+ (lj-ljtags-to-html)
+ (write-region (point-min) (point-max) vf))
+ (unwind-protect
+ (progn
+ (find-file vf)
+ (sgml-parse-prolog)
+ (sleep-for 5)
+ (sgml-validate (sgml-default-validate-command))
+ (let ((proc (get-buffer-process "*sgml validation*")))
+ (while (process-live-p proc)
+ (sit-for 0.1)
+ (message "Validating markup, please wait..."))
+ (message "Validation complete!")
+ (when (> (process-exit-status proc) 0)
+ (error 'syntax-error (process-name proc)))))
+ (kill-buffer vf)
+ (delete-file vf)
+ (switch-to-buffer pb))
+ (run-hooks 'lj-after-validate-hook)))
+
+(defun lj-preview-headers (buf)
+ "Add htmlised LJ headers in buffer, BUF for `lj-preview'."
+ (let (text pic)
+ (save-excursion
+ (save-restriction
+ (set-buffer buf)
+ (setq pic (lj-header-content "userpic"))
+ (lj-goto-body)
+ (narrow-to-region (point-min) (point))
+ (setq text (buffer-substring-no-properties)))
+ (widen)
+ (with-temp-buffer
+ (insert text)
+ (lj-text-to-html (point-min) (point-max))
+ (goto-char (point-min))
+ (insert "<div class=\"ljhead\">\n")
+ (and (search-forward "<p>")
+ (insert (format "<img src=\"%s\" align=\"right\" alt=\"Userpic\" />"
+ (cdr (assoc pic lj-pickws)))))
+ (while (search-forward "</head>" nil t)
+ (replace-match "" nil t))
+ (goto-char (point-max))
+ (insert "\n</div>\n\n")
+ (buffer-string)))))
+
+(defun lj-preview ()
+ "Preview the LJ post in a web browser.
+
+Please note that this is far from a true representation of what the
+thing will look like once it has been submitted to LiveJournal. But
+it should give you a rough idea."
+ (interactive)
+ (run-hooks 'lj-before-preview-hook)
+ (let ((vf (make-temp-name (expand-file-name "LJ-" (temp-directory))))
+ (pb (current-buffer)))
+ (with-current-buffer (get-buffer-create vf)
+ (erase-buffer)
+ (insert lj-validate-header)
+ (insert (lj-preview-headers pb))
+ (insert "<div class=\"lj\">\n")
+ (insert
+ (save-excursion
+ (set-buffer pb)
+ (lj-goto-body)
+ (save-restriction
+ (narrow-to-region (point) (point-max))
+ (buffer-string))))
+ (insert "\n</div>")
+ (insert lj-validate-footer)
+ (lj-ljtags-to-html)
+ (browse-url-of-buffer))
+ (when (region-exists-p)
+ (zmacs-deactivate-region))
+ (run-hooks 'lj-after-preview-hook)))
+
+(defvar lj-last-url "No URL yet, got nothing to blog about?"
+ "The URL to your last posted blog entry on LiveJournal.")
+
+(defun lj-post-proc-parser (buf)
+ "Process parser for `lj-post'.
+Argument BUF is the process buffer used."
+ (let ((url "^url\n\\(.*$\\)"))
+ (with-current-buffer buf
+ (when (lj-proc-success)
+ (setq lj-last-user-set-time nil)
+ (goto-char (point-min))
+ (if (re-search-forward url nil t)
+ (setq lj-last-url (match-string 1))
+ (setq lj-last-url "NO URL RETURNED FROM LiveJournal"))
+ (kill-buffer nil)))))
+
+(defun lj-archive-post (archive)
+ "Archive the current post to ARCHIVE."
+ (let ((buf (current-buffer)))
+ (with-current-buffer (find-file-noselect archive)
+ (insert-buffer buf)
+ (goto-char (point-max))
+ (insert (format "\n\n<a href\"%s\">View Online</a>\n" lj-last-url))
+ (save-buffer)
+ (kill-buffer nil))))
+
+(defun lj-send-bcc (subject security tags comm mood music location body)
+ "Send a copy of a LJ post via email to `lj-bcc-address'.
+
+Argument SUBJECT is the subject header from the post.
+
+Argument SECURITY is the security level from the post, it is added to
+them mail as X-LJ-Auth header.
+
+Argument TAGS are the tags from the post, added as Keywords header.
+
+Argument COMM is the community from the post, added as X-LJ-Community
+header
+
+Argument MOOD is the mood from the post, added as X-LJ-Mood header.
+
+Argument MUSIC is the music from the post, added as X-Now-Playing
+header.
+
+Argument LOCATION is the location from the post, added as X-LJ-Location
+header
+
+Argument BODY is of course the post's body."
+ (let* ((from (concat user-full-name
+ " <" lj-user-id "@livejournal.com>"))
+ (headers `(("From" . ,from)
+ ("Keywords" . ,tags)
+ ("X-LJ-Auth" . ,security)
+ ("X-LJ-Community" . ,comm)
+ ("X-LJ-Location" . ,location)
+ ("X-LJ-Mood" . ,mood)
+ ("X-Now-Playing" . ,music)
+ ("X-URL" . ,lj-last-url)
+ ("MIME-Version" . "1.0")
+ ("Content-Type" . "text/html")))
+ (mail-user-agent 'sendmail-user-agent))
+ (compose-mail lj-bcc-address subject headers)
+ (goto-char (point-max))
+ (insert body)
+ (declare-fboundp (mail-send-and-exit nil))))
+
+(defun lj-last-entry-proc-parser (buf)
+ "Process the output from `lj-get-last-entry-btime'.
+Argument BUF is the process buffer used."
+ (let ((regexp "^events_1_eventtime\n\\(.*$\\)"))
+ (with-current-buffer buf
+ (when (lj-proc-success)
+ (goto-char (point-min))
+ (re-search-forward regexp nil t)
+ (setq lj-last-entry-btime
+ (apply #'encode-btime (lj-parse-time-string
+ (match-string 1))))
+ (kill-buffer nil)))))
+
+(defun lj-get-last-entry-btime ()
+ "Leech the last entry from LJ to get it's date/time."
+ (let ((cookies (or lj-cookies
+ (error "No LJ cookies found")))
+ (url (concat lj-base-url
+ "?mode=getevents"
+ "&user=" lj-user-id
+ "&auth_method=cookie"
+ (format "&ver=%d" (if (lj-utf-emacs-p) 1 0))
+ "&noprops=1"
+ "&selecttype=lastn"
+ "&howmany=1")))
+ (lj-http-post url cookies #'lj-last-entry-proc-parser)))
+
+(defun lj-set-date/time ()
+ "Return an internal time value to use as post date/time.
+
+This will prompt for a date string of the format yyyy-mm-dd, and a
+time string in the format HH:MM \(24hr\). If either are given a null
+string the current date/time are used.
+
+The value returned is that same as from `encode-time'."
+ (let* ((date (read-string (format-time-string "New date [%Y-%m-%d]: ")
+ nil nil
+ (format-time-string "%Y-%m-%d")))
+ (time (read-string (format-time-string "New time [%H:%M]: ")
+ nil nil
+ (format-time-string "%H:%M")))
+ (timestr (concat date " " time))
+ (btime (apply #'encode-btime (lj-parse-time-string timestr))))
+ (btime-to-time btime)))
+
+(defun lj-twitter-compress-url (url)
+ "Compress URL using tinyurl.com."
+ (with-temp-buffer
+ (mm-url-insert
+ (concat "http://tinyurl.com/api-create.php?url="
+ (lj-hexify-string url t)))
+ (buffer-string)))
+
+(defun lj-twitter-sentinel (process status)
+ "Sentinel for `lj-twitter-update-status' PROCESS STATUS."
+ (if (equal status "finished\n")
+ (message "Sending to Twitter...done")
+ (message "Sending to Twitter...failed: %s"
+ (substring status 0 (1- (length status))))))
+
+(defun lj-twitter-update-status (user pass status url)
+ "Update twitter status.
+
+Argument USER is your twitter username.
+Argument PASS is your twitter password.
+Argument STATUS is the subject header from your LJ post.
+Argument URL is the URL to the post on livejournal.com."
+ (let* ((userpass (format "%s:%s" user pass))
+ (turl (lj-twitter-compress-url url))
+ (twit (concat "status="
+ (lj-hexify-string
+ (concat status " See: " turl) t)))
+ (twiturl "http://twitter.com/statuses/update.json")
+ proc)
+ (if (<= (length twit) 147) ; twitter's max + "status="
+ (progn
+ (setq proc
+ (apply #'start-process
+ "LJcurl" nil "curl"
+ (list "-u" userpass
+ "-d" twit
+ "-s" twiturl
+ "-H" "X-Twitter-Client: SXEmacs_LJ"
+ "-H" (format "X-Twitter-Client-Version: %s"
+ lj-version)
+ "-H" (concat
+ "X-Twitter-Client-URL: "
+ "http://www.sxemacs.org/~steve/lj/lj.xml")
+ "-d" "source=lj.el")))
+ (set-process-sentinel proc #'lj-twitter-sentinel))
+ (warn "LJ subject too long for Twitter"))))
+
+(defun lj-post (&optional out-of-order)
+ "Submit a new post to LiveJournal.
+
+With a single prefix argument, OUT-OF-ORDER, prompt for a date/time to
+use for the post.
+
+With two prefix args, also set a \"date out of order\" flag."
+ (interactive "i")
+ (run-hooks 'lj-before-post-hook)
+ (let ((subject (lj-header-content "subject"))
+ (body (and (lj-goto-body)
+ (buffer-substring-no-properties (point) (point-max))))
+ (user lj-user-id)
+ (security (lj-header-content "security"))
+ (tags (lj-header-content "tags"))
+ (comm (lj-header-content "community"))
+ (mood (lj-header-content "mood"))
+ (location (lj-header-content "location"))
+ (music (lj-header-content "music"))
+ (pickw (lj-header-content "userpic"))
+ (cookies (or lj-cookies
+ (error "No LJ cookies found")))
+ (backdated nil)
+ (date nil)
+ (draftid (buffer-file-name))
+ url)
+ (when (and out-of-order
+ (null current-prefix-arg))
+ (setq backdated t
+ date lj-last-user-set-time))
+ (cond ((eq (car current-prefix-arg) 4)
+ (setq date (lj-set-date/time)))
+ ((eq (car current-prefix-arg) 16)
+ (setq date (lj-set-date/time)
+ backdated t)))
+ (setq url (lj-construct-url subject body user security tags comm nil nil
+ mood location music pickw date backdated))
+ ;; lets save the draft out to disc just in case something goes wrong
+ (save-buffer)
+ (lj-http-post url cookies #'lj-post-proc-parser)
+ (and lj-archive-posts
+ (lj-archive-post (lj-header-content "fcc")))
+ (and lj-bcc-address
+ (lj-send-bcc subject security tags comm mood music location body))
+ (and lj-twitter-flag
+ (lj-twitter-update-status lj-twitter-username lj-twitter-password
+ subject lj-last-url))
+ (delete-file draftid)
+ (run-hooks 'lj-after-post-hook)))
+
+;; keep track of the date of the last entry for backdating purposes
+(add-hook 'lj-after-post-hook #'lj-get-last-entry-btime)
+
+;;; Writer's Block
+(defvar lj-qotd-buffer "*LJ Writer's Block*"
+ "Buffer displaying a list of LJ Writer's Block questions.")
+
+(defun lj-parse-qotd-archive ()
+ "Leech the qotd archive and make it presentable for human consumption."
+ (let ((buf (get-buffer-create lj-qotd-buffer))
+ (bregexp "<!-- Content -->")
+ (eregexp "<p class='skiplinks'>")
+ (qregexp "^<p class='qotd-archive-item-question'>\\(.*\\)</p><p")
+ (dregexp "^<p class='qotd-archive-item-date'>\\(.*[0-9]+\\)</p>")
+ (idregexp "^.*qotd=\\([0-9]+\\).*\n.*$")
+ (url "http://www.livejournal.com/misc/qotdarchive.bml")
+ b e)
+ (with-current-buffer buf
+ (when (lj-utf-emacs-p)
+ (set-buffer-file-coding-system 'utf-8))
+ (erase-buffer)
+ (mm-url-insert url)
+ (goto-char (point-min))
+ (setq b (and (search-forward bregexp nil t)
+ (forward-line 3)
+ (point-at-bol))
+ e (and (search-forward eregexp nil t)
+ (point-at-bol)))
+ (narrow-to-region b e)
+ (goto-char (point-min))
+ (insert (make-string 72 ?=) "\n")
+ (save-excursion
+ (while (re-search-forward dregexp nil t)
+ (replace-match (format "%s:\n\n" (match-string 1)) t)))
+ (save-excursion
+ (while (re-search-forward qregexp nil t)
+ (replace-match (format "QOTD: %s\n" (match-string 1)) t)))
+ (save-excursion
+ (while (re-search-forward "^QOTD:" nil t)
+ (fill-paragraph nil)))
+ (save-excursion
+ (while (re-search-forward idregexp nil t)
+ (replace-match (concat (format "\nWriter's Block ID: %s\n"
+ (match-string 1))
+ (make-string 72 ?=)) t))))))
+
+(defun lj-narrow-to-qotd (qotd)
+ "Narrow Writer's Block buffer to a single QOTD."
+ (let ((delim (make-string 72 ?=))
+ b e)
+ (goto-char (point-max))
+ (setq e (and (search-backward (format "ID: %d" qotd))
+ (point-at-eol))
+ b (search-backward delim))
+ (narrow-to-region b e)
+ (shrink-window-if-larger-than-buffer)
+ (other-window 1)
+ (unless (eq major-mode 'lj-mode)
+ (switch-to-buffer "*LJ-Post*"))
+ (unless (zerop lj-qotd)
+ (insert (format "<lj-template name=\"qotd\" id=\"%d\" />\n\n"
+ lj-qotd)))))
+
+(defun lj-cleanup-qotd ()
+ "Reset `lj-qotd' to zero and kill the qotd buffer."
+ (progn
+ (setq lj-qotd 0)
+ (delete-other-windows)
+ (when (buffer-live-p (get-buffer lj-qotd-buffer))
+ (kill-buffer lj-qotd-buffer))))
+
+(defun lj-qotd-quit ()
+ "Cancel a LJ \"Writer's Block\" composition."
+ (interactive)
+ (other-window 1)
+ (unless (eq major-mode 'lj-mode)
+ (switch-to-buffer "*LJ-Post*"))
+ (lj-cleanup-qotd)
+ (and (lj-goto-subject)
+ (kill-region (point) (point-at-eol)))
+ (and (lj-goto-tags)
+ (kill-region (point) (point-at-eol)))
+ (lj-goto-body)
+ (remove-hook 'lj-after-post-hook #'lj-cleanup-qotd))
+
+(defun lj-writers-block ()
+ "Compose an answer to a LJ \"Writer's Block\" question."
+ (interactive)
+ (and (lj-goto-subject)
+ (kill-region (point) (point-at-eol))
+ (insert "Writer's Block: "))
+ (and (lj-goto-tags)
+ (kill-region (point) (point-at-eol))
+ (insert "writer's block"))
+ (and (lj-goto-body)
+ (kill-region (point) (point-max)))
+ (lj-sgml-indent-tab-or-complete)
+ (lj-parse-qotd-archive)
+ (pop-to-buffer lj-qotd-buffer)
+ (local-set-key [space] #'scroll-up)
+ (local-set-key [delete] #'scroll-down)
+ (local-set-key [return]
+ #'(lambda ()
+ (interactive)
+ (setq lj-qotd (read-number "Select Writer's Block ID: " t))
+ (lj-narrow-to-qotd lj-qotd)))
+ (local-set-key [q] #'lj-qotd-quit)
+ (message "[SPC]/[DEL] to scroll, [q] to cancel, [RET] to enter QOTD ID")
+ (add-one-shot-hook 'lj-after-post-hook #'lj-cleanup-qotd 'append))
+
+(defun lj-session-auto-save-files ()
+ "Return a list of auto-save files in `lj-drafts-directory'."
+ (directory-files lj-drafts-directory nil
+ #'auto-save-file-name-p 'list t))
+
+(defun lj-recover-drafts (files)
+ "Recover auto-saved FILES in `lj-drafts-directory'."
+ (let ((default-directory lj-drafts-directory))
+ (while files
+ (recover-file (auto-save-original-name (car files)))
+ (lj-edit-draft (auto-save-original-name (car files)))
+ (setq files (cdr files)))))
+
+;;; Globals
+
+(defun lj ()
+ "Compose a new LiveJournal entry."
+ (interactive)
+ (run-hooks 'lj-init-hook)
+ ;; Maybe update tags, groups, moods, pic keywords
+ (or lj-tags (lj-get-tags))
+ (or lj-groups (lj-get-friends-groups))
+ (or lj-moods (lj-get-moods))
+ (or lj-default-pickw (lj-get-pickws))
+ (let ((auto-saves (lj-session-auto-save-files)))
+ (if (and auto-saves
+ (y-or-n-p "Auto saved drafts exist, do you wish to recover "))
+ (lj-recover-drafts auto-saves)
+ (lj-generate-new-buffer))))
+
+(defun lj-blog-buffer (buffer &optional noformat)
+ "Use contents of BUFFER to compose LJ entry.
+
+With optional prefix arg, NOFORMAT, don't attempt to convert the text
+to HTML."
+ (interactive "bBuffer to blog: \nP")
+ (let ((blog (with-temp-buffer
+ (insert-buffer buffer)
+ (unless current-prefix-arg
+ (lj-text-to-html (point-min) (point-max)))
+ (buffer-substring-no-properties))))
+ (lj)
+ (insert blog)))
+
+(defun lj-blog-region (beg end &optional noformat)
+ "Compose LJ entry using content of region BEG - END.
+
+With optional prefix arg, NOFORMAT, dont' attempt to convert the text
+to HTML."
+ (interactive "r\nP")
+ (let ((blog (buffer-substring beg end)))
+ (unless current-prefix-arg
+ (with-temp-buffer
+ (insert blog)
+ (lj-text-to-html (point-min) (point-max))
+ (setq blog (buffer-substring-no-properties))))
+ (lj)
+ (insert blog)))
+
+(defun lj-edit-draft (draft)
+ "Edit an existing draft previously saved from lj.el."
+ (interactive (list
+ (read-file-name "Edit draft: "
+ lj-drafts-directory "" t)))
+ (if (or (zerop (length draft))
+ (not (file-readable-p (expand-file-name draft))))
+ (error 'invalid-argument draft)
+ (switch-to-buffer (find-file-noselect (expand-file-name draft)))
+ (rename-buffer "*LJ-draft*" 'unique)
+ (goto-char (point-min))
+ (make-extent (point) (point-at-eol))
+ (lj-update-userpic-glyph
+ (expand-file-name (lj-header-content "userpic")
+ lj-userpic-directory))
+ (re-search-forward lj-header-separator nil t)
+ (forward-line -1)
+ (set-extent-property
+ (make-extent (point-at-bol) (1+ (point-at-eol))) 'invisible t)
+ (lj-goto-body)
+ (lj-mode)))
+
+(provide 'lj)
+
+;; On-load actions
+(and (file-exists-p lj-tags-file)
+ (load-file lj-tags-file))
+(and (file-exists-p lj-groups-file)
+ (load-file lj-groups-file))
+(and (file-exists-p lj-moods-file)
+ (load-file lj-moods-file))
+(and (file-exists-p lj-pickws-file)
+ (load-file lj-pickws-file))
+;;; lj.el ends here
--- /dev/null
+;; mozmail.el --- Open mailto links from Mozilla in an (X)Emacs mailer.
+
+;; Copyright (C) 2003,04,07 Steve Youngs
+
+;; Author: Steve Youngs <steve@youngs.au.com>
+;; Maintainer: Steve Youngs <steve@youngs.au.com>
+;; Time-stamp: <Tuesday Jan 30, 2007 14:28:11 steve>
+;; Created: <2003-12-22>
+;; Homepage: None, contact maintainer for the latest version.
+;; Or get it from the XEmacs "net-utils" package.
+;; Keywords: mail
+
+;; This file is part of mozmail.
+
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions
+;; are met:
+;;
+;; 1. Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; 2. Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;;
+;; 3. Neither the name of the author nor the names of any contributors
+;; may be used to endorse or promote products derived from this
+;; software without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR
+;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+;; DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
+;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
+;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
+;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
+;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+;;; Commentary:
+;;
+;; Mozilla is a terrific web browser, but for mail and news I
+;; much prefer XEmacs & Gnus. Once this is set up, clicking on a
+;; mailto link in Mozilla will fire up an (X)Emacs MUA with all
+;; the appropriate fields filled in. MUAs that are supported at
+;; this time are: Gnus, VM, MH-E, MEW, Wanderlust, RMail, and the
+;; built-in Emacs mailer.
+;;
+;; Setup (Mozilla):
+;;
+;; To get this to work you will need a very recent version of Mozilla,
+;; I was using 1.6b when I wrote this. If you get `mozmail.el' to
+;; work with older versions of Mozilla, please let me know.
+;;
+;; The first thing you must do is tweak your Mozilla settings so
+;; mailto links will invoke an external process. Fire up Mozilla,
+;; and in the location bar type: about:config
+;;
+;; That will give you a list of all of your settings. There are
+;; litterally hundreds of them so prune them down by typing
+;; "protocol-handler" in the filter bar. Now right-click on one of
+;; the items in the list and choose "New -> Boolean". In the
+;; resulting dialog, type:
+;; "network.protocol-handler.external.mailto" (sans quotes).
+;; Another dialog will appear prompting for a value for this new
+;; variable, enter "true" (sans quotes).
+;;
+;; Next, add another variable: right-click on a list item and choose "New
+;; -> String", in the dialog put: "network.protocol-handler.app.mailto".
+;; In the value dialog for this variable, put: "mozmail.sh".
+;;
+;; That's all you need to do on the Mozilla side of things. Restarting
+;; Mozilla probably wouldn't be a bad idea.
+;;
+;; Setup (Shell Script):
+;;
+;; You will also need a very small (2 line) wrapper script. Copy
+;; the following text to `mozmail.sh', put it somewhere in your
+;; $PATH and make it executable.
+;;
+;; #!/bin/bash
+;; gnuclient -eval "(mozmail \"$1\")"
+;;
+;; Setup ((X)Emacs):
+;;
+;; Add the following to your init file...
+;;
+;; (gnuserv-start)
+;; (require 'mozmail)
+;;
+;; People who use MUA's other than Gnus will need to customise the
+;; variable `mozmail-default-mua'. See that variable's doc string
+;; for details.
+;;
+;; Gnus users can optionally customise `mozmail-gnus-is-plugged' to
+;; run Gnus in either "plugged" or "unplugged" modes.
+;;
+;; Alternative Setup for GNOME users:
+;;
+;; I received some feedback from a user who had this to say about
+;; setting mozmail up with GNOME (on Debian):
+;;
+;; Here's different way to enable it for GNOME users (at least on
+;; Debian). Instead of modifying Mozilla's preferences just run
+;; gnome-default-applications-properties (see the
+;; Applications/Desktop Preferences/Advanced/Preferred Applications
+;; menu entry), on the "Mail Reader" tab select "Custom Mail Reader"
+;; and enter "mozmail.sh %s".
+;;
+;; With this mozmail gets used by all Mozilla based browser on my
+;; system.
+
+;;; Todo:
+;;
+;; o Can this be done without using gnuserv/gnuclient?
+
+;;; ChangeLog:
+;;
+;; From this point on, `mozmail.el' is in the XEmacs packages CVS
+;; repository. For further changes please consult
+;; ./xemacs-packages/net-utils/ChangeLog.
+;;
+
+;;; Code:
+(defconst mozmail-version 1.9
+ "Mozmail version.")
+
+(defun mozmail-version (&optional arg)
+ "Return the current version info for mozmail.
+
+With optional argument ARG, insert version info at point in the current
+buffer."
+ (interactive "P")
+ (let ((ver mozmail-version))
+ (if (interactive-p)
+ (if arg
+ (insert (format "mozmail v%.1f" ver))
+ (message "mozmail v%.1f" ver))
+ ver)))
+
+(eval-and-compile
+ (autoload 'with-electric-help "ehelp")
+ (autoload 'gnus-alive-p "gnus-util")
+ (autoload 'gnus-group-mail "gnus-msg" nil t)
+ (autoload 'message-goto-to "message" nil t)
+ (autoload 'message-goto-subject "message" nil t)
+ (autoload 'message-goto-cc "message" nil t)
+ (autoload 'message-goto-bcc "message" nil t)
+ (autoload 'message-goto-body "message" nil t)
+ (autoload 'gnus "gnus" nil t)
+ (autoload 'vm-mail "vm-startup" nil t)
+ (autoload 'mew-send "mew" nil t)
+ (autoload 'wl-draft "wl-draft" nil t)
+ (autoload 'mh-smail "mh-comp" nil t)
+ (autoload 'rmail-mail "rmail" nil t)
+ (autoload 'mail-to "sendmail" nil t)
+ (autoload 'mail-cc "sendmail" nil t)
+ (autoload 'mail-bcc "sendmail" nil t)
+ (autoload 'mail-subject "sendmail" nil t)
+ (autoload 'mail-text "sendmail" nil t)
+ (autoload 'lm-commentary "lisp-mnt" nil t))
+
+(eval-when-compile
+ (defalias 'mozmail-compose 'ignore))
+
+(defun mozmail-commentary ()
+ "*Display the commentary section of mozmail.el."
+ (interactive)
+ (with-electric-help
+ '(lambda ()
+ (insert
+ (with-temp-buffer
+ (erase-buffer)
+ (insert (lm-commentary (locate-library "mozmail.el")))
+ (goto-char (point-min))
+ (while (re-search-forward "^;+ ?" nil t)
+ (replace-match "" nil nil))
+ (buffer-string (current-buffer)))))
+ "*Mozmail Commentary*"))
+
+(defun mozmail-copyright ()
+ "*Display the copyright notice for mozmail."
+ (interactive)
+ (with-electric-help
+ '(lambda ()
+ (insert
+ (with-temp-buffer
+ (erase-buffer)
+ (insert-file-contents (locate-library "mozmail.el"))
+ (goto-char (point-min))
+ (re-search-forward ";;; Commentary" nil t)
+ (beginning-of-line)
+ (narrow-to-region (point-min) (point))
+ (while (re-search-backward "^;+ ?" nil t)
+ (replace-match "" nil nil))
+ (buffer-string (current-buffer)))))
+ "*Mozmail Copyright Notice*"))
+
+(defgroup mozmail nil
+ "Customisations for mozmail."
+ :prefix "mozmail-"
+ :group 'mail)
+
+(defcustom mozmail-gnus-is-plugged t
+ "*When non-nil use Gnus in \"plugged\" mode."
+ :type 'boolean
+ :group 'mozmail)
+
+(defcustom mozmail-default-mua gnus
+ "*The default \(X\)Emacs mailer to use.
+
+Valid symbols are: gnus, vm, mhe, mew, wanderlust, rmail, emacs.
+
+CAUTION: If you wish to set this variable outside of the custom
+interface, you MUST set it via `customize-set-variable'.
+
+For example:
+
+ \(customize-set-variable 'mozmail-default-mua 'gnus\)"
+ :type '(choice (const :tag "Gnus" :value gnus)
+ (const :tag "VM" :value vm)
+ (const :tag "MH-E" :value mhe)
+ (const :tag "MEW" :value mew)
+ (const :tag "Wanderlust" :value wanderlust)
+ (const :tag "RMail" :value rmail)
+ (const :tag "Emacs Mail" :value emacs))
+ :require 'mozmail
+ :initialize (lambda (symbol value)
+ (progn
+ (let ((gnus 'gnus)
+ (vm 'vm)
+ (mhe 'mhe)
+ (mew 'mew)
+ (wanderlust 'wanderlust)
+ (rmail 'rmail)
+ (emacs 'emacs))
+ (custom-initialize-default symbol value)
+ (defalias 'mozmail-compose
+ (intern (format "mozmail-compose-%s" value)))))
+ (message (format "%s set to %s" symbol value)))
+ :set (lambda (symbol value)
+ (defalias 'mozmail-compose
+ (intern (format "mozmail-compose-%s" value)))
+ (message (format "%s set to %s" symbol value)))
+ :group 'mozmail)
+
+
+;; Lifted verbatim from url.el, only the names have been changed to
+;; protect the innocent.
+(defun mozmail-url-unhex (x)
+ (if (> x ?9)
+ (if (>= x ?a)
+ (+ 10 (- x ?a))
+ (+ 10 (- x ?A)))
+ (- x ?0)))
+
+(defun mozmail-url-unhex-string (str &optional allow-newlines)
+ "Remove %XXX embedded spaces, etc in a url.
+If optional second argument ALLOW-NEWLINES is non-nil, then allow the
+decoding of carriage returns and line feeds in the string, which is normally
+forbidden in URL encoding."
+ (setq str (or str ""))
+ (let ((tmp "")
+ (case-fold-search t))
+ (while (string-match "%[0-9a-f][0-9a-f]" str)
+ (let* ((start (match-beginning 0))
+ (ch1 (mozmail-url-unhex (elt str (+ start 1))))
+ (code (+ (* 16 ch1)
+ (mozmail-url-unhex (elt str (+ start 2))))))
+ (setq tmp (concat
+ tmp (substring str 0 start)
+ (cond
+ (allow-newlines
+ (char-to-string code))
+ ((or (= code ?\n) (= code ?\r))
+ " ")
+ (t (char-to-string code))))
+ str (substring str (match-end 0)))))
+ (setq tmp (concat tmp str))
+ tmp))
+
+(defun mozmail-compose-gnus (to &optional subject cc bcc body)
+ "Compose a mail in Gnus from a Mozilla mailto link.
+
+Argument TO is the receipient of the mail.
+Optional argument SUBJECT is the mail's subject.
+Optional argument CC - carbon copy.
+Optional argument BCC - blind carbon copy.
+Optional argument BODY - text that will appear in the body of the
+mail."
+ (unless (gnus-alive-p)
+ (if mozmail-gnus-is-plugged
+ (gnus)
+ (gnus-unplugged)))
+ (gnus-group-mail)
+ (message-goto-to)
+ (insert (mozmail-url-unhex-string to))
+ (when subject
+ (message-goto-subject)
+ (insert (mozmail-url-unhex-string subject)))
+ (when cc
+ (message-goto-cc)
+ (insert (mozmail-url-unhex-string cc)))
+ (when bcc
+ (message-goto-bcc)
+ (insert (mozmail-url-unhex-string bcc)))
+ (when body
+ (message-goto-body)
+ (insert (mozmail-url-unhex-string body 'allow-newlines))))
+
+(defun mozmail-populate-headers (to &optional subject cc bcc body)
+ "Populate the mail headers from a mailto link.
+
+Argument TO is the receipient of the mail.
+Optional argument SUBJECT is the mail's subject.
+Optional argument CC - carbon copy.
+Optional argument BCC - blind carbon copy.
+Optional argument BODY - text that will appear in the body of the
+mail."
+ (mail-to)
+ (insert (mozmail-url-unhex-string to))
+ (when subject
+ (mail-subject)
+ (insert (mozmail-url-unhex-string subject)))
+ (when cc
+ (mail-cc)
+ (insert (mozmail-url-unhex-string cc)))
+ (when bcc
+ (mail-bcc)
+ (insert (mozmail-url-unhex-string bcc)))
+ (when body
+ (mail-text)
+ (insert (mozmail-url-unhex-string body 'allow-newlines))))
+
+(defun mozmail-compose-vm (to &optional subject cc bcc body)
+ "Compose a mail in VM from a Mozilla mailto link.
+
+Argument TO is the receipient of the mail.
+Optional argument SUBJECT is the mail's subject.
+Optional argument CC - carbon copy.
+Optional argument BCC - blind carbon copy.
+Optional argument BODY - text that will appear in the body of the
+mail."
+ (vm-mail)
+ (mozmail-populate-headers to subject cc bcc body))
+
+(defun mozmail-compose-mhe (to &optional subject cc bcc body)
+ "Compose a mail in MH-E from a Mozilla mailto link.
+
+Argument TO is the receipient of the mail.
+Optional argument SUBJECT is the mail's subject.
+Optional argument CC - carbon copy.
+Optional argument BCC - blind carbon copy.
+Optional argument BODY - text that will appear in the body of the
+mail."
+ (mh-smail)
+ (mozmail-populate-headers to subject cc bcc body))
+
+(defun mozmail-compose-mew (to &optional subject cc bcc body)
+ "Compose a mail in MEW from a Mozilla mailto link.
+
+Argument TO is the receipient of the mail.
+Optional argument SUBJECT is the mail's subject.
+Optional argument CC - carbon copy.
+Optional argument BCC - blind carbon copy.
+Optional argument BODY - text that will appear in the body of the
+mail."
+ (mew-send)
+ (mozmail-populate-headers to subject cc bcc body))
+
+(defun mozmail-compose-wanderlust (to &optional subject cc bcc body)
+ "Compose a mail in Wanderlust from a Mozilla mailto link.
+
+Argument TO is the receipient of the mail.
+Optional argument SUBJECT is the mail's subject.
+Optional argument CC - carbon copy.
+Optional argument BCC - blind carbon copy.
+Optional argument BODY - text that will appear in the body of the
+mail."
+ (wl-draft)
+ (mozmail-populate-headers to subject cc bcc body))
+
+(defun mozmail-compose-emacs (to &optional subject cc bcc body)
+ "Compose a mail in Emacs from a Mozilla mailto link.
+
+Argument TO is the receipient of the mail.
+Optional argument SUBJECT is the mail's subject.
+Optional argument CC - carbon copy.
+Optional argument BCC - blind carbon copy.
+Optional argument BODY - text that will appear in the body of the
+mail."
+ (mail)
+ (mozmail-populate-headers to subject cc bcc body))
+
+(defun mozmail-compose-rmail (to &optional subject cc bcc body)
+ "Compose a mail in RMail from a Mozilla mailto link.
+
+Argument TO is the receipient of the mail.
+Optional argument SUBJECT is the mail's subject.
+Optional argument CC - carbon copy.
+Optional argument BCC - blind carbon copy.
+Optional argument BODY - text that will appear in the body of the
+mail."
+ (rmail-mail)
+ (mozmail-populate-headers to subject cc bcc body))
+
+(defun mozmail-split-string (string char)
+ "Does `split-string-by-char' in XEmacs and `split-string' in GNU/Emacs."
+ (if (featurep 'xemacs)
+ ;; XEmacs
+ (split-string-by-char string char)
+ ;; GNU/Emacs
+ (split-string string (char-to-string char))))
+
+(defun mozmail-split-url (url sym)
+ "Split a mailto URL into its various components.
+
+Argument URL is a mailto URL.
+Argument SYM is a symbol representing the field name that you
+want a value for. Valid symbols are: `to', `subject', `cc', `bcc',
+and `body'."
+ (let ((value nil))
+ (cond ((eq sym 'to)
+ (setq value (substring (car (mozmail-split-string url ?\?)) 7)))
+ ((eq sym 'subject)
+ (setq url (cdr (mozmail-split-string url ?\?)))
+ (when url
+ (setq url (mozmail-split-string (car url) ?&))
+ (while url
+ (when (string= "subject=" (downcase (substring (car url) 0 8)))
+ (setq value (substring (car url) 8)))
+ (setq url (cdr url)))))
+ ((eq sym 'cc)
+ (setq url (cdr (mozmail-split-string url ?\?)))
+ (when url
+ (setq url (mozmail-split-string (car url) ?&))
+ (while url
+ (when (string= "cc=" (downcase (substring (car url) 0 3)))
+ (setq value (substring (car url) 3)))
+ (setq url (cdr url)))))
+ ((eq sym 'bcc)
+ (setq url (cdr (mozmail-split-string url ?\?)))
+ (when url
+ (setq url (mozmail-split-string (car url) ?&))
+ (while url
+ (when (string= "bcc=" (downcase (substring (car url) 0 4)))
+ (setq value (substring (car url) 4)))
+ (setq url (cdr url)))))
+ ((eq sym 'body)
+ (setq url (cdr (mozmail-split-string url ?\?)))
+ (when url
+ (setq url (mozmail-split-string (car url) ?&))
+ (while url
+ (when (string= "body=" (downcase (substring (car url) 0 5)))
+ (setq value (substring (car url) 5)))
+ (setq url (cdr url)))))
+ (t
+ (error 'invalid-argument sym)))
+ value))
+
+(defun mozmail (url)
+ "Use an (X)Emacs MUA as the target of a Mozilla mailto link.
+
+See `mozmail-commentary' for instructions on how to set this up in
+Mozilla."
+ ;; A URL that consists of just "mailto:" and nothing else is obviously
+ ;; wrong.
+ (when (string= (substring url 7) "")
+ (error 'invalid-argument url))
+ (let ((to (mozmail-split-url url 'to))
+ (subject (mozmail-split-url url 'subject))
+ (cc (mozmail-split-url url 'cc))
+ (bcc (mozmail-split-url url 'bcc))
+ (body (mozmail-split-url url 'body)))
+ (mozmail-compose to subject cc bcc body)))
+
+(provide 'mozmail)
+
+;;; mozmail.el ends here
+
--- /dev/null
+;;; mpd.el --- A complete ripoff of xwem-mpd.
+
+;; Copyright (C) 2008 Steve Youngs
+
+;; Original xwem-mpd:
+;; Copyright (C) 2005 Richard Klinda
+;; Author: Richard Klinda <ignotus@freemail.hu>
+;; Zajcev Evgeny <zevlg@yandex.ru>
+;; Created: 2004
+
+;; Keywords: music, entertainment
+
+;; This file is NOT part of anything.
+
+;; The original xwem-mpd.el was released under the terms of the GPLv2.
+;; mpd.el uses the BSD licence.
+
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions
+;; are met:
+;;
+;; 1. Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; 2. Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;;
+;; 3. Neither the name of the author nor the names of any contributors
+;; may be used to endorse or promote products derived from this
+;; software without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR
+;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+;; DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
+;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES# LOSS OF USE, DATA, OR PROFITS# OR
+;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
+;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
+;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+;;; Commentary:
+
+;; You need MusicPD - Music Playing Daemon
+;; (http://musicpd.sourceforge.net/) to be set up and running.
+
+;;; Code:
+\f
+(eval-when-compile
+ (autoload 'google-query "google-query" nil t))
+
+(defgroup mpd nil
+ "Group to customize mpd."
+ :prefix "mpd-"
+ :group 'hypermedia)
+
+(defcustom mpd-update-rate 5
+ "MPD variables updating rate in seconds."
+ :type 'number
+ :group 'mpd)
+
+(defcustom mpd-directory
+ (file-name-as-directory
+ (expand-file-name ".mpd" (user-home-directory)))
+ "Base mpd directory."
+ :type 'directory
+ :group 'mpd)
+
+(defcustom mpd-lyrics-dir
+ (file-name-as-directory
+ (expand-file-name "lyrics" mpd-directory))
+ "Directory containing songs lyrics."
+ :type 'directory
+ :group 'mpd)
+
+(defcustom mpd-after-command-hook nil
+ "Hooks to run after MPD command is executed.
+Executed command name stored in `mpd-this-command'."
+ :type 'hook
+ :group 'mpd)
+
+(defcustom mpd-before-variables-update-hook nil
+ "Hooks to run before updating mpd variables."
+ :type 'hook
+ :group 'mpd)
+
+(defcustom mpd-after-variables-update-hook nil
+ "Hooks to run after mpd variables has been updated."
+ :type 'hook
+ :group 'mpd)
+
+\f
+(defvar mpd-process nil)
+(defvar mpd-itimer nil)
+(defvar mpd-dock-frame nil)
+(defvar mpd-dock-buffer nil)
+
+(defun mpd-start-connection ()
+ "Open connection to MusicPD daemon.
+Set `mpd-process' by side effect."
+ (when (or (not mpd-process)
+ (not (eq mpd-process 'open)))
+ (setq mpd-process (open-network-stream "mpd" " *mpd connection*"
+ "localhost" 6600))
+ (when (fboundp 'set-process-coding-system)
+ (set-process-coding-system mpd-process 'utf-8 'utf-8))
+ (set-process-filter mpd-process 'mpd-process-filter)
+ (set-process-sentinel mpd-process 'mpd-process-sentinel)
+ (process-kill-without-query mpd-process)
+
+ (add-hook 'mpd-after-command-hook #'mpd-update-variables)
+ (setq mpd-itimer
+ (start-itimer "mpd-vars-update" #'mpd-update-variables
+ mpd-update-rate mpd-update-rate))))
+
+(defun mpd-disconnect ()
+ "Disconnect from the mpd daemon.
+
+Also removes the update hook, kills the itimer, and removes the dock
+frame."
+ (interactive)
+ (let ((proc (get-process (process-name mpd-process)))
+ (timer (get-itimer (itimer-name mpd-itimer))))
+ (remove-hook 'mpd-after-command-hook #'mpd-update-variables)
+ (when (itimerp timer)
+ (delete-itimer timer))
+ (when (process-live-p proc)
+ (delete-process (get-process (process-name mpd-process))))
+ (when (frame-live-p mpd-dock-frame)
+ (delete-frame mpd-dock-frame))
+ (when (buffer-live-p mpd-dock-buffer)
+ (kill-buffer mpd-dock-buffer))))
+
+;; mpd variables
+(defvar mpd-zero-vars-p t)
+(defvar mpd-status-update-p nil)
+
+(defvar **mpd-var-Album* nil)
+(defvar **mpd-var-Artist* nil)
+(defvar **mpd-var-Date* nil)
+(defvar **mpd-var-Genre* nil)
+(defvar **mpd-var-Id* nil)
+(defvar **mpd-var-Pos* nil)
+(defvar **mpd-var-Time* nil)
+(defvar **mpd-var-Title* nil)
+(defvar **mpd-var-Track* nil)
+(defvar **mpd-var-audio* nil)
+(defvar **mpd-var-bitrate* nil)
+(defvar **mpd-var-file* nil)
+(defvar **mpd-var-length* nil)
+(defvar **mpd-var-playlist* nil)
+(defvar **mpd-var-playlistlength* nil)
+(defvar **mpd-var-random* nil)
+(defvar **mpd-var-repeat* nil)
+(defvar **mpd-var-song* nil)
+(defvar **mpd-var-songid* nil)
+(defvar **mpd-var-state* nil)
+(defvar **mpd-var-time* nil)
+(defvar **mpd-var-volume* nil)
+(defvar **mpd-var-xfade* nil)
+
+(defvar mpd-pre-mute-volume nil
+ "Holds the value of `**mpd-var-volume* prior to muting.
+The purpose of this is so that when you unmute, it goes back to the
+volume you had it set to before you muted.")
+
+(defvar mpd-this-command nil
+ "The mpd command currently executing.
+Useful to use in `mpd-after-command-hook' hooks.")
+
+(defmacro define-mpd-command (cmd args &rest body)
+ "Define new mpd command."
+ `(defun ,cmd ,args
+ ,@body
+ (let ((mpd-this-command ',cmd))
+ (run-hooks 'mpd-after-command-hook))))
+
+(defun mpd-send (format &rest args)
+ "Send formated string into connection.
+FORMAT and ARGS are passed directly to `format' as arguments."
+ (let ((string (concat (apply #'format format args) "\n")))
+ (if (eq (process-status mpd-process) 'open)
+ (process-send-string mpd-process string)
+ (mpd-start-connection)
+ (process-send-string mpd-process string))))
+
+(defun mpd-stopped-p ()
+ (string= **mpd-var-state* "stop"))
+(defun mpd-paused-p ()
+ (string= **mpd-var-state* "pause"))
+(defun mpd-muted-p ()
+ (zerop (string-to-number **mpd-var-volume*)))
+
+;; (mpd-songpos)
+(defun mpd-songpos ()
+ (if **mpd-var-time*
+ (destructuring-bind (a b)
+ (split-string **mpd-var-time* ":")
+ (cons (string-to-int a) (string-to-int b)))
+ (cons 0 1))) ; todo?
+
+(defun mpd-volume-up (step)
+ "Increase the volume by STEP increments.
+STEP can be given via numeric prefix arg and defaults to 1 if omitted."
+ (interactive "p")
+ (let* ((oldvol (string-to-number **mpd-var-volume*))
+ (newvol (+ oldvol step))
+ (mpd-this-command 'mpd-volume-down))
+ (when (>= newvol 100)
+ (setq newvol 100))
+ (mpd-send "setvol %d" newvol)
+ (run-hooks 'mpd-after-command-hook)))
+
+(defun mpd-volume-down (step)
+ "Decrease the volume by STEP increments.
+STEP can be given via numeric prefix arg and defaults to 1 if omitted."
+ (interactive "p")
+ (let* ((oldvol (string-to-number **mpd-var-volume*))
+ (newvol (- oldvol step))
+ (mpd-this-command 'mpd-volume-down))
+ (when (<= newvol 0)
+ (setq newvol 0))
+ (mpd-send "setvol %d" newvol)
+ (run-hooks 'mpd-after-command-hook)))
+
+(defun mpd-volume-mute (&optional unmute)
+ "Mute the volume.
+With prefix arg, UNMUTE, let the tunes blast again."
+ (interactive "P")
+ (if unmute
+ (mpd-send "setvol %s" mpd-pre-mute-volume)
+ (setq mpd-pre-mute-volume **mpd-var-volume*)
+ (mpd-send "setvol 0"))
+ (let ((mpd-this-command 'mpd-volume-mute))
+ (run-hooks 'mpd-after-command-hook)))
+
+(defun mpd-volume-mute/unmute ()
+ "Wrapper around #'mpd-volume-mute to mute and unmute."
+ (interactive)
+ (if (mpd-muted-p)
+ (mpd-volume-mute 'unmute)
+ (mpd-volume-mute)))
+
+(define-mpd-command mpd-volume-max ()
+ "Set volume to maximum."
+ (interactive)
+ (mpd-send "setvol 100"))
+
+(define-mpd-command mpd-volume-min ()
+ "Set volume to minimum.
+Sets state to \"muted\" by side effect."
+ (interactive)
+ (setq mpd-pre-mute-volume **mpd-var-volume*)
+ (mpd-send "setvol 0"))
+
+(define-mpd-command mpd-seek (time)
+ "Seek current track to TIME."
+ (mpd-send "seekid %s %d" **mpd-var-Id* (+ (car (mpd-songpos)) time)))
+
+(defun mpd-seek-forward ()
+ (interactive)
+ (mpd-seek 10))
+
+(defun mpd-seek-backward ()
+ (interactive)
+ (mpd-seek -10))
+
+;; Plaing operations
+(define-mpd-command mpd-next-track ()
+ "Start playing next track."
+ (interactive)
+ (mpd-send "next"))
+
+(define-mpd-command mpd-previous-track ()
+ "Start playing previous track."
+ (interactive)
+ (mpd-send "previous"))
+
+(define-mpd-command mpd-stop ()
+ "Stop playing."
+ (interactive)
+ (mpd-send "stop"))
+
+(define-mpd-command mpd-play ()
+ "Start playing."
+ (interactive)
+ (mpd-send "play"))
+
+(define-mpd-command mpd-pause ()
+ "Pause playing."
+ (interactive)
+ (mpd-send "pause"))
+
+(define-mpd-command mpd-playpause ()
+ "Resume playing or pause."
+ (interactive)
+ (if (mpd-stopped-p)
+ (mpd-send "play")
+ (mpd-send "pause")))
+
+(defun mpd-process-filter (process output)
+ "MPD proccess filter."
+ (with-temp-buffer
+ (insert output)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (when (looking-at "\\(.*?\\): \\(.*\\)")
+ (set (intern (format "**mpd-var-%s*" (match-string 1)))
+ (match-string 2)))
+ (forward-line 1)))
+ (when mpd-status-update-p
+ (setq mpd-status-update-p nil)
+ (setq mpd-zero-vars-p nil)
+ (run-hooks 'mpd-after-variables-update-hook)))
+
+(defun mpd-process-sentinel (proc &optional evstr)
+ (let ((timer (get-itimer mpd-itimer)))
+ (message "[MPD]: %s" evstr)
+ (delete-process proc)
+ (when (itimerp timer)
+ (delete-itimer timer))
+ (setq mpd-itimer nil
+ mpd-process nil)))
+
+(defun mpd-update-variables ()
+ "Requests status information."
+ (run-hooks 'mpd-before-variables-update-hook)
+ (setq mpd-zero-vars-p t)
+ (mpd-send "currentsong")
+ (setq mpd-status-update-p t)
+ (mpd-send "status"))
+
+;;; Lyrics support
+(defun mpd-lyric-filename ()
+ "Return lyric filename for now playing song."
+ (when **mpd-var-file*
+ (expand-file-name
+ (concat (replace-in-string **mpd-var-file* "\/" "--") ".txt")
+ mpd-lyrics-dir)))
+
+(defun mpd-lyric-check ()
+ "Return non-nil if current track has local lyrics."
+ (let ((fn (mpd-lyric-filename)))
+ (and fn (file-exists-p fn))))
+
+(defun mpd-lyric-save ()
+ "Save selected lyric to lyric file."
+ (interactive "_")
+ (if (mpd-lyric-check)
+ (message "There is already a lyric for this song")
+ (let ((text (get-selection-no-error)))
+ (if (not text)
+ (message "You should have selected the lyric first!")
+ ;; everything is ok
+ (with-current-buffer (find-file-noselect (mpd-lyric-filename))
+ (insert text)
+ (save-buffer))))))
+
+;; Haven't decided what to do with this one yet. --SY.
+;;(define-sawfish-command mpd-lyric-show ()
+;; "Show lyrics for now playing song."
+;; (sawfish-interactive)
+;; (if (mpd-lyric-check)
+;; (let ((temp-buffer-show-function 'sawfish-special-popup-frame)
+;; (header (format "\"%s\" (by: %s)"
+;; **mpd-var-Title*
+;; **mpd-var-Artist*))
+;; (title (format "Lyrics: %s" **mpd-var-Title*)))
+;; (with-output-to-temp-buffer title
+;; (set-buffer standard-output)
+;; (insert header "\n"
+;; (make-string (length header) ?=)
+;; "\n\n")
+;; (insert-file-contents (mpd-lyric-filename))
+;; (toggle-read-only 1)
+;; (view-mode nil #'(lambda (&rest not-used-buffer)
+;; (delete-frame (selected-frame))))))
+;; (when (and **mpd-var-Artist* **mpd-var-Title*)
+;; (let ((lyric-frame (new-frame)))
+;; (select-frame lyric-frame)
+;; (google-query (format "\"%s\" \"%s\" lyrics"
+;; **mpd-var-Artist* **mpd-var-Title*))
+;; (focus-frame lyric-frame)))))
+
+\f
+;;;; Dockapp section
+(defvar mpd-dock-frame-plist
+ '((name . "MpdDock")
+ (height . 4)
+ (width . 12)
+ (unsplittable . t)
+ (minibuffer . none)
+ (menubar-visible-p . nil)
+ (has-modeline-p . nil)
+ (default-gutter-visible-p . nil)
+ (default-toolbar-visible-p . nil)
+ (scrollbar-height . 0)
+ (scrollbar-width . 0)
+ (text-cursor-visible-p . nil))
+ "Frame properties for mpd dock.")
+
+(defun mpd-info (&rest args)
+ (let ((title (or **mpd-var-Title* "Unknown"))
+ (artist (or **mpd-var-Artist* "Unknown"))
+ (album (or **mpd-var-Album* "Unknown"))
+ (genre (or **mpd-var-Genre* "Unknown"))
+ (year (or **mpd-var-Date* "Unknown"))
+ (file (file-name-nondirectory **mpd-var-file*)))
+ (format "--[ %s ]\n
+Artist: %s
+Album: %s
+Year: %s Genre: %s\n
+--[ %s ]"
+ title artist album year genre file)))
+
+(defconst mpd-prev-map
+ (let* ((map (make-sparse-keymap 'mpd-prev-map)))
+ (define-key map [button1] 'mpd-previous-track)
+ map)
+ "Keymap for \"Prev\" button.")
+
+(defconst mpd-pause-map
+ (let* ((map (make-sparse-keymap 'mpd-pause-map)))
+ (define-key map [button1] 'mpd-pause)
+ map)
+ "Keymap for \"Pause\" button.")
+
+(defconst mpd-play-map
+ (let* ((map (make-sparse-keymap 'mpd-play-map)))
+ (define-key map [button1] 'mpd-play)
+ map)
+ "Keymap for \"Play\" button.")
+
+(defconst mpd-next-map
+ (let* ((map (make-sparse-keymap 'mpd-next-map)))
+ (define-key map [button1] 'mpd-next-track)
+ map)
+ "Keymap for \"Next\" button.")
+
+(make-face 'mpd-dock-face
+ "Face used in the mpd dock buffer.")
+
+(defun mpd-new-frame ()
+ "Create new mpd frame."
+ (unless (frame-live-p mpd-dock-frame)
+ (setq mpd-dock-frame (new-frame mpd-dock-frame-plist))
+ (select-frame mpd-dock-frame)
+ (unless (buffer-live-p mpd-dock-buffer)
+ (setq mpd-dock-buffer (get-buffer-create "*MpdDock*"))
+ (set-buffer-dedicated-frame mpd-dock-buffer mpd-dock-frame)
+ (save-excursion
+ (let (prev pause play next)
+ (set-buffer mpd-dock-buffer)
+ (set-extent-properties
+ (insert-face "[Song Info]" 'mpd-dock-face)
+ `(mouse-face highlight read-only t
+ balloon-help ,#'mpd-info))
+ (insert "\n\n ")
+ (set-extent-end-glyph
+ (setq prev (make-extent (point-max) (point-max)))
+ (make-glyph
+ (list (vector 'xpm :file (expand-file-name "Rewind.xpm"
+ mpd-directory)))))
+ (set-extent-properties
+ prev
+ `(keymap ,mpd-prev-map balloon-help "Previous Track"))
+ (set-extent-end-glyph
+ (setq pause (make-extent (point-max) (point-max)))
+ (make-glyph
+ (list (vector 'xpm :file (expand-file-name "Pause.xpm"
+ mpd-directory)))))
+ (set-extent-properties
+ pause
+ `(keymap ,mpd-pause-map balloon-help "Pause"))
+ (set-extent-end-glyph
+ (setq play (make-extent (point-max) (point-max)))
+ (make-glyph
+ (list (vector 'xpm :file (expand-file-name "Play.xpm"
+ mpd-directory)))))
+ (set-extent-properties
+ play
+ `(keymap ,mpd-play-map balloon-help "Play"))
+ (set-extent-end-glyph
+ (setq next (make-extent (point-max) (point-max)))
+ (make-glyph
+ (list (vector 'xpm :file (expand-file-name "FFwd.xpm"
+ mpd-directory)))))
+ (set-extent-properties
+ next
+ `(keymap ,mpd-next-map balloon-help "Next Track")))))
+ (set-specifier horizontal-scrollbar-visible-p nil
+ (cons mpd-dock-frame nil))
+ (set-specifier vertical-scrollbar-visible-p nil
+ (cons mpd-dock-frame nil))
+ (set-window-buffer nil mpd-dock-buffer)))
+
+(defun mpd ()
+ "Start mpd dockapp to interact with MusicPD."
+ (interactive)
+ (let ((cframe (selected-frame)))
+ ;; Start client connection
+ (mpd-start-connection)
+ (mpd-new-frame)
+ (focus-frame cframe)
+ (mpd-update-variables)))
+
+
+(provide 'mpd)
+
+;;; mpd.el ends here
--- /dev/null
+;;; patch-keywords.el --- Insert action keywords into patch followups.
+
+;; Copyright (C) 2002 Steve Youngs
+
+;; RCS: $Id: patch-keywords.el,v 1.4 2003/08/17 09:34:55 adrian Exp $
+;; Author: Steve Youngs <youngs@xemacs.org>
+;; Maintainer: Steve Youngs <youngs@xemacs.org>
+;; Created: 2002-01-14
+;; Last-Modified: <2002-03-04 07:18:01 (steve)>
+;; Keywords: maint
+
+;; This file is part of XEmacs
+
+;; XEmacs 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.
+
+;; XEmacs 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
+
+
+;;; Commentary:
+;;
+;; This file is an aid to mailing followups to patches submitted via
+;; email. It adds "Reviewer Action Keywords" to the message. These
+;; "keywords" can later be used as an aid to patch tracking.
+
+;; At this stage, this file is probably only useful to anyone who
+;; reviews patches submitted to <xemacs-patches@xemacs.org>.
+
+;; To use:
+;; - M-x customize-group RET patch-review RET
+;; Change things to your liking.
+;; - (require 'patch-keywords)
+;; In your ~/.xemacs/init.el
+
+;; Then when you are following up to a patch submission, just hit
+;; 'M-p'. You'll be prompted for the keywords to apply to the
+;; message. You can use the history mechanism to select keywords.
+;; Enter a null keyword (just hit 'RET') to terminate the list of
+;; keywords.
+
+;; The keywords are added to 3 separate places in the message.
+;; - In abbreviated form (1st character of each keyword) enclosed
+;; in square brackets at the start of the subject header (version
+;; numbers are not abbreviated).
+;;
+;; - In a "X-Reviewer-Action:" header (full keywords).
+;;
+;; - At line 0, column 0 of the message body.
+
+;; To see how to setup a "X-Reviewer-Action:" header, see
+;; `gnus-posting-styles'
+
+;; Many thanks to Adrian Aichner <adrian@xemacs.org> for his ideas,
+;; code examples and testing.
+
+;;; Code:
+(eval-when-compile
+ (require 'message)
+ (autoload 'gnus-continuum-version "gnus"))
+
+;;;###autoload
+(defgroup patch-review nil
+ "Patch submission review."
+ :group 'mail)
+
+(defcustom patch-keywords
+ '("APPROVE"
+ "COMMIT"
+ "FORWARD"
+ "QUERY"
+ "RECOMMEND"
+ "SUPERSEDES"
+ "VETO"
+ "21.4"
+ "21.5")
+ "List of keywords used for reviewing patches.
+
+The default values are the keywords currently used by the XEmacs
+Review Board."
+ :group 'patch-review
+ :type '(repeat (string :tag "Review Action Keyword"))
+ :tag "Action Keywords")
+
+(defcustom patch-review-mua 'gnus
+ "The MUA (Mail User Agent) you use for reviewing patches.
+
+Currently, the only MUAs that are supported are Gnus and VM. Should
+we even bother with things like MEW or Rmail?"
+ :group 'patch-review
+ :type '(choice
+ (item gnus)
+ (item vm)
+ (item mew\ \(Not\ Supported\))
+ (item rmail\ \(Not\ Supported\)))
+ :tag "MUA")
+
+(defcustom patch-keywords-followup-to "XEmacs Beta <xemacs-beta@xemacs.org>"
+ "The address to put into the \"Mail-Followup-To:\" header.
+This is so that any further discussions relating to the submitted
+patch can take place in a separate forum."
+ :group 'patch-review
+ :type 'string
+ :tag "Followups Address")
+
+;; I use the bleeding edge Gnus (Oort 0.05), so consequently we have
+;; to define a couple of functions that aren't in the XEmacs package
+;; version of Gnus (5.8.8). Later on they're wrapped in a version
+;; test.
+(defun patch-keywords-in-header-p ()
+ "Return t if point is in the header.
+Same as `message-point-in-header-p' which exists in Gnus Oort, but not
+in Gnus 5.8.8"
+ (save-excursion
+ (let ((p (point)))
+ (goto-char (point-min))
+ (not (re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "\n")
+ p t)))))
+
+(defun patch-keywords-message-beginning-of-line (&optional n)
+ "Move point to beginning of header value or to beginning of line.
+Optional argument N non-nil or 1, move forward N - 1 lines first.
+Same as `message-beginning-of-line' which exists in Gnus Oort, but not
+in Gnus 5.8.8."
+ (interactive "p")
+ (if (if (< (gnus-continuum-version gnus-version) 5.090004)
+ (patch-keywords-in-header-p)
+ (message-point-in-header-p))
+ (let* ((here (point))
+ (bol (progn (beginning-of-line n) (point)))
+ (eol (gnus-point-at-eol))
+ (eoh (re-search-forward ": *" eol t)))
+ (if (or (not eoh) (equal here eoh))
+ (goto-char bol)
+ (goto-char eoh)))
+ (beginning-of-line n)))
+
+(defun patch-keywords-insert-gnus (patch-key)
+ "Insert the action keywords into patch followups.
+
+Argument PATCH-KEY A list of action keywords as defined in
+`patch-keywords'. They may be chosen interactively via the
+history mechanism.
+
+Insert abbreviated (1st char) keywords at the beginning of the subject
+header. Full keywords into the \"X-Reviewer-Action:\" header, if
+present, and also at the start of the message body.
+
+The \"X-Reviewer-Action:\" header can be easily inserted using
+`gnus-posting-styles'.
+
+This function also sets followups to xemacs-beta@xemacs.org."
+ (interactive
+ (let
+ ((hist patch-keywords)
+ key
+ keys)
+ (while (not
+ (string-equal
+ (setq key
+ (read-string
+ "Enter patch keywords (or RET to finish): " "" 'hist))
+ ""))
+ (setq keys (cons key keys)))
+ (list (mapconcat 'identity (reverse keys) " "))))
+ (if (string-equal patch-key "")
+ (error "Choose at least one patch-key from %s"
+ (mapconcat 'identity patch-keywords ", ")))
+ (save-excursion
+ ;; We need to preserve the original subject header so something
+ ;; like "fix for 21.5 not for 21.4" doesn't turn into "fix for
+ ;; 21.5not for 21.4"
+ (message-goto-subject)
+ (if (< (gnus-continuum-version gnus-version) 5.090004)
+ (patch-keywords-message-beginning-of-line)
+ (message-beginning-of-line))
+ (re-search-forward ".*$" (eolp) t)
+ (let ((oldsub (match-string 0))
+ (keywords (concat "\\("
+ (regexp-opt patch-keywords)
+ "\\) ")))
+ ;; Clear the original subject (reinstate it later)
+ (if (< (gnus-continuum-version gnus-version) 5.090004)
+ (patch-keywords-message-beginning-of-line)
+ (message-beginning-of-line))
+ (if (re-search-forward ".*$" (eolp) t)
+ (replace-match ""))
+ ;; Insert the long patch keywords
+ (insert-string
+ (concat "[" patch-key " ]"))
+ (insert-string " ")
+ ;; Convert to abbreviated patch keywords
+ (if (< (gnus-continuum-version gnus-version) 5.090004)
+ (patch-keywords-message-beginning-of-line)
+ (message-beginning-of-line))
+ (save-restriction
+ (narrow-to-region (point) (point-at-eol))
+ (while (re-search-forward keywords (eolp) t)
+ (let ((keyword (match-string 1)))
+ (if (save-match-data
+ (string-match "\\`[.0-9]+\\'" keyword))
+ (replace-match (match-string 1))
+ (replace-match (substring (match-string 1) 0 1))))))
+ ;; Reinstate the original subject header after the keywords
+ (end-of-line)
+ (insert-string oldsub))
+ ;; Insert keywords into the 'X-Reviewer-Action:' header
+ (goto-line 0)
+ (if (re-search-forward "^X-Reviewer-Action: " nil t)
+ (insert-string patch-key))
+ ;; Set followups to go to xemacs-beta
+ (if (< (gnus-continuum-version gnus-version) 5.090004)
+ (message-position-on-field "Mail-Followup-To" "From")
+ (message-goto-mail-followup-to))
+ (insert-string patch-keywords-followup-to)
+ ;; Insert the keywords into the body of the message
+ (message-goto-body)
+ (insert-string patch-key)
+ (insert-string "\n\n")))
+
+(defun patch-keywords-insert-vm (patch-key)
+ "Insert the action keywords into patch followups.
+
+Argument PATCH-KEY A list of action keywords as defined in
+`patch-keywords'. They may be chosen interactively via the
+history mechanism.
+
+Insert abbreviated (1st char) keywords at the beginning of the subject
+header. Full keywords into the \"X-Reviewer-Action:\" header, and
+also at the start of the message body.
+
+This function also sets followups to xemacs-beta@xemacs.org."
+ (interactive
+ (let
+ ((hist patch-keywords)
+ key
+ keys)
+ (while (not
+ (string-equal
+ (setq key
+ (read-string
+ "Enter patch keywords (or RET to finish): " "" 'hist))
+ ""))
+ (setq keys (cons key keys)))
+ (list (mapconcat 'identity (reverse keys) " "))))
+ (if (string-equal patch-key "")
+ (error "Choose at least one patch-key from %s"
+ (mapconcat 'identity patch-keywords ", ")))
+ (save-excursion
+ ;; We need to preserve the original subject header so something
+ ;; like "fix for 21.5 not for 21.4" doesn't turn into "fix for
+ ;; 21.5not for 21.4"
+ (mail-subject)
+ (patch-keywords-message-beginning-of-line)
+ (re-search-forward ".*$" (eolp) t)
+ (let ((oldsub (match-string 0))
+ (keywords (concat "\\("
+ (regexp-opt patch-keywords)
+ "\\) ")))
+ ;; Clear the original subject (reinstate it later)
+ (patch-keywords-message-beginning-of-line)
+ (if (re-search-forward ".*$" (eolp) t)
+ (replace-match ""))
+ ;; Insert the long patch keywords
+ (insert-string
+ (concat "[" patch-key " ]"))
+ (insert-string " ")
+ ;; Convert to abbreviated patch keywords
+ (patch-keywords-message-beginning-of-line)
+ (save-restriction
+ (narrow-to-region (point) (point-at-eol))
+ (while (re-search-forward keywords (eolp) t)
+ (let ((keyword (match-string 1)))
+ (if (save-match-data
+ (string-match "\\`[.0-9]+\\'" keyword))
+ (replace-match (match-string 1))
+ (replace-match (substring (match-string 1) 0 1))))))
+ ;; Reinstate the original subject header after the keywords
+ (end-of-line)
+ (insert-string oldsub))
+ ;; Insert keywords into the 'X-Reviewer-Action:' header
+ (goto-line 0)
+ (insert-string (concat "X-Reviewer-Action: " patch-key "\n"))
+ ;; Set followups to go to xemacs-beta
+ (goto-line 0)
+ (insert-string "Mail-Followup-To: ")
+ (insert-string (concat patch-keywords-followup-to "\n"))
+ ;; Insert the keywords into the body of the message
+ (mail-text)
+ (insert-string patch-key)
+ (insert-string "\n\n")))
+
+;; Bind 'patch-keywords-insert-MUA' to M-p.
+(cond ((string= patch-review-mua "gnus")
+ (define-key message-mode-map "\M-p" 'patch-keywords-insert-gnus))
+ ((string= patch-review-mua "vm")
+ (define-key mail-mode-map "\M-p" 'patch-keywords-insert-vm)))
+
+(provide 'patch-keywords)
+
+;;; patch-keywords.el ends here
+
+;Local Variables:
+;time-stamp-start: "Last-Modified:[ ]+\\\\?[\"<]+"
+;time-stamp-end: "\\\\?[\">]"
+;time-stamp-line-limit: 10
+;time-stamp-format: "%4y-%02m-%02d %02H:%02M:%02S (%u)"
+;End:
--- /dev/null
+;;; pkg-build.el --- Automate building XEmacs packages for release.
+
+;; Copyright (C) 2002 Steve Youngs
+
+;; RCS: $Id: pkg-build.el,v 1.26 2004/03/15 22:55:33 youngs Exp $
+;; Author: Steve Youngs <youngs@xemacs.org>
+;; Maintainer: Steve Youngs <youngs@xemacs.org>
+;; Created: 2002-04-07
+;; Last-Modified: <2004-03-16 08:14:03 (steve)>
+;; Keywords: maint packages
+
+;; This file is part of XEmacs
+
+;; XEmacs 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.
+
+;; XEmacs 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
+
+
+;;; Commentary:
+;;
+;; This is far from finished. The intention here is to automate as
+;; much as possible the work of the XEmacs Package Release Manager.
+
+;;; Currently implemented features:
+;;
+;; - Increment Makefile $VERSION.
+;; - Write ChangeLog entry for incremented Makefile $VERSION.
+;; - Write ChangeLog entry in toplevel directory listing released
+;; packages.
+;; - Commit changed files to CVS.
+;; - Build single or multiple packages,
+;; - Do a 'cvs tag pkgname-x_xx' for each package built.
+;; - GnuPG sign package-index file.
+;; - Upload packages to FTP site.
+;; - Handle Sumo packages. Building, tagging, uploading.
+;; - Keep a "packages to be released later" file
+;; - Release packages using above file as input.
+;;
+;;##################### W A R N I N G ################################
+;;
+;; DANGER Will Robinson! DANGER!!
+;;
+;; This will *NOT* run out of the box. You *MUST* customise it to
+;; suit first. And while on the subject of warnings... If you don't
+;; have commit access to the entire packages CVS repository, this file
+;; is not for you. If you don't have an account on gwyn.tux.org, this
+;; file is not for you. If you are not the XEmacs Packages Release
+;; Manager, this file is not for you. Pretty God damned restrictive,
+;; huh.
+;;
+;;####################################################################
+;;
+;; OK, warnings over, now Setup and Usage:
+;;
+;; 1) Stick this file somewhere in your load-path and byte-compile
+;; it. And then add: (require 'pkg-build) to ~/.xemacs/init.el
+;; (or similar). A better way to do this is left as an exercise
+;; for the reader.
+;;
+;; 2) Run 'M-x pkg-customize' (remember those big fat warnings?)
+;;
+;; 3) The only functions you need to worry about are:
+;; - `pkg-release-packages'
+;; - `pkg-release-packages-from-file'
+;; - `pkg-release-packages-later'
+;; - `pkg-release-sumo'
+;;
+;; A Note About GnuPG Comments:
+;;
+;; Since this file switched over to using PGG instead of gpg.el,
+;; setting your GnuPG comment field in this file is no longer
+;; supported. If you want to set the comment field, do so in your
+;; `~/.gnupg/gpg.conf' file: `comment "Comment Here"'.
+
+;;; Todo:
+;;
+;; - Automated release announcements.
+;; - Lots and lots of code clean up.
+;;
+
+;;; History:
+;;
+;; Go look at the ChangeLog, this is just here so `pkg-commentary'
+;; works.
+
+
+;;; Code:
+(eval-and-compile
+ (require 'add-log)
+ (require 'dired)
+ (require 'pgg)
+ (require 'package-get)
+ (autoload 'lm-commentary "lisp-mnt")
+ (autoload 'customize-group "cus-edit")
+ (autoload 'with-electric-help "ehelp"))
+
+
+(defconst pkg-build-version "3.0.5"
+ "The version of pkg-build.")
+
+(defgroup pkg-build nil
+ "Preparing XEmacs packages for release."
+ :prefix "pkg-"
+ :group 'package-tools)
+
+(defgroup pkg-directory nil
+ "The directories associated with building packages."
+ :prefix "pkg-"
+ :group 'pkg-build)
+
+(defgroup pkg-remote nil
+ "Remote host options associated with building packages."
+ :prefix "pkg-"
+ :group 'pkg-build)
+
+(defgroup pkg-sumo nil
+ "Sumo options."
+ :prefix "pkg-"
+ :group 'pkg-build)
+
+(defcustom pkg-std-packages
+ '("Sun" "ada" "apel" "auctex" "bbdb" "build" "c-support" "calc"
+ "calendar" "cc-mode" "clearcase" "cookie" "crisp" "debug" "dictionary"
+ "dired" "docbookide" "ecb" "ecrypto" "edebug" "ediff" "edit-utils"
+ "edt" "efs" "eieio" "elib" "emerge" "erc" "escreen" "eshell" "ess"
+ "eterm" "eudc" "footnote" "forms" "fortran-modes" "frame-icon" "fsf-compat"
+ "games" "general-docs" "gnats" "gnus" "haskell-mode" "hm--html-menus"
+ "hyperbole" "ibuffer" "idlwave" "igrep" "ilisp" "ispell" "jde" "liece"
+ "mail-lib" "mailcrypt" "mew" "mh-e" "mine" "misc-games" "mmm-mode"
+ "net-utils" "ocaml" "oo-browser" "os-utils" "pc" "pcl-cvs" "pcomplete"
+ "perl-modes" "pgg" "prog-modes" "ps-print" "psgml" "psgml-dtds"
+ "python-modes" "reftex" "riece" "rmail" "ruby-modes" "sasl" "scheme"
+ "semantic" "sgml" "sh-script" "sieve" "slider" "sml-mode" "sounds-au"
+ "sounds-wav" "speedbar" "strokes" "supercite" "texinfo" "text-modes"
+ "textools" "time" "tm" "tooltalk" "tpu" "tramp" "vc" "vc-cc" "vhdl"
+ "view-process" "viper" "vm" "w3" "x-symbol" "xemacs-base" "xemacs-devel"
+ "xlib" "xslide" "xslt-process" "xwem" "zenirc")
+ "*A list of all standard (non-Mule) packages."
+ :group 'pkg-build
+ :type '(repeat string)
+ :tag "Standard Packages"
+ :link '(info-link "(xemacs)Available Packages"))
+
+(defcustom pkg-mule-packages
+ '("edict" "egg-its" "latin-unity" "leim" "locale" "lookup"
+ "mule-base" "mule-ucs" "skk")
+ "*A list of all Mule packages."
+ :group 'pkg-build
+ :type '(repeat string)
+ :link '(info-link "(xemacs)Available Packages"))
+
+(defcustom pkg-log-buffer "*Pkg Build Log*"
+ "*The buffer that logs all the goings on from building packages."
+ :group 'pkg-build
+ :type 'string)
+
+(defcustom pkg-log-entry-inc-ver "\"Increment VERSION in Makefile\""
+ "*CVS commit log entry.
+
+It is used when committing a package's Makefile & ChangeLog after
+incrementing $VERSION."
+ :group 'pkg-build
+ :type 'string)
+
+(defcustom pkg-copy-cmd "cp -a"
+ "*The command used to copy a package into the working directory.
+
+This command MUST do a recursive copy."
+ :group 'pkg-build
+ :type 'string)
+
+(defcustom pkg-copy-glob "*"
+ "*A shell wildcard that means \"All files in the directory\".
+
+This is used in conjuction with `pkg-copy-cmd'."
+ :group 'pkg-build
+ :type '(choice
+ (const :tag "GNU/Linux (\"*\")" "*")
+ (const :tag "FreeBSD (Nothing)" nil)
+ (string :tag "Other" "")))
+
+(defcustom pkg-make-program (executable-find "gmake")
+ "*The \"make\" program used to build packages.
+
+The XEmacs packages need GNU/make to build."
+ :group 'pkg-build
+ :type '(file :must-match t))
+
+(defcustom pkg-make-targets `((all . ,(concat pkg-make-program " all"))
+ (aload . ,(concat pkg-make-program " autoloads"))
+ (bdist . ,(concat pkg-make-program " bindist"))
+ (clean . ,(concat pkg-make-program " clean"))
+ (dclean . ,(concat pkg-make-program " distclean"))
+ (eclean . ,(concat pkg-make-program " extraclean"))
+ (html . ,(concat pkg-make-program " html"))
+ (inst . ,(concat pkg-make-program " install"))
+ (insth . ,(concat pkg-make-program " install-html"))
+ (insto . ,(concat pkg-make-program " install-only")))
+ "*An alist of makefile targets used in building packages."
+ :group 'pkg-build
+ :type 'alist)
+
+;;;###autoload
+(defcustom pkg-packages-to-release-file
+ (expand-file-name ".pkg-todo" (getenv "HOME"))
+ "*A list of package names to be released at a later date."
+ :group 'pkg-build
+ :type 'file)
+
+(defcustom pkg-clear-release-file t
+ "*If non-nil, erase the contents of `pkg-packages-to-release-file'.
+
+The file is cleared after the packages are released. Defaults to
+non-nil so that the same set of packages aren't released multiple
+times with multiple release runs."
+ :group 'pkg-build
+ :type 'boolean)
+
+(defcustom pkg-base-directory
+ (file-name-as-directory
+ (expand-file-name "programming/XEmacs/packages"
+ (getenv "HOME")))
+ "*Base directory of the XEmacs packages source."
+ :group 'pkg-directory
+ :type 'directory)
+
+(defcustom pkg-std-directory
+ (file-name-as-directory
+ (expand-file-name "xemacs-packages" pkg-base-directory))
+ "*Parent directory of standard packages."
+ :group 'pkg-directory
+ :type 'directory)
+
+(defcustom pkg-mule-directory
+ (file-name-as-directory
+ (expand-file-name "mule-packages" pkg-base-directory))
+ "*Parent directory of Mule packages."
+ :group 'pkg-directory
+ :type 'directory)
+
+(defcustom pkg-working-base-directory
+ (file-name-as-directory
+ (expand-file-name "test-it/build/packages"
+ (getenv "HOME")))
+ "*Base directory of the XEmacs packages source.
+
+The `pkg-working-*-directory' are where the packages are actually
+built. I use a different directory from the checked out CVS source
+just in case something goes wrong."
+ :group 'pkg-directory
+ :type 'directory)
+
+(defcustom pkg-working-std-directory
+ (file-name-as-directory
+ (expand-file-name "xemacs-packages" pkg-working-base-directory))
+ "*Parent directory of standard packages.
+
+The `pkg-working-*-directory' are where the packages are actually
+built. I use a different directory from the checked out CVS source
+just in case something goes wrong."
+ :group 'pkg-directory
+ :type 'directory)
+
+(defcustom pkg-working-mule-directory
+ (file-name-as-directory
+ (expand-file-name "mule-packages" pkg-working-base-directory))
+ "*Parent directory of Mule packages.
+
+The `pkg-working-*-directory' are where the packages are actually
+built. I use a different directory from the checked out CVS source
+just in case something goes wrong."
+ :group 'pkg-directory
+ :type 'directory)
+
+(defcustom pkg-staging-directory
+ (file-name-as-directory
+ (expand-file-name "staging" (getenv "HOME")))
+ "*This is the directory whereto make bindist puts its products."
+ :group 'pkg-directory
+ :type 'directory)
+
+(defcustom pkg-upload-directory
+ (file-name-as-directory
+ (expand-file-name "upload" (getenv "HOME")))
+ "*This is the directory from where the packages get uploaded from.
+
+WARNING! DANGER! *EVERYTHING* in this directory may deleted! DON'T use
+it for any other purpose. You have been warned!!"
+ :group 'pkg-directory
+ :type 'directory)
+
+(defcustom pkg-packages-omit-sumo '("Sun")
+ "*A list of packages to NOT include in the SUMO packages."
+ :group 'pkg-sumo
+ :type '(repeat string))
+
+(defcustom pkg-sumo-tarball-directory
+ (file-name-as-directory
+ (expand-file-name "Sumo"
+ pkg-staging-directory))
+ "*The top level Sumo directory.
+
+Under this directory is where all the packages are installed to in
+readiness for creating the Sumo package tarballs."
+ :group 'pkg-sumo
+ :type 'directory)
+
+(defcustom pkg-std-sumo-install-directory
+ (file-name-as-directory
+ (expand-file-name "xemacs-packages"
+ pkg-sumo-tarball-directory))
+ "*The directory where the standard packages are installed for Sumo creation."
+ :group 'pkg-sumo
+ :type 'directory)
+
+(defcustom pkg-mule-sumo-install-directory
+ (file-name-as-directory
+ (expand-file-name "mule-packages"
+ pkg-sumo-tarball-directory))
+ "*The directory where the mule packages are installed for Sumo creation."
+ :group 'pkg-sumo
+ :type 'directory)
+
+(defcustom pkg-std-sumo-build-flags
+ (format "NONMULE_INSTALLED_PACKAGES_ROOT=%s"
+ pkg-std-sumo-install-directory)
+ "*Args to pass to make when building the standard Sumo."
+ :group 'pkg-sumo
+ :type 'string)
+
+(defcustom pkg-mule-sumo-build-flags
+ (format "MULE_INSTALLED_PACKAGES_ROOT=%s"
+ pkg-mule-sumo-install-directory)
+ "*Args to pass to make when building the Mule Sumo."
+ :group 'pkg-sumo
+ :type 'string)
+
+(defcustom pkg-sumo-tar-gzip
+ "tar --create --owner=0 --group=0 --use-compress-program=gzip --file"
+ "*The program and flags used to build the tar.gz Sumo tarballs."
+ :group 'pkg-sumo
+ :type 'string)
+
+(defcustom pkg-sumo-tar-bzip
+ "tar --create --owner=0 --group=0 --use-compress-program=bzip2 --file"
+ "*The program and flags used to build the tar.bz2 Sumo tarballs."
+ :group 'pkg-sumo
+ :type 'string)
+
+(defcustom pkg-online-status-file "/var/run/ppp0.pid"
+ "*This file must exist for CVS tagging and commits to happen."
+ :group 'pkg-remote
+ :type 'file)
+
+(defcustom pkg-upload-command "scp -qC"
+ "*Program to use for uploading packages & Sumo's to the FTP site."
+ :group 'pkg-remote
+ :type 'string)
+
+(defcustom pkg-remote-path "youngs@ftp.xemacs.org:pkgtmp/"
+ "*Path where packages get uploaded to.
+
+This path is compatible with \"scp\" and includes a user name."
+ :group 'pkg-remote
+ :type 'string)
+
+;;;###autoload
+(defun pkg-customize ()
+ "Convenience function to customise pkg-build."
+ (interactive)
+ (customize-group 'pkg-build))
+
+;;;###autoload
+(defun pkg-version (&optional arg)
+ "Print the current version of pkg-build.
+
+With prefix arg ARG, insert version string at point."
+ (interactive "P")
+ (if arg
+ (insert (format "Pkg Build v%s" pkg-build-version))
+ (message (format "Pkg Build v%s" pkg-build-version))))
+
+;;;###autoload
+(defun pkg-commentary ()
+ "Display the commentary section from pkg-build.el."
+ (interactive)
+ ;; Yeah, yeah, I know there is `finder-commentary', but this is
+ ;; better.
+ (with-electric-help
+ '(lambda ()
+ (insert
+ (with-temp-buffer
+ (erase-buffer)
+ (insert (lm-commentary (locate-library "pkg-build.el")))
+ (goto-char (point-min))
+ (while (re-search-forward "^;+ ?" nil t)
+ (replace-match "" nil nil))
+ (buffer-string (current-buffer)))))))
+
+(defsubst pkg-call-process (command &optional buffer displayp)
+ "Call a shell process executing COMMAND with output to BUFFER.
+
+Argument COMMAND is a string.
+Optional argument BUFFER if omitted will be the current buffer.
+Optional argument DISPLAYP if non-nil update the output buffer on the
+fly instead of just when command finishes."
+ (apply 'call-process shell-file-name nil (or buffer t) displayp
+ shell-command-switch (list command)))
+
+(defun pkg-make-bindist (pkg type)
+ "Build a binary distribution for package PKG.
+
+Argument TYPE is a string of either \"standard\" or \"mule\".
+
+This function is called from `pkg-release-packages'. It copies the
+package's source files from the CVS checkout directory to a working
+directory. And then does a \"make distclean\", \"make autoloads\",
+and a \"make bindist\".
+
+The output from the compilations is appended to `pkg-log-buffer'."
+ (let (copy-dest)
+ ;; Mule or Standard.
+ (cond
+ ((string= type "standard")
+ (setq default-directory
+ (file-name-as-directory
+ (expand-file-name pkg pkg-std-directory))
+ copy-dest
+ (file-name-as-directory
+ (expand-file-name pkg pkg-working-std-directory))))
+ ((string= type "mule")
+ (setq default-directory
+ (file-name-as-directory
+ (expand-file-name pkg pkg-mule-directory))
+ copy-dest
+ (file-name-as-directory
+ (expand-file-name pkg pkg-working-mule-directory))))
+ (t
+ (error 'wrong-type-argument
+ (format "Type: %s is not valid for package: %s" type pkg))))
+ ;; Copy the package to the working directory
+ (shell-command
+ (concat
+ pkg-copy-cmd " " default-directory pkg-copy-glob " " copy-dest))
+ ;; Set the default directory to the working directory
+ (setq default-directory copy-dest)
+ ;; make distclean.
+ (pkg-call-process
+ (cdr (assq 'dclean pkg-make-targets)) pkg-log-buffer t)
+ ;; make autoloads.
+ (pkg-call-process
+ (cdr (assq 'aload pkg-make-targets)) pkg-log-buffer t)
+ ;; make all
+ (pkg-call-process
+ (cdr (assq 'all pkg-make-targets)) pkg-log-buffer t)
+ ;; make bindist.
+ (pkg-call-process
+ (cdr (assq 'bdist pkg-make-targets)) pkg-log-buffer t)))
+
+(defun pkg-commit-inc-ver (pkg type)
+ "Commit the ChangeLog & Makefile of package PKG.
+
+Argument TYPE is a string of either \"standard\" or \"mule\".
+
+Once $VERSION in Makefile has been incremented and a ChangeLog entry
+written, this function commits the Makefile & ChangeLog to CVS."
+ (let ((files "ChangeLog Makefile")
+ (cvs-cmd "cvs commit -m"))
+ ;; Mule or Standard.
+ (cond
+ ((string= type "standard")
+ (setq default-directory
+ (file-name-as-directory (expand-file-name pkg pkg-std-directory))))
+ ((string= type "mule")
+ (setq default-directory
+ (file-name-as-directory (expand-file-name pkg pkg-mule-directory))))
+ (t
+ (error 'wrong-type-argument
+ (format "Type: %s is not valid for package: %s" type pkg))))
+ (pkg-call-process
+ (concat cvs-cmd " " pkg-log-entry-inc-ver " " files)
+ pkg-log-buffer t)))
+
+(defun pkg-tag-package (pkg version type)
+ "Run \"cvs tag package-x_xx\" for package PKG.
+
+Argument PKG is the name of the package to tag (a string).
+Argument VERSION is the version number of the package to tag.
+Argument TYPE is a string of either \"standard\" or \"mule\"."
+ (let ((tag-name))
+ (with-temp-buffer
+ (erase-buffer)
+ (insert (concat pkg "-" (format "%.2f" version)))
+ (while (re-search-backward "\\." nil t)
+ (replace-match "_" nil nil))
+ (goto-char (point-min))
+ (re-search-forward ".*$" (eolp) t)
+ (setq tag-name (match-string 0)))
+ (cond
+ ((string= type "standard")
+ (setq default-directory
+ (file-name-as-directory (expand-file-name pkg pkg-std-directory)))
+ (pkg-call-process (concat "cvs tag " tag-name) pkg-log-buffer t))
+ ((string= type "mule")
+ (setq default-directory
+ (file-name-as-directory (expand-file-name pkg pkg-mule-directory)))
+ (pkg-call-process (concat "cvs tag " tag-name) pkg-log-buffer t))
+ (t
+ (error 'wrong-type-argument
+ (format "Type: %s is not valid for package: %s" type pkg))))))
+
+(defun pkg-upload-packages (pkgs)
+ "Upload compiled XEmacs packages to the FTP site.
+
+Argument PKGS is a list of filenames to upload."
+ (let* ((staging (file-name-as-directory pkg-staging-directory))
+ (oldfilelist (directory-files pkg-upload-directory nil nil nil t))
+ (pgg-output-buffer "package-index.gpg"))
+ (setq default-directory staging)
+ (loop for each in '("package-index"
+ "package-index.gpg")
+ do (find-file-noselect each))
+ (erase-buffer "package-index.gpg")
+ (with-current-buffer "package-index"
+ (pgg-sign-region (point-min) (point-max) 'cleartext)
+ (kill-buffer (current-buffer)))
+ (with-current-buffer pgg-output-buffer
+ (save-buffer)
+ (kill-buffer (current-buffer)))
+ (loop for each in '("package-index"
+ "package-index.gpg"
+ "setup-packages.ini")
+ do (setq pkgs (push each pkgs)))
+ ;; DANGER Will Robinson! Delete anything that is in
+ ;; `pkg-upload-directory'.
+ (if (yes-or-no-p "DELETE upload/* BEFORE we copy files into it? ")
+ (let* ((default-directory pkg-upload-directory))
+ (while oldfilelist
+ (delete-file (car oldfilelist))
+ (setq oldfilelist (cdr oldfilelist)))))
+ (while pkgs
+ (copy-file (expand-file-name (car pkgs) staging) pkg-upload-directory)
+ (setq pkgs (cdr pkgs)))
+ (start-process-shell-command "Package Upload"
+ pkg-log-buffer
+ (concat pkg-upload-command " "
+ (expand-file-name "*"
+ pkg-upload-directory)
+ " "
+ pkg-remote-path))))
+
+;;;###autoload
+(defun pkg-release-packages (packages)
+ "Prepare PACKAGES for release.
+
+Argument PACKAGES is a list of one or more XEmacs packages to
+operate on. They must be members of either `pkg-std-packages' or
+`pkg-mule-packages'.
+
+It increments $VERSION in the Makefile and writes a new ChangeLog
+entry, commits those changes to CVS, and start the ball rolling on
+tagging the CVS repository, building the binary distribution, and
+upload them to the FTP site."
+ (interactive "sWhitespace separated list of 1 or more packages: ")
+ (when (not (featurep 'mule))
+ (error 'unimplemented
+ "`mule': It is best to build packages with a Mule-enabled XEmacs"))
+ (let* ((pkg-list (with-temp-buffer
+ (insert packages)
+ (remove-if (lambda (s) (string= "" s))
+ (split-string
+ (buffer-string (current-buffer))))))
+ (changelog (expand-file-name "ChangeLog" pkg-base-directory))
+ (log-entry "\"Package release\"")
+ (ci-top-changelog (concat "cvs commit -m "
+ log-entry " ChangeLog"))
+ packages type tarball-name all-tarballs)
+ (setq packages pkg-list)
+ (switch-to-buffer (get-buffer-create pkg-log-buffer))
+ (insert
+ (format "Releasing the following packages:\n\t%s" packages))
+ (insert "\n===================================================\n")
+ ;; Add a ChangeLog entry in the top level ChangeLog and commit
+ ;; that to CVS if we're online.
+ (save-excursion
+ (find-file changelog)
+ (add-change-log-entry nil nil nil t)
+ (insert
+ (format "Packages released: %s." packages))
+ (while (re-search-backward "(\\|)" nil t)
+ (replace-match "" nil nil))
+ (fill-paragraph 1)
+ (change-log-exit))
+ (if (file-readable-p pkg-online-status-file)
+ (progn
+ (setq default-directory pkg-base-directory)
+ (pkg-call-process ci-top-changelog pkg-log-buffer t))
+ (save-excursion
+ (set-buffer pkg-log-buffer)
+ (insert-string "\n*** OFFLINE *** Commit toplevel ChangeLog manually.\n")))
+ ;; Increment $VERSION for each package and write a ChangeLog entry
+ ;; for it.
+ (while packages
+ ;; Standard or Mule.
+ (cond
+ ((member (car packages) pkg-std-packages)
+ (set-buffer (find-file (expand-file-name
+ "Makefile"
+ (file-name-as-directory
+ (expand-file-name (car packages)
+ pkg-std-directory)))))
+ (setq type "standard"))
+ ((member (car packages) pkg-mule-packages)
+ (set-buffer (find-file (expand-file-name
+ "Makefile"
+ (file-name-as-directory
+ (expand-file-name (car packages)
+ pkg-mule-directory)))))
+ (setq type "mule"))
+ (t
+ (error 'invalid-argument
+ (format "%s is not a valid package" (car packages)))))
+ (goto-char (point-min))
+ (re-search-forward "^VERSION = " nil t)
+ (re-search-forward ".*$" (eolp) t)
+ (let* ((oldver (match-string 0))
+ (incver (+ 0.01 (string-to-number oldver))))
+ (replace-match (format "%.2f" incver))
+ (save-buffer (current-buffer))
+ (add-change-log-entry nil nil nil t)
+ (insert
+ (format "XEmacs package %.2f released." incver))
+ (change-log-exit)
+ (kill-buffer (current-buffer))
+ (pkg-make-bindist (car packages) type)
+ (setq tarball-name (concat (car packages) "-"
+ (format "%.2f" incver)
+ "-pkg.tar.gz"))
+ (setq all-tarballs (push tarball-name all-tarballs))
+ ;; If online, commit the Makefile & ChangeLog, and tag CVS.
+ (if (file-readable-p pkg-online-status-file)
+ (progn
+ (pkg-commit-inc-ver (car packages) type)
+ (pkg-tag-package (car packages) incver type))
+ (save-excursion
+ (set-buffer pkg-log-buffer)
+ (insert
+ (format
+ "\n*** OFFLINE *** Commit changes and tag tree for %s manually.\n"
+ (car packages)))))
+ (setq packages (cdr packages))))
+ ;; If online, upload the package tarballs.
+ (if (file-readable-p pkg-online-status-file)
+ (pkg-upload-packages all-tarballs)
+ (save-excursion
+ (set-buffer pkg-log-buffer)
+ (insert
+ (format
+ "\n*** OFFLINE *** Upload these packages manually:\n\t%s"
+ (cl-prettyprint (symbol-value 'all-tarballs))))))))
+
+;;;###autoload
+(defun pkg-release-packages-from-file (&optional file arg)
+ "Call `pkg-release-packages' using FILE as input.
+
+Optional Argument FILE is a file to use. It must contain a single
+line that is a whitespace separated list of package names.
+
+With Prefix Argument ARG, prompt for a file to use.
+
+The default is to use `pkg-packages-to-release-file', but if that
+doesn't exist, prompt for a file to use."
+ (interactive "i\nP")
+ (let* ((list-file (if file
+ file
+ (if (or arg
+ (not (file-exists-p pkg-packages-to-release-file)))
+ (expand-file-name
+ (read-file-name "Package list file: " nil nil t))
+ pkg-packages-to-release-file)))
+ (buf (find-file-noselect list-file))
+ (pkg-list (buffer-string buf)))
+ (when (not (file-readable-p list-file))
+ (error 'file-error
+ "Release file not readable or nonexistent"))
+ (pkg-release-packages pkg-list)
+ (save-excursion
+ (switch-to-buffer buf)
+ (when pkg-clear-release-file
+ (erase-buffer buf))
+ (save-buffer)
+ (kill-buffer buf))))
+
+;;;###autoload
+(defun pkg-release-packages-later (packages &optional now)
+ "Create or add to a list of packages to release.
+
+The list is kept in the file, `pkg-packages-to-release-file'.
+
+Argument PACKAGES is a whitespace separated list of package names.
+
+With Optional prefix Argument NOW, release the packages instead
+of keeping a list to do later."
+ (interactive "sWhitespace separated list of packages: \nP")
+ (if now
+ (pkg-release-packages packages)
+ (let ((buf (find-file-noselect pkg-packages-to-release-file)))
+ (save-excursion
+ (switch-to-buffer (get-buffer buf))
+ (when (y-or-n-p "Erase any previous entries first? ")
+ (erase-buffer buf))
+ (insert (concat packages " "))
+ (save-buffer)
+ (kill-buffer buf)))))
+
+;;;###autoload
+(defun pkg-release-sumo ()
+ "Builds the SUMO packages."
+ (interactive)
+ (when (not (featurep 'mule))
+ (error 'unimplemented
+ "`mule': Sumos built with a non-Mule XEmacs is discouraged"))
+ (switch-to-buffer (get-buffer-create pkg-log-buffer))
+ (let ((sumo-std (reverse pkg-std-packages))
+ (sumo-mule pkg-mule-packages)
+ (sumo-pkgs))
+ (while sumo-std
+ (setq sumo-pkgs (push (car sumo-std) sumo-mule))
+ (setq sumo-std (cdr sumo-std)))
+ ;; Do a 'make autoloads' just to be on the safe side.
+ (setq default-directory pkg-working-base-directory)
+ (pkg-call-process
+ (cdr (assq 'aload pkg-make-targets)) pkg-log-buffer t)
+ ;; Build each package.
+ (while sumo-pkgs
+ (unless (member (car sumo-pkgs) pkg-packages-omit-sumo)
+ (cond
+ ((member (car sumo-pkgs) pkg-std-packages)
+ (setq default-directory (file-name-as-directory
+ (expand-file-name (car sumo-pkgs)
+ pkg-working-std-directory)))
+ (pkg-call-process
+ (cdr (assq 'all pkg-make-targets)) pkg-log-buffer t)
+ (pkg-call-process
+ (concat (cdr (assq 'inst pkg-make-targets))
+ " "
+ pkg-std-sumo-build-flags) pkg-log-buffer t))
+ ((member (car sumo-pkgs) pkg-mule-packages)
+ (setq default-directory (file-name-as-directory
+ (expand-file-name (car sumo-pkgs)
+ pkg-working-mule-directory)))
+ (pkg-call-process
+ (cdr (assq 'all pkg-make-targets)) pkg-log-buffer t)
+ (pkg-call-process
+ (concat (cdr (assq 'inst pkg-make-targets))
+ " "
+ pkg-mule-sumo-build-flags) pkg-log-buffer t))
+ (t
+ (error 'invalid-argument
+ (format "%s is not a valid package" (car sumo-pkgs))))))
+ (setq sumo-pkgs (cdr sumo-pkgs))))
+ ;; Add a ChangeLog entry to say that a Sumo package has been released.
+ (save-excursion
+ (find-file (expand-file-name "ChangeLog" pkg-base-directory))
+ (add-change-log-entry nil nil nil t)
+ (insert-string "Sumo packages released.")
+ (change-log-exit))
+ (let ((log-msg "\"Sumo packages released\"")
+ (tag (format-time-string "sumo-%Y-%m-%d"))
+ (sumo-build-directory pkg-sumo-tarball-directory))
+ (if (file-readable-p pkg-online-status-file)
+ (progn
+ ;; Commit the ChangeLog.
+ (setq default-directory pkg-base-directory)
+ (pkg-call-process (concat "cvs commit -m "
+ log-msg
+ " ChangeLog")
+ pkg-log-buffer t)
+ ;; Tag the tree.
+ (pkg-call-process (concat "cvs tag " tag) pkg-log-buffer t)
+ (pkg-call-process "cvs tag -F sumo-current" pkg-log-buffer t))
+ (save-excursion
+ (set-buffer pkg-log-buffer)
+ (insert
+ (format
+ "\n*** OFFLINE *** Manually commit ChangeLog and tag tree as: %s.\n"
+ tag))))
+ ;; Build the tarballs.
+ (setq default-directory sumo-build-directory)
+ (pkg-call-process (concat pkg-sumo-tar-gzip " "
+ (format-time-string
+ "./xemacs-sumo-%Y-%m-%d.tar.gz")
+ " ./xemacs-packages/")
+ pkg-log-buffer t)
+ (pkg-call-process (concat pkg-sumo-tar-gzip " "
+ (format-time-string
+ "./xemacs-mule-sumo-%Y-%m-%d.tar.gz")
+ " ./mule-packages/")
+ pkg-log-buffer t)
+ (pkg-call-process (concat pkg-sumo-tar-bzip " "
+ (format-time-string
+ "./xemacs-sumo-%Y-%m-%d.tar.bz2")
+ " ./xemacs-packages/")
+ pkg-log-buffer t)
+ (pkg-call-process (concat pkg-sumo-tar-bzip " "
+ (format-time-string
+ "./xemacs-mule-sumo-%Y-%m-%d.tar.bz2")
+ " ./mule-packages/")
+ pkg-log-buffer t)
+ ;; Upload them if we're online.
+ (if (file-readable-p pkg-online-status-file)
+ (start-process-shell-command "Sumo Upload"
+ pkg-log-buffer
+ (concat pkg-upload-command " "
+ "*-sumo-*.tar.* "
+ pkg-remote-path))
+ (save-excursion
+ (set-buffer pkg-log-buffer)
+ (insert-string "\n*** OFFLINE *** Upload Sumo tarballs manually.\n")))))
+
+(provide 'pkg-build)
+
+;;; pkg-build.el ends here
+
+;Local Variables:
+;time-stamp-start: "Last-Modified:[ ]+\\\\?[\"<]+"
+;time-stamp-end: "\\\\?[\">]"
+;time-stamp-line-limit: 10
+;time-stamp-format: "%4y-%02m-%02d %02H:%02M:%02S (%u)"
+;End:
--- /dev/null
+;; sy-pui-update.el --- Update packages from cron.
+
+;;; Commentary:
+;; This is hardly worth putting a copyright notice on, so you can
+;; do whatever you like with this. :-)
+;;
+;; Set the download mirror and directory to your liking. It's hard
+;; coded because we don't want to waste our time loading up any
+;; customisations. Put it in you load-path and then add something
+;; like this to your crontab:
+;;
+;; 15 3 * * sun xemacs -batch -vanilla -l pui-update -f pui-update-all
+;;
+;; Then every Sunday at 3:15am your installed packages will be
+;; updated.
+
+;;; Code:
+
+(require 'package-get)
+(require 'ffi-curl)
+
+(defvar pui-update-mirror '("ftp.au.xemacs.org" "pub/xemacs/beta/experimental/packages")
+ "Mirror to use")
+
+(defun pui-update-fetch-index ()
+ (let ((remote (concat "ftp://"
+ (nth 0 pui-update-mirror)
+ "/"
+ (nth 1 pui-update-mirror)
+ "/package-index.LATEST.gpg"))
+ (local (expand-file-name "package-index.LATEST.gpg"
+ user-init-directory)))
+ (curl:download remote local)))
+
+(defun pui-update-all ()
+ (interactive)
+ (let ((package-get-remote pui-update-mirror)
+ (efs-use-passive-mode t))
+ (epa-file-disable)
+ (package-get-update-all)))
+
+; (pui-update-fetch-index)
+; (catch 'exit
+; (mapcar (lambda (pkg)
+; (if (not (package-get (car pkg) nil 'never))
+; (throw 'exit nil))) ;; Bail out if error detected
+; packages-package-list))))
+
+(provide 'pui-update)
+;;; sy-pui-update.el ends here
--- /dev/null
+;;; snap.el --- save/load snapshot of application to/from text
+
+;; Copyright (c) 2003, 2004, 2005, 2006, 2007
+;; by HIRAOKA Kazuyuki <khi@users.sourceforge.jp>
+;; $Id: snap.el,v 1.40 2007/05/16 14:44:28 hira Exp $
+;;
+;; 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 1, 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.
+;;
+;; The GNU General Public License is available by anonymouse ftp from
+;; prep.ai.mit.edu in pub/gnu/COPYING. Alternately, you can write to
+;; the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139,
+;; USA.
+
+;;; Commentary:
+
+;; Usage:
+;;
+;; (1) M-x snap-record on application, e.g. Wanderlust.
+;; (2) Yank (C-y) on any buffer, e.g. *scratch* or ~/memo.txt.
+;; (3) M-x snap-play on yanked text ==> snapshot (1) is restored.
+
+;; Supported applications:
+;;
+;; - BBDB
+;; - BibTeX
+;; - Bookmark
+;; - Dired
+;; - Emacs-wiki
+;; - Gnus
+;; - Help
+;; - howm-search ( C-c , g )
+;; - Info
+;; - Man
+;; - Navi2ch (Article buffer)
+;; - occur (experimental, using fake cgi-extension)
+;; - PCVS
+;; - Shell
+;; - Thumbs
+;; - w3m
+;; - Wanderlust (Summary buffer)
+;; - snap:/// (only message it's version)
+;;
+;; For unsupported buffers,
+;; file name and current position are recorded.
+
+;; Caution for byte-compilation:
+;;
+;; Byte-compiling this file is not recommended.
+;; Some fucntions will be dropped silently if required features are not
+;; available at compile time.
+;; For example, snap-*:w3m are ignored if the feature w3m is not available.
+;; You may want to recompile this file after you set up these features.
+
+;; Internal:
+;;
+;; Format of snapshot string is "snap://MAJOR-MODE/SPELL".
+;; Format and meaning of SPELL depend on MAJOR-MODE.
+;; For example,
+;; snap://wl-summary-mode/+ME/hira/<20031101192305.AFA8C43EDC@hoge.fuga.piyo>
+;; is a snapshot string of wl-summary-mode for the spell
+;; +ME/hira/<20031101192305.AFA8C43EDC@hoge.fuga.piyo>,
+;; which indicates
+;; message-id <20031101192305.AFA8C43EDC@hoge.fuga.piyo>
+;; in the folder +ME/hira.
+;;
+;; Please define snap-record:MAJOR-MODE and snap-play:MAJOR-MODE
+;; if you want to support your favorite application.
+;; (snap-record:MAJOR-MODE) returns SPELL string for current snapshot.
+;; (snap-play:MAJOR-MODE SPELL) restores snapshot from SPELL string.
+
+;; Abbreviation (experimental):
+;;
+;; You can add abbreviation rules of snap strings
+;; to the variable `snap-abbrev'. See its docstring for details.
+
+;; Fake cgi-extension (experimental):
+;;
+;; When `snap-record-cgi' is not empty, you can use a
+;; fake cgi like "snap://MAJOR-MODE/SPELL??g=110&s=str&q=word&x=",
+;; which calls snap-play::g, snap-play::s, snap-play::q and
+;; snap-play::x.
+;;
+;; At this experimental stage, format of url is not
+;; strict like RFC and not *escaped*. (and I have no idea for doing it
+;; :-) An example of the problem is
+;; "snap://occur-mode/dired-mode/~/??q=drwx??g=2", but it still works
+;; because of longest-match tricks. See `snap-cgi-decode'
+;;
+;; Supported cgi-functions:
+;; g=110 goto-line
+;; s=str search string
+;; q=word occur word
+;; x= dired-x
+;;
+;; For some cases, mode-specific commands may be desired.
+;; See `snap-play-cgi' and `snap-play:help-mode:' for example.
+
+;; Repair (experimental):
+;;
+;; When you fail snap-play, you can try M-x snap-repair
+;; to repair snapshot text.
+;; This can happen, e.g. when you move mails to other folders.
+;;
+;; You have to write your own 'my-snap-search-mail' function
+;; which receives message-id and returns its file name.
+;; My version requires namazu and howm.
+;; - namazu: full text search engine <http://www.namazu.org/index.html.en>
+;; - howm: note-taking tool <http://howm.sourceforge.jp/>
+;; (defvar my-namazu-mail-dir (expand-file-name "~/PATH/NMZ/Mail"))
+;; (defun my-snap-search-mail (message-id)
+;; (let* ((query (format "+message-id:%s" message-id))
+;; (args `("-l" "-n" "1" ,query ,my-namazu-mail-dir)))
+;; (car (howm-view-call-process "namazu" args))))
+
+;; Replace environment variables in file name.
+;;
+;; If you like "snap:///${HOME}/hoge" and "snap:///${FOODIR}/bar"
+;; instead of "snap:///~/hoge" and "snap:///usr/local/foo/bar", try this.
+;; I'm not sure whether there is considerable demand for this feature.
+;;
+;; (defvar snap-abbreviate-environment-variables '("FOODIR" "HOME"))
+;; (defadvice snap-abbreviate-file-name (around env-var (raw-path) activate)
+;; ad-do-it
+;; (let ((path (expand-file-name raw-path))
+;; (rules (mapcar (lambda (var)
+;; (let ((val (getenv var)))
+;; (and val
+;; (cons (concat "^" (regexp-quote val))
+;; (format "${%s}" var)))))
+;; snap-abbreviate-environment-variables)))
+;; (mapc (lambda (r)
+;; (when (and r (string-match (car r) path))
+;; (setq ad-return-value
+;; (replace-regexp-in-string (car r) (cdr r) path))))
+;; (reverse rules))))
+
+;; With bookmark and ffap (experimental):
+;;
+;; ;; Put this code into your .emacs to enable bookmark+snap feature.
+;; (eval-after-load "bookmark"
+;; (ad-enable-advice 'bookmark-buffer-file-name 'around 'with-snap)
+;; (ad-enable-advice 'bookmark-jump-noselect 'around 'with-snap))
+;;
+;; ;; Put this code into your .emacs to enable ffap+snap feature.
+;; (setq ffap-url-regexp snap-ffap-url-regexp)
+;; (setq ffap-url-fetcher snap-ffap-url-fetcher)
+
+;; ChangeLog:
+;;
+;; [2007-08-01] Made most things work for (S)XEmacs (Steve Youngs)
+;; [2007-05-16] use snap-define-op instead of require in defun.
+;; [2007-05-16] PCVS and Thumbs are supported. (thx > Ma)
+;; [2007-05-16] experimental features with bookmark and ffap (thx > Ma)
+;; [2007-02-24] byte-compilation is now OK.
+;; (thx > Taiki SUGAWARA <buzz.taiki at gmail.com>)
+;; [2006-06-15] snap-record:dired-mode also supports environment variables
+;; (thx > taku)
+;; [2006-06-07] snap-play:dired-mode also supports environment variables
+;; (thx > taku)
+;; [2006-05-28] snap-try-decode for atode.el
+;; [2006-04-23] replace environment variables in snap-record: (thx > taku)
+;; [2006-04-11] environment variables in file path are expanded (thx > taku)
+;; [2006-03-25] fix: Obsolete constant name in bibtex. (thx > 20)
+;; [2006-03-21] add document on byte-compilation. (thx > 20)
+;; [2006-01-31] fix: Drive letter problem in windows. (thx > Touhi)
+;; [2005-09-28] cgi for Man-mode. (thx > Ma)
+;; [2005-09-27] mode-specific cgi command. (thx > Ma)
+;; [2005-07-03] Gnus is supported. (thx > Wi)
+;; Variable snap-mode-functions for extension.
+;; [2005-05-24] snap-record-string never cause error again.
+;; This is necessary for my another tool, atode.el.
+;; http://howm.sourceforge.jp/a/atode.el
+;; [2005-05-19] BBDB, BibTeX, Shell ,occur, howm-search are supported.
+;; fix: `snap-play' and extend fake cgi and `snap-expand-alist'.
+;; And set `snap-record-default-format'. (thx > Ma)
+;; [2005-03-03] snap-record-string doesn't cause error any more.
+;; [2004-11-16] fix: second -> cadr (thx > Toorisugari)
+;; [2004-09-11] Emacs-wiki, Navi2ch, w3m, Dired are supported. (thx > Ma)
+;; [2004-04-21] fix: Error when action-lock is not available (thx > Nanashi)
+;; [2004-04-18] Goto occurrence when it is unique match.
+;; [2004-04-10] Help, Bookmark, Man, Info are supported. (thx > Ma)
+;; [2004-02-25] action-lock
+;; [2004-02-23] fix: Error on CVS latest Wanderlust (thx > hirose31)
+;; [2004-01-16] Jump to specified position
+;; [2003-11-09] fix: All modes said 'not supported'.
+;; [2003-11-08] First upload
+;; [2003-11-05] First version
+
+;; Bug/Restriction
+;; - thing-at-point fails to recognize "snap:///file#1: snap:///"
+
+;;; Code:
+
+(eval-when-compile
+ (require 'cl))
+(require 'thingatpt)
+
+(defvar snap-version "$Id: snap.el,v 1.40 2007/05/16 14:44:28 hira Exp $")
+(defvar snap-prt "snap://")
+(defvar snap-format (concat snap-prt "%s/%s"))
+(defvar snap-regexp (concat (regexp-quote snap-prt) "\\([^/\r\n]*\\)/\\(.*\\)"))
+(defvar snap-mode-pos 1)
+(defvar snap-spell-pos 2)
+(defvar snap-root-dir (expand-file-name "/")) ;; "c:/" etc. for windows
+(defvar snap-record-string-no-error t
+ "For private use by other packages.
+It indicates that old bug on `snap-record-string' is already fixed.")
+(defvar snap-spell-format "%s??%s"
+ "Note: You can change this default to \"%s?%s\" like a cgi. But you
+will face to ploblem; how to deal with
+\"snap://w3m-mode/http://www.google.com?q=1?q=2\".")
+(defvar snap-cgi-format "%s=%s")
+(defvar snap-spell-regexp "\\(.*\\)[?][?]\\([a-z][=].*\\)"
+ "Note: Longest match of first part is important for the case:
+\"snap://occur-mode/dired-mode/~/??q=drwx??g=2\"")
+(defvar snap-nocgi-pos 1)
+(defvar snap-cgi-pos 2)
+(defvar snap-cgi-separator "&")
+(defvar snap-record-cgi nil
+ "List of recorded cgi types in `snap-record'")
+;;; for test use:
+;;; (setq snap-record-cgi '("g" "s" "q"))
+
+(defvar snap-abbrev nil
+ "List of rules on abbreviation for snap string.
+Each rule is a list of three strings: ABBREV, MODE, and SPELL-HEAD.
+snap://ABBREV/xxx is expanded as snap://MODE/SPELL-HEADxxx.
+
+Example:
+ ;; snap://l/file ==> snap://dired-mode/usr/local/meadow/1.15/lisp/file
+ ;; snap://s/dir ==> snap://shell-mode/~/#dir
+ (setq snap-abbrev
+ '((\"l\" \"dired-mode\" \"usr/local/meadow/1.15/lisp/\")
+ (\"s\" \"shell-mode\" \"~/\#\")))
+")
+
+(defvar snap-mode-functions nil
+ "List of functions which give the mode string of current buffer
+instead of the variable `major-mode'.
+Each function must return nil if it cannot determine the mode, so that
+decision is passed to the next function.
+
+This variable is prepared for applications which does not use
+their own major-mode, e.g. message buffers in Wanderlust.")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; main
+
+(defun snap-record ()
+ "Convert snapshot of application to string, and put it to kill-ring."
+ (interactive)
+ (let ((snap (snap-record-string)))
+ (when (null snap)
+ (error "This buffer is not supported."))
+ (kill-new snap)
+ (message "%s" snap)))
+
+(defun snap-play ()
+ "Restore snapshot of application from string at point."
+ (interactive)
+ (let ((snap (thing-at-point 'snap)))
+ ;; avoid (snap-play-string nil)
+ (and snap (snap-play-string snap))))
+
+(defun snap-repair ()
+ (interactive)
+ (let ((snap (thing-at-point 'snap))
+ (beg (match-beginning 0))
+ (end (match-end 0)))
+ (let ((repaired (snap-repair-string snap)))
+ (goto-char beg)
+ (delete-region beg end)
+ (insert repaired)
+ (message "Repaired."))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; util
+
+(defun snap-record-string ()
+ (let ((long (snap-record-string-exact)))
+ (and long (snap-shrink-string long))))
+(defun snap-play-string (snap)
+ (snap-play-string-exact (snap-expand-string snap)))
+
+(defun snap-shrink-string (snap)
+ "String SNAP is shrinked according to rules in `snap-abbrev'.
+When several rules are applicable, the shortest result is returned."
+ (let ((candidates (mapcar (lambda (rule)
+ (snap-shrink-string-by-rule snap rule))
+ snap-abbrev)))
+ (if candidates
+ (car (sort candidates (lambda (x y) (< (length x) (length y)))))
+ snap)))
+
+(defun snap-shrink-string-by-rule (snap rule)
+ (apply (lambda (abbrev mode spell-head)
+ (apply (lambda (o-mode o-spell)
+ (let ((reg (concat "^" (regexp-quote spell-head))))
+ (if (and (string= mode o-mode)
+ (string-match reg o-spell))
+ (snap-encode abbrev (substring o-spell (match-end 0)))
+ snap)))
+ (snap-decode snap)))
+ rule))
+
+(defun snap-expand-string (snap)
+ (apply (lambda (a-mode a-spell)
+ (let ((rule (assoc a-mode snap-abbrev)))
+ (if rule
+ (apply (lambda (abbrev mode spell-head)
+ (snap-encode mode (concat spell-head a-spell)))
+ rule)
+ snap)))
+ (snap-decode snap)))
+
+(defun snap-record-string-exact ()
+ "Convert snapshot of application to string.
+Nil is returned for unsupported buffer."
+ (let* ((mode (snap-get-mode snap-mode-functions))
+ (recorder (or (snap-op 'record mode t)
+ (progn (setq mode "") (snap-op 'record mode))))
+ (spell (funcall recorder)))
+ (and spell
+ (snap-encode mode spell
+ (delq nil (mapcar #'snap-record-cgi snap-record-cgi))))))
+
+(defun snap-get-mode (functions)
+ (if (null functions)
+ major-mode
+ (or (funcall (car functions))
+ (snap-get-mode (cdr functions)))))
+
+(defun snap-play-string-exact (snap)
+ "Restore snapshot of application from string. "
+ (let* ((x (snap-decode snap snap-record-cgi))
+ (mode (car x))
+ (spell (cadr x))
+ (cgi (cddr x))
+ (player (snap-op 'play mode)))
+ (funcall player spell)
+ (mapcar (lambda (z)
+ (apply (lambda (op val) (snap-play-cgi op val mode))
+ z))
+ cgi)))
+
+(defun snap-play-cgi (op val &optional mode)
+ "Find fake cgi command for operation OP and call it with the argument VAL.
+If MODE is given, snap-play:MODE:OP or snap-play:MODE: are used preferably
+rather than general snap-play::OP.
+They are called as
+ (snap-play:MODE:OP VAL)
+ (snap-play:MODE: OP VAL)
+ (snap-play::OP VAL)
+respectively."
+ (let ((player-mo (and mode (snap-op 'play (concat mode ":" op) t)))
+ (player-m (and mode
+ (let ((f (snap-op 'play (concat mode ":"))))
+ (and f
+ ;; elisp is not scheme. sigh...
+ `(lambda (val) (funcall (function ,f)
+ (quote ,op)
+ val))))))
+ (player-o (snap-op 'play (concat ":" op))))
+ (funcall (or player-mo player-m player-o) val)))
+
+(defun snap-play-cgi-on (buffer op val)
+ (snap-do-on buffer (lambda () (snap-play-cgi op val))))
+
+(defun snap-do-on (buffer proc)
+ (save-selected-window
+ (select-window (get-buffer-window buffer t))
+ (funcall proc)))
+
+(defun snap-record-cgi (op)
+ (let ((s (funcall (snap-op 'record (concat ":" op)))))
+ (if s
+ (snap-cgi-encode op s)
+ nil)))
+
+(defun snap-spell-decode (spell)
+ ;; suppose: spell has no-property
+ ;; Example:
+ ;; (snap-spell-decode "body#tag1?g=1&q=2??g=op1&q=?q=&x=#tag2&x")
+ ;; => ("body#tag1?g=1&q=2" ("g" "op1") ("q" "?q") ("x" "#tag2&x"))
+ (if (string-match snap-spell-regexp spell)
+ (cons (match-string snap-nocgi-pos spell)
+ (snap-cgi-decode (match-string snap-cgi-pos spell)))
+ (list spell)))
+
+(defun snap-cgi-decode (cgi)
+ ;; (snap-cgi-decode "a=1&b=c&d&e=&f")
+ ;; => '(("a" "1") ("b" "c&d") ("e" "&f"))
+ (let* ((f-regexp (snap-cgi-encode "\\([a-z]\\)" "\\(.*\\)"))
+ (s-regexp (concat "^\\(.*\\)" snap-cgi-separator f-regexp))
+ ;; using longest-match of the first part.
+ (rest cgi)
+ (olist '()))
+ (while (string-match s-regexp rest)
+ (setq olist (cons (list (match-string 2 rest) (match-string 3 rest)) olist))
+ (setq rest (match-string 1 rest)))
+ (if (string-match f-regexp rest)
+ (setq olist (cons (list (match-string 1 rest) (match-string 2 rest)) olist))
+ (message "unknown error"))
+ olist))
+
+(defun snap-repair-string (snap)
+ (let* ((x (snap-decode snap))
+ (mode (car x))
+ (spell (cadr x)))
+ (let ((repairer (snap-op 'repair mode)))
+ (snap-encode mode (funcall repairer spell)))))
+
+(defun snap-encode (mode spell &optional cgi-list)
+ (when cgi-list
+ (setq spell
+ (format snap-spell-format
+ spell
+ (mapconcat #'identity cgi-list
+ snap-cgi-separator))))
+ (format snap-format mode spell))
+
+(defun snap-spell-encode (spell cgi)
+ (format snap-spell-format spell cgi))
+
+(defun snap-cgi-encode (op str)
+ (format snap-cgi-format op str))
+
+(defun snap-decode (snap &optional cgi-p)
+ (or (snap-try-decode snap cgi-p)
+ (error "Wrong snapshot format: %s" snap)))
+
+(defun snap-try-decode (snap &optional cgi-p)
+ (and (string-match snap-regexp snap)
+ (let ((mode (match-string-no-properties snap-mode-pos snap))
+ (spell (match-string-no-properties snap-spell-pos snap)))
+ (if cgi-p
+ (cons mode (snap-spell-decode spell))
+ (list mode spell)))))
+
+(defun snap-op (op mode &optional no-err)
+ (let ((f (intern-soft (format "snap-%s:%s" op mode))))
+ (cond ((functionp f) f)
+ (no-err nil)
+ (t (error "%s is not supported." mode)))))
+
+;;; for thing-at-point
+(defun forward-snap (arg)
+ (interactive "p")
+ (if (natnump arg)
+ (re-search-forward snap-regexp nil 'move arg)
+ (progn
+ (skip-chars-forward "^ \t\r\n")
+ (while (< arg 0)
+ (if (re-search-backward snap-regexp nil 'move)
+ (skip-chars-backward "^ \t\r\n"))
+ (setq arg (1+ arg))))))
+
+;;; You need your own 'my-snap-search-mail'
+;;; which receives message-id and returns its file name.
+(eval-when-compile
+ (defalias 'my-snap-search-mail 'ignore))
+
+(defun snap-search-mail (message-id)
+ (message "Searching...")
+ (or (my-snap-search-mail message-id)
+ (error "Not found: %s" message-id)))
+
+(defun snap-line-number ()
+ (let ((raw (count-lines (point-min) (point))))
+ ;; see (describe-function 'count-lines)
+ (if (bolp)
+ (+ raw 1)
+ raw)))
+
+;;; check
+(let ((snap-abbrev '(("l" "dired-mode" "usr/meadow/1.15/lisp/")
+ ("s" "shell-mode" "~/#")))
+ (qa '(("snap://l/file" "snap://dired-mode/usr/meadow/1.15/lisp/file")
+ ("snap://s/dir" "snap://shell-mode/~/#dir"))))
+ (mapcar (lambda (z)
+ (apply (lambda (short long)
+ (if (and (string= short (snap-shrink-string long))
+ (string= (snap-expand-string short) long))
+ t
+ (error "incorrect snap-abbrev: %s %s" short long)))
+ z))
+ qa))
+
+(defun snap-find-file (path)
+ (find-file (expand-file-name (substitute-in-file-name path)
+ snap-root-dir)))
+
+(put 'snap-with-features 'lisp-indent-function 1)
+(put 'snap-define-op 'lisp-indent-function 2)
+;; SXEmacs doesn't have font-lock-add-keywords --SY.
+(unless (featurep 'sxemacs)
+ (font-lock-add-keywords
+ 'emacs-lisp-mode
+ '(("(\\(snap-with-features\\)\\>" 1 font-lock-keyword-face)
+ ("(\\(snap-define-op\\)\\>[
+ \t]+\\(\\sw+\\)"
+ (1 font-lock-keyword-face)
+ (2 font-lock-function-name-face)))))
+
+(defmacro snap-with-features (snap-features &rest body)
+ "Check existence of all SNAP-FEATURES and evaluate BODY if ok.
+This macro also attaches requirements of SNAP-FEATURES
+inside `eval-when-compile'.
+
+In this environment, a macro `snap-define-op' is available.
+This macro is similar to `defun', but requires SNAP-FEATURES."
+ (unless (memq nil
+ (mapcar (lambda (feature)
+ (locate-library (symbol-name feature)))
+ snap-features))
+;; `(eval-when-compile
+;; (message "Ignore some features which require %s." ',snap-features))
+ `(progn
+ (eval-when-compile
+ ,@(mapcar (lambda (feature)
+ `(require ',feature))
+ snap-features))
+ (macrolet
+ ((snap-define-op
+ (name arg &rest body)
+ (append (list 'defun name arg)
+ (mapcar (lambda (feature)
+ (list 'require (list 'quote feature)))
+ ',snap-features)
+ body)))
+ ,@body))))
+
+;; dummy definition for completion
+(defalias 'snap-define-op 'ignore)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; applications
+
+;;; <Application>
+;;; <Sample>
+
+;;; (Default)
+;;; snap:///~/elisp/snap.el#177:(defun snap-record: ()
+
+(defvar snap-record-default-format "%s#%s:%s")
+ ;see also `snap-record:occur-mode'
+(defun snap-record: ()
+ (let ((raw-path (buffer-file-name)))
+ (if (null raw-path)
+ nil
+ (let* ((line (snap-line-number))
+ (text (save-excursion
+ (beginning-of-line)
+ (looking-at "^[ \t]*\\(.*\\)")
+ (match-string-no-properties 1)))
+ (path (snap-abbreviate-file-name raw-path)))
+ (format snap-record-default-format path line text)))))
+
+(defun snap-abbreviate-file-name (raw-path)
+ (let ((relative-path ;; not snap:////etc but snap:///etc
+ (file-relative-name raw-path snap-root-dir))
+ (abbrev-path ;; not snap:///home/foo but snap:///~foo
+ (abbreviate-file-name raw-path)))
+ ;; use shorter one
+ (if (< (length relative-path) (length abbrev-path))
+ relative-path
+ abbrev-path)))
+
+(defun snap-play: (spell)
+ (cond
+ ((or (null spell) (string= spell ""))
+ (message "snap-version %s" snap-version))
+ ((string-match "\\([^#\r\n]+\\)\\(#\\([0-9]+\\):\\(.*\\)\\)?" spell)
+ (let ((path (match-string-no-properties 1 spell))
+ (positionp (match-string-no-properties 2 spell))
+ (line (match-string-no-properties 3 spell))
+ (text (match-string-no-properties 4 spell)))
+ (snap-find-file path)
+ (when positionp
+ (snap-play-search: (concat "^[ \t]*" (regexp-quote text) "$")
+ (string-to-number line)))))
+ (t
+ (error "not supported: %s" spell))))
+
+(defun snap-play-search: (regexp line-number)
+ (goto-line line-number)
+ (cond ((looking-at regexp) t)
+ ((snap-occur-p regexp) (snap-occur regexp line-number))
+ (t (message "No match."))))
+
+(defun snap-occur-p (regexp)
+ (save-excursion
+ (goto-char (point-min))
+ (re-search-forward regexp nil t)))
+
+(defun snap-occur (regexp line-number)
+ (occur regexp 0)
+ (switch-to-buffer "*Occur*") ;; why needed??
+ (let ((hits (snap-looking-at-number)))
+ (forward-line)
+ (if (= hits 1)
+ (snap-occur-goto-occurence)
+ (snap-occur-goto-line line-number))))
+
+(defun snap-occur-goto-occurence ()
+ (message "Line number is obsolete.")
+ (occur-mode-goto-occurrence)
+ ;; I prefer bol.
+ (beginning-of-line))
+
+(defun snap-occur-goto-line (line-number)
+ (while (let* ((n (snap-looking-at-number))
+ (stop (and n (>= n line-number))))
+ (and (not stop)
+ (= (forward-line) 0)))
+ ;; nothing to do
+ nil)
+ (if (not (snap-looking-at-number))
+ (forward-line -1)))
+
+(defun snap-looking-at-number ()
+ (and (looking-at "[ \t]*\\([0-9]+\\)")
+ (string-to-number (match-string-no-properties 1))))
+
+;;; Wanderlust
+;;; snap://wl-summary-mode/+ME/hira/<20031101192305.AFA8C43EDC@hoge.fuga.piyo>
+
+(snap-with-features (wl)
+ (snap-define-op snap-record:wl-summary-mode ()
+ (let ((n (wl-summary-message-number)))
+ (and (numberp n)
+ (let* ((folder wl-summary-buffer-elmo-folder)
+ (fld-name (elmo-folder-name-internal folder))
+ (id (elmo-message-field folder n 'message-id)))
+ (snap-encode:wl-summary-mode fld-name id)))))
+
+ (snap-define-op snap-play:wl-summary-mode (spell)
+ (let ((prefix-arg 4))
+ (wl prefix-arg)) ;; skip folder checking
+ (let* ((state (snap-decode:wl-summary-mode spell))
+ (fld-name (car state))
+ (id (cadr state))
+ (summary-buf (wl-summary-get-buffer-create fld-name)))
+ (wl-summary-goto-folder-subr fld-name
+ (wl-summary-get-sync-range
+ (wl-folder-get-elmo-folder fld-name))
+ nil nil t)
+ (wl-summary-jump-to-msg-by-message-id id)
+ (wl-summary-redisplay)))
+
+ (snap-define-op snap-repair:wl-summary-mode (spell)
+ (let* ((state (snap-decode:wl-summary-mode spell))
+ (id (cadr state))
+ (found-file (snap-search-mail id))
+ (folder (snap:wl-file-folder found-file)))
+ (when (null folder)
+ (error "No folder for %s" found-file))
+ (snap-encode:wl-summary-mode folder id)))
+
+ (defun snap-encode:wl-summary-mode (folder-name message-id)
+ (concat folder-name "/" message-id))
+
+ (defun snap-decode:wl-summary-mode (spell)
+ (and (string-match "\\(.*\\)/\\([^/]*\\)" spell)
+ (let ((fld-name (match-string-no-properties 1 spell))
+ (id (match-string-no-properties 2 spell)))
+ (list fld-name id))))
+
+ (defun snap:wl-file-folder (file)
+ (setq file (file-truename file))
+ (let ((buf (current-buffer)))
+ (wl 4)
+ (goto-char (point-min))
+ (wl-folder-open-all)
+ (prog1
+ (catch 'found
+ (while (not (eobp))
+ (let* ((name (wl-folder-get-entity-from-buffer))
+ (folder (wl-folder-search-entity-by-name
+ name
+ wl-folder-entity 'folder))
+ (ef (and folder (wl-folder-get-elmo-folder folder)))
+ (dir (and ef
+ (eq (elmo-folder-type-internal ef) 'localdir)
+ (elmo-localdir-folder-directory-internal ef))))
+ (when (and dir
+ (string-match (format "^%s"
+ (regexp-quote
+ (file-truename dir)))
+ file))
+ (throw 'found name))
+ (forward-line)))
+ nil)
+ (switch-to-buffer buf))))
+ )
+
+;;; Help
+;;; snap://help-mode/f/find-file
+;;; snap://help-mode/m/lambda
+;;; snap://help-mode/v/buffer-file-name
+
+;; Recording the `m' (macro) variant of the spell is only available
+;; on (S)XEmacs because I didn't know how to do it for GNU/Emacs.
+;; snap-play should work fine for all emacsen though. --SY.
+(eval-and-compile
+ (when (featurep 'xemacs)
+ (provide 'help)))
+
+(snap-with-features (help)
+ (snap-define-op snap-record:help-mode ()
+ (if (featurep 'xemacs)
+ (progn
+ (let ((name (save-excursion
+ (goto-char (point-min))
+ (re-search-forward "^`\\(.*\\)'" (eolp) t)
+ (intern-soft (match-string 1)))))
+ (if (fboundp name)
+ (if (eq 'macro (car-safe (symbol-function name)))
+ (format "m/%s" name)
+ (format "f/%s" name))
+ (format "v/%s" name))))
+ (let ((function (car help-xref-stack-item))
+ (variable (car (cdr help-xref-stack-item))))
+ (cond
+ ((equal function 'describe-function) (format "f/%s" variable))
+ ((equal function 'describe-variable) (format "v/%s" variable))
+ (help-xref-stack-item help-xref-stack-item)
+ (t "")))))
+
+ (snap-define-op snap-play:help-mode (spell)
+ (if (string-match "\\([^/\n \t]+\\)/\\(.+\\)" spell)
+ (let ((function (match-string 1 spell))
+ (variable (match-string 2 spell)))
+ (cond
+ ((or (string-match "^f.*" function)
+ (string-match "^m.*" function)
+ (string-match "describe-function" function))
+ (describe-function (intern variable)))
+ ((or (string-match "^v.*" function)
+ (string-match "describe-variable" function))
+ (describe-variable (intern variable)))
+ (t
+ (message "Not support this method %s" spell))))
+ (message "I can't all %s" spell)))
+
+;; for fake cgi
+ (defun snap-play:help-mode: (op val)
+ (snap-play-cgi-on "*Help*" op val))
+ )
+
+;;; Bookmark
+;;; snap://bookmark-bmenu-mode/kuzu
+
+(snap-with-features (bookmark)
+ (snap-define-op snap-record:bookmark-bmenu-mode ()
+ (bookmark-bmenu-bookmark))
+
+ (snap-define-op snap-play:bookmark-bmenu-mode (spell)
+ (if (equal spell "")
+ (progn
+ (bookmark-bmenu-list)
+ (switch-to-buffer "*Bookmark List*"))
+ (bookmark-jump spell)))
+ )
+
+;;; Man
+;;; snap://Man-mode/printf/3
+
+;;; (S)XEmacs records to these spells, but can play both formats. --SY.
+;;; snap://Manual-mode/ls
+;;; snap://Manual-mode/printf/3
+
+(snap-with-features (man)
+ (defvar snap-man-spacer "/")
+
+ (defvar *snap-man-mode-cgi* nil "for internal use")
+ (defvar *snap-man-mode-buffer* nil "for internal use")
+
+ (if (featurep 'xemacs)
+ ;; (S)XEmacs
+ (progn
+ (snap-define-op snap-record:Manual-mode ()
+ (let ((buf (buffer-name)))
+ (cond
+ ((string-match "^Man: \\(.*\\)(\\([1-8]+\\))$" buf)
+ (concat (match-string 1 buf) snap-man-spacer (match-string 2 buf)))
+ ((string-match "^Man: \\(.*$\\)" buf)
+ (concat (match-string 1 buf)))
+ (t
+ (error "not support buffer-name of man-mode: %s" buf)))))
+
+ (snap-define-op snap-play:Manual-mode (spell)
+ (let* ((strs (split-string spell (regexp-quote snap-man-spacer)))
+ (str-com (car strs))
+ (str-sec (mapconcat 'concat (cdr strs) snap-man-spacer))
+ (topic (if (equal str-sec "")
+ (concat str-com)
+ (concat str-com "(" str-sec ")"))))
+ ;; `snap-play:Man-mode:' needs this information.
+ (setq *snap-man-mode-buffer* (snap-man-mode-buffer topic))
+ (manual-entry topic)))
+
+ (snap-define-op snap-play:Man-mode (spell)
+ (let* ((strs (split-string spell (regexp-quote snap-man-spacer)))
+ (str-com (car strs))
+ (str-sec (mapconcat 'concat (cdr strs) snap-man-spacer))
+ (topic (if (equal str-sec "")
+ (concat str-com)
+ (concat str-com "(" str-sec ")"))))
+ ;; `snap-play:Man-mode:' needs this information.
+ (setq *snap-man-mode-buffer* (snap-man-mode-buffer topic))
+ (manual-entry topic))))
+ ;; GNU/Emacs
+ (snap-define-op snap-record:Man-mode ()
+ (let ((buf (buffer-name)))
+ (cond
+ ((string-match "^[*]Man[ \t]+\\([^ \t]+\\)[ \t]+\\([^ \t]+\\)[*]" buf)
+ (concat (match-string 2 buf) snap-man-spacer (match-string 1 buf)))
+ ((string-match "^[*]Man[ \t]+\\([^ \t]+\\)[*]" buf)
+ (concat (match-string 1 buf)))
+ (t
+ (error "not support buffer-name of man-mode: %s" buf)))))
+
+ (snap-define-op snap-play:Man-mode (spell)
+ (let* ((strs (split-string spell (regexp-quote snap-man-spacer)))
+ (str-com (car strs))
+ (str-sec (mapconcat 'concat (cdr strs) snap-man-spacer))
+ (topic (if (equal str-sec "")
+ (concat str-com)
+ (concat str-com "(" str-sec ")"))))
+ ;; `snap-play:Man-mode:' needs this information.
+ (setq *snap-man-mode-buffer* (snap-man-mode-buffer topic))
+ (man topic))))
+
+
+ ;; For fake cgi, we need to adjourn operations
+ ;; because man process is run asynchronously.
+
+ (defun snap-play:Man-mode: (op val)
+ (if *snap-man-mode-buffer*
+ ;; When corresponding man-buffer already exists, `man' just notifies it.
+ ;; Man-mode-hook is not run in this case.
+ ;; So, we will do our job immediately.
+ (snap-play-cgi-on *snap-man-mode-buffer* op val)
+ (snap-man-mode-adjourn-cgi op val)))
+
+ (defadvice Man-bgproc-sentinel (around snap-cgi (process msg) activate)
+ ad-do-it
+ (snap-do-on (snap-man-mode-process-buffer process)
+ #'snap-man-mode-play-cgi))
+
+ (defun snap-man-mode-adjourn-cgi (op val)
+ (add-to-list '*snap-man-mode-cgi* (cons op val)))
+
+ (defun snap-man-mode-play-cgi (&optional buf)
+ (unwind-protect
+ (mapcar (lambda (pair)
+ (snap-play-cgi (car pair) (cdr pair)))
+ *snap-man-mode-cgi*)
+ (setq *snap-man-mode-cgi* nil)))
+
+ ;; copied from man.el
+
+ (defun snap-man-mode-buffer (topic)
+ ;; from `Man-getpage-in-background'
+ (let* ((man-args topic)
+ (bufname (concat "*Man " man-args "*"))
+ (buffer (get-buffer bufname)))
+ buffer))
+
+ (defun snap-man-mode-process-buffer (process)
+ ;; from `Man-bgproc-sentinel'
+ (if (stringp process)
+ (get-buffer process)
+ (process-buffer process)))
+
+ ;; ;; I used `Man-mode-hook' instead of defadvice at first.
+ ;; ;; But, "q" operation failed because Man-mode-hook is run
+ ;; ;; inside save-excursion in `Man-bgproc-sentinel'.
+ ;; (add-hook 'Man-mode-hook #'snap-man-mode-play-cgi)
+ )
+
+;;; Info
+;;; snap://Info-mode/cvs#Tracking sources
+
+(snap-with-features (info)
+ (defvar snap-info-spacer "#")
+
+ (snap-define-op snap-record:Info-mode ()
+ (let ((str-file (if Info-current-file
+ (file-name-nondirectory Info-current-file)
+ ""))
+ (str-node (or Info-current-node "")))
+ (concat str-file snap-info-spacer str-node)))
+
+ (snap-define-op snap-play:Info-mode (spell)
+ (let* ((strs (split-string spell (regexp-quote snap-info-spacer)))
+ (str-file (or (car strs) "dir"))
+ (str-node (mapconcat 'concat (cdr strs) snap-info-spacer)))
+ (Info-goto-node (concat "(" str-file ")" str-node))))
+ )
+
+;;; Emacs-wiki
+;;; snap://emacs-wiki-mode/WelcomePage#title
+
+(snap-with-features (emacs-wiki)
+ (snap-define-op snap-record:emacs-wiki-mode ()
+ (let ((raw-path (buffer-file-name)))
+ (if (null raw-path)
+ nil
+ (format "%s" (file-name-nondirectory raw-path)))))
+
+ (snap-define-op snap-play:emacs-wiki-mode (spell)
+ (emacs-wiki-visit-link spell))
+ )
+
+;;; Navi2ch
+;;; snap://navi2ch-article-mode/pc5.2ch.net/test/read.cgi/tech/1068351911/100-200
+;;; snap://navi2ch-article-mode/http://pc5.2ch.net/test/read.cgi/tech/1068351911/150
+
+(snap-with-features (navi2ch)
+ (defvar snap-navi2ch-set-offline t)
+
+ (snap-define-op snap-record:navi2ch-article-mode ()
+ (save-match-data
+ (let* ((n (navi2ch-article-get-current-number))
+ (s (navi2ch-article-to-url navi2ch-article-current-board
+ navi2ch-article-current-article
+ n n t)))
+ (when (string-match "^http://" s)
+ (setq s (substring s (match-end 0))))
+ s)))
+
+ (snap-define-op snap-play:navi2ch-article-mode (spell)
+ (when snap-navi2ch-set-offline
+ (setq navi2ch-offline t))
+ (navi2ch-goto-url (if (string-match "^http://" spell)
+ spell
+ (concat "http://" spell))))
+ )
+
+;;; w3m
+;;; snap://w3m-mode/http://www
+
+;; (snap-with-features (w3m)
+;; (snap-define-op snap-record:w3m-mode ()
+;; w3m-current-url)
+
+;; (snap-define-op snap-play:w3m-mode (spell)
+;; (w3m spell))
+;; )
+
+;;; Dired
+;;; snap://dired-mode/~/
+
+(snap-with-features (dired)
+ (snap-define-op snap-record:dired-mode ()
+ (snap-abbreviate-file-name dired-directory))
+
+ (snap-define-op snap-play:dired-mode (spell)
+ (snap-find-file spell))
+ )
+
+;;; BBDB
+;;; snap://bbdb-mode/name
+
+(snap-with-features (bbdb)
+ (snap-define-op snap-play:bbdb-mode (spell)
+ (bbdb spell nil))
+
+ (snap-define-op snap-record:bbdb-mode ()
+ (let ((bbdb-record (bbdb-current-record)))
+ (car (bbdb-record-net bbdb-record))))
+
+ (defun snap-play:bbdb-mode: (op val)
+ ;; disable fake cgi
+ )
+ )
+
+;;; Bibtex
+;;; snap://bibtex-mode/file#bibtex-key
+
+(snap-with-features (bibtex)
+ (defvar snap-bibtex-spacer "#")
+ (snap-define-op snap-play:bibtex-mode (spell)
+ (if (string-match "^\\(.*\\)#\\(.*\\)$" spell)
+ (let ((k (match-string 2 spell)))
+ (find-file (match-string 1 spell))
+ (and k
+ (not (snap-bibtex-search k))
+ (message "No such bibtex-key \"%s\"" k)))
+ (find-file spell)))
+ (defun snap-bibtex-search (k)
+ (let ((regexp (concat "^@.*" k)))
+ (goto-char (point-max))
+ (while (and (re-search-backward regexp nil t)
+ (not (string= k (snap-bibtex-key)))))
+ (string= k (snap-bibtex-key))))
+ (defun snap-bibtex-key ()
+ (save-excursion ;c.f. `bibtex-clean-entry'
+ (let ((case-fold-search t)
+ (eob (bibtex-end-of-entry))
+ (head (cond ((boundp 'bibtex-entry-head) ; new
+ bibtex-entry-head)
+ ((boundp 'bibtex-reference-head) ; old
+ bibtex-reference-head)
+ (t
+ (error "Neither bibtex-entry-head nor bibtex-reference-head is defined.")))))
+ (bibtex-beginning-of-entry)
+ (if (re-search-forward head eob t)
+ (buffer-substring-no-properties
+ (match-beginning bibtex-key-in-head)
+ (match-end bibtex-key-in-head))))))
+ (snap-define-op snap-record:bibtex-mode ()
+ (let ((f (buffer-file-name))
+ (k (snap-bibtex-key)))
+ (if k
+ (concat f snap-bibtex-spacer k)
+ f)))
+ )
+
+;;; Shell
+;;; snap://shell-mode/~/#pwd
+
+;;; ToDo directory with # is not allowed!
+
+(snap-with-features (shell)
+ (defvar snap-shell-spacer "#")
+ (defvar snap-shell-buffer-name "*shell*snap*")
+
+ (snap-define-op snap-record:shell-mode ()
+ "record now directory and a command now inputed"
+ (let ((pm (process-mark (get-buffer-process (current-buffer))))
+ (p (point)))
+ ;; c.f. comint-kill-input
+ (concat default-directory
+ (if (> p (marker-position pm))
+ (concat snap-shell-spacer (buffer-substring-no-properties pm p))))))
+ (snap-define-op snap-play:shell-mode (spell)
+ "1. start shell-mode for snap 2. insert a command (without
+execution)"
+ (string-match "\\([^#\r\n]+\\)#?\\(.*\\)" spell)
+ (let ((default-directory (match-string-no-properties 1 spell))
+ (c (or (match-string-no-properties 2 spell) ""))
+ nn no)
+ (if (not (comint-check-proc "*shell*"))
+ (shell)
+ ;;duplicate shell
+ (set-buffer "*shell*")
+ (setq no (rename-buffer "*shell*" t))
+ (shell)
+ (setq nn (rename-buffer snap-shell-buffer-name t))
+ (set-buffer no)
+ (rename-buffer "*shell*" t)
+ (set-buffer nn)
+ )
+ (insert c)))
+ )
+
+;;; Occur
+;;; snap://occur-mode/dired-mode/~/??q=drwx??g=2
+;;; by using "snap://MAJOR-MODE/SPELL??q=word"
+
+(snap-with-features ()
+ (defvar snap-occur-cgi-string "q")
+ (snap-define-op snap-record:occur-mode ()
+ (let* ((b occur-buffer)
+ (s (car occur-command-arguments))
+ (snap-record-cgi nil)
+ (snap-record-default-format "%s")
+ (x (snap-decode (save-excursion (set-buffer b) (snap-record-string))))
+ (mode (car x))
+ (spell (cadr x))
+ (snap (snap-encode mode (snap-spell-encode spell (snap-cgi-encode snap-occur-cgi-string s)))))
+ (if (string-match (concat "^" snap-prt) snap)
+ (substring snap (match-end 0))
+ snap)))
+
+ (snap-define-op snap-play:occur-mode (spell)
+ (save-window-excursion
+ (snap-play-string (concat snap-prt spell)))
+ (if (get-buffer "*Occur*")
+ (switch-to-buffer "*Occur*")
+ (message "maybe failed to match")))
+ )
+
+;;; Howm
+;;; snap://howm-view-summary-mode/word
+;;; snap://howm-view-contents-mode/word
+ ; checked on howm-test-050518
+
+(snap-with-features (howm)
+ (snap-define-op snap-record:howm-view-summary-mode ()
+ (howm-view-name))
+ (snap-define-op snap-record:howm-view-contents-mode ()
+ (howm-view-name))
+ (snap-define-op snap-play:howm-view-summary-mode (spell)
+ ;; completion-p is always nil in my case.
+ (message "howm searching %s ..." spell)
+ ;; message is needed because howm-search needs long time.
+ (howm-search spell nil))
+ (snap-define-op snap-play:howm-view-contents-mode (spell)
+ (message "howm searching %s ..." spell)
+ (howm-search spell nil))
+ )
+
+;;; Gnus
+;;; snap://gnus-summary-mode/group/article-number:<20031101.ACDC@hoge.fuga.piyo>
+
+(snap-with-features (gnus gnus-sum)
+ (snap-define-op snap-record:gnus-summary-mode ()
+ (snap-encode:gnus-summary-mode
+ gnus-newsgroup-name
+ (gnus-summary-article-number)
+ (mail-header-message-id (gnus-summary-article-header))))
+
+ (snap-define-op snap-play:gnus-summary-mode (spell)
+ (unless (and (fboundp 'gnus-alive-p) (gnus-alive-p)) (gnus))
+ (require 'gnus-score)
+ (let* ((state (snap-decode:gnus-summary-mode spell))
+ (group (car state))
+ (article (cadr state))
+ (id (car (cddr state)))
+ backend
+ ;; cf. gnus-group-quick-select-group
+ ;; gnus-visual
+ gnus-score-find-score-files-function
+ gnus-home-score-file
+ gnus-apply-kill-hook
+ gnus-summary-expunge-below)
+ (setq backend
+ (if (string-match "\\([^+]+\\).*:.+" group)
+ (match-string 1 group)
+ (symbol-name (car gnus-select-method))))
+ ;; disable getting new message
+ (eval `(let ((,(intern (concat backend "-get-new-mail")) nil))
+ (gnus-group-read-group 0 t group)))
+ (unless (and
+ (gnus-summary-goto-article article nil t)
+ (string= id (mail-header-message-id (gnus-summary-article-header))))
+ (gnus-summary-goto-article id nil t))))
+
+ (defun snap-encode:gnus-summary-mode (group article id)
+ (format "%s/%s:%s" group article id))
+
+ (defun snap-decode:gnus-summary-mode (spell)
+ (when (string-match "\\(.*\\)/\\([0-9]+\\):\\([^/]*\\)" spell)
+ (list (match-string-no-properties 1 spell)
+ (match-string-no-properties 2 spell)
+ (match-string-no-properties 3 spell))))
+ )
+
+;;; PCVS
+;;; snap://cvs-mode/~/hoge/
+
+(snap-with-features (pcl-cvs)
+ (snap-define-op snap-play:cvs-mode (spell)
+ (cvs-examine spell t))
+ (snap-define-op snap-record:cvs-mode ()
+ (abbreviate-file-name default-directory))
+ )
+
+;;; Thumb
+;;; snap://thumbs-mode/~/hoge/
+;;; snap://thumbs-view-image-mode/~/tmp.jpg
+
+(snap-with-features (thumbs)
+ (snap-define-op snap-record:thumbs-mode ()
+ ;; only for `thumbs-show-all-from-dir' not `thumbs-dired-show-marked'.
+ (abbreviate-file-name thumbs-current-dir))
+ (snap-define-op snap-play:thumbs-mode (spell)
+ (thumbs-show-all-from-dir spell nil t))
+ (snap-define-op snap-record:thumbs-view-image-mode ()
+ (abbreviate-file-name thumbs-current-image-filename))
+ (snap-define-op snap-play:thumbs-view-image-mode (spell)
+ (if (file-exists-p spell)
+ (thumbs-find-image spell)
+ (message "No such file:%s" spell)))
+ )
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; cgi extension
+;;;
+;;; Examples:
+;;;|goto-line |snap:///file??g=110
+;;;|search&move str |snap:///file??s=str
+;;;|occur str |snap:///file??q=str
+;;;|dired-x (file) |snap:///??x=file
+;;;|dired-x (buffer)|snap:///??x=
+;;;|open & dired-x |snap:///file??x=
+;;;|open &dired-x |snap:///dir??x=file
+;;;|find & dired-x |snap:///dir??s=str&x=
+;;;|move & dired-x |snap:///dir??g=10&x=
+;;;
+;;; ToDo: find and compilation
+
+(defun snap-play-dired-x (file)
+ ""
+ (let ((dir (or (file-name-directory file) default-directory))
+ (filename (file-name-nondirectory file))
+ (font-lock-global-modes nil))
+ (save-excursion
+ (find-file dir)
+ (goto-char (point-min))
+ (search-forward-regexp (concat "[ ]" (regexp-quote filename) "$") nil)
+ (call-interactively 'dired-do-shell-command)
+ (bury-buffer))))
+
+(defun snap-play::x (spell)
+ "snap-record cgi extension for execute"
+ (if (or (null spell) (string= "" spell))
+ (cond
+ (buffer-file-name
+ (snap-play-dired-x buffer-file-name))
+ ((eq major-mode 'dired-mode)
+ (call-interactively 'dired-do-shell-command))
+ (t
+ (message "error")))
+ (cond
+ ((or (file-exists-p spell) (eq major-mode 'dired-mode))
+ (snap-play-dired-x spell))
+ (buffer-file-name
+ (snap-play-dired-x buffer-file-name))
+ (t
+ (message "error")))))
+(defun snap-record::g ()
+ "snap-record cgi extension for goto-line"
+ (number-to-string (snap-line-number)))
+(defun snap-play::g (spell)
+ "snap-record cgi extension for goto-line"
+ (goto-line (string-to-number spell)))
+(defun snap-record:: ()
+ "snap-record cgi extension for default tag"
+ (number-to-string (snap-line-number)))
+(defun snap-play:: (spell)
+ "snap-record cgi extension for default tag"
+ (goto-line (string-to-number spell)))
+(defun snap-record::s ()
+ "snap-record cgi extension for search return the string of
+kill-ring. (not work. help) "
+ (cond
+ ;; ((eq last-command 'kill-ring-save)
+ ;; (remove-text-properties (current-kill 0))
+ ;; )
+ (t
+ (save-excursion
+ (beginning-of-line)
+ (looking-at "^[ \t]*\\(.*\\)")
+ (match-string-no-properties 1)))))
+(defun snap-play::s (spell)
+ "snap-play cgi extension for search around point"
+ (or (search-forward spell nil t)
+ (progn (goto-char (point-max))
+ (search-backward spell nil t))
+ (message "Failed search")))
+(defun snap-record::q ()
+ "snap-record cgi extension for search
+
+return 1. the string of kill-ring. (not yet)
+
+2. the word at cursor."
+ (cond
+ ;; ((eq last-command 'kill-ring-save)
+ ;; (remove-text-properties (current-kill 0))
+ ;; )
+ ((provide 'thingatpt)
+ (or (thing-at-point 'word) (thing-at-point 'symbol)))
+ (t
+ nil)))
+
+(defun snap-play::q (spell)
+ "snap-play cgi extension for occur"
+ (occur spell))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; with other tools
+
+;;; with action-lock.el
+;;; (in howm: <http://howm.sourceforge.jp/>)
+
+(snap-with-features (action-lock)
+ (defun snap-action-lock (regexp arg-pos &optional hilit-pos)
+ (action-lock-general #'(lambda (f u)
+ (call-interactively 'snap-play))
+ regexp arg-pos hilit-pos t))
+ )
+
+(eval-after-load "action-lock"
+ '(let ((snap-action-lock-rules (list (snap-action-lock snap-regexp 0))))
+ (setq action-lock-default-rules
+ (append snap-action-lock-rules action-lock-default-rules))))
+
+;;; with bookmark
+
+(snap-with-features (bookmark)
+ (defadvice bookmark-buffer-file-name
+ (around with-snap first () disable)
+ "Extend it's function for snap protocol"
+ ad-do-it
+ (unless ad-return-value
+ (setq ad-return-value (snap-record-string))))
+ (defadvice bookmark-jump-noselect (around with-snap first (str) disable)
+ "Extend it's function for snap protocol with the help of
+`snap-bookmark-jump-noselect'.
+
+Suppose `bookmark-jump-noselect' has (str) as inputs and
+returns (BUFFER . POINT)
+"
+ (bookmark-maybe-load-default-file)
+ (let* ((str (ad-get-arg 0))
+ (url (bookmark-get-filename str)))
+ (cond
+ ((string-match snap-regexp url)
+ (setq ad-return-value (snap-bookmark-jump-noselect str)))
+ (t ad-do-it))))
+ (defun snap-bookmark-jump-noselect (str)
+ (let* ((url (bookmark-get-filename str))
+ (snap-p (string-match snap-regexp url))
+;; (file (if snap-p url (expand-file-name url)))
+ (forward-str (bookmark-get-front-context-string str))
+ (behind-str (bookmark-get-rear-context-string str))
+;; (place (bookmark-get-position str))
+;; (info-node (bookmark-get-info-node str))
+;; (orig-file file)
+ )
+ (if snap-p
+ (save-excursion
+ (save-window-excursion
+ (snap-play-string url)
+ (when (and forward-str
+ (search-forward forward-str (point-max) t))
+ (goto-char (match-beginning 0)))
+ (when (and behind-str
+ (search-backward behind-str (point-min) t))
+ (goto-char (match-end 0)))
+ (setq bookmark-current-bookmark str)
+ (cons (current-buffer) (point))))
+ (ding))))
+ )
+
+;;; with ffap
+
+(snap-with-features (ffap)
+ (defvar snap-ffap-url-regexp
+ (concat
+ "\\`\\("
+ "news\\(post\\)?:\\|mailto:\\|file:" ; no host ok
+ "\\|"
+ "\\(ftp\\|https?\\|telnet\\|gopher\\|www\\|wais\\|snap\\)://" ; needs host
+ "\\)." ; require one more character
+ ))
+ (defvar snap-ffap-url-fetcher 'snap-ffap-browse-url)
+ (defun snap-ffap-browse-url (url &rest args)
+ "Deal with a snap protocol in addition to the function `browse-url'"
+ (if (string-match snap-regexp url)
+ (snap-play-string url)
+ (browse-url url args)))
+ )
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; provide
+
+(provide 'snap)
+
+;;; snap.el ends here.
--- /dev/null
+;;; sxell.el --- Browse the Emacs Lisp List (SXEmacs version)
+
+;; Copyright (C) 2005 Steve Youngs
+
+;; Author: Steve Youngs <steve@sxemacs.org>
+;; Maintainer: Steve Youngs <steve@sxemacs.org>
+;; Created: Jul 4, 2005
+;; Version: 0.1
+;; Download: ftp://ftp.youngs.au.com/pub/lisp/SXEmacs/sxell.el
+
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions
+;; are met:
+;;
+;; 1. Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; 2. Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;;
+;; 3. Neither the name of the author nor the names of any contributors
+;; may be used to endorse or promote products derived from this
+;; software without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR
+;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+;; DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
+;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
+;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
+;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
+;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+;;; Commentary:
+;;
+;; The Emacs Lisp List is a list of links to a wide variety of
+;; emacs-lisp libraries around the globe. The list is maintained by
+;; Stephen Eglen and can be found at
+;; http://www.damtp.cam.ac.uk/user/sje30/emacs/ell.html. sxell.el
+;; allows you to view that list in a normal buffer inside SXEmacs
+;; (no, sxell.el does NOT work with XEmacs or GNU/Emacs).
+;;
+;; The data you see in the *sxell-packages* buffer originally comes
+;; from a .xml file from Stephen's site. This .xml is parsed and
+;; stored in a local PostgreSQL db. Most operations default to
+;; using the local PostgreSQL db. Remote operations are only done
+;; when explicitly requested.
+;;
+;; When checking for updates, to save on bandwidth, just the HTTP
+;; header of the .xml file is downloaded and a match against the
+;; "Etag" header is done. (this is also saved in the db). If the
+;; Etag hasn't changed, the .xml file isn't downloaded.
+;;
+;; Keeping a copy of the list in a local db allows for, amongst
+;; other things, "offline" operation and complex searching of the
+;; list.
+;;
+;; The idea for this comes from ell.el by Jean-Philippe Theberge et
+;; al.
+
+;;; Code:
+
+(unless (featurep 'sxemacs)
+ (error "We're sorry, this library is for SXEmacs ONLY"))
+
+(require 'xml)
+
+(when (fboundp 'ffi-defun)
+ (require 'ffi-curl))
+
+(unless (featurep '(and ffi postgresql))
+ (error 'unimplemented "FFI and/or PostgreSQL"))
+
+(defgroup sxell nil
+ "Browse the Emacs Lisp List."
+ :prefix "sxell-"
+ :group 'hypermedia)
+
+(defcustom sxell-initialised-flag nil
+ "*When nil, initialise the PostgreSQL db and import the Ell.
+
+This variable is set to non-nil and saved the first time you run
+`sxell-packages', so in most cases you can leave this alone."
+ :type 'boolean
+ :group 'sxell)
+
+(defcustom sxell-remote-file
+ "http://www.damtp.cam.ac.uk/user/sje30/emacs/ell.xml"
+ "*URL to the Emacs Lisp List XML file."
+ :type 'string
+ :group 'sxell)
+
+(defcustom sxell-local-file (expand-file-name "ell.xml" (temp-directory))
+ "*Local version of the Emacs Lisp List XML file."
+ :type 'string
+ :group 'sxell)
+
+(defcustom sxell-download-directory
+ (file-name-as-directory (user-home-directory))
+ "*Directory for files downloaded from the *sxell-packages* buffer.
+
+The default is $HOME."
+ :type '(directory :must-match t)
+ :group 'sxell)
+
+(defcustom sxell-use-font-lock t
+ "*If non-nil, we font-lock the ELL buffer."
+ :type 'boolean
+ :group 'sxell)
+
+(defcustom sxell-mode-hook nil
+ "*Hooks run after entering `sxell-mode'."
+ :type 'hook
+ :group 'sxell)
+
+(defcustom sxell-download-hook nil
+ "*Hooks run after downloading a file from the *sxell-packages* buffer."
+ :type 'hook
+ :group 'sxell)
+
+(defcustom sxell-fetch-remote-xml-hook nil
+ "*Hooks run after fetching the ELL xml file."
+ :type 'hook
+ :group 'sxell)
+
+(defvar sxell-last-updated nil
+ "Date that the list was last updated.
+
+Internal var, don't set it.")
+
+(defvar sxell-current-etag nil
+ "ETag HTTP header of ell.xml.
+
+Internal var, don't set it.")
+
+(defun sxell-db-initialise ()
+ "Initialise the SXEll PostgreSQL database."
+ (let* ((initdb (pq-connectdb "dbname=template1"))
+ (ellres (pq-exec
+ initdb
+ "SELECT * FROM pg_catalog.pg_database WHERE datname='ell';")))
+ (when (zerop (pq-ntuples ellres))
+ (pq-exec initdb "CREATE DATABASE ell;"))
+ (pq-finish initdb))
+ (let* ((elldb (pq-connectdb "dbname=ell")))
+ (ignore-errors
+ (pq-exec elldb "CREATE TABLE ell (
+filename text NOT NULL DEFAULT ''::text,
+description text NOT NULL DEFAULT ''::text,
+site text NOT NULL DEFAULT 'http://'::text,
+contact text NOT NULL DEFAULT ''::text,
+time_stamp date NOT NULL DEFAULT ('now'::text)::date,
+note text NOT NULL DEFAULT ''::text,
+installed_p bool NOT NULL DEFAULT false,
+direct_link_p bool );"))
+ (ignore-errors
+ (pq-exec elldb "CREATE TABLE last_upd (
+etag text NOT NULL DEFAULT ''::text,
+last_date text NOT NULL DEFAULT ''::text );")
+ (pq-exec elldb "INSERT INTO last_upd VALUES (
+'bogus-etag','Thu Jan 1 00:00:00 EST 1970' );"))
+ (pq-finish elldb)))
+
+(defun sxell-get-pg-packages-list (&optional sql)
+ "Return a list of packages from the local PostgreSQL db.
+
+Optional argument, SQL is the PostgreSQL SELECT statement to use. If
+it is omitted, `SELECT * FROM ell ORDER by filename ;' is used."
+ (let* ((db (pq-connectdb "dbname=ell"))
+ (res (pq-exec db (or sql "SELECT * FROM ell ORDER by filename ;")))
+ (nrows (pq-ntuples res))
+ (nfields (pq-nfields res))
+ (upd-res (pq-exec db "SELECT last_date FROM last_upd ;"))
+ list-o-matic mega-list)
+ (loop for row from 0 to (1- nrows)
+ do (loop for field downfrom (1- nfields) to 0
+ do (push (pq-get-value res row field) list-o-matic))
+ do (push list-o-matic mega-list)
+ do (setq list-o-matic nil))
+ (setq sxell-last-updated (pq-get-value upd-res 0 0))
+ (pq-finish db)
+ (nreverse mega-list)))
+
+(defun sxell-fetch-ell-xml ()
+ (message "Fetching Emacs Lisp List. Please wait...")
+ (curl:download sxell-remote-file sxell-local-file)
+ (message "Fetching Emacs Lisp List. Done!")
+ (run-hooks 'sxell-fetch-remote-xml-hook))
+
+(defun sxell-fetch-ell-etag ()
+ "Returns the \"ETag\" of ell.xml's HTTP header."
+ (let ((file (expand-file-name "ell.tag" (temp-directory)))
+ etag)
+ (curl:download sxell-remote-file file :header t :nobody t)
+ (setq etag (with-temp-buffer
+ (insert-file-contents-literally file)
+ (goto-char (point-min))
+ (re-search-forward "^ETag:\\s-\"\\(.*\\)\"" nil t)
+ (match-string 1)))
+ (delete-file file)
+ etag))
+
+(defun sxell-parse-ell-xml ()
+ "Parse the contents of the ELL site ell.xml file."
+ (let* ((xml (xml-parse-file sxell-local-file))
+ (root (car xml))
+ (entries (cadddr root)))
+ (setq sxell-last-updated (nth 2 (caddr root)))
+ (mapcar (lambda (entry)
+ (let ((attrs (cadr entry)))
+ (list
+ (pq-escape-string (cdr (assoc 'filename attrs)))
+ (pq-escape-string (cdr (assoc 'description attrs)))
+ (pq-escape-string (cdr (assoc 'site attrs)))
+ (pq-escape-string (cdr (assoc 'contact attrs)))
+ (pq-escape-string (cdr (assoc 'timestamp attrs)))
+ (pq-escape-string (cdr (assoc 'note attrs))))))
+ (cddr entries))))
+
+(defun sxell-update-pg-from-xml ()
+ (let ((entries (sxell-parse-ell-xml))
+ (db (pq-connectdb "dbname=ell"))
+ (chk-entry-fmt (concat "SELECT * FROM ell WHERE "
+ "filename = '%s' AND ( description = '%s' OR "
+ "site = '%s' OR contact = '%s' OR "
+ "time_stamp = '%s' OR note = '%s' ) ;"))
+ (upd-fmt (concat "UPDATE ell "
+ "SET filename = '%s', description = '%s', "
+ "site = '%s', contact = '%s', time_stamp = '%s', "
+ "note = '%s' "
+ "WHERE filename = '%1$s' AND ( description = '%2$s' "
+ "OR site = '%3$s' OR contact = '%4$s' OR "
+ "time_stamp = '%5$s' OR note = '%6$s' ) ;"))
+ existing)
+ (while entries
+ ;; Check to see if we need to update or add an entry.
+ (setq existing (pq-exec db (apply #'format chk-entry-fmt (car entries))))
+ (if (zerop (pq-ntuples existing))
+ ;; This is a new entry
+ (pq-exec db (format "INSERT INTO ell VALUES (%s) ;"
+ (mapconcat #'(lambda (el)
+ (concat "'" el "'"))
+ (car entries) ",")))
+ ;; Existing entry, update it
+ (pq-exec db (apply #'format upd-fmt (car entries))))
+ (setq entries (cdr entries)))
+ ;; Update last updated date and etag
+ (pq-exec db (format "UPDATE last_upd SET last_date = '%s', etag = '%s' ;"
+ sxell-last-updated sxell-current-etag))
+ (pq-finish db)))
+
+(defvar sxell-font-lock-keywords
+ '((" <\\(New\\)> " (1 font-lock-warning-face))
+ ("^Note: \\(.*$\\)" (1 font-lock-warning-face))
+ ("^\\(Note\\|Contact\\|Added\\):" (1 font-lock-keyword-face))
+ ("^\\*" . font-lock-warning-face)
+ ("^\\*?\\(\\w+.*\\(\\.el\\)?\\)\\s-\\(<\\|-\\)"
+ (1 font-lock-function-name-face)))
+ "Font lock keywords in sxell mode.")
+
+(defun sxell-prepare-buffer ()
+ "Prepare to make the new *sxell-packages* buffer."
+ (switch-to-buffer (get-buffer-create "*sxell-packages*"))
+ (erase-buffer)
+ (insert "==========================================")
+ (center-line)(insert "\n")
+ (insert "The Emacs Lisp List")(center-line)(insert "\n")
+ (insert "by Stephen Eglen: stephen@anc.ed.ac.uk")(center-line)(insert "\n")
+ (insert "==========================================")
+ (center-line)(insert "\n\n"))
+
+(defun sxell-update-buffer (date)
+ "Update the counters at the top of the *sxell-packages* buffer.
+DATE is the date when ELL was last updated."
+ (when sxell-last-updated
+ (goto-line 5)
+ (insert (format "Last updated: %s" date))
+ (goto-line 5)
+ (center-line)))
+
+(defun sxell-url-at-point ()
+ "Browse to a URL from the sxell buffer."
+ (interactive)
+ (when (extentp (extent-at (point)))
+ (browse-url (extent-string (extent-at (point))))))
+
+(defun sxell-url-at-mouse (event)
+ "Browse to a URL at EVENT via the mouse from the sxell buffer."
+ (interactive "e")
+ (when (extentp (extent-at-event event))
+ (browse-url (extent-string (extent-at-event event)))))
+
+(defun sxell-download-file-at-point ()
+ "Download the file from the URL in the sxell buffer."
+ (interactive)
+ (when (extentp (extent-at (point)))
+ (let* ((remote (extent-string (extent-at (point))))
+ (local (car (last (split-string-by-char remote ?/)))))
+ (if (string-match ".*\\.\\(el\\|t?gz\\|bz2\\)$" local)
+ (curl:download remote
+ (expand-file-name local sxell-download-directory))
+ (message "Nothing to download here :-(")))))
+
+(defun sxell-download-file-at-mouse (event)
+ "Download the file from the URL in the sxell buffer."
+ (interactive "e")
+ (when (extentp (extent-at-event event))
+ (let* ((remote (extent-string (extent-at-event event)))
+ (local (car (last (split-string-by-char remote ?/)))))
+ (if (string-match ".*\\.\\(el\\|t?gz\\|bz2\\)$" local)
+ (curl:download remote
+ (expand-file-name local sxell-download-directory))
+ (message-or-box "Nothing to download here :-(")))))
+
+(defun sxell-kill-buffer ()
+ (interactive)
+ (kill-buffer nil)
+ (when (file-exists-p sxell-local-file)
+ (delete-file sxell-local-file)))
+
+(defconst sxell-mode-map
+ (let* ((map (make-sparse-keymap 'sxell-mode-map)))
+ (define-key map [space] 'scroll-up)
+ (define-key map [delete] 'scroll-down)
+ (define-key map [q] 'bury-buffer)
+ (define-key map [Q] 'sxell-kill-buffer)
+ map)
+ "A keymap for the sxell buffer.")
+
+(defconst sxell-ext-map
+ (let* ((map (make-sparse-keymap 'sxell-ext-map)))
+ (define-key map [button2] 'sxell-url-at-mouse)
+ (define-key map [return] 'sxell-url-at-point)
+ (define-key map [d] 'sxell-download-file-at-point)
+ (define-key map [(control button2)] 'sxell-download-file-at-mouse)
+ map)
+ "A keymap for the extents in sxell buffer.")
+
+(defun sxell-make-url-extents ()
+ "Create extent objects for all the URLs in the buffer."
+ (goto-char (point-min))
+ (save-excursion
+ (while (re-search-forward "^\\(ht\\|f\\)tp.*$" nil t)
+ (let ((extent (make-extent (match-beginning 0) (match-end 0)))
+ (echo "Visit: RET, button2; Download: d, C-button2"))
+ (set-extent-property extent 'face 'font-lock-comment-face)
+ (set-extent-property extent 'mouse-face 'highlight)
+ (set-extent-property extent 'keymap sxell-ext-map)
+ (set-extent-property extent 'help-echo echo)
+ (set-extent-property extent 'balloon-help echo)
+ (set-extent-property extent 'duplicable t)))))
+
+(defun sxell-fix-quoting ()
+ (goto-char (point-min))
+ (save-excursion
+ (while (re-search-forward """ nil t)
+ (replace-match "\""))))
+
+(defun sxell-mode ()
+ "Major mode for browsing the Emacs Lisp List.
+\\{sxell-mode-map}"
+ (interactive)
+ (kill-all-local-variables)
+ (set (make-local-variable 'font-lock-defaults)
+ '(sxell-font-lock-keywords t))
+ (use-local-map sxell-mode-map)
+ (setq major-mode 'sxell-mode
+ mode-name "SXEll")
+ (when sxell-use-font-lock
+ (font-lock-mode))
+ (run-hooks 'sxell-mode-hook))
+
+(defun sxell-init ()
+ "Initialise SXEll.
+
+This _ONLY_ needs to be run _ONCE_. It initialises the PostgreSQL
+database, and fills it from a fresh copy of the ELL."
+ (sxell-db-initialise)
+ (customize-save-variable 'sxell-initialised-flag t)
+ (sxell-packages 'remote))
+
+(defun sxell-check-remote-update ()
+ "Check to see if the local Ell db needs updating from the remote."
+ (let* ((db (pq-connectdb "dbname=ell"))
+ (res (pq-exec db "SELECT etag FROM last_upd ;"))
+ old-etag)
+ (setq old-etag (pq-get-value res 0 0))
+ (setq sxell-current-etag (sxell-fetch-ell-etag))
+ (pq-finish db)
+ (unless (string= old-etag sxell-current-etag)
+ (sxell-fetch-ell-xml)
+ (sxell-update-pg-from-xml))))
+
+(defun sxell-mark-installed ()
+ "Mark ELL entries that are installed locally.
+
+CAUTION: this can be a slow and CPU intensive operation, be patient."
+ (interactive)
+ (when (y-or-n-p "This can take considerable time, are you sure? ")
+ (let* ((db (pq-connectdb "dbname=ell"))
+ (res
+ (pq-exec
+ db
+ "SELECT DISTINCT filename FROM ell WHERE filename like '%.el' ;"))
+ (num (pq-ntuples res)))
+ (message "Finding installed libraries... Please wait.")
+ (loop for row from 0 to (1- num)
+ do (pq-exec
+ db
+ (format "UPDATE ell SET installed_p = '%s' WHERE filename = '%s';"
+ (if (locate-library (pq-get-value res row 0))
+ "t"
+ "f")
+ (pq-get-value res row 0))))
+ (pq-finish db)
+ (message "Finding installed libraries... Done!"))))
+
+(defun sxell-mark-downloadable ()
+ "Mark ELL db entries that have a URL to a .el that can be directly downloaded.
+
+For example: http://www.foo.com/foo.el"
+ (interactive)
+ (let ((db (pq-connectdb "dbname=ell")))
+ (pq-exec db "UPDATE ell SET direct_link_p = 't' WHERE (
+site LIKE '%.el' OR
+site LIKE '%.gz' OR
+site LIKE '%.bz2' OR
+site LIKE '%.tgz' ) ;")
+ (pq-exec db "UPDATE ell SET direct_link_p = 'f' WHERE (
+site NOT LIKE '%.el' AND
+site NOT LIKE '%.gz' AND
+site NOT LIKE '%.bz2' AND
+site NOT LIKE '%.tgz' ) ;")
+ (pq-finish db)
+ (message "Noted the directly downloadable files.")))
+
+(defun sxell-sort-by-contact (&optional reverse remote)
+ "Display ELL, sorted by contact.
+
+The default is to display in alphabetical ascending order, using the
+local data. This behaviour can be changed by the use of prefix args:
+
+ 0 prefix arg -- Sort ascending with local data \(default\)
+ 1 prefix args -- Sort descending with local data
+ 2 prefix args -- Sort ascending check remote updates
+ 3 prefix args -- Sort descending check remote updates
+
+To do the same thing non-interactively, use:
+
+Optional arg, REVERSE, display in reverse order.
+Optional arg, REMOTE, check remote ELL for updates."
+ (interactive "P")
+ (let* ((arg current-prefix-arg)
+ ;; Reset `current-prefix-arg' to nil because `sxell-packages'
+ ;; can use a prefix arg too.
+ (current-prefix-arg nil)
+ (sql "SELECT * FROM ell ORDER by contact "))
+ (if (not (interactive-p))
+ ;; When called non-interactively
+ (progn
+ (setq sql (concat sql
+ (when reverse "desc ")
+ ";"))
+ (if remote
+ (sxell-packages 'remote sql)
+ (sxell-packages nil sql)))
+ ;; When called interactively
+ (cond
+ ((eq (car arg) 4)
+ (setq sql (concat sql "desc ;"))
+ (sxell-packages nil sql))
+ ((eq (car arg) 16)
+ (setq sql (concat sql ";"))
+ (sxell-packages 'remote sql))
+ ((eq (car arg) 64)
+ (setq sql (concat sql "desc ;"))
+ (sxell-packages 'remote sql))
+ (t
+ (setq sql (concat sql ";"))
+ (sxell-packages nil sql))))))
+
+(defun sxell-sort-by-date (&optional oldfirst remote)
+ "Display ELL, sorted by date.
+
+The default is to display newest to oldest, using the local data.
+This behaviour can be changed through the use of prefix args:
+
+ 0 prefix arg -- newest to oldest with local data \(default\)
+ 1 prefix args -- oldest to newest with local data
+ 2 prefix args -- newest to oldest, check for remote updates
+ 3 prefix args -- oldest to newest, check for remote updates
+
+To do the same thing non-interactively, use:
+
+Optional arg, OLDFIRST, display oldest to newest.
+Optional arg, REMOTE, check for remote updates."
+ (interactive "P")
+ (let* ((arg current-prefix-arg)
+ ;; Reset `current-prefix-arg' to nil because `sxell-packages'
+ ;; can use a prefix arg too.
+ (current-prefix-arg nil)
+ (sql "SELECT * FROM ell order by time_stamp "))
+ (if (not (interactive-p))
+ ;; When called non-interactively
+ (progn
+ (setq sql (concat sql
+ (unless oldfirst "desc ")
+ ";"))
+ (if remote
+ (sxell-packages 'remote sql)
+ (sxell-packages nil sql)))
+ ;; When called interactively
+ (cond
+ ((eq (car arg) 4)
+ (setq sql (concat sql ";"))
+ (sxell-packages nil sql))
+ ((eq (car arg) 16)
+ (setq sql (concat sql "desc ;"))
+ (sxell-packages 'remote sql))
+ ((eq (car arg) 64)
+ (setq sql (concat sql ";"))
+ (sxell-packages 'remote sql))
+ (t
+ (setq sql (concat sql "desc ;"))
+ (sxell-packages nil sql))))))
+
+(defun sxell-search ()
+ "Search records in ELL."
+ (interactive)
+ ;; write me... I'm thinking map-y-or-n-p shit
+ )
+
+(defun sxell-packages (&optional remote sql)
+ "Display the Emacs Lisp List in a Emacs buffer.
+
+The data for the list comes from the local PostgreSQL database. The
+first time this is run, the PostgreSQL database is initialised and the
+Ell is imported into it.
+
+With non-nil prefix arg, REMOTE, check for updates to the Ell.
+
+Optional argument, SQL is the SQL SELECT statement to use. If it is
+omitted, `SELECT * FROM ell ORDER by filename ;' is used."
+ (interactive "P")
+ (unless sxell-initialised-flag
+ (sxell-init))
+ (when (or current-prefix-arg remote)
+ (sxell-check-remote-update))
+ (let ((packages (sxell-get-pg-packages-list sql)))
+ (sxell-prepare-buffer)
+ (insert "Files with an asterisk `*' "
+ "are already installed on your system.")
+ (center-line)
+ (insert "\n\n")
+ (mapcar (lambda (x)
+ ;; NAME - DESCRIPTION
+ ;; URL
+ ;; Contact
+ ;; Added: TIMESTAMP Note: NOTE
+ (let* ((name (car x))
+ (description (cadr x))
+ (url (caddr x))
+ (author (cadddr x))
+ (timestamp (car (cddddr x)))
+ (note (cadr (cddddr x)))
+ (installed (caddr (cddddr x))))
+ ;(downloadable (cadddr (cddddr x))))
+ (insert (format "%s - %s\n%s\nContact: %s\nAdded: %s"
+ (if (string= installed "t")
+ (concat "*" name)
+ name)
+ description url author timestamp))
+ (if (not (string= note ""))
+ (insert (format "\nNote: %s\n\n" note))
+ (insert "\n\n"))))
+ packages)
+ (sxell-update-buffer sxell-last-updated)
+ (sxell-mode)
+ (sxell-make-url-extents)
+ (sxell-fix-quoting)))
+
+
+(provide 'sxell)
+
+;;; sxell.el ends here
projects / slh / commitdiff