--- /dev/null
+;;; c-comment-edit2.el --- C Comment Edit
+
+;; This file is not part of Emacs
+
+;; Copyright (C) 1987 Kyle Jones
+;; Author: Kyle Jones
+;; Maintainer: Jari Aalto
+;; Keywords: extensions
+
+;;{{{ id
+
+;; COPYRIGHT NOTICE
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Docs
+
+;; .................................................. &t-documentation ...
+
+;;; Commentary:
+
+;;
+;; Date: 12 Jan 89 17:36:19 GMT
+;;
+;; Attached is an enhanced version of the `c-comment-edit' package, last
+;; posted sometime in 1987.
+;;
+;; c-comment-edit is a command that copies a C comment into a
+;; temporary buffer for editing under a more suitable major mode
+;; (usually text-mode). Once the comment is edited,
+;; c-comment-edit-end (normally bound to C-c ESC) replaces the old
+;; comment with the edited version, adding comment delimiters and
+;; leaders as necessary. c-comment-edit is ideal for large comments
+;; of these styles:
+;;
+;; /* /* /*
+;; ... * ... ** ...
+;; ... * ... ** ...
+;; */ */ */
+;;
+;; Features added:
+;;
+;; o c-comment-edit no longer uses a recursive-edit so multiple
+;; c-comment-edit's be running simultaneously.
+;; o c-comment-edit will now search forward from point for a comment if
+;; point is not within a comment.
+;; o c-comment-edit-hook is provided.
+;; o Bill Carpenter's c-comment-leader-regexp fixed was incorporated.
+;;
+;; Kyle Jones
+
+;;}}}
+;;{{{ history
+
+;; ......................................................... &t-history ...
+;;; Change Log:
+;;
+;; Mar 03 2001 [jari] 20.7 v1.18 Released
+;; - Added ###autoload items.
+;;
+;; Mar 23 1998 [jari] 19.34 v1.12 Released
+;; - Byte compile errors fixed.
+;;
+;; Aug 11 1997 [jari] 19.28 v1.11 Released
+;; - The example setup at the end worked fine, execept if used inside
+;; the function. The last line was not adjusted to
+;;
+;; ***********/ but to *********
+;; */
+;;
+;; That is; the last */ was not shifted to the end of line.
+;; - corrected the example.
+;;
+;; Feb 24 1997 [jari] 19.28 v1.10 Released
+;; - Rick Flower <flower@ms31.sp.trw.com> reported that c-indent-command
+;; wasn't seen by 19.15 byte compiler. Now requires cc-mode.
+;;
+;; Feb 26 1997 [jari] 19.28 v1.9 Released
+;; - Small error in window configuration restore corrected.
+;;
+;; Dec 11 1996 [jari] 19.28 v1.6-1.8 Released
+;; - Some minor byte compilation corrections. Window configuration
+;; bug corrected. c-comment-edit-at-point corrected in C++ mode.
+;;
+;; May 27 1996 [jari] 19.28 v1.5 Released
+;; - Added saving/restoring the frame configuration. Previously the
+;; window layout was destroyed when the c-comment-edit-end was
+;; finished. Now windows are restored as they were.
+;; - Made this package 18.xx compatible again.
+;;
+;; Apr 30 1996 [jari] 19.28 v1.4 Released
+;; - Jerome Santini <santini@chambord.univ-orleans.fr> reported problems
+;; in 19.30 with the font-lock code. Now the eval-when-compile
+;; forms take in effect only if font-lock is not present. This was
+;; serious bug.
+;; - Renamed all the rest functions to have prefix "c-comment". This
+;; follows the GNU package guidelines.
+;; - Added defontifying a comment in separate buffer to get clear look.
+;;
+;; Oct 14 1995 [jari] 19.28 v1.3 Released
+;; - Corrected the LCD entry, that was mistakenly modified.
+;;
+;; Sep 8 1995 [jari] 19.28 v1.2 NotReleased
+;; - Cleaned up the Newsereader headers and presedved only 'date:'
+;; of original introduction
+;; within-c-comment-p :! renamed to comment-area, more general
+;; - Added new function c-comment-edit-at-point. If point is inside of a
+;; comment, the comment is edited. Otherwise, a new comment is created
+;; at point. [jcolman]
+;; - Cleared byte-compiler errors. Added optional parameters to main function
+;; c-comment-edit. Main also now returns more gracefully, if comment
+;; syntax isn't defined. This really should be made more general..
+;;
+;; Sep 4 1995 [jari] 19.28 v1.1 NotReleased
+;; - Jake Colman <jcolman@j51.com> sent mail asking to crrect some
+;; things. Great that I get user feedback!
+;; - kill-all-local-variables call removed
+;; - renamed c-comment-edit-after-hook --> c-comment-edit-exit-hook
+;; and moved it to the end of defun.
+;; - The fill-column setting has been adjusted to include "/*" (-2 from the
+;; original setting).
+;; - When edited comment is inserted back, the colors are gone. This has been
+;; corrected to re-fontify the comment if font-lock-mode is on.
+;; - Added c-comment-edit-load-hook
+;;
+;; Apr 28 1995 [jari] 19.28 v0.2 NotReleased
+;; - After talking with Kyle directly, he said that I should load
+;; this .el with some other name, because he didn't plan to have
+;; any enhancement support. He said that I had been among the very
+;; few that had ever asked any changes to this module.
+;; - On my behalf, since this is almost identical copy of the
+;; original, I have no objections that someone else modifies this
+;; .el with the "c-comment-edit2.el" -- I do plan to update this if it has
+;; errors that are caused by me of course, but right now I don't
+;; think it misses anything crucial. Just drop me a note, I love to hear
+;; about new improvements.
+;;
+;; Feb 22 1995 [jari] 19.28 v0.1 NotReleased
+;; - I had used this intensively when 18.57 was still around in our
+;; envinronment (about 4 moths ago), but when I moved to 19.28
+;; I found some incompatibilities in keybindings and I dislike the
+;; comment syntax which left first line empty. Now there is variable
+;; to configure 1st line layout.
+;; - Now ESC ESC terminates in 19 and ESC in 18.
+;; - Added few confortable variables
+;; * c-comment-edit-bname , c-comment-edit-empty-1-line
+;; * c-comment-edit-other-buffer , c-comment-edit-C-buf
+;; * c-comment-edit-[bc,ec]
+;; - Added hooks
+;; * c-comment-edit-end-hook
+;; * c-comment-edit-after-hook
+;;
+;; - touched original code:
+;; * c-comment-edit
+;; - there was one problem with this, the hook was too early
+;; run compared to kill-local-var, so if you turned on some minor
+;; mode, it was effectively lost. --> now the hook runs last.
+;; * c-comment-edit-end
+;; - Added the new functionality here, many changes, sets global
+;; variables + runs hooks
+;;
+;; - There is an EXAMPLE section at the end of this file which is one of
+;; my favourite C/C++ function header. And cleanup function to
+;; retain the format after comment has been added too.
+
+;;}}}
+
+;;{{{ setup: bind, hooks
+
+;;; Code:
+
+(require 'cc-mode)
+(load "c-mode" 'noerr) ;Hm, XEmacs 19.13 lacks this?
+(eval-when-compile (require 'cl))
+
+;;; .......................................................... &v-bind ...
+
+(defvar c-com-mode-map nil "C comment edit map")
+
+(if c-com-mode-map
+ nil
+ (setq c-com-mode-map (make-sparse-keymap))
+ ;; keys;
+ (if (string< emacs-version "19")
+ (progn
+ (define-key c-com-mode-map "\C-c\C-c" 'c-comment-edit-end)
+ (define-key c-com-mode-map "\e" 'c-comment-edit-abort))
+ (define-key c-com-mode-map "\C-c\C-c" 'c-comment-edit-end)
+ (define-key c-com-mode-map "\e\e" 'c-comment-edit-abort)))
+
+;;; ......................................................... &v-hooks ...
+
+(defvar c-comment-edit-hook nil
+ "*Function to call whenever `c-comment-edit' is used.
+The function is called just before the `c-comment-edit' function allows you to
+begin editing the comment.")
+
+(defvar c-comment-edit-exit-hook nil
+ "*Enables you to do some cleanup after edit is done, not called
+if user aborted the action. Buffer is already inserted back when this
+hook is called.")
+
+(defvar c-comment-edit-end-hook nil
+ "*When user has pressed C-c or ESC to complete editing, the
+Comment prefix lines are drawn. After it has completed drawing,
+and the buffer is in ready to be inserted back, this hook will be called. ")
+
+(defvar c-comment-edit-load-hook nil
+ "*Run when file has been loaded.")
+
+;;}}}
+;;{{{ setup: read-only vars
+
+;;; ....................................................... &v-private ...
+;;; These are set by funcs, user can check the values in hooks.
+
+(defconst c-comment-edit-beg-c nil
+ "After the comment is edited, this variable contains
+begin MARK of comment.")
+
+(defconst c-comment-edit-end-c nil
+ "After the comment is edited, this variable contains
+end MARK of comment.")
+
+(defconst c-comment-edit-bufc nil
+ "After the comment is edited, this variable contains C-code buffer name,
+where comment edited belonged.")
+
+;;}}}
+;;{{{ setup: -- user config
+
+;;; .......................................................... &v-conf ...
+
+(defvar c-comment-window-register ?w
+ "*Which register to use to save window configuration.")
+
+;;;###autoload
+(defvar c-comment-leader " *"
+ "*Leader used when rebuilding edited C comments. The value of this variable
+should be a two-character string. Values of \" \", \" *\" and \"**\"
+produce the comment styles:
+ /* /* /*
+ ... * ... ** ...
+ ... * ... ** ...
+ */ */ */
+respectively.")
+
+(defconst c-comment-leader-regexp "^[ ]*\\(\\*\\*\\|\\*\\)?[ ]?"
+ "Regexp used to match C comment leaders.")
+
+(defvar c-comment-edit-mode 'text-mode
+ "*Major mode used by `c-comment-edit' when editing C comments.")
+
+(defvar c-comment-edit-buffer-alist nil
+ "Assoc list of C buffers and their associated comment buffers.
+Elements are of the form (C-BUFFER COMMENT-BUFFER COMMENT-START COMMENT-END)
+COMMENT-START and COMMENT-END are markers in the C-BUFFER.")
+
+(defvar c-comment-edit-bname " *C Comment Edit*"
+ "*buffer name to edit the comment")
+
+(defvar c-comment-edit-empty-1-line nil
+ "*This determines if the first comment line will be left empty
+
+/*
+ * comment begin, when value is t
+ */
+")
+
+(defvar c-comment-edit-other-buffer t
+ "*Set to nil if you want to edit in full buffer")
+
+;;}}}
+;;{{{ code: macros
+
+;;; ########################################################## &Macros ###
+
+(defmacro c-comment-save-point (&rest body)
+ "Save value of point, evalutes FORMS and restore value of point.
+If the saved value of point is no longer valid go to (point-max).
+The variable `save-point' is lambda-bound to the value of point for
+the duration of this call."
+ (list 'let '((save-point (point)))
+ (list 'unwind-protect
+ (cons 'progn body)
+ '(goto-char (min (point-max) save-point)))))
+
+(defmacro c-comment-marker (pos &optional buffer)
+ (list 'set-marker '(make-marker) pos buffer))
+
+;;}}}
+
+;;; ########################################################### &Funcs ###
+
+;;{{{ code: general
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun c-comment-save-state ()
+ "Save window configuration."
+ (if (fboundp 'point-to-register-compatibility-binding)
+ (funcall
+ (symbol-function 'point-to-register-compatibility-binding)
+ c-comment-window-register
+ 'window-config)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun c-comment-restore-state ()
+ "Save window configuration."
+ (if (and c-comment-window-register
+ (get-register c-comment-window-register)
+ (fboundp 'jump-to-register-compatibility-binding))
+ (funcall
+ (symbol-function 'jump-to-register-compatibility-binding)
+ c-comment-window-register)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun c-comment-area (beg end)
+ "Searches area bounds delimited by strings BEG and END.
+First searches backward, them forward.
+
+Returns:
+ (beg-point . end-point)
+ nil."
+ (condition-case nil
+ (let (p pp)
+ (c-comment-save-point
+ (search-backward beg)
+ (setq p (point))
+ (search-forward end)
+ (setq pp (point)))
+ (if (< (point) pp) (cons p pp) nil))
+ (search-failed
+ nil)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun c-comment-find-buffer (&optional buffer)
+ (or buffer (setq buffer (current-buffer)))
+ (let ((list c-comment-edit-buffer-alist))
+ (catch 'return-value
+ (while list
+ (if (eq (nth 1 (car list)) buffer)
+ (throw 'return-value (car list))
+ (setq list (cdr list)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun c-comment-find-c-buffer (&optional buffer)
+ (or buffer (setq buffer (current-buffer)))
+ (let ((list c-comment-edit-buffer-alist))
+ (catch 'return-value
+ (while list
+ (if (eq (car (car list)) buffer)
+ (throw 'return-value (car list))
+ (setq list (cdr list)))))))
+
+;;}}}
+
+;;{{{ code: edit
+
+;;; ----------------------------------------------------------------------
+;;; 1995-09-07 Jake Colman <jcolman@j51.com> supplied basic code
+;;;
+;;;###autoload
+(defun c-comment-edit-at-point ()
+ "Edit C comment at point.
+If point is inside of a comment, the comment is edited. Otherwise, a new
+comment is created at point.
+"
+ (interactive)
+ (let* ((cs comment-start)
+ (ce comment-end)
+ comment)
+ (when (memq major-mode '(c-mode c++-mode cc-mode))
+ ;; override the comment settings, because C++ has
+ ;; "//" and "" by default and that's not what we want
+ (setq cs "/*" ce "*/"))
+
+ (if (c-comment-area cs ce)
+ (c-comment-edit nil)
+ ;; The catch is, that we first create a comment and then
+ ;; pass control to the main.
+ (setq comment (concat cs " " ce))
+ (insert comment)
+ (goto-char (- (point) (length comment))) ;go inside it
+ (c-indent-command)
+ (c-comment-edit nil))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun c-comment-edit-end ()
+ "End c-comment-edit.
+C comment is replaced by its edited counterpart in the appropriate C buffer.
+Indentation will be the same as the original."
+ (interactive)
+ (let ((tuple (c-comment-find-buffer))
+ (line1-empty c-comment-edit-empty-1-line)
+ (i 0)
+ edited
+ char-count)
+
+ (if (null tuple)
+ (error "Not a c-comment-edit buffer."))
+
+ (let ((inhibit-quit t)
+ (c-comment-c-buffer (car tuple))
+ (c-comment-buffer (nth 1 tuple))
+ (c-comment-start (nth 2 tuple))
+ (c-comment-end (nth 3 tuple)))
+
+ (cond
+ ((buffer-modified-p)
+ ;; rebuild the comment
+ (goto-char (point-min))
+
+ (if (null line1-empty)
+ (insert "/*")
+ (insert "/*\n"))
+
+ (if (string= c-comment-leader " ")
+ (while (not (eobp))
+ (setq i (1+ i))
+ (if (eq 1 i)
+ (insert " ")
+ (if (not (eolp)) (insert c-comment-leader " ")))
+ (forward-line))
+ (setq i 0)
+ (while (not (eobp))
+ (setq i (1+ i))
+ (if (and (eq 1 i) (null line1-empty))
+ (insert " ")
+ (insert c-comment-leader (if (eolp) "" " ")))
+ (forward-line)))
+
+ (if (not (char-equal (preceding-char) ?\n))
+ (insert "\n"))
+
+ (insert (if (string= c-comment-leader " *") " */" "*/"))
+
+ ;; indent if necessary
+ (let ((indention
+ (save-excursion
+ (set-buffer c-comment-c-buffer)
+ (goto-char c-comment-start)
+ (current-column))))
+ (goto-char (point-min))
+ (unless (zerop indention)
+ ;; first line is already indented
+ ;; in the C buffer
+ (forward-line)
+ (while (not (eobp))
+ (indent-to indention)
+ (forward-line))))
+
+ (setq edited t) ;Raise the Flag
+ (run-hooks 'c-comment-edit-end-hook)
+
+ ;; replace the old comment with the new
+
+ (save-excursion
+ (setq char-count (- (point-max) (point-min)) )
+ (set-buffer c-comment-c-buffer)
+
+ (delete-region c-comment-start c-comment-end)
+ (goto-char c-comment-start)
+
+ (insert-buffer c-comment-buffer)
+
+ ;; save values for possible hook function
+
+ (setq c-comment-edit-beg-c (marker-position c-comment-start)
+ c-comment-edit-end-c (+ c-comment-edit-beg-c char-count)
+ c-comment-edit-bufc c-comment-c-buffer)
+
+ ;; The colors vanished, when we deleted that region and inserted
+ ;; new comment into buffer, lets get them back
+
+ (if (and (featurep 'font-lock)
+ (symbol-value 'font-lock-mode))
+ (funcall
+ (symbol-function 'font-lock-fontify-region)
+ c-comment-edit-beg-c c-comment-edit-end-c))))
+
+ (t
+ (message "No change.")))
+
+ ;; .................................................. cond
+
+ (c-comment-restore-state)
+
+ ;; switch to the C buffer
+
+ (if (get-buffer-window c-comment-c-buffer)
+ (select-window (get-buffer-window c-comment-c-buffer))
+ (switch-to-buffer c-comment-c-buffer))
+
+ ;; delete the window viewing the comment buffer
+
+ (and (get-buffer-window c-comment-buffer)
+ (delete-window (get-buffer-window c-comment-buffer)))
+
+ ;; unlink the tuple from c-comment-edit-buffer-alist
+
+ (setq c-comment-edit-buffer-alist
+ (delq tuple c-comment-edit-buffer-alist))
+
+ ;; let Emacs reclaim various resources
+
+ (save-excursion
+ (set-buffer c-comment-buffer)
+ (set-buffer-modified-p nil)
+ (kill-buffer c-comment-buffer))
+
+ ;; Now kill the markers so that they don't consume resources
+
+ (set-marker c-comment-start nil)
+ (set-marker c-comment-end nil))
+
+ (if edited ;only if touched the contents
+ (run-hooks 'c-comment-edit-exit-hook))))
+
+;;}}}
+;;{{{ code: abort
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun c-comment-edit-abort ()
+ "Abort a c-comment-edit with no change."
+ (interactive)
+ (let* ((tuple (c-comment-find-buffer))
+ (c-comment-c-buffer (car tuple))
+ (c-comment-buffer (nth 1 tuple))
+ (c-comment-start (nth 2 tuple))
+ (c-comment-end (nth 3 tuple)))
+
+ (if (null tuple)
+ (error "Not a c-comment-edit buffer."))
+
+ ;; switch to the C buffer
+
+ (if (get-buffer-window c-comment-c-buffer)
+ (select-window (get-buffer-window c-comment-c-buffer))
+ (switch-to-buffer c-comment-c-buffer))
+
+ (let ((inhibit-quit t))
+ (save-excursion
+ (set-buffer c-comment-buffer)
+ (set-buffer-modified-p nil)
+ (if c-comment-edit-other-buffer
+ (delete-window))
+ (kill-buffer c-comment-buffer))
+ ;; unlink the tuple from c-comment-edit-buffer-alist
+ (setq c-comment-edit-buffer-alist
+ (delq tuple c-comment-edit-buffer-alist))
+ (set-marker c-comment-start nil)
+ (set-marker c-comment-end nil)
+ (message "Aborted with no change.")
+ (c-comment-restore-state))))
+
+;;}}}
+;;{{{ code: main
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun c-comment-edit (&optional search-prefix com-start com-end)
+ "Edit multi-line C comments.
+This command allows the easy editing of a multi-line C comment like this:
+ /*
+ * ...
+ * ...
+ */
+The comment may be indented or flush with the left margin.
+
+If point is within a comment, that comment is used. Otherwise the
+comment to be edited is found by searching forward from point.
+
+With one \\[universal-argument] searching starts after moving back one
+ paragraph.
+With two \\[universal-argument]'s searching starts at the beginning of the
+ current or proceeding C function.
+With three \\[universal-argument]'s searching starts at the beginning of the
+ current page.
+With four \\[universal-argument]'s searching starts at the beginning of the
+ current buffer (clipping restrictions apply).
+
+Once located, the comment is copied into a temporary buffer, the comment
+leaders and delimiters are stripped away and the resulting buffer is
+selected for editing. The major mode of this buffer is controlled by
+the variable `c-comment-edit-mode'.
+
+Use \\[c-comment-edit-end] when you have finished editing the comment. The
+comment will be inserted into the original buffer with the appropriate
+delimiters and indention, replacing the old version of the comment. If
+you don't want your edited version of the comment to replace the
+original, use \\[c-comment-edit-abort]."
+ (interactive "*P")
+ (catch 'out
+ (let ((inhibit-quit t)
+ (bname c-comment-edit-bname)
+ (other-bedit c-comment-edit-other-buffer)
+ marker
+ cs ce
+ tem
+ c-comment-fill-column
+ c-comment-buffer
+ c-comment-start
+ c-comment-end)
+
+ (cond
+ ((and com-start com-end) ;don't touch they are set.
+ nil)
+
+ ((memq major-mode '(c-mode c++-mode cc-mode))
+ ;; override the comment settings, because C++ has
+ ;; "//" and "" by default and that's not what we want
+ (setq cs "/*" ce "*/"))
+
+ (t
+ (setq cs (or comment-start
+ "cbAnything##"))
+ (setq ce (or comment-end
+ "ceAnything##"))))
+
+ ;; What was the prefix arg ?
+
+ (cond ((equal search-prefix '(4))
+ (backward-paragraph))
+ ((equal search-prefix '(16))
+ (end-of-defun)
+ (beginning-of-defun)
+ (backward-paragraph))
+ ((equal search-prefix '(64))
+ (backward-page))
+ ((equal search-prefix '(256))
+ (goto-char (point-min))))
+
+ (if (and (null search-prefix)
+ (setq tem (c-comment-area cs ce)))
+ (setq c-comment-start (c-comment-marker (car tem))
+ c-comment-end (c-comment-marker (cdr tem)))
+ (let (start end)
+ (condition-case nil
+ (c-comment-save-point
+ (search-forward cs)
+ (setq start (- (point) (length cs)))
+ (search-forward ce)
+ (setq end (point)))
+ (search-failed
+ (message
+ (concat "No C comment found. Check comment-start: "
+ cs "|" ce))
+ (throw 'out t)))
+ (setq c-comment-start (c-comment-marker start))
+ (setq c-comment-end (c-comment-marker end))))
+
+ ;; calculate the correct fill-column for the comment
+
+ (setq c-comment-fill-column
+ (- fill-column
+ (save-excursion
+ (goto-char c-comment-start)
+ (+ (length comment-start) (current-column)))))
+
+ ;; create the comment buffer
+
+ (setq c-comment-buffer
+ (generate-new-buffer (concat (buffer-name) bname)))
+
+ ;; link into the c-comment-edit-buffer-alist
+
+ (setq c-comment-edit-buffer-alist
+ (cons (list (current-buffer) c-comment-buffer
+ c-comment-start c-comment-end)
+ c-comment-edit-buffer-alist))
+
+ ;; copy to the comment to the comment-edit buffer
+
+ (copy-to-buffer c-comment-buffer
+ (+ c-comment-start 2) (- c-comment-end 2))
+
+ ;; mark the position of point, relative to the beginning of the
+ ;; comment, in the comment buffer. (if point is within a comment.)
+
+ (or search-prefix (< (point) c-comment-start)
+ (setq marker (c-comment-marker (+ (- (point) c-comment-start 2) 1)
+ c-comment-buffer)))
+ ;; ...............................................................
+ ;; select the comment buffer for editing
+
+ (c-comment-save-state)
+
+ (if (null other-bedit)
+ (switch-to-buffer c-comment-buffer)
+ (switch-to-buffer-other-window c-comment-buffer))
+
+ ;; remove the comment leaders and delimiters
+
+ (goto-char (point-min))
+
+ (while (not (eobp))
+ (and (re-search-forward c-comment-leader-regexp nil t)
+ (replace-match "" nil t))
+ (forward-line))
+
+ ;; run appropriate major mode
+
+ (funcall (or c-comment-edit-mode 'fundamental-mode))
+
+ ;; override user's default fill-column here since it will lose if
+ ;; the comment is indented in the C buffer.
+
+ (setq fill-column c-comment-fill-column)
+
+ ;; delete one leading whitespace char
+
+ (goto-char (point-min))
+
+ (if (looking-at "[ \n\t]")
+ (delete-char 1))
+
+ ;; restore cursor if possible
+
+ (goto-char (or marker (point-min)))
+
+ ;; defontify to get a clear look at text
+
+ (put-text-property (point-min) (point-max) 'face 'default)
+
+ (set-buffer-modified-p nil))
+ ;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ let end ^^^
+
+ (use-local-map c-com-mode-map)
+ (run-hooks 'c-comment-edit-hook)
+
+ (message
+ (substitute-command-keys
+ (concat "Type \\[c-comment-edit-end] to end edit, "
+ "\\[c-comment-edit-abort] to abort with no change.")))))
+
+ ;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ catch end ^^^
+
+;;}}}
+
+;;{{{ Example
+;;; ......................................................... &example ...
+
+;; - Here is ready setup, which you could use right away.
+;; - I am used to program all my C/C++ function like this, where the
+;; header is just before each function:
+;;
+;; /*************************************************************************
+;; * <PUBLIC> FUNCTION: MyFunc
+;; *************************************************************************
+;; * DESCRIPTION
+;; * - This is function is the main entry point to class myClass.
+;; * it handles reading the oracle database....
+;; *
+;; * SPECIAL
+;; * - Note, that the oracle connection must be verified before your're
+;; * using this function....
+;; *
+;; * RETURNS
+;; * - Creates object errorAtom which hold data about the promlem occurred.
+;; * other
+;; *************************************************************************/
+;; errorAtom_c *myClass_c::Execute(char * ptr)
+;; {
+;;
+;; }
+;;
+;;
+;; - In order to maintain the '*****' breaks correctly you have to use some
+;; cleanup function like one below. It detects if the Comment has
+;; '****' in it and does nothing if it's regular comment.
+;;
+;; - Remember that when the comment has been edited, the comment style you
+;; choosed, affects the function. This supposes you have use the 'one star'
+;; style.
+
+;; Setting proper hooks.
+;; I seldom need M-c (capitalize word) in C/C++
+;; If you use many hooks, use command add-hook instead.
+;;
+;; (setq c++-mode-hook 'c++-my-hook)
+;; (defun c++-my-hook ()
+;; (local-set-key "\M-c" 'c-comment-edit))
+;;
+;; (setq c-mode-hook 'c-my-hook)
+;; (defun c-my-hook ()
+;; (local-set-key "\M-c" 'c-comment-edit))
+
+;; (defun my-com-end ()
+;; "C- comment edit cleanup."
+;; (let* ((sep (make-string 70 ?* )) ;what separator you want to use
+;; (fix-re "[-=*] [-=*][-=*]" ) ;the gap " " is in buffer
+;; (back-step 3) ;depends on the fix-re
+;; (break-re " +[-=*][-=*][-=*]*") ;at least two continuous chars
+;; )
+;;
+;; ;; To preserve indentation. Remember that C-comment markers are
+;; ;; added to the beginning
+;;
+;; (untabify (point-min) (point-max))
+;;
+;;
+;; ;; - We are in comment buffer now, so we can move freely with goto-char
+;; ;; - fix all break-marked lines to certain length
+;;
+;; (goto-char (point-min))
+;; (while (re-search-forward fix-re nil t)
+;; (backward-char back-step) (kill-line) (insert sep))
+;;
+;; ;; - Check if the last line has separator == it is function header
+;; ;; - The last line holds "*/", so look at the previous one.
+;;
+;; (goto-char (point-max)) (forward-line -1)
+;;
+;; (cond
+;; ((looking-at break-re)
+;; ;; Remove that lonely "*/" and shift it one line up
+;; ;;
+;; (goto-char (point-max)) (beginning-of-line)
+;; (kill-line)
+;; (backward-delete-char 1)
+;; (insert "/"))) ;terminate C comment
+;; nil)) ;hook must return this
+
+;;}}}
+
+(provide 'c-comment-edit)
+(run-hooks 'c-comment-edit-load-hook)
+
+;;; c-comment-edit2.el ends here
--- /dev/null
+;;; calist.el --- Condition functions
+
+;; Copyright (C) 1998 MORIOKA Tomohiko.
+
+;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;; Keywords: condition, alist, tree
+
+;; This file is part of APEL (A Portable Emacs Library).
+
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2, or (at
+;; your option) any later version.
+
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+
+(defvar calist-field-match-method-obarray [nil])
+
+(defun define-calist-field-match-method (field-type function)
+ "Set field-match-method for FIELD-TYPE to FUNCTION."
+ (fset (intern (symbol-name field-type) calist-field-match-method-obarray)
+ function))
+
+(defun calist-default-field-match-method (calist field-type field-value)
+ (let ((s-field (assoc field-type calist)))
+ (cond ((null s-field)
+ (cons (cons field-type field-value) calist))
+ ((eq field-value t)
+ calist)
+ ((equal (cdr s-field) field-value)
+ calist))))
+
+(defsubst calist-field-match-method (field-type)
+ (condition-case nil
+ (symbol-function
+ (intern-soft
+ (symbol-name field-type) calist-field-match-method-obarray))
+ (error (symbol-function 'calist-default-field-match-method))))
+
+(defsubst calist-field-match (calist field-type field-value)
+ (funcall (calist-field-match-method field-type)
+ calist field-type field-value))
+
+(defun ctree-match-calist (rule-tree alist)
+ "Return matched condition-alist if ALIST matches RULE-TREE."
+ (if (null rule-tree)
+ alist
+ (let ((type (car rule-tree))
+ (choices (cdr rule-tree))
+ default)
+ (catch 'tag
+ (while choices
+ (let* ((choice (car choices))
+ (choice-value (car choice)))
+ (if (eq choice-value t)
+ (setq default choice)
+ (let ((ret-alist (calist-field-match alist type (car choice))))
+ (if ret-alist
+ (throw 'tag
+ (if (cdr choice)
+ (ctree-match-calist (cdr choice) ret-alist)
+ ret-alist))))))
+ (setq choices (cdr choices)))
+ (if default
+ (let ((ret-alist (calist-field-match alist type t)))
+ (if ret-alist
+ (if (cdr default)
+ (ctree-match-calist (cdr default) ret-alist)
+ ret-alist))))))))
+
+(defun ctree-match-calist-partially (rule-tree alist)
+ "Return matched condition-alist if ALIST matches RULE-TREE."
+ (if (null rule-tree)
+ alist
+ (let ((type (car rule-tree))
+ (choices (cdr rule-tree))
+ default)
+ (catch 'tag
+ (while choices
+ (let* ((choice (car choices))
+ (choice-value (car choice)))
+ (if (eq choice-value t)
+ (setq default choice)
+ (let ((ret-alist (calist-field-match alist type (car choice))))
+ (if ret-alist
+ (throw 'tag
+ (if (cdr choice)
+ (ctree-match-calist-partially
+ (cdr choice) ret-alist)
+ ret-alist))))))
+ (setq choices (cdr choices)))
+ (if default
+ (let ((ret-alist (calist-field-match alist type t)))
+ (if ret-alist
+ (if (cdr default)
+ (ctree-match-calist-partially (cdr default) ret-alist)
+ ret-alist)))
+ (calist-field-match alist type t))))))
+
+(defun ctree-find-calist (rule-tree alist &optional all)
+ "Return list of condition-alist which matches ALIST in RULE-TREE.
+If optional argument ALL is specified, default rules are not ignored
+even if other rules are matched for ALIST."
+ (if (null rule-tree)
+ (list alist)
+ (let ((type (car rule-tree))
+ (choices (cdr rule-tree))
+ default dest)
+ (while choices
+ (let* ((choice (car choices))
+ (choice-value (car choice)))
+ (if (eq choice-value t)
+ (setq default choice)
+ (let ((ret-alist (calist-field-match alist type (car choice))))
+ (if ret-alist
+ (if (cdr choice)
+ (let ((ret (ctree-find-calist
+ (cdr choice) ret-alist all)))
+ (while ret
+ (let ((elt (car ret)))
+ (or (member elt dest)
+ (setq dest (cons elt dest))))
+ (setq ret (cdr ret))))
+ (or (member ret-alist dest)
+ (setq dest (cons ret-alist dest))))))))
+ (setq choices (cdr choices)))
+ (or (and (not all) dest)
+ (if default
+ (let ((ret-alist (calist-field-match alist type t)))
+ (if ret-alist
+ (if (cdr default)
+ (let ((ret (ctree-find-calist
+ (cdr default) ret-alist all)))
+ (while ret
+ (let ((elt (car ret)))
+ (or (member elt dest)
+ (setq dest (cons elt dest))))
+ (setq ret (cdr ret))))
+ (or (member ret-alist dest)
+ (setq dest (cons ret-alist dest)))))))
+ dest)))
+
+(defun calist-to-ctree (calist)
+ "Convert condition-alist CALIST to condition-tree."
+ (if calist
+ (let* ((cell (car calist)))
+ (cons (car cell)
+ (list (cons (cdr cell)
+ (calist-to-ctree (cdr calist))))))))
+
+(defun ctree-add-calist-strictly (ctree calist)
+ "Add condition CALIST to condition-tree CTREE without default clause."
+ (cond ((null calist) ctree)
+ ((null ctree)
+ (calist-to-ctree calist))
+ (t
+ (let* ((type (car ctree))
+ (values (cdr ctree))
+ (ret (assoc type calist)))
+ (if ret
+ (catch 'tag
+ (while values
+ (let ((cell (car values)))
+ (if (equal (car cell)(cdr ret))
+ (throw 'tag
+ (setcdr cell
+ (ctree-add-calist-strictly
+ (cdr cell)
+ (delete ret (copy-alist calist)))))))
+ (setq values (cdr values)))
+ (setcdr ctree (cons (cons (cdr ret)
+ (calist-to-ctree
+ (delete ret (copy-alist calist))))
+ (cdr ctree))))
+ (catch 'tag
+ (while values
+ (let ((cell (car values)))
+ (setcdr cell
+ (ctree-add-calist-strictly (cdr cell) calist)))
+ (setq values (cdr values)))))
+ ctree))))
+
+(defun ctree-add-calist-with-default (ctree calist)
+ "Add condition CALIST to condition-tree CTREE with default clause."
+ (cond ((null calist) ctree)
+ ((null ctree)
+ (let* ((cell (car calist))
+ (type (car cell))
+ (value (cdr cell)))
+ (cons type
+ (list (list t)
+ (cons value (calist-to-ctree (cdr calist)))))))
+ (t
+ (let* ((type (car ctree))
+ (values (cdr ctree))
+ (ret (assoc type calist)))
+ (if ret
+ (catch 'tag
+ (while values
+ (let ((cell (car values)))
+ (if (equal (car cell)(cdr ret))
+ (throw 'tag
+ (setcdr cell
+ (ctree-add-calist-with-default
+ (cdr cell)
+ (delete ret (copy-alist calist)))))))
+ (setq values (cdr values)))
+ (if (assq t (cdr ctree))
+ (setcdr ctree
+ (cons (cons (cdr ret)
+ (calist-to-ctree
+ (delete ret (copy-alist calist))))
+ (cdr ctree)))
+ (setcdr ctree
+ (list* (list t)
+ (cons (cdr ret)
+ (calist-to-ctree
+ (delete ret (copy-alist calist))))
+ (cdr ctree)))))
+ (catch 'tag
+ (while values
+ (let ((cell (car values)))
+ (setcdr cell
+ (ctree-add-calist-with-default (cdr cell) calist)))
+ (setq values (cdr values)))
+ (let ((cell (assq t (cdr ctree))))
+ (if cell
+ (setcdr cell
+ (ctree-add-calist-with-default (cdr cell)
+ calist))
+ (let ((elt (cons t (calist-to-ctree calist))))
+ (or (member elt (cdr ctree))
+ (setcdr ctree (cons elt (cdr ctree))))))
+ ctree))))
+
+(defun ctree-set-calist-strictly (ctree-var calist)
+ "Set condition CALIST in CTREE-VAR without default clause."
+ (set ctree-var
+ (ctree-add-calist-strictly (symbol-value ctree-var) calist)))
+
+(defun ctree-set-calist-with-default (ctree-var calist)
+ "Set condition CALIST to CTREE-VAR with default clause."
+ (set ctree-var
+ (ctree-add-calist-with-default (symbol-value ctree-var) calist)))
+
+))));;; @ end
+;;;
+
+(provide 'calist)
+
+;;; calist.el ends here
--- /dev/null
+;;; complete-menu.el --- show completions in X-popup menu
+
+;;{{{ Id
+
+;; This file is not part of Emacs
+
+;; Copyright (C) 1993 Alon Albert
+;; Author: Alon Albert <alon@milcse.rtsg.mot.com>
+;; Maintainer: Jari Aalto
+;; Created: 1993-12-07
+
+;; COPYRIGHT NOTICE
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+;;; install:
+
+;; Put this file in your load-path and insert the following in .emacs
+;;
+;; (require 'cl)
+;; (when window-system
+;; (require 'complete-menu))
+;;
+;; Or use autoload, your emacs starts up faster (then maybe not, because
+;; there is so much code)
+;;
+;; (when window-system
+;; (setq cm-load-hook 'cm-install-default) ;; Need advices too
+;; (autoload 'cm-minibuffer-completion-help "complete-menu")
+;; (define-key minibuffer-local-completion-map [C-tab]
+;; 'cm-minibuffer-completion-help)
+;; (define-key minibuffer-local-must-match-map [C-tab]
+;; 'cm-minibuffer-completion-help)
+;; (substitute-key-definition 'minibuffer-completion-help
+;; 'cm-minibuffer-completion-help
+;; minibuffer-local-completion-map)
+;; (substitute-key-definition 'minibuffer-completion-help
+;; 'cm-minibuffer-completion-help
+;; minibuffer-local-must-match-map)
+;; (substitute-key-definition 'PC-completion-help
+;; 'cm-minibuffer-completion-help
+;; minibuffer-local-completion-map)
+;; (substitute-key-definition 'PC-completion-help
+;; 'cm-minibuffer-completion-help
+;; minibuffer-local-must-match-map))
+;;
+;;
+;; The X-popup appears if "?" is pressed in minibuffer.
+
+;;}}}
+;;{{{ Documentation
+;;; Commentary:
+
+;; Press "?" while in minibuffer to get the X-popup
+;; Also supports unix like wildcards so:
+;;
+;; find file: comp*.el* <?>
+;;
+;; This utility may be useful for `describe-function' and `describe-variable'.
+;; typing C-h v *word* pops a menu with all variables with the word "word"
+;; in them. (something like apropos)
+
+;;}}}
+;;{{{ History
+
+;;; History:
+
+;; v1.10 2001-03-05 [jari] Released
+;; - Added Autoload statements.
+;;
+;; v1.8-1.9 May 24 1997 [jari] Released
+;; - Added byte compilation stop for XEmacs, thank to note from
+;; Rick Flower <flower@ms31.sp.trw.com>
+;; - Added defcustom support. Checkdoc 1.29 clear.
+;;
+;; v1.7 Dec 5 1996 [jari] Released
+;; - I was reordering my emacs startup files to make
+;; maximum use of autoloads and delete all unnecessary
+;; require commands, then I noticed that this file didn't have
+;; autoload choice.
+;; - updated the installation instructions, so that you this
+;; package is loaded only in demand.
+;;
+;; v1.6 Jun 3 1996 [jari] Released
+;; - Noticed bug. I I pressed "*" and tried to find all temporary
+;; buffers, it showed me all. Too bad...
+;; - Now I can hit "*m" to show me all "*mail* foo" "*mail* quux"
+;; and other pending mail buffers.
+;; - Advertise: If you want to have user name attached to mail
+;; buffer, like above, get my lisp libs and do this:
+;;
+;; (require 'tinylibmail)
+;; (add-hook 'mail-setup-hook 'ti::mail-rename-buffer)
+;;
+;; v1.5 Jun 3 1996 [jari] Released
+;; - Error in installation, now there is cm-install-2
+;;
+;; v1.4 Jun 3 1996 [jari] NotReleased
+;; - Small corrections
+;;
+;; v1.3 Sep 21 1995 [jari] NotReleased
+;; - Bryan M Kramer <kramer@cs.toronto.edu> popped up in g.e.help
+;; asking why this package didn't work in XEmacs any more.
+;; It turned out that this package wasn't archived anywhere, nor
+;; in the OHIO nor did any archie could find it. So I received
+;; copy of this code and packaged whole file in suitable form.
+;; - added separate installation, added final load hook, replaced
+;; right copyright info. added advice, lots of small stuff..
+;; - Corrected bug in cm-minibuffer-completion-help: if user didn't
+;; choose anything, it cleared the minibuffer entry. Now the original
+;; entry is preserved.
+;;
+;; v1.2 Aug 22 1993 [Alon]
+;; - a few minor fixes
+;; - a new chooser from *completions* buffer that allows completion to
+;; be yanked into any buffer (not just the minibuffer)
+;;
+;; v1.1 July 18 1993 [Alon]
+;; - Cleaner faster version.
+;; - Special thanks to Kevin Rodgers <kevin@traffic.den.mmc.com>
+;; for an intriguing discussion about list manipulation in emacs lisp
+;;
+;; v1.0 July 7 1993: [Alon]
+;; - First release.
+
+;;}}}
+
+;;; Code:
+
+;;; ......................................................... &require ...
+
+(require 'advice)
+
+(eval-and-compile
+ (when (boundp 'xemacs-logo)
+ (message "\n\
+ ** complete-menu.el: This package works only in Emacs, because the popup\n\
+ function is not compatible between Emacs versions.\n\
+ Ignore `Aborted' error command if you're\n\
+ byte compiling this file in XEmacs.")
+ (error "Aborted.")))
+
+(defgroup complete-menu nil
+ "Provides X-popup list where you can select completions items. See ? key."
+ :prefix "complete-menu-"
+ :group 'extensions)
+
+;;{{{ setup: variables
+
+;;; ....................................................... &variables ...
+
+;;; or if you dont't want to substitute the originals, use
+;;; 'cm-install-2
+;;;
+;;;###autoload
+(defcustom cm-load-hook '(cm-install-default)
+ "*Hook run when file has been loaded."
+ :type 'hook
+ :group 'complete-menu)
+
+;; handy if you want to call from non-mouse, eg. pressing key.
+;;
+(defcustom cm-x-coord 170
+ "*Default X menu coordinate."
+ :type 'integer
+ :group 'complete-menu)
+
+(defcustom cm-y-coord 170
+ "*Default Y menu coordinate."
+ :type 'integer
+ :group 'complete-menu)
+
+(defcustom cm-max-entries-in-menu 45
+ "*Maximum lines to display in a single menu pane"
+ :type 'integer
+ :group 'complete-menu)
+
+(defcustom cm-store-cut-buffer t
+ "If not nill then store selection in mouse cut buffer"
+ :type 'boolean
+ :group 'complete-menu)
+
+(defcustom cm-execute-on-completion t
+ "If not nil then exucute command after completion"
+ :type 'boolean
+ :group 'complete-menu)
+
+(defvar cm-wildcard-to-regexp
+ '((?* . ".*")
+ (?. . "\\.")
+ (?? . "."))
+ "Translation table from wildcard format to regexp format")
+
+;;}}}
+;;{{{ code: funcs
+
+;;; ....................................................... &Functions ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun cm-make-regexp (wildcard)
+ "Make a regexp out of unix like WILDCARD."
+ (let* ((char-list (append wildcard)))
+ (mapconcat (function
+ (lambda (elt)
+ (let ((regexp (cdr (assoc elt cm-wildcard-to-regexp))))
+ (if regexp
+ regexp
+ (char-to-string elt)))))
+ char-list "")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun cm-old-zap-to-char (arg char)
+ "Kill up to (but not including) ARG'th occurrence of CHAR.
+Goes backward if ARG is negative; goes to end of buffer if CHAR not found."
+;;; (interactive "*p\ncZap to char: ")
+ (kill-region (point) (if (search-forward (char-to-string char) nil t arg)
+ (progn (goto-char
+ (if (> arg 0) (1- (point)) (1+ (point))))
+ (point))
+ (if (> arg 0) (point-max) (point-min)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun cm-minibuffer-completion-help ()
+ "List completions in a menu and copy selction into minibuffer"
+ (interactive)
+ (message "Making completion list...")
+ (let* ((complete (buffer-string))
+ (mouse-pos (mouse-position))
+ (mouse-pos (if (nth 1 mouse-pos)
+ mouse-pos
+ (set-mouse-position (car mouse-pos)
+ (/ (frame-width) 2) 2)
+ (unfocus-frame)
+ (mouse-position)))
+ (pos (list (list (car (cdr mouse-pos))
+ (1+ (cdr (cdr mouse-pos))))
+ (car mouse-pos)))
+ (match nil)
+ (panes nil)
+ (pane nil)
+ (i 0)
+
+ completion-list
+ name
+ menu
+ elt)
+
+ (if (string-match "?" complete)
+ (setq match (format "^%s$" (cm-make-regexp
+ (file-name-nondirectory complete)))
+ complete (substring complete 0 (match-beginning 0))))
+
+ (setq completion-list
+ (sort (all-completions
+ complete
+ minibuffer-completion-table
+ minibuffer-completion-predicate)
+ 'string<))
+
+ (message "Making completion list... Done")
+ (message "Creating menu...")
+
+ (while (setq elt (car completion-list))
+ (if (or (null match)
+ (string-match match elt))
+ (setq pane (cons elt pane)
+ i (1+ i)))
+ (setq completion-list (cdr completion-list))
+ (if (= i cm-max-entries-in-menu)
+ (setq panes (cons pane (nreverse panes))
+ pane nil
+ i 0)))
+
+ (if pane (setq panes (cons pane (nreverse panes))))
+
+ (setq menu (cons "Completions"
+ (mapcar (function
+ (lambda (elt)
+ (cons (car elt)
+ (mapcar (function
+ (lambda (elt)
+ (cons elt elt)))
+ elt))))
+ panes)))
+
+ (message "Creating menu... Done")
+ (if (not (car (cdr menu)))
+ (beep)
+ (setq name (x-popup-menu pos menu))
+ (cm-old-zap-to-char -1 ?/)
+ (if (null name)
+ ;; User didn't select anything
+ (insert complete) ;put previous back.
+ (insert name)
+ (if cm-store-cut-buffer
+ (kill-new name))
+ (if cm-execute-on-completion
+ (exit-minibuffer))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun cm-delete-max-match (string)
+ "Return maximum match for STRING."
+ (let* ((len (min (length string) (1- (point))))
+ (string (substring string 0 len)))
+ (goto-char (- (point) len))
+ (while (and (> len 0) (null (looking-at string)))
+ (setq string (substring string 0 -1)
+ len (1- len))
+ (forward-char 1))
+ (delete-char len)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun cm-choose-completion (event)
+ "Display completion menu. EVENT is x popup event."
+ (interactive "e")
+ (let ((buffer (window-buffer))
+ choice)
+ (save-excursion
+ (set-buffer (window-buffer (posn-window (event-start event))))
+ (save-excursion
+ (goto-char (posn-point (event-start event)))
+ (skip-chars-backward "^ \t\n")
+ (let ((beg (point)))
+ (skip-chars-forward "^ \t\n")
+ (setq choice (buffer-substring beg (point))))))
+ (set-buffer buffer)
+ (cm-delete-max-match choice)
+ (insert choice)
+ (and (equal buffer (window-buffer (minibuffer-window)))
+ cm-execute-on-completion (exit-minibuffer))))
+
+;;; ----------------------------------------------------------------------
+;;; Not activated until user wants it, this overrides ? keys
+;;;
+(defadvice minibuffer-completion-help (around cm-x-complete dis)
+ "Replaces function and calls cm-minibuffer-completion-help.
+Displays completions in X-menu instead of separate buffer."
+ (cm-minibuffer-completion-help))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defadvice PC-completion-help (around cm-x-complete dis)
+ "Replaces function and calls cm-minibuffer-completion-help.
+Displays completions in X-menu instead of separate buffer."
+ (cm-minibuffer-completion-help))
+
+;;; ----------------------------------------------------------------------
+;;; You may also want to bind it to "more closer key", [left hand
+;;; pops the X, and right controls the mouse]:
+;;;
+(defun cm-install-2 ()
+ "Install the X-menuing feature to separate C-tab key."
+ (define-key minibuffer-local-completion-map [C-tab]
+ 'cm-minibuffer-completion-help)
+ (define-key minibuffer-local-must-match-map [C-tab]
+ 'cm-minibuffer-completion-help))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun cm-install-default (&optional arg verb)
+ "Install the X-menuing feature. With ARG, remove X-menuing. VERB.
+Note: installation is only possible in X envinronment."
+ (interactive "P")
+ (let* ((map1 'minibuffer-local-completion-map)
+ (map2 'minibuffer-local-must-match-map)
+ (ofun1 'minibuffer-completion-help)
+ (ofun2 'PC-completion-help)
+ (nfun 'cm-minibuffer-completion-help))
+
+ (or verb
+ (setq verb (interactive-p)))
+
+ (if (null window-system)
+ (if verb
+ (message "No window system detected. Cannot do nothing."))
+ (cond
+ (arg
+ (substitute-key-definition nfun ofun1 (eval map1))
+ (substitute-key-definition nfun ofun1 (eval map2))
+
+ (substitute-key-definition nfun ofun2 (eval map1))
+ (substitute-key-definition nfun ofun2 (eval map2))
+
+ (ad-disable-advice ofun1 'around 'cm-x-complete)
+ (ad-disable-advice ofun2 'around 'cm-x-complete)
+ (if verb
+ (message "X-menu completion off")))
+ (t
+ (substitute-key-definition ofun1 nfun (eval map1))
+ (substitute-key-definition ofun1 nfun (eval map2))
+
+ (substitute-key-definition ofun2 nfun (eval map1))
+ (substitute-key-definition ofun2 nfun (eval map2))
+
+ (ad-enable-advice ofun1 'around 'cm-x-complete)
+ (ad-enable-advice ofun2 'around 'cm-x-complete)
+ (if verb
+ (message "X-menu completion on"))))
+ (ad-activate ofun1)
+ (ad-activate ofun2))))
+
+;;}}}
+
+(provide 'complete-menu)
+(run-hooks 'cm-load-hook)
+
+;;; complete-menu.el ends here
--- /dev/null
+;;; date-parse.el --- Parse and sort dates
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 1989 John Rose
+;; Author: John Rose <rose@think.com>
+;; Maintainer: none
+;; Packaged-by: Jari Aalto
+;; Created: 1989-03
+;; Keywords: extensions
+
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;;; Install:
+
+;; Put this file on your Emacs-Lisp load path, add following into your
+;; ~/.emacs startup file.
+;;
+;; (require 'date-parse)
+
+;;}}}
+;;{{{ Commentary
+
+;;; Commentary:
+
+;; Preface, 1989
+;;
+;; Hacks for reading dates. Something better needs to be done,
+;; obviously. In the file "dired-resort" are dired commands for
+;; reordering the buffer by modification time, which is the whole
+;; purpose of this exercise.
+;;
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+(require 'cl-compat) ;; 19.30 'setnth'
+
+(eval-and-compile
+ (autoload 'sort-subr "sort"))
+
+;;; ....................................................... &variables ...
+
+(defvar parse-date-indices nil
+ "List of (START END) from last successful call to parse-date.")
+
+(defconst date-patterns
+ '(( ;; Sep 29 12:09:55 1986
+ "[ \t]*\\([A-Za-z]+\\)[. \t]+\\([0-9]+\\)[, \t]+\
+\\([0-9]+\\):\\([0-9]+\\):\\([0-9]+\\)[, \t]+\
+\\([0-9]+\\)[ \t]*"
+ 6 1 2 nil 3 4 5)
+ ( ;; Sep 29 12:09
+ "[ \t]*\\([A-Za-z]+\\)[. \t]+\\([0-9]+\\)[, \t]+\
+\\([0-9]+\\):\\([0-9]+\\)[ \t]*"
+ nil 1 2 nil 3 4)
+ ( ;; Sep 29 1986
+ "[ \t]*\\([A-Za-z]+\\)[. \t]+\\([0-9]+\\)[, \t]+\
+\\([0-9]+\\)[ \t]*"
+ 3 1 2)
+ ( ;; Sep 29
+ "[ \t]*\\([A-Za-z]+\\)[. \t]+\\([0-9]+\\)[ \t]*"
+ nil 1 2)
+ ( ;; 2004-10-14 17:23
+ "^[ \t]*\\([0-9][0-9][0-9][0-9]\\)-\\([0-9][0-9]\\)-\\([0-9][0-9]\\)[ \t]+\
+\\([0-9][0-9]\\):\\([0-9][0-9]\\)"
+ 1 2 3 nil 4 5))
+ "List of (regexp field field ...), each parsing a different style of date.
+The fields locate, in order:
+
+ 1. the year
+ 2. month
+ 3. day
+ 4. weekday,
+ 5. hour
+ 6. minute
+ 7. second
+ 8. and timezone of the date.
+
+Any or all can be null, and the list can be short. Each field is nil,
+an integer referring to a regexp field, or a 2-list of an integer and
+a string-parsing function which is applied (instead of a default) to
+the field string to yield the appropriate integer value.")
+
+;;; ............................................................ &code ...
+
+(defun parse-date (date &optional exactp nodefault)
+ "Parse a DATE into a 3-list of year, month, day.
+This list may be extended by the weekday,
+and then by the hour, minute, second, and timezone
+\(if such information is found), making a total of eight list elements.
+Optional arg EXACTP means the whole string must hold the date.
+Optional NODEFAULT means the date is not defaulted (to the current year).
+In any case, if parse-date succeeds, parse-date-indices is set
+to the 2-list holding the location of the date within the string."
+ (if (not (stringp date))
+ date
+ (let ((ptr date-patterns)
+ (string date)
+ start end)
+ (and (or (string= string "now")
+ (string= string "today"))
+ (setq string (current-time-string)
+ exactp nil))
+ (setq date nil)
+ (while ptr
+ (let ((pat (car (car ptr)))
+ (fields (cdr (car ptr))))
+ (if (setq start (string-match pat string))
+ (setq end (match-end 0)))
+ (and start
+ exactp
+ (or (plusp start)
+ (< end (length string)))
+ (setq start nil))
+ (setq ptr (cdr ptr))
+ (if start
+ ;; First extract the strings,
+ ;; and decide which parsers to call.
+ ;; At this point, the pattern can still fail
+ ;; if a parser returns nil.
+ (let ((strs nil)
+ (fns nil)
+ (default-fns
+ '(parse-date-year
+ parse-date-month
+ nil ;;day
+ parse-date-weekday
+ nil nil nil ;;hhmmss
+ parse-date-timezone)))
+ (while fields
+ (let ((field (car fields))
+ (fn (car default-fns)))
+ (setq fields (cdr fields)
+ default-fns (cdr default-fns))
+ ;; Allow field to be either 3 or (3 string-to-int)
+ (if (listp field)
+ (setq field (car field)
+ fn (car (cdr field))))
+ (setq strs
+ (cons
+ (cond
+ ((null field) nil)
+ ((integerp field)
+ (substring
+ string
+ (match-beginning field)
+ (match-end field)))
+ (t field))
+ strs))
+ (setq fns (cons (or fn 'string-to-int) fns))))
+ ;; Now parse them:
+ (setq strs (nreverse strs)
+ fns (nreverse fns))
+ (setq date strs) ;; Will replace cars.
+ (while strs
+ (if (car strs)
+ (setcar strs
+ (or (funcall (car fns) (car strs))
+ (setq date nil strs nil))))
+ (setq strs (cdr strs) fns (cdr fns)))
+ ;; Break the while?
+ (if date
+ (setq ptr nil))))))
+ (or nodefault
+ (null date)
+ (setq date (default-date-list date)))
+ (if date
+ (setq parse-date-indices (list start end)))
+ date)))
+
+;; FIXME: Yuck. We only default the year.
+(defun default-date-list (date)
+ "Return DATE list."
+ (let ((now nil))
+ ;; If the year is missing, default it to this year or last year,
+ ;; whichever is closer.
+ (or (nth 0 date)
+ (let ((year (nth 0 (or now (setq now (parse-date "now" t t)))))
+ (diff (* 30 (- (nth 1 date) (nth 1 now)))))
+ (if (zerop diff)
+ (setq diff (- (nth 2 date) (nth 2 now))))
+ (if (> diff 7)
+ (setq year (1- year)))
+ (setnth 0 date year)))
+ date))
+
+;; Date field parsers:
+
+(defun parse-date-month (month)
+ "Parse MONTH."
+ (if (not (stringp month))
+ month
+ (let ((sym 'parse-date-month-obarray))
+ ;; This guy's memoized:
+ (or (boundp sym) (set sym nil))
+ (setq sym (intern month
+ (or (symbol-value sym)
+ (set sym (make-vector 51 0)))))
+ (or (boundp sym)
+ (let ((try nil)
+ (key (downcase month)))
+ (or try
+ (plusp (setq try (string-to-int month)))
+ (setq try nil))
+ (or try
+ (let ((ptr '("january" "february" "march" "april"
+ "may" "june" "july" "august"
+ "september" "october" "november" "december"))
+ (idx 1))
+ (while ptr
+ (if (eql 0 (string-match key (car ptr)))
+ (setq try idx ptr nil)
+ (setq idx (1+ idx) ptr (cdr ptr))))))
+ (or try
+ (if (string= key "jly")
+ (setq try 7)))
+ (and try
+ (or (> try 12)
+ (< try 1))
+ (setq try nil))
+ (set sym try)))
+ (symbol-value sym))))
+
+(defun parse-date-year (year)
+ "Parse YEAR."
+ (if (not (stringp year))
+ year
+ (setq year (string-to-int year))
+ (cond
+ ((> year 9999) nil)
+ ((<= year 0) nil)
+ ((> year 100) year)
+ (t (+ year 1900)))))
+
+;; Other functions:
+
+(defun date-compare-key (date &optional integer-p)
+ "Map DATE to strings preserving ordering.
+If optional INTEGER-P is true, yield an integer instead of a string.
+In that case, the granularity is minutes, not seconds,
+and years must be in this century."
+ (or (consp date) (setq date (parse-date date)))
+ (let ((year (- (nth 0 date) 1900))
+ (month (- (nth 1 date) 1))
+ (day (- (nth 2 date) 1))
+ (hour (or (nth 4 date) 0))
+ (minute (or (nth 5 date) 0))
+ (second (or (nth 6 date) 0)))
+ (if integer-p
+ (+ (* (+ (* year 366) (* month 31) day)
+ (* 24 60))
+ (* hour 60)
+ minute)
+ ;; Else yield a string, which encodes everything:
+ (let* ((sz (zerop second))
+ (mz (and sz (zerop minute)))
+ (hz (and mz (zerop hour)))
+ (fmt
+ (cond
+ ((minusp year)
+ (setq year (+ year 1900))
+ (cond (hz "-%04d%c%c")
+ (mz "-%04d%c%c%c")
+ (sz "-%04d%c%c%c%02d")
+ (t "-%04d%c%c%c%02d%02d")))
+ ((> year 99)
+ (setq year (+ year 1900))
+ (cond (hz "/%04d%c%c")
+ (mz "/%04d%c%c%c")
+ (sz "/%04d%c%c%c%02d")
+ (t "/%04d%c%c%c%02d%02d")))
+ (hz "%02d%c%c")
+ (mz "%02d%c%c%c")
+ (sz "%02d%c%c%c%02d")
+ (t "%02d%c%c%c%02d%02d"))))
+ (setq month (+ month ?A) day (+ day ?a))
+ (setq hour (+ hour ?A))
+ (format fmt year month day hour minute second)))))
+
+(defun date-lessp (date1 date2)
+ "Compare DATE1 to DATE2 (which may be unparsed strings or parsed date lists).
+Equivalent to (string< (date-compare-key date1) (date-compare-key date2))."
+ (or (consp date1) (setq date1 (parse-date date1)))
+ (or (consp date2) (setq date2 (parse-date date2)))
+ (catch 'return
+ (let ((check (function (lambda (n1 n2)
+ (or n1 (setq n1 0))
+ (or n2 (setq n2 0))
+ (cond ((< n1 n2) (throw 'return t))
+ ((> n1 n2) (throw 'return nil)))))))
+ (funcall check (nth 0 date1) (nth 0 date2))
+ (funcall check (nth 1 date1) (nth 1 date2))
+ (funcall check (nth 2 date1) (nth 2 date2))
+ (funcall check (nth 4 date1) (nth 4 date2))
+ (funcall check (nth 5 date1) (nth 5 date2))
+ (funcall check (nth 6 date1) (nth 6 date2))
+ nil)))
+
+(defun sort-date-fields (reverse beg end)
+ "Sort lines in region by date value; argument means descending order.
+Called from a program, there are three required arguments:
+REVERSE (non-nil means reverse order), BEG and END (region to sort)."
+ (interactive "P\nr")
+ (save-restriction
+ (narrow-to-region beg end)
+ (goto-char (point-min))
+ (sort-subr
+ reverse 'forward-line 'end-of-line
+ (function
+ (lambda ()
+ (date-compare-key
+ (or (parse-date
+ (buffer-substring (point) (progn (end-of-line) (point))))
+ (throw 'key nil))))))))
+
+(provide 'date-parse)
+
+;;; date-parse.el ends here
--- /dev/null
+;;; dired-sort.el --- Sort by by size, date, field, name and type
+
+;; This file is not part of Emacs
+
+;; {{{ Id
+
+;; Maintainer: Jari Aalto
+;; Created: 1989-03
+;; Keywords: extensions
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;; }}}
+;; {{{ Install
+
+;;; Install:
+
+;; Put this file on your Emacs-Lisp load path, add following into your
+;; ~/.emacs startup file.
+;;
+;; (add-hook 'dired-mode-hook '(lambda () (require 'dired-sort)))
+;;
+;; NOTE: ls-lisp.el, which dired.el uses, by default inserts month names
+;; in national format. If the setting is anything other than English,
+;; this module *cannot* parse the dired lines. Please add this setting
+;; to your Emacs (21.4+) to make dired listing use ISO 8601 date stamps:
+;;
+;; (setq ls-lisp-format-time-list
+;; '("%Y-%m-%d %H:%M"
+;; "%Y-%m-%d "))
+
+;; }}}
+;; {{{
+
+;;; Commentary:
+
+;;
+;; Preface, Nov 1997
+;;
+;; Not much to say. I have had this package lying in my lisp directory
+;; since Emacs 18.xx days. When I noticed that this package doesn't
+;; exist in the OHIO archive, neither did the ftpsearch locate it,
+;; I decided to clen it up and put publically available.
+;;
+;; The original author is unknown And the only thing that was in the
+;; original documentation was this line:
+;;
+;; $Header: /tmp_mnt/am/p7/utility/gmacs/f2/RCS/dired-resort.el,v
+;; 1.1 88/11/03 13:22:08 fad Exp $
+;;
+;; New bindings in dired
+;;
+;; When you load this file, function `dired-sort-default-keys' is called.
+;; The following bindings to dired mode are defined.
+;;
+;; S" " dired-sort-resort (that's an "s" + SPACE)
+;; Ss dired-sort-by-size
+;; Sd dired-sort-by-date
+;; Sf dired-sort-by-field
+;; Sn dired-sort-by-name
+;; St dired-sort-by-type
+;;
+;; }}}
+
+;;; Change Log:
+
+;;; Code:
+
+(require 'date-parse)
+
+(eval-and-compile
+ ;; Silence Byte compiler
+ (defvar revert-buffer-function)
+ (defvar current-prefix-arg) ;; Elint.el
+ ;; Not exported from sort.el
+ (autoload 'sort-subr "sort")
+ (autoload 'sort-fields-1 "sort")
+ (autoload 'dired-revert "dired")
+ (autoload 'dired-get-filename "dired")
+ (autoload 'dired-move-to-filename "dired")
+ (autoload 'sort-skip-fields "sort"))
+
+;;; ....................................................... &variables ...
+
+(defvar dired-sort-load-hook '(dired-sort-default-keys)
+ "Hook run when file is loaded.")
+
+;; File property caching mechanism for dired
+
+(defvar dired-sort-line-property-table nil
+ "Buffer local obarray:
+Each symbol is a file name whose plist caches file properties,
+accessed by #'dired-line-property")
+(make-variable-buffer-local 'dired-sort-line-property-table)
+
+(defvar dired-sort-resort-last-kind '(date)
+ "What the last sort did to the buffer.")
+(make-variable-buffer-local 'dired-sort-resort-last-kind)
+
+(defvar dired-sort-resort-alist
+ '(("name" dired-sort-by-name nil "ascending order")
+ (nil dired-sort-by-name t "descending order")
+ ("date" dired-sort-by-date nil "most recent first")
+ (nil dired-sort-by-date t "oldest first")
+ ("size" dired-sort-by-size nil "biggest first")
+ (nil dired-sort-by-size t "smallest first")
+ ("type" dired-sort-by-type t "alphabetically")
+ ("modes" dired-sort-by-field 1 "file modes")
+ ("links" dired-sort-by-field 2 "number of links")
+ ("owner" dired-sort-by-field 3 "file owner")
+ ("field" dired-sort-by-field (1) "textual field")))
+
+;;; ............................................................ &code ...
+
+(defvar dired-sort-last-sort nil
+ "Last sort indication.")
+
+(defun dired-sort-revert-and-decache (&optional arg noconfirm)
+ "Revert buffer using `dired-revert' ARG and NOCONFIRM."
+ (if dired-sort-line-property-table
+ (mapatoms (function (lambda (file) (setplist file nil)))
+ dired-sort-line-property-table))
+ (dired-revert arg noconfirm))
+
+(defun dired-sort-line-property (func)
+ "Call FUNC with one argument: The (absolute) file name of this dired line.
+Cache the result, and return it the next time without calling FUNC.
+ The caches are cleared when the buffer is reverted.
+ See dired-sort-line-property-table."
+ (or dired-sort-line-property-table
+ (progn
+ (if (eq revert-buffer-function 'dired-revert)
+ (setq revert-buffer-function 'dired-sort-revert-and-decache))
+ (setq dired-sort-line-property-table (make-vector 31 0))))
+ (let ((file (intern (dired-get-filename t) dired-sort-line-property-table)))
+ (or (get file func)
+ (put file func
+ (funcall func (symbol-name file))))))
+
+(defun dired-sort-move-word-backward ()
+ "move one space dlimited word backward. Must already be on word."
+ (skip-chars-backward "^ \t" (line-beginning-position))
+ (skip-chars-backward " \t" (line-beginning-position))
+ (skip-chars-backward "^ \t" (line-beginning-position)))
+
+;; FIXME: It is unreliable to read words from dired buffer,
+;; because the Month name can be in national format.
+;; => There is no eas way, doing file stat() would be too
+;; expensive to find out the month name?
+;; => It is bets to configure Emacs to always use
+;; ISO dates only.
+
+(defun dired-sort-move-to-date (&optional and-extract)
+ "Details depend on the `dired-extract-size' AND-EXTRACT."
+ ;; Go two words backward
+ ;; 4694 Month 16 19:44 file
+ ;; -rw-rw---- 1 foo foo 2082 2004-10-14 17:23 .
+ ;; |
+ ;; start here
+ (when (dired-move-to-filename)
+ (let ((end (point)))
+ (dired-sort-move-word-backward)
+ (dired-sort-move-word-backward)
+ ;; Now, should we still take on leap due to Month name?
+ (unless (looking-at "[0-9][0-9][0-9][0-9]-")
+ (dired-sort-move-word-backward))
+ (if and-extract
+ (parse-date (buffer-substring (point) end) t)
+ (point)))))
+
+(defun dired-sort-extract-date ()
+ "Call `dired-sort-move-to-date'."
+ (dired-sort-move-to-date t))
+
+(defun dired-sort-extract-size ()
+ "Read size with regular expression."
+ (let ((ret -1))
+ (when (dired-sort-move-to-date)
+ (skip-chars-backward " " (line-beginning-position))
+ (skip-chars-backward "0-9" (line-beginning-position))
+ (if (looking-at "[0-9]+ ")
+ (setq ret (read (current-buffer)))))
+ ret))
+
+(defun dired-sort-header-line-p ()
+ "Check `dired-sort-extract-size'."
+ (save-excursion
+ (minusp (dired-sort-extract-size))))
+
+(defun dired-sort-first-file ()
+ "Goto first file."
+ (interactive)
+ (goto-char (point-min))
+ (while (and (dired-sort-header-line-p)
+ (not (eobp)))
+ (forward-line 1))
+ (dired-move-to-filename))
+
+(defun dired-sort-extract-date-key (&optional ignore)
+ "Extract key with IGNORE."
+ (let ((date (dired-sort-extract-date)))
+ (if date
+ (date-compare-key date 'integer))))
+
+(defun dired-sort-by-size-key (&optional ignore)
+ "Sort by zise or IGNORE."
+ (dired-sort-by-size-key-1 nil))
+
+(defun dired-sort-by-size-increasing-key (&optional ignore)
+ "Sort by zise or IGNORE."
+ (dired-sort-by-size-key-1 t))
+
+(defun dired-sort-resort-menu-options ()
+ "See `dired-sort-resort-alist'."
+ (list "Help"
+ (cons "Sort Dired listing by:"
+ (mapcar
+ (function(lambda (elt)
+ (cons
+ (format "%5s (%s)"
+ (capitalize (or (nth 0 elt) " '' "))
+ (nth 3 elt))
+ elt)))
+ dired-sort-resort-alist))))
+
+(defun dired-sort-by-size-key-1 (incr-p)
+ "Sort possibly with INCR-P."
+ (let ((size (dired-sort-extract-size))
+ (char (save-excursion
+ (forward-line 0)
+ (skip-chars-forward " ")
+ (following-char))))
+ (setq char (downcase char))
+ (cond
+ ((not incr-p))
+ ((= char ?-) (setq char ?~))
+ ((>= char ?a) (setq char (- (+ ?a ?z) char))))
+ (format "%c%09d" char size)))
+
+(defun dired-sort-read-resort-args (&optional res)
+ "Produce a 1- or 2- list.
+Suitable for non-interactive calling of dired-sort-resort.
+Optional RES is a line from dired-sort-resort-alist."
+ (or res
+ (setq res
+ (completing-read
+ (format "Sort by: [%s] " (car dired-sort-resort-last-kind))
+ dired-sort-resort-alist
+ nil t)))
+ (if (zerop (length res))
+ dired-sort-resort-last-kind
+ (if (atom res)
+ (setq res (or (assoc res dired-sort-resort-alist)
+ (error "reading resort"))))
+ (let ((type (nth 0 res))
+ (func (nth 1 res))
+ (arg (nth 2 res))
+ (what (nth 3 res)))
+ (let ((ptr dired-sort-resort-alist) elt)
+ (while (and ptr (null type))
+ (setq elt (car ptr) ptr (cdr ptr))
+ (if (eq func (nth 1 elt))
+ (setq type (nth 0 elt)))))
+ (setq type (intern type))
+ (cond
+ ((atom arg))
+ (current-prefix-arg
+ (setq arg
+ (if (integerp (car arg))
+ (prefix-numeric-value current-prefix-arg)
+ (and current-prefix-arg t))))
+ ((integerp (car arg))
+ (setq arg (read-string (format "What %s? " what))))
+ (t (setq arg (y-or-n-p (format "%s? " what)))))
+ (if (null arg)
+ type
+ (list type arg)))))
+
+;;; ..................................................... &interactive ...
+
+(defun dired-sort-last-file ()
+ "Go to last file."
+ (interactive)
+ (goto-char (point-max))
+ (while (and (dired-sort-header-line-p)
+ (not (bobp)))
+ (forward-line -1))
+ (dired-move-to-filename))
+
+(defun dired-sort-narrow-to-files ()
+ "Narrow to visible files."
+ (interactive)
+ (narrow-to-region
+ (save-excursion
+ (dired-sort-first-file)
+ (forward-line 0)
+ (point))
+ (save-excursion
+ (dired-sort-last-file)
+ (forward-line 1)
+ (point))))
+
+;;;###autoload
+(defun dired-sort-by-date (&optional arg)
+ "In dired, sort the lines by date, newest first.
+With ARG, sorts oldest first."
+ (interactive "P")
+ (save-restriction
+ (dired-sort-narrow-to-files)
+ (let (buffer-read-only)
+ (goto-char (point-min))
+ (sort-subr
+ (not arg) 'forward-line 'end-of-line
+ (function
+ (lambda ()
+ (or (dired-sort-line-property 'dired-sort-extract-date-key)))))))
+ ;; (throw key 'nil)
+ (setq dired-sort-last-sort (if arg
+ 'oldest
+ 'newest))
+ (message "Dired-sort: Now sorted by date, %s first."
+ (if arg
+ "oldest"
+ "newest")))
+
+(defun dired-sort-by-name (&optional arg skip-to sort-by)
+ "In dired, sort the lines by file name.
+With ARG, sorts in reverse order. SKIP-TO SORT-BY."
+ (interactive "P")
+ (or sort-by (setq sort-by 'name))
+ (save-restriction
+ (dired-sort-narrow-to-files)
+ (let ((buffer-read-only nil)
+ (reverse-sort-p arg))
+ (goto-char (point-min))
+ (sort-subr
+ reverse-sort-p 'forward-line 'end-of-line
+ (function(lambda ()
+ (dired-move-to-filename)
+ (cond
+ ((null skip-to))
+ (reverse-sort-p
+ (let ((here (point)))
+ (end-of-line)
+ (re-search-backward
+ skip-to here 'move)))
+ ((re-search-forward
+ skip-to
+ (save-excursion (end-of-line) (point))
+ 'move)
+ (goto-char (match-beginning 0))))
+ nil)))))
+ (setq dired-sort-last-sort sort-by)
+ (message "Dired-sort: Now sorted by %s%s." sort-by
+ (if arg
+ ", in reverse order"
+ "")))
+
+;;;###autoload
+(defun dired-sort-by-type (&optional arg)
+ "Sort by type, ARG means reverse."
+ (interactive "P")
+ (dired-sort-by-name
+ arg (if arg
+ "[.#~]"
+ "[.~0-9#]+")
+ 'type))
+
+;;;###autoload
+(defun dired-sort-by-field (field)
+ "In dired, sort the lines by FIELD (defaults to the mode field)."
+ (interactive "p")
+ (save-restriction
+ (dired-sort-narrow-to-files)
+ (let ((buffer-read-only nil))
+ (goto-char (point-min))
+ (sort-fields-1
+ field (point-min) (point-max)
+ (function(lambda ()
+ (sort-skip-fields (1- field))
+ (skip-chars-backward " ")
+ nil))
+ nil)))
+ (setq dired-sort-last-sort 'fields)
+ (message "Dired-sort: Now sorted by %s."
+ (cond ((= field 1) "file mode")
+ ((= field 2) "number of links")
+ ((= field 3) "file owner")
+ (t (format "field #%d" field)))))
+
+;;;###autoload
+(defun dired-sort-by-size (&optional arg)
+ "In dired, sort the lines by file size, largest first.
+With ARG, sorts in the reverse order (smallest first).
+All directories are grouped together at the head of the buffer,
+and other file types are also grouped."
+ (interactive "P")
+ (let ((buffer-read-only nil)
+ (incr-p arg))
+ (save-restriction
+ (dired-sort-narrow-to-files)
+ (goto-char (point-min))
+ (sort-subr
+ (not incr-p) 'forward-line 'end-of-line
+ (if incr-p
+ (function (lambda () (dired-sort-line-property
+ 'dired-sort-by-size-increasing-key)))
+ (function (lambda () (dired-sort-line-property
+ 'dired-sort-by-size-key))))))
+ (setq dired-sort-last-sort (if incr-p
+ 'smallest
+ 'largest))
+ (message "Dired-sort: Now sorted by type and size, %s first."
+ (if incr-p
+ "smallest"
+ "largest"))))
+
+;;;###autoload
+(defun dired-sort-resort (kind &optional args)
+ "In dired, change the sorting of lines. Prompt for the KIND of sorting.
+Non-interactively, takes a sort-kind, and an optional argument for
+the associated function. To get a list of such arguments interactively,
+call dired-sort-read-resort-args. ARGS are passed to sort."
+ (interactive (list (dired-sort-read-resort-args)))
+ (if (null kind)
+ (setq kind dired-sort-resort-last-kind))
+ (if (consp kind)
+ (setq args (cdr kind) kind (car kind)))
+ (if (symbolp kind) (setq kind (symbol-name kind)))
+ (apply
+ (or (nth 1 (assoc kind dired-sort-resort-alist))
+ (error "No such sorting method: %s" kind))
+ args)
+ (setq dired-sort-resort-last-kind (cons kind args)))
+
+;;;###autoload
+(defun dired-sort-default-keys-dired-mode-map ()
+ "Define default bindings to dired map."
+ (interactive)
+ (let* ((map (symbol-value 'dired-mode-map)))
+ (unless map
+ (error "dired-sort.el: [ERROR] dired is not yet loaded."))
+ (define-key map "\C-cs" nil)
+ (define-key map "\C-cs " 'dired-sort-resort)
+ (define-key map "\C-css" 'dired-sort-by-size)
+ (define-key map "\C-csd" 'dired-sort-by-date)
+ (define-key map "\C-csf" 'dired-sort-by-field)
+ (define-key map "\C-csn" 'dired-sort-by-name)
+ (define-key map "\C-cst" 'dired-sort-by-type)))
+
+;;;###autoload
+(defun dired-sort-default-keys ()
+ "Define default bindings to dired map."
+ (eval-after-load "dired"
+ '(progn (dired-sort-default-keys-dired-mode-map))))
+
+;;;###autoload
+(add-hook 'dired-mode-hook 'dired-sort-default-keys 'end)
+
+(run-hooks 'dired-sort-load-hook)
+(provide 'dired-sort)
+
+;;; dired-sort.el ends here
--- /dev/null
+;;; expect.el --- support for external process communication
+
+;; This file is not part of Emacs
+
+;; Copyright (C) 1997 Free Software Foundation, Inc.
+;; Author: Lars Magne Ingebrigtsen <lmi@gnus.org>
+;; Keywords: extensions, processes
+;;
+;; This file is soon to be part of GNU Emacs.
+;;
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; GNU Emacs 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 program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'cl)
+
+(eval-and-compile
+ ;; Old XEmacs does not have this, ignore load error
+ (ignore-errors (require 'timer))
+
+ (when (and (not (fboundp 'run-at-time))
+ (locate-library "tinyliba"))
+ (require 'tinyliba)))
+
+(defvar expect-message nil
+ "*If non-nil, report how much data has arrived in the process buffer.
+This variable is buffer-local to all Expect buffers, and should be set
+inside @code{with-expect} forms.")
+
+(defvar expect-start nil
+ "If a number, start the Expect searches from that point.
+If not, start searches from `(point-min)'.
+This variable is typically `let' to t before calling `with-expect'
+when waiting for output from a process that is already started and may
+have output data.")
+
+(defvar expect-timeout 10
+ "The number of seconds to wait before an Expect timeout element is triggered.")
+
+;;; Internal variables.
+
+(defvar expect-processes nil)
+(defvar expect-asynchronous nil)
+(defvar expect-process nil) ; Dynamic variable
+(defvar expect-current-info nil) ; Dynamic variable
+
+;;; Utility macros.
+
+(defun expect-make-info (process message point)
+ (list process message point nil nil))
+
+(defmacro expect-info-process (info)
+ `(nth 0 ,info))
+
+(defmacro expect-info-message (info)
+ `(nth 1 ,info))
+
+(defmacro expect-info-point (info)
+ `(nth 2 ,info))
+(defmacro expect-info-set-point (info point)
+ `(setcar (nthcdr 2 ,info) ,point))
+
+(defmacro expect-info-sentinels (info)
+ `(nth 3 ,info))
+(defmacro expect-info-set-sentinels (info sentinels)
+ `(setcar (nthcdr 3 ,info) ,sentinels))
+
+(defmacro expect-info-timer (info)
+ `(nth 4 ,info))
+(defmacro expect-info-set-timer (info timer)
+ `(setcar (nthcdr 4 ,info) ,timer))
+
+(defmacro expect-info-queries (info)
+ `(nthcdr 5 ,info))
+(defmacro expect-info-set-queries (info queries)
+ `(setcdr (nthcdr 4 ,info) ,queries))
+
+(defmacro expect-find-info (process)
+ `(assoc ,process expect-processes))
+
+;;; Interface macros.
+
+;;;###autoload
+(defmacro with-expect (program &rest forms)
+ "Set things up for communication with PROGRAM.
+FORMS will be evaluated in the normal manner. To talk to the process,
+use `expect' and `expect-send'. See the manual for full documentation.
+This macro returns nil.
+
+If PROGRAM is a string, start that program. If PROGRAM is a list, use
+the first element of that list as the program and the remainder as the
+parameters. If PROGRAM is a process, talk to that process.
+
+PROGRAM will be started up in a new, fresh temporary buffer. The
+buffer will be killed upon completion. If PROGRAM is a process,
+a new buffer won't be created, and the buffer won't be killed upon
+completion."
+ (let ((buf (make-symbol "buf"))
+ (point (make-symbol "point")))
+ `(save-excursion
+ (let ((,buf (generate-new-buffer " *expect*"))
+ (,point (point))
+ expect-process expect-current-info)
+ (set-buffer ,buf)
+ (unless (setq expect-process
+ (expect-start-process ,program))
+ (error "Can't start program"))
+ (expect-setup ,point)
+ ,@forms
+ (unless (expect-info-sentinels expect-current-info)
+ (expect t))
+ nil))))
+
+(defun expect-start-process (program)
+ (cond
+ ((stringp program)
+ (start-process "expect" (current-buffer) program))
+ ((consp program)
+ (apply 'start-process
+ "expect" (current-buffer) (car program) (cdr program)))
+ ((processp program)
+ program)
+ (t
+ (error "Illegal process spec"))))
+
+(defmacro with-expect-asynchronous (program &rest forms)
+ "Set things up for asynchronous communication with PROGRAM.
+This macro behaves like `with-expect', only that `expect' calls
+contained in FORMS will be evaluated asyncronously.
+
+See the documentation of the `with-expect' macro for documentation."
+ `(let ((expect-asynchronous t))
+ (with-expect ,program ,@forms)))
+
+(defmacro expect (regexp &rest forms)
+ "Execute FORMS when REGEXP has arrived in the buffer."
+ `(expect-1 ,regexp #'(lambda () ,@forms)))
+
+(defmacro expect-cond (&rest clauses)
+ "Try each clause until one succeeds.
+Each clause looks like (CONDITION BODY). CONDITION should be
+a regular expression to wait for, or a process status symbol.
+If CONDITION is satisfied (i. e., the data has arrived or
+the process has entered the specified status), BODY will be executed."
+ (let (result)
+ (while clauses
+ (push (if (stringp (caar clauses)) (caar clauses)
+ (list 'quote (caar clauses)))
+ result)
+ (push (car `(#'(lambda () ,@(cdar clauses)))) result)
+ (pop clauses))
+ `(expect-1 ,@(nreverse result))))
+
+(defmacro expect-exit (&rest forms)
+ "Execute FORMS when the process has exited."
+ `(expect-exit-1 #'(lambda () ,@forms)))
+
+;;; User utility functions.
+
+(defmacro expect-send (string)
+ "Send STRING to the current buffer's process."
+ `(process-send-string expect-process ,string))
+
+;;; Internal functions.
+
+(defun expect-setup (&optional point)
+ "Initialize Expect data, filter and sentinel."
+ (setq expect-current-info
+ (expect-make-info expect-process expect-message
+ (or point expect-start (point-min))))
+ (push expect-current-info expect-processes)
+ (set-process-filter expect-process 'expect-filter)
+ (set-process-sentinel expect-process 'expect-sentinel)
+ (set-buffer (process-buffer expect-process)))
+
+(defun expect-shutdown (process)
+ "Remove Expect infestation of PROCESS."
+ (setq expect-processes (delq (expect-find-info process) expect-processes))
+ (set-process-filter process nil)
+ (set-process-sentinel process nil))
+
+(defun expect-kill (process)
+ "Kill PROCESS and its buffer."
+ (let ((buffer (process-buffer process)))
+ (when (buffer-name buffer)
+ (kill-buffer buffer))
+ (expect-shutdown process)
+ (delete-process process)))
+
+(defun expect-wait ()
+ "Wait until the current outstanding command has been performed."
+ (let ((info (expect-find-info expect-process)))
+ (expect-setup-timer info)
+ (while (and (car (expect-info-queries (expect-find-info expect-process)))
+ (memq (process-status expect-process) '(open run)))
+ (accept-process-output expect-process 1))
+ (expect-cancel-timer info))
+ ;; We return nil.
+ nil)
+
+(defun expect-1 (&rest clauses)
+ (let (entries
+ timeout)
+ (unless expect-process
+ (error "No expect in this buffer"))
+ ;; Add this clause to the list of things to be executed.
+ (while clauses
+ (if (eq (car clauses) 'timeout)
+ (setq timeout (cadr clauses)
+ clauses (cddr clauses))
+ (push (list (pop clauses) (pop clauses))
+ entries)))
+ (when timeout
+ (expect-info-set-timer expect-current-info
+ (list nil expect-timeout timeout)))
+ (nconc expect-current-info (list (nreverse entries)))
+ ;; We see whether we have to wait for the command to complete
+ ;; or not.
+ (if expect-asynchronous
+ nil
+ (expect-wait))))
+
+(defun expect-exit-1 (function)
+ (unless expect-process
+ (error "No expect in this buffer"))
+ (let ((info (expect-find-info expect-process)))
+ (expect-info-set-sentinels
+ info
+ (nconc (expect-info-sentinels info)
+ (list function))))
+ ;; We return nil.
+ nil)
+
+(defun expect-filter (process string)
+ "Controlling Expect function run as a process filter."
+ (let ((old-buffer (current-buffer))
+ (expect-process process))
+ (unwind-protect
+ (let (moving)
+ (set-buffer (process-buffer process))
+ (setq moving (= (point) (process-mark process)))
+ (save-excursion
+ ;; Insert the text, moving the process-marker.
+ (goto-char (process-mark process))
+ (insert string)
+ (set-marker (process-mark process) (point))
+ ;; Do Expect things.
+ (expect-find-event process))
+ (when (memq (process-status process) '(open run))
+ (if moving (goto-char (process-mark process)))))
+ (when (buffer-name old-buffer)
+ (set-buffer old-buffer)))))
+
+(defun expect-sentinel (process status)
+ "Controlling Expect sentinel."
+ ;; Perhaps we're waiting for one of the process events?
+ (when (memq (process-status process) '(open run))
+ (expect-find-event process))
+ ;; We do `expect-exit' calls.
+ (when (eq 'exit (process-status process))
+ (save-excursion
+ (let ((expect-process process))
+ (when (and (process-buffer process)
+ (buffer-name (process-buffer process)))
+ (set-buffer (process-buffer process))
+ (let ((sentinels (expect-info-sentinels (expect-find-info process))))
+ (while sentinels
+ (save-excursion
+ (funcall (pop sentinels))))
+ (expect-shutdown process)))))))
+
+(defun expect-find-event (process)
+ "Find (and execute) the next event."
+ (let* ((info (expect-find-info process))
+ (point (expect-info-point info))
+ (queries (expect-info-queries info))
+ (clause (car queries))
+ cond)
+ (expect-setup-timer info)
+ (when (expect-info-message info)
+ (message "Expect received %d bytes" (point-max)))
+ (when clause
+ (if (eq (caar clause) t)
+ ;; We have handled all queries and want to die.
+ (expect-kill process)
+ (when (> (point-max) point)
+ (goto-char point)
+ (while clause
+ (setq cond (caar clause))
+ (when (cond
+ ;; Regexp
+ ((stringp cond)
+ (re-search-forward (caar clause) nil t))
+ ;; Fall-through
+ ((eq t cond)
+ t)
+ ;; Process state
+ ((memq cond '(exit run stop signal open closed))
+ (eq cond (process-status process)))
+ (t
+ (error "Illegal condition: %s" cond)))
+ (expect-cancel-timer info)
+ (expect-info-set-point info (point))
+ (expect-info-set-queries info (cdr queries))
+ (save-excursion
+ (funcall (cadar clause)))
+ (setq clause nil)
+ ;; More than one event may have arrived, so we try again.
+ (when (memq (process-status process) '(open run))
+ (expect-find-event process)))
+ (setq clause (cdr clause))))))))
+
+(defun expect-setup-timer (info)
+ (let ((timer (expect-info-timer info)))
+ (when timer
+ (expect-cancel-timer info)
+ (setcar timer (run-at-time (cadr timer) nil (caddr timer))))))
+
+(defun expect-cancel-timer (info)
+ (when (car (expect-info-timer info))
+ (ignore-errors (cancel-timer (car (expect-info-timer info))))))
+
+;;; Indentation and edebug specs.
+
+(put 'expect 'lisp-indent-function 1)
+(put 'expect 'edebug-form-spec '(form body))
+(put 'expect-exit 'lisp-indent-function 0)
+(put 'expect-exit 'edebug-form-spec '(body))
+(put 'with-expect 'lisp-indent-function 1)
+(put 'with-expect 'edebug-form-spec '(form body))
+(put 'with-expect-asynchronous 'lisp-indent-function 1)
+(put 'with-expect-asynchronous 'edebug-form-spec '(form body))
+
+(provide 'expect)
+
+;;; expect.el ends here
--- /dev/null
+;;; fnexpand.el --- filename expansion anywhere
+
+;; This file is not part of Emacs
+
+;; Copyright (C) 1991-2007 eirik and trost
+
+;; Author: <eirik@theory.tn.cornell.edu> and <trost@reed.edu>
+;; Adapted-By: Jari Aalto
+;; Idea by: karl@cs.umb.edu
+;; Keywords: tools
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; GNU Emacs 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 program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;; Install:
+
+;; Put this file on your Emacs-Lisp load path, add following into your
+;; ~/.emacs startup file.
+;;
+;; (require 'fnexpand)
+;;
+;; or use this; your .emacs loads up a bit quicker
+;;
+;; (autoload 'fnexpand-complete "fnexpand" t t)
+;;
+;; You should also add some keybinding to use the expansion feature
+;; The following example replaces seldom used original emacs binding.
+;;
+;; (global-set-key "\e`" 'fnexpand-complete)
+;; (define-key minibuffer-local-must-match-map "\e`" 'fnexpand-complete)
+;; (define-key minibuffer-local-completion-map "\e`" 'fnexpand-complete)
+;;
+;; If you want to expand executables, you should add following statement
+;; before any require command. Loading this package slows down remarkably
+;; after this though.
+;;
+;; (setq fnexpand-executable-enable t)
+;;
+
+;;; Commentary:
+
+;; The enclosed elisp code provides completion of user names and
+;; environment variables, as well as a function which does filename
+;; completion "in place", in any buffer. The latter function is
+;; particularly useful as the local binding of the TAB key in shell
+;; mode, but it can be used in global bindings too.
+;;
+;; Code to do completion of $envvar and ~username in filenames
+;; Code to do completion of filenames in place (e.g. in shell buffers)
+;; Sample binding:
+;;
+;; (setq shell-mode-hook
+;; (function
+;; (lambda () (local-set-key "\^I" 'fnexpand-complete ))))
+;;
+;;
+;; If you want to expand
+;;
+;;
+;; The code that does expansion on $ and ~ only works if the $ or ~ is
+;; either at the beginning of the buffer, or after "/". One result of
+;; this is that file names which end in ~ are still allowed.
+
+;;; Change Log:
+
+;; May 12 1997 [jari] 19.28 v1.10 NotReleased
+;; - William A. Hoffman" <hoffman@albirio.crd.ge.com> reported that
+;; Emacs asked to save /etc/passwd buffer.
+;; - Changed the code so that no direct file buffer is used any more.
+;; This also inhibits reverting the contents, but since /etc/passwd
+;; changes so seldom, I don't believe the revert loss can be noticed in
+;; real use.
+;;
+;; Apr 22 1997 [jari] 19.28 v1.8-1.9 NotReleased
+;; - Added advice to complete Env variables in minibuffer prompt (TAB/SPC)
+;;
+;; Mar 20 1997 [jari] 19.28 v1.7 Released
+;; - Added new user variable fnexpand-passwd-eval-form which now reads
+;; also Solaris NIS+ password table.
+;; - rewrote fnexpand-complete-username
+;;
+;; Mar 19 1997 [jari] 19.28 v1.6 Released
+;; - Added varaible fnexpand-expand-env-directories which controls
+;; expand mode for directory env variables.
+;; - Corrected byteComp errors.
+;;
+;; May 17 1996 [jari] 19.28 v1.2-1.5 Released
+;; - Found this code lying around in my ~/elisp. I cannot recall where
+;; did I get this file.
+;; - Rewrote most of the package. Added fnexpand- prefix to every function
+;; and variable. Added the executable file expanding.
+;; - got rid of the redefinitions of emacs functions. Cleared the pacakge.
+
+;;; Code:
+
+(require 'assoc)
+
+(eval-when-compile
+ (require 'advice))
+
+;;; ....................................................... &v-private ...
+
+(defconst fnexpand-version
+ "$Id: fnexpand.el,v 2.12 2007/05/07 10:50:05 jaalto Exp $"
+ "Latest RCS modification time and version number.")
+
+(defvar fnexpand-envvars nil
+ "Private, a list of environment variable names and values.
+Format: '((ENV-VAR-NAME . ENAV-VAR-VALUE).")
+
+(defvar fnexpand-executable-file-cache nil
+ "Private, list of executable files. The list is updated periodically.
+Format: '((FILE . 1) (FILE . 2) ..).")
+
+(defvar fnexpand-executable-file-cache-counter nil
+ "Private, incremented every time when executable file cache is asked.")
+
+(defvar fnexpand-yp-passwd-buffer " *fnexpand-yp-passwords*"
+ "Password buffer name.")
+
+;;; ........................................................ &v-public ...
+;;; User configurable
+
+(defvar fnexpand-expand-env-directories nil
+ "If nono-nil then environment varaiables $DIR which contain
+directory slash are expanded.
+
+Examples; when nil, suppose PROJECT holds directory
+
+ $PROJ[TAB] --> $PROJECT
+ $PRIN[TAB] --> $PRINTER
+
+When non-nil
+
+ $PROJ[TAB] --> /user/local/project/dbms/
+ $PRIN[TAB] --> $PRINTER
+
+")
+
+(defvar fnexpand-passwd-eval-form
+ (cond
+ ((string-match "hppa\\|hpux" (emacs-version))
+ '(call-process "ypcat" nil
+ (get-buffer-create fnexpand-yp-passwd-buffer)
+ nil "passwd"))
+ ((and (string-match "solaris" (emacs-version))
+ (file-exists-p "/var/nis"))
+ '(call-process "niscat" nil
+ (get-buffer-create fnexpand-yp-passwd-buffer)
+ nil "passwd.org_dir"))
+ (t
+ (insert-file-contents "/etc/passwd" t)
+ (setq buffer-file-name nil))) ;Make sure it is not saved back
+ "EVAL form to readt the password file to fnexpand-yp-passwd-buffer.
+HPUX 'ypcat --> ypcat passwd
+Solaris 'NIS+ --> niscat passwd.org_dir
+others nil --> cat /etc/passwd
+")
+
+;;; You don't want to update cache very often...
+;;;
+(defvar fnexpand-executable-file-cache-update 200
+ "*Counter when to update fnexpand-executable-file-cache.
+Default every 200th call. See also 'fnexpand-executable-enable'.")
+
+(defvar fnexpand-executable-cache-no-dirs "RCS"
+ "*Regexp, which directories in path not to cache. Eg looking into
+RCS directory makes no sense.")
+
+;;;###autoload
+(defvar fnexpand-executable-enable nil
+ "*if non-nil, then try to expand executable files too.
+Beware, this may be time consuming.")
+
+(defvar fnexpand-filename-boundary-chars "[^#$%+-9=@-Z_a-z~]"
+ "*Characters used to bound filenames in 'fnexpand-find-filename'.")
+
+(defvar fnexpand-complete-filename-look-right nil
+ "*If t, consider text on both sides of point in fnexpand-complete-filename.")
+
+;;; .................................................... compatibility ...
+
+(eval-and-compile
+ (cond
+ ((fboundp 'read-file-name-internal-primitive)
+ (defalias 'fnexpand-read-file-name-internal-primitive
+ 'read-file-name-internal-primitive))
+ (t
+ (defalias 'fnexpand-read-file-name-internal-primitive
+ (symbol-function 'read-file-name-internal)))))
+
+;;; ............................................................ funcs ...
+
+(defun fnexpand-getenv (&optional var)
+ "Return env VAR slot. If VAR is t, then update
+global list 'fnexpand-envvars' if needed and return all variables
+in format '((ENV-VAR-NAME . ENAV-VAR-VALUE) (E-NAME. E-VAL) ..)"
+ (cond
+ ((eq t var)
+ (if fnexpand-envvars
+ fnexpand-envvars ;read from cache
+ (setq fnexpand-envvars
+ (mapcar
+ (function
+ (lambda (string)
+ (let ((d (string-match "=" string)))
+ (cons (substring string 0 d)
+ (and d (substring string (1+ d)))))))
+ process-environment))))
+ (t
+ (getenv var))))
+
+(defun fnexpand-read-file-name-internal (name dir action)
+ "Like 'read-file-name-internal' that expands partial usernames and
+environment variable names.
+
+NAME is the filename to complete; DIR is the directory to complete in.
+ACTION is nil to complete, t to return list of completions, lambda to
+verify final value."
+ (let* ((buf (current-buffer))
+ (char (progn
+ (set-buffer (get-buffer-create " *read*"))
+ (erase-buffer)
+ (insert name)
+ (and (re-search-backward "[$~]" nil t)
+ (char-after (point)))))
+ (can (and char
+ (or (eq (point) (point-min))
+ (save-excursion (backward-char 1)
+ (looking-at "/")))
+ (not (progn
+ (forward-char 1)
+ (save-excursion
+ (search-forward "/"
+ (point-max) t))))
+ (buffer-substring (point) (point-max)))))
+ (set-buffer buf)
+ (if (null can) (fnexpand-read-file-name-internal-primitive
+ name dir action)
+ (let ((prefix (substring name 0 (- (length name) (length can) 1))))
+ (cond
+ ((eq char ?~)
+ (let ((s (fnexpand-complete-username can nil action)))
+ (cond ((stringp s)
+ (concat "~" s
+ (and
+ (eq t (fnexpand-complete-username s nil action))
+ (file-directory-p
+ (expand-file-name (concat "~" s)))
+ "/")))
+ ((eq t s) (concat name
+ (if (file-directory-p
+ (expand-file-name name))
+ "/")))
+ (t s))))
+ ((eq char ?$)
+ (let ((completion-list
+ (all-completions
+ can (fnexpand-getenv t))))
+ (cond
+ ((null action)
+ (let* ((un (and (eq (length completion-list) 1)
+ (car completion-list)))
+ (unv (and un (fnexpand-getenv un)))
+ (dirp (and unv (> (length unv) 0)
+ (file-directory-p unv)
+ "/")))
+ (if (and un (string-equal un can))
+ (concat prefix unv dirp)
+ (let ((s (try-completion can (fnexpand-getenv t)))
+ exp)
+ (cond
+ ((stringp s)
+ (setq exp (getenv s))
+ (if (or (null fnexpand-expand-env-directories)
+ (not (string-match "/" exp)))
+ (concat prefix "$" s dirp)
+ (concat prefix exp dirp)))
+ (t
+ s))))))
+ ((eq t action)
+ completion-list)
+ (t
+ (eq 1 (length completion-list)))))))))))
+
+(defun fnexpand-find-completing-names (string predicate yp-p)
+ "Looking for USERNAME completions matching PREDICATE (if non-nil) in current
+buffer. Does not do save-excursion. If third argument YP-P is non-nil, allow
+matches for individual yp entries as well."
+ (let ((regexp (concat (if yp-p "^+?" "^") string "[^:]*:"))
+ ret)
+ (goto-char (point-min))
+ (while (re-search-forward regexp () t)
+ (let ((name (buffer-substring (match-beginning 0) (1- (match-end 0)))))
+ (if (or (not predicate) (funcall predicate name))
+ (setq ret (cons (if (eq (string-to-char name) ?+)
+ (substring name 1)
+ name)
+ ret)))
+ (end-of-line)))
+ ret))
+
+(defun fnexpand-complete-username (string predicate flag)
+ "Use passwd file to expand a ~. A \"+\" at the beginning of the
+line is assumed to indicate a yp entry."
+ (let* ((buffer "*passwd*")
+ (pwbuf (get-buffer buffer))
+ yp-p
+ list)
+ (if (string-match ":" string)
+ nil
+ (save-excursion
+ (cond
+ (pwbuf
+ (set-buffer pwbuf))
+ (t
+ (set-buffer (get-buffer-create buffer))
+ (insert-file-contents "/etc/passwd" t)
+ (setq buffer-file-name nil))) ;Make sure it is not saved back
+
+ (goto-char (point-min))
+ (cond
+ ((and (setq yp-p (re-search-forward "^+:" nil t))
+ (null (get-buffer fnexpand-yp-passwd-buffer)))
+ (eval fnexpand-passwd-eval-form)))
+ (setq buffer-read-only t)
+
+;;; (d! "YP" yp-p (current-buffer) string predicate)
+
+ (cond
+ ((eq flag t)
+ (nconc (fnexpand-find-completing-names string predicate t)
+ (if yp-p
+ (progn
+ (set-buffer (get-buffer fnexpand-yp-passwd-buffer))
+ (fnexpand-find-completing-names
+ string predicate nil)))))
+ (flag ; should this be (eq flag 'lambda)?
+ (if (or (re-search-forward (concat "^+?" string ":") nil t)
+ (and yp-p
+ (progn
+ (set-buffer fnexpand-yp-passwd-buffer)
+ (re-search-forward (concat "^" string ":") nil t))))
+ t))
+ (t
+ (setq list (mapcar 'list
+ (fnexpand-complete-username string nil t)))
+ (or (and (eq (length list) 1)
+ (fnexpand-complete-username string predicate 'lambda))
+ (try-completion string list))))))))
+
+(defun fnexpand-path-list ()
+ "Return PATH in list format '(PATH PATH ..). Only unique paths are
+returned."
+ (let* ((path (or (getenv "PATH")
+ (getenv "path")))
+ list
+ elt)
+ (while path
+ (cond
+ ((string-match "^[^:]+" path)
+ (setq elt (substring path 0 (match-end 0)))
+
+ (if (> (length path) (match-end 0))
+ (setq path (substring path (1+ (match-end 0))))
+ (setq path nil)) ;no more
+
+ ;; make sure, has ending slash
+ (if (not (string-match "/$" elt))
+ (setq elt (concat elt "/")))
+
+ ;; consing is faster that append.
+ (if (not (member elt list))
+ (setq list (cons elt list ))))))
+ (reverse list))) ;preserve order
+
+(defun fnexpand-executables (&optional verb)
+ "Return all unique executable files. If VERB is non-nil, print
+verbose messages during updating cache. Cache is updated only
+if it's nil or of cache counter reaches certain value.
+
+References:
+ 'fnexpand-executable-file-cache-counter'
+ 'fnexpand-executable-file-cache-update'
+ 'fnexpand-executable-file-cache'
+"
+ (let* ((counter 0)
+ path-list
+ path
+ file
+ files)
+
+ (if (integerp fnexpand-executable-file-cache-counter)
+ (setq fnexpand-executable-file-cache-counter
+ (1+ fnexpand-executable-file-cache-counter))
+ (setq fnexpand-executable-file-cache-counter 0))
+
+ ;; time's up? update cache if needed
+ ;;
+ (cond
+ ((or (null fnexpand-executable-file-cache)
+ (eq 0 (% fnexpand-executable-file-cache-counter
+ fnexpand-executable-file-cache-update)))
+
+ (setq fnexpand-executable-file-cache-counter 1
+ fnexpand-executable-file-cache nil
+ path-list (fnexpand-path-list))
+
+ (while path-list
+ (setq path (car path-list))
+
+ (if verb
+ (message (format "fnexpand: cacheing executables %s" path)))
+
+ (cond
+ ((and (not (string-match fnexpand-executable-cache-no-dirs path))
+ (file-exists-p path)) ;ignore non-existing paths
+ (setq files (directory-files path))
+ (mapcar
+ '(lambda (x)
+ (setq file (concat path x))
+
+ (cond
+ ((and (not (file-directory-p file))
+ (file-executable-p file)
+ (not (assoc x fnexpand-executable-file-cache)))
+
+ (setq fnexpand-executable-file-cache
+ (cons
+ (list x counter)
+ fnexpand-executable-file-cache ))
+ (setq counter (1+ counter)))))
+ files)))
+ (setq path-list (cdr path-list))) ;; while path-list
+ (if verb (message ""))))
+
+ fnexpand-executable-file-cache))
+
+(defun fnexpand-executable-completions (name)
+ "Return executable completions for NAME. If there is only one completion,
+return string."
+ (let* ((list (fnexpand-executables 'verb))
+ ret)
+ (setq ret (all-completions name list))
+ (if (eq 1 (length ret))
+ (setq ret (car ret)))
+ ret))
+
+(defun fnexpand-find-filename ()
+ "Return the largest substring to the left of point which can contain
+a file name. Ignore the most recent prompt in a shell buffer"
+ (let ((mark (let ((process (get-buffer-process (current-buffer))))
+ (and process (process-mark process)))))
+ (buffer-substring
+ (save-excursion
+ (if (re-search-backward fnexpand-filename-boundary-chars
+ (and mark (>= (point) mark) mark)
+ 1)
+ (1+ (point))
+ (point)))
+ (point))))
+
+;;;###autoload
+(defun fnexpand-complete ()
+ "Expand the file name, env var or command near point"
+ (interactive)
+ (and fnexpand-complete-filename-look-right
+ (re-search-forward fnexpand-filename-boundary-chars nil 1)
+ (forward-char -1))
+
+ (let* ((name (fnexpand-find-filename))
+ (completion
+ (fnexpand-read-file-name-internal name default-directory nil)))
+
+ (cond
+ ((eq completion t)
+ (insert " "))
+
+ ((and (null completion) ;try command name
+ fnexpand-executable-enable)
+
+ (setq completion (fnexpand-executable-completions name))
+
+ (cond
+ ((stringp completion)
+ (delete-region (- (point) (length name)) (point))
+ (insert completion))
+
+ ((and (listp completion)
+ (> (length completion) 0))
+ (save-window-excursion
+ (with-output-to-temp-buffer " *Completions*"
+ (display-completion-list
+ completion))
+ (sit-for 32767)))
+ (t
+ (message "[No match]"))))
+
+ (completion
+ (if (equal completion name)
+ (save-window-excursion
+ (with-output-to-temp-buffer " *Completions*"
+ (display-completion-list
+ (fnexpand-read-file-name-internal name
+ default-directory t)))
+ (sit-for 32767))
+ (unwind-protect
+ (if (eq t (fnexpand-read-file-name-internal
+ completion
+ default-directory
+ nil))
+ (setq completion (concat completion " "))))
+ (delete-region (- (point) (length name)) (point))
+ (insert completion)))
+ (t (message "[No match]")))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun fnexpand-env-var-complete ()
+ "This function completes environment varaible.
+It is used in minibuffer. Returns t if completion was not initiated."
+ (cond
+ ((save-excursion
+ (and (skip-chars-backward "^$ \t\n")
+ (string= (char-to-string (preceding-char)) "$")))
+ (call-interactively 'fnexpand-complete)
+ nil)
+ (t
+ t)))
+
+;;; ----------------------------------------------------------------------
+;;; minibuffer's TAB key from complete.el
+;;;
+(defadvice PC-complete (around fnexpand act)
+ "Complete Envinronment variable."
+ (if (fnexpand-env-var-complete) ad-do-it))
+
+;;; ----------------------------------------------------------------------
+;;; TAB
+;;;
+(defadvice minibuffer-complete (around fnexpand act)
+ "Complete Envinronment variables."
+ (if (fnexpand-env-var-complete) ad-do-it))
+
+;;; ----------------------------------------------------------------------
+;;; SPACE
+;;;
+(defadvice PC-complete-word (around fnexpand act)
+ "Complete Envinronment variable."
+ (if (fnexpand-env-var-complete) ad-do-it))
+
+;;; ----------------------------------------------------------------------
+;;; SPACE
+;;;
+(defadvice minibuffer-complete-word (around fnexpand act)
+ "Complete Envinronment variables."
+ (if (fnexpand-env-var-complete) ad-do-it))
+
+(if fnexpand-executable-enable ;update cache immediately
+ (fnexpand-executables 'verb))
+
+(provide 'fnexpand)
+
+;;; fnexpand.el ends here
--- /dev/null
+;;; folding.el --- A folding-editor-like minor mode.
+
+;; This file is not part of Emacs
+
+;; Copyright (C) 2000-2007
+;; Jari Aalto
+;; Copyright (C) 1995-1999
+;; Jari Aalto, Anders Lindgren.
+;; Copyright (C) 1994
+;; Jari Aalto
+;; Copyright (C) 1992, 1993
+;; Jamie Lokier, All rights reserved.
+;;
+;; Author: Jamie Lokier <jamie A T imbolc.ucc dt ie>
+;; Jari Aalto <jari aalto A T cante dt net>
+;; Anders Lindgren <andersl A T csd.uu dt se>
+;; Maintainer: Jari Aalto <jari aalto A T cante dt net>
+;; Created: 1992
+;; Version: 2007.0506
+;; VCS-Version: $Revision: 3.42 $
+;; VCS-URL: http://nongnu.org/projects/emacs-tiny-tools/
+;; VCS-Date: $Date: 2007/05/07 10:50:05 $
+;; Keywords: tools
+
+;;{{{ GPL
+
+;; 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,
+;; or (at your option) any later version.
+;;
+;; GNU Emacs 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 program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+
+;;; Commentary:
+
+;;{{{ Introduction
+
+;; Preface
+;;
+;; This package provides a minor mode, compatible with all major
+;; editing modes, for folding (hiding) parts of the edited text or
+;; program.
+;;
+;; Folding mode handles a document as a tree, where each branch
+;; is bounded by special markers `{{{' and `}}}'. A branch can be
+;; placed inside another branch, creating a complete hierarchical
+;; structure.
+;;
+;; Folding mode can CLOSE a fold, leaving only the initial `{{{'
+;; and possibly a comment visible.
+;;
+;; It can also ENTER a fold, which means that only the current
+;; fold will be visible, all text above `{{{' and below `}}}'
+;; will be invisible.
+;;
+;; Please note, that the maintainers do not recommend to use only
+;; folding for you your code layout and navigation. Folding.el is
+;; on its best when it can "chunk" large sections of code inside
+;; folds. The larger the chunks, the more the usability of
+;; folding will increase. Folding.el is not meant to hide
+;; individual functions: you may be better served by hideshow.el
+;; or imenu.el (which can parse the function indexes)
+
+;;}}}
+;;{{{ Installation
+
+;; Installation
+;;
+;; To install Folding mode, put this file (folding.el) on your
+;; Emacs `load-path' (or extend the load path to include the
+;; directory containing this file) and optionally byte compile it.
+;;
+;; The best way to install folding is the autoload installation,
+;; so that folding is loaded into your emacs only when you turn on
+;; `folding-mode'. This statement speeds up loading your .emacs
+;;
+;; (autoload 'folding-mode "folding" "Folding mode" t)
+;; (autoload 'turn-off-folding-mode "folding" "Folding mode" t)
+;; (autoload 'turn-on-folding-mode "folding" "Folding mode" t)
+;;
+;; But if you always use folding, then perhaps you want more
+;; traditional installation. Here Folding mode starts
+;; automatically when you load a folded file.
+;;
+;; ;; (setq folding-default-keys-function
+;; ;; 'folding-bind-backward-compatible-keys)
+;;
+;; (if (load "folding" 'nomessage 'noerror)
+;; (folding-mode-add-find-file-hook))
+;;
+;; Folding uses a keymap which conforms with the new Emacs
+;; (started 19.29) style. The key bindings are prefixed with
+;; "C-c@" instead of old "C-c". To use the old keyboard bindings,
+;; uncomment the lines in the the above installation example
+;;
+;; The same folding marks can be used in `vim' editor command
+;; "set fdm=marker".
+;;
+;; Uninstallation
+;;
+;; To remove folding, call `M-x' `folding-uninstall'.
+;;
+;; To read the manual
+;;
+;; At any point you can reach the manual with `M-x'
+;; `finder-commentary' RET folding RET.
+
+;;}}}
+;;{{{ DOCUMENTATION
+
+;; Compatibility
+;;
+;; Folding supports following Emacs flavors:
+;;
+;; Unix Emacs 19.28+ and Win32 Emacs 19.34+
+;; Unix XEmacs 19.14+ and Win32 XEmacs 21.0+
+;;
+;; Compatibility not for old NT Emacs releases
+;;
+;; NOTE: folding version starting from 2.47 gets around this bug
+;; by using adviced kill/yank functions. The advice functions are
+;; only instantiated under problematic NT Emacs versions.
+;;
+;; Windows NT/9x 19.34 - 20.3.1 (i386-*-nt4.0) versions contained
+;; a bug which affected using folding. At the time the bug was
+;; reported by Trey Jackson <trey A T cs berkeley edu>
+;;
+;; If you kill folded area and yank it back, the ^M marks are
+;; removed for some reason.
+;;
+;; Before kill
+;; ;;{{{ fold...
+;;
+;; After yank
+;; ;;{{{ fold all lines together }}}
+;;
+;; Relates packages or modes
+;;
+;; Folding.el was designed to be a content organizer and it is most
+;; suitable for big files. Sometimes people misunderstand the
+;; package's capabilities and try to use folding.el in wrong places,
+;; where some other package would do a better job. Trying to wrap
+;; individual functions inside fold-marks is not where folding is
+;; it's best. Grouping several functions inside a logical fold-block
+;; in the other is. So, to choose a best tool for your need,
+;; here are some suggestions,:
+;;
+;; o Navigating between or hiding individual functions -
+;; use combination of imenu.el, speedbar.el and
+;; hideshow.el
+;; o Organizing large blocks - use folding.el
+;; o For text, `outline-mode' is more non-intrusive than folding.
+;; Look at Emacs NEWS file (`C-x' `n') and you can see beatifully
+;; laid content.
+;;
+;; Tutorial
+;;
+;; To start folding mode, give the command: `M-x' `folding-mode'
+;; `RET'. The mode line should contain the string "Fld" indicating
+;; that folding mode is activated.
+;;
+;; When loading a document containing fold marks, Folding mode is
+;; automatically started and all folds are closed. For example when
+;; loading my init file, only the following lines (plus a few lines
+;; of comments) are visible:
+;;
+;; ;;{{{ General...
+;; ;;{{{ Keyboard...
+;; ;;{{{ Packages...
+;; ;;{{{ Major modes...
+;; ;;{{{ Minor modes...
+;; ;;{{{ Debug...
+;;
+;; To enter a fold, use `C-c @ >'. To show it without entering,
+;; use `C-c @ C-s', which produces this display:
+;;
+;; ;;{{{ Minor modes
+;;
+;; ;;{{{ Follow mode...
+;; ;;{{{ Font-lock mode...
+;; ;;{{{ Folding...
+;;
+;; ;;}}}
+;;
+;; To show everything, just as the file would look like if
+;; Folding mode hadn't been activated, give the command `M-x'
+;; `folding-open-buffer' `RET', normally bound to `C-c' `@'
+;; `C-o'. To close all folds and go to the top level, the
+;; command `folding-whole-buffer' could be used.
+;;
+;; Mouse support
+;;
+;; Folding mode v2.0 introduced mouse support. Folds can be shown
+;; or hidden by simply clicking on a fold mark using mouse button
+;; 3. The mouse routines have been designed to call the original
+;; function bound to button 3 when the user didn't click on a
+;; fold mark.
+;;
+;; The menu
+;;
+;; A menu is placed in the "Tools" menu. Should no Tools menu exist
+;; (Emacs 19.28) the menu will be placed in the menu bar.
+;;
+;; ISearch
+;;
+;; When searching using the incremental search (C-s) facilities,
+;; folds will be automagically entered and closed.
+;;
+;; Problems
+;;
+;; Uneven fold marks
+;;
+;; Oops, I just deleted some text, and a fold mark got deleted!
+;; What should I do? Trust me, you will eventually do this
+;; sometime. the easiest way is to open the buffer using
+;; `folding-open-buffer' (C-c @ C-o) and add the fold mark by
+;; hand. To find mismatching fold marks, the package `occur' is
+;; useful. The command:
+;;
+;; M-x occur RET {{{\|}}} RET
+;;
+;; will extract all lines containing folding marks and present
+;; them in a separate buffer.
+;;
+;; Even though all folding marks are correct, Folding mode
+;; sometimes gets confused, especially when entering and leaving
+;; folds very often. To get it back on track, press C-g a few
+;; times and give the command `folding-open-buffer' (C-c @ C-o).
+;;
+;; Fold must have a label
+;;
+;; When you make a fold, be sure to write some text for the name
+;; of the fold, otherwise there may be an error "extraneous fold
+;; mark..." Write like this:
+;;
+;; ;;{{{ Note
+;; ;;}}}
+;;
+;; instead of
+;;
+;; ;;{{{
+;; ;;}}}
+;;
+;; folding-whole-buffer doesn't fold whole buffer
+;;
+;; If you call commands `folding-open-buffer' and
+;; `folding-whole-buffer' and notice that there are open fold
+;; sections in the buffer, then you have mismatch of folds
+;; somewhere. Run ` M-x' `occur' and type regexp `{{{\|}}}' to
+;; check where is the extra open or closing fold mark.
+;;
+;; Folding and outline modes
+;;
+;; Folding mode is not the same as Outline mode, a major and
+;; minor mode which is part of the Emacs distribution. The two
+;; packages do, however, resemble each other very much. The main
+;; differences between the two packages are:
+;;
+;; o Folding mode uses explicit marks, `{{{' and `}}}', to
+;; mark the beginning and the end of a branch.
+;; Outline, on the other other hand, tries to use already
+;; existing marks, like the `\section' string in a TeX
+;; document.
+;;
+;; o Outline mode has no end marker which means that it is
+;; impossible for text to follow a sub-branch.
+;;
+;; o Folding mode use the same markers for branches on all depths,
+;; Outline mode requires that marks should be longer the
+;; further, down in the tree you go, e.g `\chap', \section',
+;; `\subsection', `\subsubsection'. This is needed to
+;; distinguish the next mark at the current or higher levels
+;; from a sub-branch, a problem caused by the lack of
+;; end-markers.
+;;
+;; o Folding mode has mouse support, you can navigate through a
+;; folded document by clicking on fold marks. (The XEmacs version
+;; of Outline mode has mouse support.)
+;;
+;; o The Isearch facilities of Folding is capable of
+;; automatically to open folds. Under Outline, the the entire
+;; document must be opened prior isearch.
+;;
+;; In conclusion, Outline mode is useful when the document being
+;; edited contains natural markers, like LaTeX. When writing code
+;; natural markers are hard to find, except if you're happy with
+;; one function per fold.
+;;
+;; Future development ideas
+;;
+;; The plan was from the beginning to rewrite the entire package.
+;; Including replacing the core of the program, written using
+;; old Emacs technology (selective display), and replace it with
+;; modern equivalences, like overlays or text-properties for
+;; Emacs and extents for XEmacs.
+;;
+;; It is not likely that any of this will come true considering
+;; the time required to rewrite the core of the package. Since
+;; the package, in it's current state, is much more powerful than
+;; the original, it would be appropriate to write such package
+;; from scratch instead of doing surgery on this one.
+
+;;}}}
+
+;;{{{ Customization
+
+;; Customization: general
+;;
+;; The behavior of Folding mode is controlled mainly by a set of
+;; Emacs Lisp variables. This section will discuss the most
+;; useful ones, for more details please see the code. The
+;; descriptions below assumes that you know a bit about how to
+;; use simple Emacs Lisp and knows how to edit ~/.emacs, your
+;; init file.
+;;
+;; Customization: hooks
+;;
+;; The normal procedure when customizing a package is to write a
+;; function doing the customization. The function is then added
+;; to a hook which is called at an appropriate time. (Please see
+;; the example section below.) The following hooks are
+;; available:
+;;
+;; o `folding-mode-hook'
+;; Called when folding mode is activated.
+;; o `<major mode>-folding-hook'
+;; Called when starting folding mode in a buffer with major
+;; mode set to <major mode>. (e.g. When editing C code
+;; the hook `c-mode-folding-hook' is called.)
+;; o `folding-load-hook'
+;; Called when folding mode is loaded into Emacs.
+;;
+;; Customization: The Mouse
+;;
+;; The variable `folding-behave-table' contains the actions which
+;; should be performed when the user clicks on an open fold, a
+;; closed fold etc. For example, if you prefer to `enter' a fold
+;; rather than `open' it you should rebind this variable.
+;;
+;; The variable `folding-default-mouse-keys-function' contains
+;; the name of the function used to bind your mouse keys. To use
+;; your own mouse bindings, create a function, say
+;; `my-folding-bind-mouse', and set this variable to it.
+;;
+;; Customization: Keymaps
+;;
+;; When Emacs 19.29 was released, the keymap was divided into
+;; strict parts. (This division existed before, but a lot of
+;; packages, even the ones delivered with Emacs, ignored them.)
+;;
+;; C-c <letter> -- Reserved for the users private keymap.
+;; C-c C-<letter> -- Major mode. (Some other keys are
+;; reserved as well.)
+;; C-c <Punctuation Char> <Whatever>
+;; -- Reserved for minor modes.
+;;
+;; The reason why `C-c@' was chosen as the default prefix is that
+;; it is used by outline-minor-mode. It is not likely that few
+;; people will try to use folding and outline at the same time.
+;;
+;; However, old key bindings have been kept if possible. The
+;; variable `folding-default-keys-function' specifies which
+;; function should be called to bind the keys. There are various
+;; function to choose from how user can select the keybindings.
+;; To use the old key bindings, add the following line to your
+;; init file:
+;;
+;; (setq folding-default-keys-function
+;; 'folding-bind-backward-compatible-keys)
+;;
+;; To define keys similar to the keys used by Outline mode, use:
+;;
+;; (setq folding-default-keys-function
+;; 'folding-bind-outline-compatible-keys)
+;;
+;; Customization: adding new major modes
+;;
+;; To add fold marks for a new major mode, use the function
+;; `folding-add-to-marks-list'. Example:
+;;
+;; (folding-add-to-marks-list
+;; 'c-mode "/* {{{ " "/* }}} */" " */" t)
+;; (folding-add-to-marks-list
+;; 'java-mode "// {{{ " "// }}}" nil t)
+;;
+;; Customization: ISearch
+;;
+;; If you don't like the extension folding.el applies to isearch,
+;; set the variable `folding-isearch-install' to nil before
+;; loading this package.
+
+;;}}}
+;;{{{ Examples
+
+;; Example: personal setup
+;;
+;; To define your own key binding instead of using the standard
+;; ones, you can do like this:
+;;
+;; (setq folding-mode-prefix-key "\C-c")
+;; ;;
+;; (setq folding-default-keys-function
+;; '(folding-bind-backward-compatible-keys))
+;; ;;
+;; (setq folding-load-hook 'my-folding-load-hook)
+;;
+;;
+;; (defun my-folding-load-hook ()
+;; "Folding setup."
+;;
+;; (folding-install) ;; just to be sure
+;;
+;; ;; ............................................... markers ...
+;;
+;; ;; Change text-mode fold marks. Handy for quick
+;; ;; sh/perl/awk code
+;;
+;; (defvar folding-mode-marks-alist nil)
+;;
+;; (let* ((ptr (assq 'text-mode folding-mode-marks-alist)))
+;; (setcdr ptr (list "# {{{" "# }}}")))
+;;
+;; ;; ........................................ bindings ...
+;;
+;; ;; Put `folding-whole-buffer' and `folding-open-buffer'
+;; ;; close together.
+;;
+;; (defvar folding-mode-prefix-map nil)
+;;
+;; (define-key folding-mode-prefix-map "\C-w" nil)
+;; (define-key folding-mode-prefix-map "\C-s"
+;; 'folding-show-current-entry)
+;; (define-key folding-mode-prefix-map "\C-p"
+;; 'folding-whole-buffer))
+;;
+;; Example: changing default fold marks
+;;
+;; In case you're not happy with the default folding marks, you
+;; can change them easily. Here is an example
+;;
+;; (setq folding-load-hook 'my-folding-load-hook)
+;;
+;; (defun my-folding-load-hook ()
+;; "Folding vars setup."
+;; (let* ((ptr (assq 'text-mode folding-mode-marks-alist)))
+;; (setcdr ptr (list "# {{{" "# }}}"))))
+;;
+;;
+;; Example: choosing different fold marks for mode
+;;
+;; Suppose you sometimes want to use different fold marks for the
+;; major mode: e.g. to alternate between "# {{{" and "{{{" in
+;; `text-mode' Call `M-x' `my-folding-text-mode-setup' to change
+;; the marks.
+;;
+;; (defun my-folding-text-mode-setup (&optional use-custom-folding-marks)
+;; (interactive
+;; (list (y-or-n-p "Use Custom fold marks now? ")))
+;; (let* ((ptr (assq major-mode folding-mode-marks-alist))
+;; (default-begin "# {{{")
+;; (default-end "# }}}")
+;; (begin "{{{")
+;; (end "}}}"))
+;; (when (eq major-mode 'text-mode)
+;; (unless use-custom-folding-marks
+;; (setq begin default-begin end default-end)))
+;; (setcdr ptr (list begin end))
+;; (folding-set-marks begin end)))
+;;
+;; Example: AucTex setup
+;;
+;; Suppose you're using comment.sty with AucTeX for editing
+;; LaTeX2e documents and you have these comment types. You would
+;; like to be able to set which of these 3 is to be folded at any
+;; one time, using a simple key sequence: move back and forth
+;; easily between the different comment types, e.g., "unfold
+;; everything then fold on \x".
+;;
+;; \O ... \endO
+;; \L ... \endL
+;; \B ... \endB
+;;
+;; (setq folding-load-hook 'my-folding-load-hook)
+;;
+;; (defun my-folding-load-hook ()
+;; "Folding vars setup."
+;; (let ((ptr (assq 'text-mode folding-mode-marks-alist)))
+;; (setcdr ptr (list "\\O" "\\endO"))
+;; (define-key folding-mode-prefix-map "C"
+;; 'my-folding-marks-change)))
+;;
+;; (defun my-folding-marks-change (&optional selection)
+;; "Select folding marks: prefixes nil, C-u and C-u C-u."
+;; (interactive "P")
+;; (let ((ptr (assq major-mode folding-mode-marks-alist))
+;; input)
+;; (when (string-match "^\\(plain-\\|la\\|auc\\)?tex-"
+;; (symbol-name major-mode))
+;; (setq input
+;; (read-string "Latex \\end(X) Marker (default O): "
+;; nil nil "O" nil))
+;; (setq input (upcase input))
+;; (turn-off-folding-mode)
+;; (folding-add-to-marks-list
+;; major-mode
+;; (concat "\\" input) (concat "\\end" input) nil nil t)
+;; ;; (setcdr ptr (list (concat "\\" input) (concat "\\end" input)))
+;; (turn-on-folding-mode))))
+;; ;; End of example
+;;
+;; Bugs: Lazy-shot.el conflict in XEmacs
+;;
+;; [XEmacs 20.4 lazy-shot-mode]
+;; 1998-05-28 Reported by Solofo Ramangalahy <solofo A T mpi-sb mpg de>
+;;
+;; % xemacs -q folding.el
+;; M-x eval-buffer
+;; M-x folding-mode
+;; M-x font-lock-mode
+;; M-x lazy-shot-mode
+;; C-s mouse
+;;
+;; then search for mouse again and again. At some point you will
+;; see "Deleting extent" in the minibuffer and XEmacs freezes.
+;;
+;; The strange point is that I have this bug only under Solaris
+;; 2.5 sparc (binaries from ftp.xemacs.org) but not under Solaris
+;; 2.6 x86. (XEmacs 20.4, folding 2.35). I will try to access
+;; more machines to see if it's the same.
+;;
+;; I suspect that the culprit is lazy-shot as it is beta, but
+;; maybe you will be able to describe the bug more precisely to
+;; the XEmacs people I you can reproduce it.
+
+;;}}}
+;;{{{ Old Documentation
+
+;; Old documentation
+;;
+;; The following text was written by Jamie Lokier for the release
+;; of Folding V1.6. It is included here for no particular reason:
+;;
+;; Emacs 18:
+;; Folding mode has been tested with versions 18.55 and
+;; 18.58 of Emacs.
+;;
+;; Epoch:
+;; Folding mode has been tested on Epoch 4.0p2.
+;;
+;; [X]Emacs:
+;; There is code in here to handle some aspects of XEmacs.
+;; However, up to version 19.6, there appears to be no way to
+;; display folds. Selective-display does not work, and neither do
+;; invisible extents, so Folding mode has no chance of
+;; working. This is likely to change in future versions of
+;; XEmacs.
+;;
+;; Emacs 19:
+;; Tested on version 19.8, appears to be fine. Minor bug:
+;; display the buffer in several different frames, then move in
+;; and out of folds in the buffer. The frames are automatically
+;; moved to the top of the stacking order.
+;;
+;; Some of the code is quite horrible, generally in order to
+;; avoid some Emacs display "features". Some of it is specific to
+;; certain versions of Emacs. By the time Emacs 19 is around and
+;; everyone is using it, hopefully most of it won't be necessary.
+;;
+;; More known bugs
+;;
+;; *** Needs folding-fold-region to be more intelligent about
+;; finding a good region. Check folding a whole current fold.
+;;
+;; *** Now works with 19! But check out what happens when you
+;; exit a fold with the file displayed in two frames. Both
+;; windows get fronted. Better fix that sometime.
+;;
+;; Future features
+;;
+;; *** I will add a `folding-next-error' sometime. It will only
+;; work with Emacs versions later than 18.58, because compile.el
+;; in earlier versions does not count line-numbers in the right
+;; way, when selective display is active.
+;;
+;; *** Fold titles should be optionally allowed on the closing
+;; fold marks, and `folding-tidy-inside' should check that the
+;; opening title matches the closing title.
+;;
+;; *** `folded-file' set in the local variables at the end of a
+;; file could encode the type of fold marks used in that file,
+;; and other things, like the margins inside folds.
+;;
+;; *** I can see a lot of use for the newer features of Emacs 19:
+;;
+;; Using invisible text-properties (I hope they are intended to
+;; make text invisible; it isn't implemented like that yet), it
+;; will be possible to hide folded text without affecting the
+;; text of the buffer. At the moment, Folding mode uses selective
+;; display to hide text, which involves substituting
+;; carriage-returns for line-feeds in the buffer. This isn't such
+;; a good way. It may also be possible to display different folds
+;; in different windows in Emacs 19.
+;;
+;; Using even more text-properties, it may be possible to track
+;; pointer movements in and out of folds, and have Folding mode
+;; automatically enter or exit folds as necessary to maintain a
+;; sensible display. Because the text itself is not modified (if
+;; overlays are used to hide text), this is quite safe. It would
+;; make it unnecessary to provide functions like
+;; `folding-forward-char', `folding-goto-line' or
+;; `folding-next-error', and things like I-search would
+;; automatically move in and out of folds as necessary.
+;;
+;; Yet more text-properties/overlays might make it possible to
+;; avoid using narrowing. This might allow some major modes to
+;; indent text properly, e.g., C++ mode.
+
+;;}}}
+
+;;; Change Log:
+
+;;{{{ History
+;; [person version] = developer and his revision tree number.
+;;
+;; May 06 2007 21.4 [jari 3.38-3.41 2007.0506]
+;; - Cleanup. Eol whitespaces removed, extra newlines cleaned.
+;; Paren positions corrected.
+;; - 'Personal reflections by Anders Lindgren' topic
+;; rephrased 'Future development ideas'
+;;
+;; Nov 16 2006 21.4 [jari 3.36-3.37 2006.1118]
+;; - Jeremy Hankins <nowan A T nowan org> sent a patch, which
+;; adds variable `folding-narrow-by-default'. The patch affects
+;; mostly `folding-shift-in'. This makes it possible to
+;; advise viper-search to open folds. Thanks.
+;; - Added VCS URL header to the beginning for canonnical location.
+;; Updated maintainer section.
+;; - Fixed Copyright years.
+;;
+;; Nov 25 2004 21.3 [jari 3.35 2004.1125]
+;; - non-ascii character removed from bibtex-mode.
+;; Changed bib-mode '@comment' => '%'. Closes Debian
+;; Bug#282388
+;;
+;; Sep 10 2004 21.3 [jari 2.116 2004.0910]
+;; - (folding-fold-region): caused to indent bottom fold
+;; some 50 spaces forward in auctex:latex-mode. Disabled
+;; running `indent-according-to-mode' while in latex-mode.
+;; Bug reported by Uwe Brauer; oub A T mat dot ucm dot es
+;; - Removed extra newlines from whole buffer.
+;; - Changed version scheme to date based YYYY.MMDD
+;; - Removed unnecessary 'all rights reserved'.
+;; - (folding-check-folded): Added check for \r character, which
+;; - protected all email addresses by removing AT-signs.
+;;
+;; Apr 01 2004 21.3 [jari 2.111-2.115]
+;; - Merged in changes made by 2003-11-12 Adrian Aichner
+;; from XEmacs tree 1.15; Typo fixes for docstrings and comments.
+;; - Returned to old bug and solved it in a better way (preserve region) by
+;; using different expansion macros for XEmacs and Emacs.
+;; See See http://list-archive.xemacs.org/xemacs-beta/199810/msg00039.html
+;; - (folding-forward-char-1): 2.112 Renamed.
+;; Was `folding-forward-char'.
+;; (folding-backward-char-1): 2.112 Renamed.
+;; Was `folding-backward-char'.
+;; (folding-forward-char-macro): 2.112 New. Fix XEmacs
+;; region preservation with '_p' interactive spec.
+;; (folding-backward-char-macro): 2.112 New. Fix XEmacs
+;; region preservation with '_p' interactive spec.
+;; (folding-interactive-spec-p): 2.112 New.
+;;
+;; Sep 11 2003 21.2 [jari 2.107-2.111]
+;; - Added new sections "Uninstallation" and "To read the manual".
+;; M-x finder can invoke folding too provided that patch to
+;; lisp-mnt.el and finder.el is installed. Sent patch to XEmacs and
+;; Emacs developers.
+;; - Moved fold-mark ";;{{{ Introduction" after the Commentary:
+;; tag to have it included in M-x finder-commentary.
+;; - If called like this: `folding-uninstall' and immediately
+;; `folding-mode', the keybindings were not there any more. Added
+;; call to `folding-install' in `folding-mode'.
+;; - Completely rewrote `folding-install'. It's now divided into
+;; `folding-install-keymaps' and `folding-uninstall-keymaps'
+;; - Added support for `php-mode', `javascript-mode',
+;; `change-log-mode' and `finder-mode'.
+;; - Documentation changes (fit all to 80 characters).
+;;
+;; Aug 21 2002 21.2 [jari 2.105-2.106]
+;; - Added user function `folding-uninstall'.
+;; - Removed `interactive' status: `folding-install-hooks' and
+;; `folding-uninstall-hooks'
+;;
+;; Aug 02 2002 20.7 [jari 2.101-2.104]
+;; - Added font lock support. Now beginning and end markers are
+;; highlighted with user variables `folding-font-lock-begin-mark'
+;; `folding-font-lock-end-mark'. Feature suggested by
+;; <Claude BOUCHER A T astrium-space com>
+;; - Removed LCD entry - unnecessary.
+;;
+;; Jan 24 2002 20.7 [jari 2.100]
+;; - (folding-context-next-action):New user function.
+;; Code by Scott Evans <gse A T antisleep com>
+;; - (folding-bind-default-keys): Added
+;; C-x . to run `folding-context-next-action'
+;; - (folding-mouse-call-original): Added `car-safe' to read
+;; EVENT, which may be nil.
+;;
+;; Jul 31 2001 20.7 [jari 2.98-2.99]
+;; - Gleb Arshinov <gleb A T barsook com> fixed the broken XEmacs
+;; isearch support and sent nice patch.
+;;
+;; Jul 19 2001 20.7 [jari 2.92-2.97]
+;; - Beautified lisp code by removing parens that were alone.
+;; - XEmacs latex-mode fix. The folds were strangely indented too
+;; far right. The cause was `indent-according-to-mode' which is
+;; now disabled in latex. bug reported by
+;; Uwe Brauer; oub A T maraton sim ucm es
+;; - 2.96 Erroneous `:' in `folding-mode-write-file'
+;; when it should have been `;'. Bug reported by
+;; Brand Michael; michael brand A T siemens com
+;;
+;; Apr 04 2001 20.7 [jari 2.89-2.91]
+;; - Small corrections to find-func.el::find-function-search-for-symbol
+;; implementation.
+;;
+;; Mar 08 2001 20.6 [jari 2.88]
+;; - Dave Masterson <dmasters A T rational com> reported that jumping to a
+;; url displayed by the C-h f FUNCTION which told where the function
+;; was located died. The reason was that the buffer was folded and
+;; find-func.el::find-function-search-for-symbol used regexps that
+;; do not take into account folded buffers. The regexps used there
+;; rely on syntax tables.
+;; - Added two new advices to catch find-func.el and unfold the buffer
+;; prior searching: (advice find-file-noselect after) and (advice
+;; find-function-search-for-symbol around)
+;;
+;; Mar 04 2001 20.6 [jari 2.83-2.87]
+;; - Added ###autoload statements, tidied up empty lines and lisp syntax.
+;; - Run checkdoc.el 0.6.1 and corrected errors.
+;;
+;; Jan 04 2001 20.6 [jari 2.82]
+;; - Added FOLD highlight feature for XEmacs:
+;; `folding-mode-motion-highlight-fold'
+;; and package `mode-motion' Suggested by
+;; Thomas Ruhnau <thomas ruhnau A T intermetall de>
+;; - (folding-bind-default-keys): 2.81 New binding C-k
+;; `folding-marks-kill'
+;; (fold-marks-kill): 2.81 New.
+;;
+;; Jan 03 2001 20.6 [jari 2.81]
+;; - (folding-folding-region): 2.80 Renamed to `folding-fold-region'
+;; - (folding-mark-look-at-top-mark-p): 2.80 New.
+;; - (folding-mark-look-at-bottom-mark-p): 2.80 New.
+;; - (folding-tidy-inside): 2.80 Use `folding-mark-look-at-top-mark-p'
+;; and `folding-mark-look-at-bottom-mark-p'.
+;; - Didn't accept spaces in front of fold markers.
+;; - (folding-fold-region): 2.80 Added `indent-according-to-mode'
+;; to indent folds as needed.
+;;
+;; Dec 16 2000 20.6 [jari 2.79-2.80]
+;; - `folding-xemacs-p' now test (featurep 'xemacs)
+;; - Added missing folding functions to the menubar
+;; - `folding-package-url-location' new variable used by function
+;; `folding-insert-advertise-folding-mode'
+;; - `folding-keep-hooked' was commented out in `folding-mode'. Added
+;; back.
+;;
+;; Jul 25 2000 20.6 [jari 2.76-2.78]
+;; - 2.75 Added support for modes:
+;; xrdb-mode, ksh-mode and sql-mode contributed by
+;; Juhapekka Tolvanen <juhtolv A T st jyu fi>. Scanned systematically
+;; all modes under Emacs 20.6 progmodes and added support for:
+;; ada-mode, asm-mode, awk-mode, cperl-mode, fortran-mode, f90-mode,
+;; icon-mode, m4-mode, meta-mode, pascal-mode, prolog-mode,
+;; simula-mode, vhdl-mode, bibtex-mode, nroff-mode, scribe-mode(*),
+;; sgml-mode
+;; - Mode marked with (*) was not added.
+;; - (folding-insert-advertise-folding-mode): 2.76 New. Suggested by
+;; Juhapekka Tolvanen <juhtolv A T st jyu fi>
+;; - (folding-bind-default-keys): 2.76
+;; folding-insert-advertise-folding-mode Bound to key "I"
+;;
+;; Apr 24 1999 20.4 [jari 2.73-2.75]
+;; - (folding-bind-terminal-keys): 2.74 New. Bind C-f and C-b only at
+;; non-window system where they are really needed. Someone may use
+;; C-f for `isearch-forward' in windowed Emacs.
+;; - (folding-bind-default-keys): 2.74 Use `folding-bind-terminal-keys'
+;; - (folding-bind-outline-compatible-keys): 2.74
+;; Use `folding-bind-terminal-keys'
+;;
+;; Feb 13 1999 20.4 [jari 2.71-2.72]
+;; - (folding-event-posn): 2.70 Wrong
+;; place of paren and the following was malformed call:
+;; (let* ((el (funcall (symbol-function 'event-start) event)))
+;;
+;; Jan 13 1999 20.4 [jari 2.70]
+;; - 2.69 The `looking-at' is now smarter with
+;; fold beginning marks. The tradition has been the the fold always
+;; has a name, so the requirement to search fold is "{{{ ". Now
+;; the " " is searched as " *", not requiring a space --> not requiring
+;; a fold name.
+;; - (folding-skip-folds): >>feature not not enabled<<
+;; 2.69 Do not require trailing " " any more.'
+;; (folding-tidy-inside): >>feature not not enabled<<
+;; 2.69 Do not require trailing " " any more.
+;; - (folding-install): 2.69 Fixed indentation.
+;; - (folding-mark-look-at): 2.69 The "em" missed "*" and thus pressing
+;; mouse-3 at the end-fold didn't collapse the whole fold.
+;;
+;; Jan 12 1999 20.4 [jari 2.69]
+;; (folding-bind-default-mouse): 2.68
+;; XEmacs and Emacs Mouse binding was different. Now use common
+;; bindings: The S-mouse-2 was superfluous, because mouse-3 already
+;; did that, so the binding was removed.
+;; mouse-3 folding-mouse-context-sensitive
+;; S-mouse-2 folding-hide-current-entry
+;; C-S-mouse-2 folding-mouse-pick-move
+;;
+;;;; Jan 09 1999 20.4 [jari 2.67-2.68]
+;; - (folding-event-posn): 2.66 Hide `event-start' From XEmacs
+;; (byte compile silencer)
+;;
+;; Jan 07 1999 20.4 [jari 2.65-2.66]
+;; - The Folding begin and AND mark was not case sensitive;
+;; that's why a latex styles "\B" and "\endB" fold marks couldn't
+;; be used. Added relevant `case-fold-search' settings. Not tested
+;; very well, though.
+;; - Added standard "turn-on" "turn-off" functions.
+;; - (folding-whole-buffer): 2.65 Better
+;; Error message. Show used folding-mark on error.
+;; - (folding-skip-folds): 2.65 Moved docs in function.
+;; - (turn-off-folding-mode): 2.65 New.
+;; - (turn-on-folding-mode): 2.65 New.
+;; - (folding-mark-look-at): 2.65 `case-fold-search'
+;; - (folding-next-visible-heading): 2.65 `case-fold-search'
+;; - (folding-find-folding-mark): 2.65 `case-fold-search'
+;; - (folding-pick-move): 2.65 `case-fold-search'
+;; - (folding-skip-folds): 2.65 `case-fold-search'
+;; - (folding-tidy-inside): 2.65 `case-fold-search'
+;; - (folding-convert-to-major-folds): 2.65 `case-fold-search'
+;;
+;; Jan 04 1999 20.4 [jari 2.62-2.64]
+;; - (folding-set-local-variables): 2.61 New. Now it is possible to
+;; change the folding marks dynamically.
+;; - (folding-mode): 2.61 Call `folding-set-local-variables'
+;; (folding-mode-marks-alist): 2.61 mention
+;; - `folding-set-local-variables'
+;; Added documentation section: "Example: AucTex setup"
+;; - NT Emacs fix wrapped inside `eval-and-compile'. hs-discard-overlays
+;; are now hidden from byte compiler (since the code is not
+;; executed anyway)
+;;
+;; May 24 1999 19.34 [jari 2.59-2.61]
+;; - New function `folding-all-comment-blocks-in-region'. Requested by
+;; Uwe Brauer <oub A T eucmos sim ucm es>. Bound under "/" key.
+;; - (folding-all-comment-blocks-in-region):
+;; Check non-whitespace `comment-end'. Added `matlab-mode' to
+;; fold list
+;; - (folding-event-posn): 2.63 Got rid of the XEmacs/Emacs
+;; posn-/event- byte compiler warnings
+;; - (folding-mouse-call-original): 2.63 Got rid of the XEmacs
+;; `event-button' byte compiler warning.
+;;
+;; Apr 15 1999 19.34 [jari 2.57]
+;; - (folding-mouse-call-original): Samuel Mikes
+;; <smikes A T alumni hmc edu> reported that the `concat' function was
+;; used to add an integer to "button" event. Applied patch to use
+;; `format' instead.
+;;
+;; Mar 03 1999 19.34 [andersl]
+;; - (folding-install): had extra paren. Removed.
+;;
+;; Feb 22 1999 19.34 [jari 2.56]
+;; - folding-install):
+;; Check if `folding-mode-prefix-map' is nil and call
+;;
+;; Feb 19 1999 19.34 [jari 2.55]
+;; - (folding-mode-hook-no-re):
+;; Renamed to `folding-mode-hook-no-regexp'
+;; - (fold-inside-mode-name): Renames to `folding-inside-mode-name'
+;; (fold-mode-string): Renamed to `folding-mode-string'
+;; - Renamed all `fold-' prefixes to `folding-'
+;; - Rewrote chapter `Example: personal setup'
+;;
+;; Jan 01 1999 19.34 [jari 2.54]
+;; - Byte compiler error fix: (folding-bind-outline-compatible-keys):
+;; 'folding-show-all lacked the quote.
+;;
+;; Dec 30 1998 19.34 [jari 2.53]
+;; - Jesper Pedersen <blackie A T imada ou dk> reported bug that hiding
+;; subtree was broken. This turned out to be a bigger problem in fold
+;; handling in general. This release has big relatively big error
+;; fixes.
+;; - Many of the folding functions were also renamed to mimic Emacs 20.3
+;; allout.el names. Outline keybindings were rewritten too.
+;; - folding.el (folding-mouse-yank-at-point): Renamed from
+;; `folding-mouse-operate-at-point'. The name is similar to Emacs
+;; standard variable name. The default value changed from nil --> t
+;; according to suggestion by Jesper Pedersen <blackie A T imada ou dk>
+;; Message "Info, Ignore [X]Emacs specific..." is now displayed only
+;; while byte compiling file.
+;; (folding-bind-outline-compatible-keys):
+;; Checked the Emacs 20.3 allout.el outline bindings and made
+;; folding mimic them
+;; (folding-show-subtree): Renamed to `folding-show-current-subtree'
+;; according to allout.el
+;; (folding-hide-subtree): Renamed to `folding-hide-current-subtree'
+;; according to allout.el
+;; (folding-enter): Renamed to `folding-shift-in'
+;; according to allout.el
+;; (folding-exit): Renamed to `folding-shift-out'
+;; according to allout.el
+;; (folding-move-up): Renamed to `folding-previous-visible-heading'
+;; according to allout.el
+;; (folding-move): Renamed to `folding-next-visible-heading'
+;; according to allout.el
+;; (folding-top-level): Renamed to `folding-show-all'
+;; according to allout.el
+;; (folding-show): Renamed to `folding-show-current-entry'
+;; according to allout.el
+;; (folding-hide): Renamed to `folding-hide-current-entry'
+;; according to allout.el
+;; (folding-region-open-close): While loop rewritten so that if user
+;; is already on a fold mark, then close current fold. This also
+;; fixed the show/hide subtree problem.
+;; (folding-hide-current-subtree): If use hide subtree that only had
+;; one fold, then calling this function caused error. The reason was
+;; error in `folding-pick-move' (folding-pick-move): Test that
+;; `moved' variable is integer and only then move point. This is the
+;; status indicator from `folding-find-folding-mark'
+;; (folding-find-folding-mark): Fixed. mistakenly moved point when
+;; checking TOP level marker, status 11. the point was permanently
+;; moved to point-min.
+;;
+;; Dec 29 1998 19.34 [jari 2.51]
+;; - Jesper Pedersen <blackie A T imada ou dk> reported that prefix key
+;; cannot take vector notation [(key)]. This required changing the way
+;; how folding maps the keys. Now uses intermediate keymap
+;; `folding-mode-prefix-map'
+;; - `folding-kbd' is new.
+;; - `folding-mode' function description has better layout.
+;; - `folding-get-mode-marks' is now defsubst.
+;;
+;; Dec 13 1998 19.34 [jari 2.49-2.50]
+;; - Gleb Arshinov <gleb A T CS Stanford EDU> reported that the XEmacs 21.0
+;; `concat' function won't accept integer argument any more and
+;; provided patch for `folding-set-mode-line'.
+;;
+;; Nov 28 1998 19.34 [jari 2.49-2.50]
+;; - Gleb Arshinov <gleb A T CS Stanford EDU> reported that the
+;; zmacs-region-stays must not be set globally but in the functions
+;; that need it. He tested the change on tested on XEmacs 21.0 beta
+;; and FSF Emacs 19.34.6 on NT and sent a patch . Thank you.
+;; - (folding-preserve-active-region): New macro to set
+;; `zmacs-region-stays' to t in XEmacs.
+;; - (folding-forward-char): Use `folding-preserve-active-region'
+;; - (folding-backward-char): Use `folding-preserve-active-region'
+;; - (folding-end-of-line): Use `folding-preserve-active-region'
+;; - (folding-isearch-general): Variables `is-fold' and
+;; `is narrowed' removed, because they were not used. (Byte
+;; Compilation fix)
+;; - Later: interestingly using `defmacro'
+;; folding-preserve-active-region does not work in XEmacs 21.0 beta,
+;; but `defsubst' does. Reported and corrected by Gleb.
+;;
+;; Oct 22 1998 19.34 [jari 2.47-2.48]
+;; - NT Emacs has had long time a bug where it strips away ^M when
+;; closed fold is copied to kill ring. When pasted, then ^M are
+;; gone. This cover NT Emacs releases 19.34 - 20.3. Bug report has
+;; been filed.
+;; - to cope with the situation I added new advice functions that
+;; get instantiated only for these versions of NT Emacs. See
+;; `kill-new' and `current-kill'
+;;
+;; Oct 21 1998 19.34 [jari 2.46]
+;; - `folding-isearch-general' now enters folds as usual with isearch.
+;; The only test needed was to check `quit-isearch' before calling
+;; `folding-goto-char', because the narrow case was already taken
+;; cared of in the condition case.
+;;
+;; Oct 19 1998 19.34 [jari 2.44]
+;; - 1998-10-19 Uwe Brauer <oub A T sunma4 mat ucm es> reported that
+;; In Netscape version > 4 the {{{ marks cannot be used. For IE they
+;; were fine, but not for Netscape. Some bug there.
+;; --> Marks changed to [[[ ]]]
+;;
+;; Oct 5 1998 19.34 [jari 2.43]
+;; - The "_p" flag does not exist in Emacs 19.34, so the previous patch
+;; was removed. <greg A T alphatech com> (Greg Klanderman) suggested using
+;; `zmacs-region-stays'. Added to the beginning of file.
+;; - todo: folding does not seem to open folds any more with Isearch.
+;;
+;; Oct 5 1998 19.34 [jari 2.42]
+;; - Gleb Arshinov <gleb A T cs stanford edu> reported (and supplied patch):
+;; I am using the latest beta of folding.el with XEmacs 21.0 "Finnish
+;; Landrace" [Lucid] (i386-pc-win32) (same bug is present with folding.el
+;; included with XEmacs). Being a big fan of zmacs-region, I was
+;; disappointed to find that folding mode caused my usual way of
+;; selecting regions (e.g. to select a line C-space, C-a, C-e) to break
+;; :( I discovered that the following 3 functions would unset my mark.
+;; Upon reading some documentation, this seems to be caused by an
+;; argument to interactive used by these functions. With the following
+;; tiny patch, the undesirable behaviour is gone.
+;; - Patch was applied as is. Function affected:
+;; `folding-forward-char' `folding-backward-char'
+;; `folding-end-of-line'. Interactive spec changed from "p" to "_p"
+;;
+;; Sep 28 1998 19.34 [jari 2.41]
+;; - Wrote section "folding-whole-buffer doesn't fold whole buffer" to
+;; Problems topic. Fixed some indentation in documentation so that
+;; command ripdoc.pl folding.el | t2html.pl --simple > folding.html
+;; works properly.
+;;
+;; Sep 24 1998 19.34 [jari 2.40]
+;; - Stephen Smith <steve A T fmrib ox ac uk> wished that the
+;; `folding-comment-fold' should handle modes that have comment-start
+;; and comment-end too. That lead to rewriting the comment function so
+;; that it can be adapted to new modes.
+;; - `folding-pick-move' didn't work in C-mode. Fixed.
+;; (folding-find-folding-mark):
+;; m and re must be protected with `regexp-quote'. This
+;; corrected error eg. in C-mode where `folding-pick-move'
+;; didn't move at all.
+;; (folding-comment-fold): Added support for major modes that
+;; have `comment-start' and `comment-end'. Use
+;; `folding-comment-folding-table'
+;; (folding-comment-c-mode): New.
+;; (folding-uncomment-c-mode): New.
+;; (folding-comment-folding-table): New. To adapt to any major-mode.
+;; (folding-uncomment-mode-generic): New.
+;; (folding-comment-mode-generic): New.
+;;
+;; Aug 08 1998 19.34 [jari 2.39]
+;; - Andrew Maccormack <andrewm A T bristol st com> reported that the
+;; `em' end marker that was defined in the `let' should also have
+;; `[ \t\n]' which is in par with the `bm'. This way fold markers do
+;; not need to be parked to the left any more.
+;;
+;; Jun 05 1998 19.34 [jari 2.37-2.38]
+;; - Alf-Ivar Holm <affi A T osc no> send functions
+;; `folding-toggle-enter-exit' and `folding-toggle-show-hide' which
+;; were integrated. Alf also suggested that Fold marks should now
+;; necessarily be located at the beginning of line, but allow spaces
+;; at front. The patch was applied to `folding-mark-look-at'
+;;
+;; Mar 17 1998 19.34 [Anders]
+;; - Anders: This patch fixes one problem that was reported in the
+;; beginning of May by Ryszard Kubiak <R Kubia A T ipipan gda pl>.
+;; - Finally, I think that I have gotten mouse-context-sensitive
+;; right. Now, when you click on a fold that fold rather than the
+;; one the cursor is on is used, while still not breaking commands
+;; like `mouse-save-then-kill' which assumes that the point hasn't
+;; been moved.
+;; - Jari: Added topic "Fold must have a label" to the Problem section.
+;; as reported by Solofo Ramangalahy <solofo A T mpi-sb mpg de>
+;; - 1998-05-04 Ryszard Kubiak <R Kubiak A T ipipan gda pl> reported: I am
+;; just curious if it is possible to make Emacs' cursor
+;; automatically follow a mouse-click on the {{{ and }}} lines. I
+;; mean by this that a [S-mouse-3] (as defined in my settings below
+;; --- I keep not liking overloading [mouse-3]) first moves the
+;; cursor to where the click happened and then hides or shows a
+;; folded area. I presume that i can write a two-lines long
+;; interactive function to do this. Still, may be this kind of mouse
+;; behaviour is already available.
+;;
+;; Mar 17 1998 19.34 [Jari 2.34-2.35]
+;; - Added "Example: choosing different fold marks for mode"
+;; - corrected `my-folding-text-mode-setup' example.
+;;
+;; Mar 10 1998 19.34 [Jari 2.32-2.33]
+;; - [Anders] responds to mouse-3 handling problem: I have found the
+;; cause of the problem, and I have a suggestion for a fix.
+;;
+;; The problem is caused by two things:
+;; * The "mouse-save-then-kill" checks that the previous command also
+;; was "mouse-save-then-kill".
+;;
+;; * The second (more severe) problem is that
+;; "folding-mouse-context-sensitive" sets the point to the
+;; location of the click, effectively making
+;; "mouse-save-then-kill" mark the area between the point and the
+;; point! (This is why no region appears.)
+;;
+;; The first problem can be easily fixed by setting "this-command"
+;; in "folding-mouse-call-original":
+;;
+;; - Now the good old mouse-3 binding is back again.
+;; - (folding-mouse-context-sensitive): Added `save-excursion' as
+;; Anders suggested before setting `state'.
+;; (folding-mouse-call-original): commented out experimental code and
+;; used (setq this-command orig-func) as Anders suggested.
+;;
+;; Mar 10 1998 19.34 [Jari 2.31]
+;; - (folding-act): Added `event' to `folding-behave-table' calls.
+;; Input argument takes now `event' too
+;; - (folding-mouse-context-sensitive): Added argument `event'
+;; - (folding-mouse-call-original): Added (this-command orig-func)
+;; when calling original command.
+;; - (folding-bind-default-mouse): Changed mouse bindings. The
+;; button-3 can't be mapped by folding, because folding is unable to
+;; call the original function `mouse-save-then-kill'. Passing simple
+;; element to `mouse-save-then-kill' won't do the job. Eg if I
+;; (clicked mouse-1) moved mouse pointer to place X and pressed
+;; mouse-3, the area was not highlighted in folding mode. If folding
+;; mode was off the are was highlighted. I traced the
+;; `folding-mouse-call-original' and it was passing exactly the same
+;; event as without folding mode. I have no clue what to do about
+;; it...That's why I removed default mouse-3 binding and left it to
+;; emacs. This bug was reported by Ryszard Kubiak"
+;; <R Kubiak A T ipipan gda pl>
+;;
+;; Feb 12 1998 19.34 [Jari 2.30]
+;; - (html-mode): New mode added to `folding-mode-marks-alist'
+;; - (folding-get-mode-marks): Rewritten, now return 3rd element too.
+;; - (folding-comment-fold): Added note that function with `comment-end'
+;; is not supported. Function will flag error in those cases.
+;; - (folding-convert-to-major-folds): Conversion failed if eg; you
+;; switched between modes that has 2 and 1 comments, like
+;; /* */ (C) and //(C++). Now the conversion is bit smarter, but it's
+;; impossible to convert from /* */ to // directly because we don't
+;; know how to remove */ mark, you see:
+;;
+;; Original mode was C
+;;
+;; /* {{{ */
+;;
+;; And now used changed it to C++ mode, and ran command
+;; `folding-convert-to-major-folds'. We no longer have information
+;; about old mode's beginning or end comment markers, so we only
+;; can convert the folds to format
+;;
+;; // {{{ */
+;;
+;; Where the ending comment mark from old mode is left there.
+;; This is slightly imperfect situation, but at least the fold
+;; conversion works.
+;;
+;; Jan 28 1998 19.34 [Jari 2.25-2.29]
+;; - Added `generic-mode' to fold list, suggested by Wayne Adams
+;; <wadams A T galaxy sps mot com>
+;; - Finally rewrote the awesome menu-bar code: now uses standard
+;; easy-menu Which works in both XEmacs and Emacs. The menu is no
+;; longer under "Tools", but appear when minor mode is turned on.
+;; - Radical changes: Decided to remove all old lucid and epoch
+;; dependencies. Lot of code removed and reprogrammed.
+;; - I also got rid of the `folding-has-minor-mode-map-alist-p' variable
+;; and old 18.xx function `folding-merge-keymaps'.
+;; - Symbol's value as variable is void ((folding-xemacs-p)) error fixed.
+;; - Optimized 60 `folding-use-overlays-p' calls to only 4 within
+;; `folding-subst-regions'. (Used elp.el). It seems that half of the
+;; time is spent in the function `folding-narrow-to-region'
+;; function. Could it be optimized somehow?
+;; - Changed "lucid" tests to `folding-xemacs-p' variable tests.
+;; - Removed `folding-hack' and print message 'Info, ignore missing
+;; functions.." instead. It's better that we see the missing
+;; functions and not define dummy hacks for them.
+;;
+;; Nov 13 1997 19.34 [Jari 2.18-2.24]
+;; - Added tcl-mode fold marks, suggested by Petteri Kettunen
+;; <Petteri Kettunen A T oulu fi>
+;; - Removed some old code and modified the hook functions a bit.
+;; - Added new user function `folding-convert-to-major-folds', key "%".
+;; - Added missing items to Emacs menubar, didn't dare to touch the
+;; XEmacs part.
+;; - `folding-comment-fold': Small fix. commenting didn't work on
+;; closed folds. or if point was on topmost fold.
+;; - Added `folding-advice-instantiate' And corrected byte compiler
+;; message: Warning: variable oldposn bound but not referenced
+;; Warning: reference to free variable folding-stack
+;; - updated (require 'custom) code
+;;
+;; Nov 6 1997 19.34 [Jari 2.17]
+;; - Uwe Brauer <oub A T sunma4 mat ucm es> used folding for Latex files
+;; and he wished a feature that would allow him to comment away ext
+;; that was inside fold; when compiling the TeX file.
+;; - Added new user function `folding-comment-fold'. And new
+;; keybinding ";".
+;;
+;; Oct 8 1997 19.34 [Jari 2.16]
+;; - Now the minor mode map is always re-installed when this file is
+;; loaded. If user accidentally made mistake in
+;; `folding-default-keys-function', he can simply try again and
+;; reload this file to have the new key definitions.
+;; - Previously user had to manually go and delete the previous map
+;; from the `minor-mode-map-alist' before he could try again.
+;;
+;; Sep 29 1997 19.34 [Jari 2.14-2.15]
+;; - Robert Marshall <rxmarsha A T bechtel com> Sent enhancement to goto-line
+;; code. Now M-g works more intuitively.
+;; - Reformatted totally the documentation so that it can be ripped to
+;; html with jari's ema-doc.pls and t2html.pls Perl scripts.
+;; - Run through checkdoc.el 1.55 and Elint 1.10 and corrected code.
+;; - Added defcustom support. (not tested)
+;;
+;; Sep 19 1997 19.28 [Jari 2.13]
+;; - Robert Marshall <rxmarsha A T bechtel com> Sent small correction to
+;; overlay code, where the 'owner tag was set wrong.
+;;
+;; Aug 14 1997 19.28 [Jari 2.12 ]
+;; - A small regexp bug (extra whitespace was required after closing
+;; fold) cause failing of folding-convert-buffer-for-printing in the
+;; following situation
+;; - Reported by Guide. Fixed now.
+;;
+;; {{{ Main topic
+;; {{{ Subsection
+;; }}} << no space or end tag here!
+;; }}} Main topic
+;;
+;; Aug 14 1997 19.28 [Jari 2.11]
+;; - Guide Van Hoecke <Guido Van Hoecke A T bigfoot com> reported that
+;; he was using closing text for fold like:
+;;
+;; {{{ Main topic
+;; {{{ Subsection
+;; }}} Subsection
+;; }}} Main topic
+;;
+;; And when he did folding-convert-buffer-for-printing, it couldn't
+;; remove those closing marks but threw an error. I modified the
+;; function so that the regexp accepts anything after closing fold.
+;;
+;; Apr 18 1997 19.28 [Jari 2.10]
+;; - Corrected function folding-show-current-subtree, which didn't
+;; find the correct end region, because folding-pick-move needed
+;; point at the top of beginning fold. Bug was reported by Uwe
+;; Brauer <oub A T sunma4 mat ucm es> Also changed folding-mark-look-at,
+;; which now has new call parameter 'move.
+;;
+;; Mar 22 1997 19.28 [Jari 2.9]
+;; - Made the XEmacs20 match more stricter, so that
+;; folding-emacs-version gets value 'XEmacs19. Also added note about
+;; folding in WinNT in the compatibility section.
+;; - Added sh-script-mode indented-text-mode folding marks.
+;; - Moved the version from branch to the root, because the extra
+;; overlay code added, seems to be behaving well and it didn't break
+;; the existing functionality.
+;;
+;; Feb 17 1997 19.28 [Jari 2.8.1.2]
+;; - Cleaned up Dan's changes. First: we must not replace the
+;; selective display code, but offer these two choices: Added
+;; folding-use-overlays-p function which looks variable
+;; folding-allow-overlays.
+;; - Dan uses function from another Emacs specific (19.34+?) package
+;; hs-discard-overlays. This is not available in 19.28. it should
+;; be replaced with some new function... I didn't do that yet.
+;; - The overlays don't exist in XEmacs. XE19.15 has promises: at least
+;; I have heard that they have overlay.el library to mimic Emacs
+;; functions.
+;; - Now the overlay support can be turned on by setting
+;; folding-allow-overlays to non-nil. The default is to use selective
+;; display. Overlay Code is not tested!
+;;
+;; Feb 17 1997 19.28 [Dan 2.8.1.1]
+;; - Dan Nicolaescu <done A T ece arizona edu> sent patch that replaced
+;; selective display code with overlays.
+;;
+;; Feb 10 1997 19.28 [jari 2.8]
+;; - Ricardo Marek <ricky A T ornet co il> Kindly sent patch that
+;; makes code XEmacs 20.0 compatible. Thank you.
+;;
+;; Nov 7 1996 19.28 [jari 2.7]
+;; - When I was on picture-mode and turned on folding, and started
+;; isearch (I don't remember how I got fold mode on exactly) it
+;; gave error that the fold marks were not defined and emacs
+;; locked up due to simultaneous isearch-loop
+;; - Added few fixes to the isearch handling function to avoid
+;; infinite error loops.
+;;
+;; Nov 6 1996 19.28 [jari 2.5 - 2.6]
+;; - Situation: have folded buffer, manually _narrow_ somewhere, C-x n n
+;; - Then try searching --> folding breaks. Now it checks if the
+;; region is true narrow and not folding-narrow before trying
+;; to go outside of region and open a fold
+;; - If it's true narrow, then we stay in that narrowed region.
+;;
+;; folding-isearch-general :+
+;; folding-region-has-folding-marks-p :+
+;;
+;; Oct 23 1996 19.28 [jari 2.4]
+;; folding-display-name :+ new user cmd "C-n"
+;; folding-find-folding-mark :+ new
+;; folding-pick-move :! rewritten, full of bugs
+;; folding-region-open-close :! rewritten, full of bugs
+;;
+;; Oct 22 1996 19.28 [jari 2.3]
+;; - folding-pick-move :! rewritten
+;; folding-region-open-close :+ new user cmd "#"
+;; folding-show-current-subtree :+ new user cmd "C-s", hides too
+;;
+;; Aug 01 1996 19.31 [andersl]
+;; - folding-subst-regions, variable `font-lock-mode' set to nil.
+;; Thanks to <stig A T hackvan com>
+;;
+;; Jun 19 1996 19.31 [andersl]
+;; - The code has proven itself stable through the beta testing phase
+;; which has lasted the past six months.
+;; - A lot of comments written.
+;; - The package `folding-isearch' integrated.
+;; - Some code cleanup:
+;; BOLP -> folding-BOL :! renamed
+;; folding-behave-table :! field `down' removed.
+;;
+;;
+;; Mar 14 1996 19.28 [jari 1.27]
+;; - No code changes. Only some textual corrections/additions.
+;; - Section "about keymaps" added.
+;;
+;; Mar 14 1996 19.28 [jackr 1.26]
+;; - spell-check run over code.
+;;
+;; Mar 14 1996 19.28 [davidm 1.25]
+;; - David Masterson <davidm A T prism kla com> This patch makes the menubar in
+;; XEmacs work better. After I made this patch, the Hyperbole menus
+;; starting working as expected again. I believe the use of
+;; set-buffer-menubar has a problem, so the recommendation in XEmacs
+;; 19.13 is to use set-menubar-dirty-flag.
+;;
+;; Mar 13 1996 19.28 [andersl 1.24]
+;; - Corrected one minor bug in folding-check-if-folding-allowed
+;;
+;; Mar 12 1996 19.28 [jari 1.23]
+;; - Renamed all -func variables to -function.
+;;
+;; mar 12 1996 19.28 [jari 1.22]
+;; - Added new example how to change the fold marks. The automatic folding
+;; was reported to cause unnecessary delays for big files (eg. when using
+;; ediff) Now there is new function variable which can totally disable
+;; automatic folding if the return value is nil.
+;;
+;; folding-check-allow-folding-function :+ new variable
+;; folding-check-if-folding-allowed :+ new func
+;; folding-mode-find-file :! modified
+;; folding-mode-write-file :! better docs
+;; folding-goto-line :! arg "n" --> "N" due to XEmacs 19.13
+;;
+;; Mar 11 1996 19.28 [jari 1.21]
+;; - Integrated changes made by Anders' to v1.19 [folding in beta dir]
+;;
+;; Jan 25 1996 19.28 [jari 1.20]
+;; - ** Mainly cosmetic changes **
+;; - Added some 'Section' codes that can be used with lisp-mnt.el
+;; - Deleted all code in 'special section' because it was never used.
+;; - Moved some old "-v-" named variables to better names.
+;; - Removed folding-mode-flag that was never used.
+;;
+;; Jan 25 1996 19.28 [jari 1.19]
+;; - Put Anders' latest version into RCS tree.
+;;
+;; Jan 03 1996 19.30 [andersl]
+;; - `folding-mouse-call-original' uses `call-interactively'.
+;; `folding-mouse-context-sensitive' doesn't do `save-excursion'.
+;; (More changes will come later.)
+;; `folding-mouse-yank-at-p' macro corrected (quote added).
+;; Error for `epoch::version' removed.
+;; `folding-mark-look-at' Regexp change .* -> [^\n\r]* to avoid error.
+;;
+;; Nov 24 1995 19.28 [andersl]
+;; - (sequencep ) added to the code which checks for the existence
+;; of a tools menu.
+;;
+;; Aug 27 1995 19.28 19.12 [andersl]
+;; - Keybindings restructured. They now conforms with the
+;; new 19.29 styleguide. Old keybindings are still available.
+;; - Menus new goes into the "Tools" menu, if present.
+;; - `folding-mouse-open-close' renamed to
+;; `folding-mouse-context-sensitive'.
+;; - New entry `other' in `folding-behave-table' which defaults to
+;; `folding-calling-original'.
+;; - `folding-calling-original' now gets the event from `last-input-event'
+;; if called without arguments (i.e. the way `folding-act' calls it.)
+;; - XEmacs mouse support added.
+;; - `folding-mouse-call-original' can call functions with or without
+;; the Event argument.
+;; - Byte compiler generates no errors neither for Emacs 19 and XEmacs.
+;;
+;; Aug 24 1995 19.28 [jari 1.17]
+;; - To prevent infinite back calling loop, Anders suggested smart way
+;; to detect that func call chain is started only once.
+;; folding-calling-original :+ v, call chain terminator
+;; "Internal" :! v, all private vars have this string
+;; folding-mouse-call-original :! v, stricter chain check.
+;; "copyright" :! t, newer notice
+;; "commentary" :! t, ripped non-supported emacsen
+;;
+;; Aug 24 1995 19.28 [jari 1.16]
+;; ** mouse interface rewritten
+;; - Anders gave many valuable comments about simplifying the mouse usage,
+;; he suggested that every mouse function should accept standard event,
+;; and it should be called directly.
+;; folding-global :- v, not needed
+;; folding-mode-off-hook :- v, not needed
+;; folding-mouse-action-table :- v, not needed any more
+;; folding-default-keys-function :+ v, key settings
+;; folding-default-mouse-keys-function:+ v, key settings
+;; folding-mouse :- f, unnecessary
+;; 'all mouse funcs' :! f, now accept "e" parameter
+;; folding-default-keys :+ f, defines keys
+;; folding-mouse-call-original :+ f, call orig mouse func
+;; "examples" :! t, radical rewrote, only one left
+;;
+;; Aug 24 1995 19.28 [jari 1.15]
+;; - some minor changes. If we're inside a fold, Mouse-3 will go one
+;; level up if it points END or BEG marker.
+;; folding-mouse-yank-at-point:! v, added 'up 'down
+;; folding-mark-look-at :! f, more return values: '11 and 'end-in
+;; folding-open-close :! f, bug, didn't exit if inside fold
+;; PMIN, PMAX, NEXTP, add-l :+ more macros fom tinylibm.el
+;;
+;; Aug 23 1995 19.28 [andersl 1.14]
+;; - Added `eval-when-compile' around 1.13 byte-compiler fix
+;; to avoid code to be executed when using a byte-compiled version
+;; of folding.el.
+;; - Binds mode keys via `minor-mode-map-alist'
+;; (i.e. `folding-merge-keymaps' is not used in modern Emacsen.)
+;; This means that the user can not bind `folding-mode-map' to a new
+;; keymap, \\(s\\|\\)he must modify the existing one.
+;; - `defvars' for global feature test variables `folding-*-p'.
+;; - `folding-mouse-open-close' now detects when the current fold was been
+;; pressed. (The "current" is the fold around which the buffer is
+;; narrowed.)
+;;
+;; Aug 23 1995 19.28 [jari 1.13]
+;; - 19.28 Byte compile doesn't handle fboundp, boundp well. That's a bug.
+;; Set some dummy functions to get cleaner output.
+;; - The folding-mode-off doesn't seem very useful, because it
+;; is never run when another major-mode is turned on ... maybe we should
+;; utilize kill-all-local-variables-hooks with defadvice around
+;; kill-all-local-variables ...
+;;
+;; folding-emacs-version :+ added. it was in the docs, but not defined
+;; kill-all-local-variables-hooks :! v, moved to variable section
+;; list-buffers-mode-alist :! v, --''--
+;; "compiler hacks" :+ section added
+;; "special" :+ section added
+;; "Compatibility" :! moved at the beginning
+;;
+;; Aug 22 1995 19.28 [jari 1.12]
+;; - Only minor changes
+;; BOLP, BOLPP, EOLP, EOLPP :+ f, macros added from tinylibm.el
+;; folding-mouse-pick-move :! f, when cursor at beolp, move always up
+;; "bindings" :+ added C-cv and C-cC-v
+;;
+;; Aug 22 1995 19.28 [jari 1.11]
+;; - Inspired by mouse so much, that this revision contain substantial
+;; changes and enhancements. Mouse is now powered!
+;; - Anders wanted mouse to operate according to 'mouse cursor', not
+;; current 'point'.
+;; folding-mouse-yank-at-point: controls it. Phwew, I like this
+;; one a lot.
+;;
+;; examples :! t, totally changed, now 2 choices
+;; folding-mode-off-hook :+ v, when folding ends
+;; folding-global :+ v, global store value
+;; folding-mouse-action-table :! v, changed
+;; folding-mouse :! f, stores event to global
+;; folding-mouse-open-close :! f, renamed, mouse activated open
+;; folding-mode :! f, added 'off' hook
+;; folding-event-posn :+ f, handles FSF mouse event
+;; folding-mouse-yank-at-p :+ f, check which mouse mode is on
+;; folding-mouse-point :+ f, return working point
+;; folding-mouse-move :+ f, mouse moving down , obsolete ??
+;; folding-mouse-pick-move :+ f, mouse move accord. fold mark
+;; folding-next-visible-heading :+ f, from tinyfold.el
+;; folding-previous-visible-heading :+ f, from tinyfold.el
+;; folding-pick-move :+ f, from tinyfold.el
+;;
+;;
+;; Aug 22 1995 19.28 [jari 1.10]
+;; - Minor typing errors corrected : fol-open-close 'hide --> 'close
+;; This caused error when trying to close open fold with mouse
+;; when cursor was sitting on fold marker.
+;;
+;; Aug 22 1995 19.28 [jari 1.9]
+;; - Having heard good suggestions from Anders...!
+;; "install" : add-hook for folding missed
+;; folding-open-close : generalized
+;; folding-behave-table : NEW, logical behavior control
+;; folding-:mouse-action-table : now folding-mouse-action-table
+;;
+;; - The mouse function seems to work with FSF emacs only, because
+;; XEmacs doesn't know about double or triple clicks. We're working
+;; on the problem...
+;;
+;; Aug 21 1995 19.28 [jari 1.8]
+;; - Rearranged the file structure so that all variables are at the
+;; beginning of file. With new functions, it easy to open-close
+;; fold. Added word "code:" or "setup:" to the front of code folds,
+;; so that the toplevel folds can be recognized more easily.
+;; - Added example hook to install section for easy mouse use.
+;; - Added new functions.
+;; folding-get-mode-marks : return folding marks
+;; folding-mark-look-at : status of current line, fold mark in it?
+;; folding-mark-mouse : execute action on fold mark
+;;
+;;
+;; Aug 17 1995 19.28/X19.12 [andersl 1.7]
+;; - Failed when loaded into XEmacs, when `folding-mode-map' was
+;; undefined. Folding marks for three new major modes added:
+;; rexx-mode, erlang-mode and xerl-mode.
+;;
+;; Aug 14 1995 19.28 [jari 1.6]
+;; - After I met Anders we exchanged some thoughts about usage philosophy
+;; of error and signal commands. I was annoyed by the fact that they
+;; couldn't be suppressed, when the error was "minor". Later Anders
+;; developed fdb.el, which will be integrated to FSF 19.30. It
+;; offers by-passing error/signal interference.
+;; --> I changed back all the error commands that were taken away.
+;;
+;; Jun 02 1995 19.28 [andersl]
+;; - "Narrow" not present in mode-line when in folding-mode.
+;;
+;; May 12 1995 19.28 [jari 1.5]
+;; - Installation text cleaned: reference to 'install-it' removed,
+;; because such function doesn't exist any more. The installation is
+;; now automatic: it's done when user calls folding mode first time.
+;; - Added 'private vars' section. made 'outside all folds' message
+;; informational, not an error.
+;;
+;; May 12 1995 19.28 [jackr x.x]
+;; - Corrected 'broken menu bar' problem.
+;; - Even though make-sparse-keymap claims its argument (a string to
+;; name the menu) is optional, it's not. Lucid has other
+;; arrangements for the same thing..
+;;
+;; May 10 1995 19.28 [jari 1.2]
+;; - Moved provide to the end of file.
+;; - Rearranged code so that the common functions are at the beginning.
+;; Reprogrammed the whole installation with hooks. Added Write file
+;; hook that makes sure you don't write in 'binary' while folding were
+;; accidentally off.
+;; - Added regexp text for certain files which are not allowed to
+;; 'auto fold' when loaded.
+;; - changed some 'error' commands to 'messages', this prevent screen
+;; mixup when debug-on-error is set to t
+;; + folding-list-delete , folding-msg , folding-mode-find-file ,
+;; folding-mode-write-file , folding-check-folded , folding-keep-hooked
+;;
+;; 1.7.4 May 04 1995 19.28 [jackr 1.11]
+;; - Some compatibility changes:
+;; v.18 doesn't allow an arg to make-sparse-keymap
+;; testing epoch::version is trickier than that
+;; free-variable reference cleanup
+;;
+;; 1.7.3 May 04 1995 19.28 [jari]
+;; - Corrected folding-mode-find-file-hook , so that it has more
+;; 'mode turn on' capabilities through user function
+;; + folding-mode-write-file-hook: Makes sure your file is saved
+;; properly, so that you don't end up saving in 'binary'.
+;; + folding-check-folded: func, default checker provided
+;; + folding-check-folded-file-function variable added, User can put his
+;; 'detect folding.el file' methods here.
+;; + folding-mode-install-it: func, Automatic installation with it
+;;
+;; 1.7.2 Apr 01 1995 19.28 [jackr] , Design support by [jari]
+;; - Added folding to FSF & XEmacs menus
+;;
+;; 1.7.1 Apr 28 1995 19.28 [jackr]
+;; - The folding editor's merge-keymap couldn't handle FSF menu-bar,
+;; so some minor changes were made, previous is '>' and enhancements
+;; are '>'
+;;
+;; < (buffer-disable-undo new-buffer)
+;; ---
+;; > (buffer-flush-undo new-buffer)
+;; 1510,1512c1510
+;; < key (if (symbolp keycode)
+;; < (vector keycode)
+;; < (char-to-string keycode))
+;; ---
+;; > key (char-to-string keycode)
+;; 1802,1808d1799
+;; < ;;{{{ Compatibility hacks for various Emacs versions
+;; <
+;; < (or (fboundp 'buffer-disable-undo)
+;; < (fset 'buffer-disable-undo (symbol-function 'buffer-flush-undo)))
+;; <
+;; < ;;}}}
+;;
+;;
+;; X.x Dec 1 1994 19.28 [jari]
+;; - Only minor change. Made the folding mode string user configurable.
+;; Added these variables:
+;; folding-mode-string, folding-inside-string,folding-inside-mode-name
+;; - Changed revision number from 1.6.2 to 1.7 , so that people know
+;; this package has changed.
+
+;;}}}
+
+;;; Code:
+
+;;{{{ setup: require packages
+
+;;; ......................................................... &require ...
+
+(eval-when-compile (require 'cl))
+(require 'easymenu)
+
+(defvar folding-package-url-location
+ "Latest folding is available at http://cvs.xemacs.org/viewcvs.cgi/XEmacs/packages/xemacs-packages/text-modes/")
+
+;;}}}
+;;{{{ setup: byte compiler hacks
+
+;;; ............................................. &byte-compiler-hacks ...
+;;; - This really only should be evaluated in case we're about to byte
+;;; compile this file. Since `eval-when-compile' is evaluated when
+;;; the uncompiled version is used (great!) we test if the
+;;; byte-compiler is loaded.
+
+;; Make sure `advice' is loaded when compiling the code.
+
+(eval-and-compile
+ (require 'advice)
+ (defvar folding-xemacs-p (or (boundp 'xemacs-logo)
+ (featurep 'xemacs))
+ "Folding determines which emacs version it is running. t if Xemacs.")
+ ;; loading overlay.el package removes some byte compiler whinings.
+ ;; By default folding does not use overlay code.
+ (if folding-xemacs-p
+ (or (fboundp 'overlay-start) ;; Already loaded
+ (load "overlay" 'noerr) ;; No? Try loading it.
+ (message "\
+** folding.el: XEmacs 19.15+ has package overlay.el, try to get it.
+ This is only warning. Folding does not use overlays by
+ default. You can safely ignore possible overlay byte
+ compilation error
+ messages."))))
+
+(eval-when-compile
+
+ (when nil ;; Disabled 2000-01-05
+ ;; While byte compiling
+ (if (string= (buffer-name) " *Compiler Input*")
+ (progn
+ (message "** folding.el:\
+ Info, Ignore [X]Emacs's missing motion/event/posn functions calls"))))
+
+ ;; ARGS: (symbol variable-p library)
+ (defadvice find-function-search-for-symbol (around folding act)
+ "Set folding flag for `find-file-noselect' to open all folds."
+ (let ((file (ad-get-arg 2)))
+ (when file
+ (message "FILE %s" file)
+ (put 'find-file-noselect 'folding file)))
+ ad-do-it
+ (put 'find-file-noselect 'folding nil))
+
+ (defun folding-find-file-noselect ()
+ (let* ((file (get 'find-file-noselect 'folding))
+ (buffer (and file
+ ;; It may be absolute path name, file.el,
+ ;; or just "file".
+ (or (find-buffer-visiting file)
+ (get-buffer file)
+ (get-buffer (concat file ".el"))))))
+ (when buffer
+ (with-current-buffer buffer
+ (when (symbol-value 'folding-mode) ;; Byte compiler silencer
+ (turn-off-folding-mode))))))
+
+ ;; See find.func.el find-function-search-for-symbol
+ ;; Make C-h f and mouse-click work to jump to a file. Folding mode
+ ;; Must be turned off due to regexps in find.func.el that can't
+ ;; search ^M lines.
+
+ (defadvice find-file-noselect (after folding act)
+ "When called by `find-function-search-for-symbol', turn folding off."
+ (folding-find-file-noselect))
+
+ (defadvice make-sparse-keymap
+ (before
+ make-sparse-keymap-with-optional-argument
+ (&optional byte-compiler-happyfier)
+ activate)
+ "This advice does nothing except adding an optional argument
+to keep the byte compiler happy when compiling Emacs specific code
+with XEmacs.")
+
+ ;; XEmacs and Emacs 19 differs when it comes to obsolete functions.
+ ;; We're using the Emacs 19 versions, and this simply makes the
+ ;; byte-compiler stop wining. (Why isn't there a warning flag which
+ ;; could have turned off?)
+
+ (and (boundp 'mode-line-format)
+ (put 'mode-line-format 'byte-obsolete-variable nil))
+
+ (and (fboundp 'byte-code-function-p)
+ (put 'byte-code-function-p 'byte-compile nil))
+
+ (and (fboundp 'eval-current-buffer)
+ (put 'eval-current-buffer 'byte-compile nil)))
+
+(defsubst folding-preserve-active-region ()
+ "In XEmacs keep the region alive. In Emacs do nothing."
+ (if (boundp 'zmacs-region-stays) ;Keep regions alive
+ (set 'zmacs-region-stays t))) ;use `set' to Quiet Emacs Byte Compiler
+
+;; Work around the NT Emacs Cut'n paste bug in selective-display which
+;; doesn't preserve C-m's. Only installed in problematic Emacs and
+;; in other cases these lines are no-op.
+
+(eval-and-compile
+ (when (and (not folding-xemacs-p)
+ (memq (symbol-value 'window-system) '(win32 w32)) ; NT Emacs
+ (string< emacs-version "20.4")) ;at least in 19.34 .. 20.3.1
+
+ (unless (fboundp 'char-equal)
+ (defalias 'char-equal 'equal))
+
+ (unless (fboundp 'subst-char)
+ (defun subst-char (str char to-char)
+ "Replace in STR every CHAR with TO-CHAR."
+ (let ((len (length str))
+ (ret (copy-sequence str))) ;because 'aset' is destructive
+ (while (> len 0)
+ (if (char-equal (aref str (1- len)) char)
+ (aset ret (1- len) to-char))
+ (decf len))
+ ret)))
+
+ (defadvice kill-new (around folding-win32-fix-selective-display act)
+ "In selective display, convert each C-m to C-a. See `current-kill'."
+ (let* ((string (ad-get-arg 0)))
+ (when (and selective-display (string-match "\C-m" (or string "")))
+ (setq string (subst-char string ?\C-m ?\C-a)))
+ ad-do-it))
+
+ (defadvice current-kill (around folding-win32-fix-selective-display act)
+ "In selective display, convert each C-a back to C-m. See `kill-new'."
+ ad-do-it
+ (let* ((string ad-return-value))
+ (when (and selective-display (string-match "\C-a" (or string "")))
+ (setq string (subst-char string ?\C-a ?\C-m))
+ (setq ad-return-value string))))))
+
+(defvar folding-mode) ;; Byte Compiler silencer
+
+(when (locate-library "mode-motion") ;; XEmacs
+ (defun folding-mode-motion-highlight-fold (event)
+ "Highlight line under mouse if it has a foldmark."
+ (when folding-mode
+ (funcall
+ ;; Emacs Byte Compiler Shutup fix
+ (symbol-function 'mode-motion-highlight-internal)
+ event
+ (function
+ (lambda ()
+ (beginning-of-line)
+ (if (folding-mark-look-at)
+ (search-forward-regexp "^[ \t]*"))))
+ (function
+ (lambda ()
+ (if (folding-mark-look-at)
+ (end-of-line)))))))
+ (require 'mode-motion)
+ (add-hook 'mode-motion-hook 'folding-mode-motion-highlight-fold 'at-end))
+
+;;}}}
+
+;;{{{ setup: some variable
+
+;;; .................................................. &some-variables ...
+
+;; This is a list of structures which keep track of folds being entered
+;; and exited. It is a list of (MARKER . MARKER) pairs, followed by the
+;; symbol `folded'. The first of these represents the fold containing
+;; the current one. If the view is currently outside all folds, this
+;; variable has value nil.
+
+(defvar folding-stack nil
+ "Internal. A list of marker pairs representing folds entered so far.")
+
+(defvar folding-version (substring "$Revision: 3.42 $" 11 15)
+ "Version number of folding.el.")
+
+;;}}}
+;;{{{ setup: bind
+
+;;; .......................................................... &v-bind ...
+
+;; Custom hack for Emacs that does not have custom
+
+(eval-and-compile
+ (condition-case ()
+ (require 'custom)
+ (error nil))
+ (if (and (featurep 'custom) (fboundp 'custom-declare-variable))
+ nil ;; We've got what we needed
+ ;; We have the old custom-library, hack around it!
+ (defmacro defgroup (&rest args)
+ nil)
+ (defmacro defcustom (var value doc &rest args)
+ (` (defvar (, var) (, value) (, doc))))))
+
+(defgroup folding nil
+ "Managing buffers with Folds."
+ :group 'tools)
+
+(defcustom folding-mode-prefix-key "\C-c@"
+ "*Prefix key to use for Folding commands in Folding mode."
+ :type 'string
+ :group 'folding)
+
+(defcustom folding-goto-key "\M-g"
+ "*Key to be bound to `folding-goto-line' in folding mode.
+The default value is M - g, but you probably don't want folding to
+occupy it if you have used M - g got `goto-line'."
+ :type 'string
+ :group 'folding)
+
+(defcustom folding-font-lock-begin-mark 'font-lock-reference-face
+ "Face to highlight beginning fold mark."
+ :type 'face
+ :group 'folding)
+
+(defcustom folding-font-lock-end-mark 'font-lock-reference-face
+ "Face to highlight end fold mark."
+ :type 'face
+ :group 'folding)
+
+(defvar folding-mode-map nil
+ "Keymap used in Folding mode (a minor mode).")
+
+(defvar folding-mode-prefix-map nil
+ "Keymap used in Folding mode keys sans `folding-mode-prefix-key'.")
+
+;;;###autoload
+(defvar folding-mode nil
+ "When Non nil, Folding mode is active in the current buffer.")
+
+(make-variable-buffer-local 'folding-mode)
+(set-default 'folding-mode nil)
+
+(defmacro folding-kbd (key function)
+ "Folding: define KEY with FUNCTION to `folding-mode-prefix-map'.
+This is used when assigning keybindings to `folding-mode-map'.
+See also `folding-mode-prefix-key'."
+ (` (define-key
+ folding-mode-prefix-map
+ (, key) (, function))))
+
+(defun folding-bind-default-mouse ()
+ "Bind default mouse keys used by Folding mode."
+ (interactive)
+ (cond
+ (folding-xemacs-p
+ (define-key folding-mode-map [(button3)]
+ 'folding-mouse-context-sensitive)
+ ;; (define-key folding-mode-map '(double button3) 'folding-hide-current-entry)
+ (define-key folding-mode-map [(control shift button2)]
+ 'folding-mouse-pick-move))
+ (t
+ (define-key folding-mode-map [mouse-3] 'folding-mouse-context-sensitive)
+ (define-key folding-mode-map [C-S-mouse-2] 'folding-mouse-pick-move))))
+
+(defun folding-bind-terminal-keys ()
+ "In non-window system, rebind C - f and C - b as folding-{forward,backward}-char."
+ (unless (or (and (boundp 'window-system) ;; Emacs
+ (symbol-value 'window-system)) ;; Byte compiler silencer
+ (and (fboundp 'console-type) ;; XEmacs
+ (let ((val (fboundp 'console-type)))
+ (not (eq 'tty val)))))
+ (define-key folding-mode-map "\C-f" 'folding-forward-char)
+ (define-key folding-mode-map "\C-b" 'folding-backward-char)))
+
+(defun folding-bind-default-keys ()
+ "Bind the default keys used the `folding-mode'.
+
+The variable `folding-mode-prefix-key' contains the prefix keys,
+the default is C - c @.
+
+For the good ol' key bindings, please use the function
+`folding-bind-backward-compatible-keys' instead."
+ (interactive)
+ (define-key folding-mode-map folding-goto-key 'folding-goto-line)
+ (folding-bind-terminal-keys)
+ (define-key folding-mode-map "\C-e" 'folding-end-of-line)
+ (folding-kbd "\C-f" 'folding-fold-region)
+ (folding-kbd ">" 'folding-shift-in)
+ (folding-kbd "<" 'folding-shift-out)
+ (folding-kbd "\C-t" 'folding-show-all)
+ (folding-kbd "\C-s" 'folding-show-current-entry)
+ (folding-kbd "\C-x" 'folding-hide-current-entry)
+ (folding-kbd "\C-o" 'folding-open-buffer)
+ (folding-kbd "\C-w" 'folding-whole-buffer)
+ (folding-kbd "\C-r" 'folding-convert-buffer-for-printing)
+ (folding-kbd "\C-k" 'folding-marks-kill)
+ (folding-kbd "\C-v" 'folding-pick-move)
+ (folding-kbd "v" 'folding-previous-visible-heading)
+ (folding-kbd " " 'folding-next-visible-heading)
+ (folding-kbd "." 'folding-context-next-action)
+ ;; C-u: kinda "up" -- "down"
+ (folding-kbd "\C-u" 'folding-toggle-enter-exit)
+ (folding-kbd "\C-q" 'folding-toggle-show-hide)
+ ;; Think "#" as a 'fence'
+ (folding-kbd "#" 'folding-region-open-close)
+ ;; Esc-; is the standard emacs commend add key.
+ (folding-kbd ";" 'folding-comment-fold)
+ (folding-kbd "%" 'folding-convert-to-major-folds)
+ (folding-kbd "/" 'folding-all-comment-blocks-in-region)
+ (folding-kbd "\C-y" 'folding-show-current-subtree)
+ (folding-kbd "\C-z" 'folding-hide-current-subtree)
+ (folding-kbd "\C-n" 'folding-display-name)
+
+ (folding-kbd "I" 'folding-insert-advertise-folding-mode))
+
+(defun folding-bind-backward-compatible-keys ()
+ "Bind keys traditionally used by Folding mode.
+For bindings which follow newer Emacs minor mode conventions, please
+use the function `folding-bind-default-keys'.
+
+This function sets `folding-mode-prefix-key' to `C-c'."
+ (interactive)
+ (setq folding-mode-prefix-key "\C-c")
+ (folding-bind-default-keys))
+
+(defun folding-bind-outline-compatible-keys ()
+ "Bind keys used by the minor mode `folding-mode'.
+The keys used are as much as possible compatible with
+bindings used by Outline mode.
+
+Currently, some outline mode functions doesn't have a corresponding
+folding function.
+
+The variable `folding-mode-prefix-key' contains the prefix keys,
+the default is C - c @.
+
+For the good ol' key bindings, please use the function
+`folding-bind-backward-compatible-keys' instead."
+ (interactive)
+ ;; Traditional keys:
+ (folding-bind-terminal-keys)
+ (define-key folding-mode-map "\C-e" 'folding-end-of-line)
+ ;; Mimic Emacs 20.3 allout.el bindings
+ (folding-kbd ">" 'folding-shift-in)
+ (folding-kbd "<" 'folding-shift-out)
+ (folding-kbd "\C-n" 'folding-next-visible-heading)
+ (folding-kbd "\C-p" 'folding-previous-visible-heading)
+ ;; ("\C-u" outline-up-current-level)
+ ;; ("\C-f" outline-forward-current-level)
+ ;; ("\C-b" outline-backward-current-level)
+ ;; (folding-kbd "\C-i" 'folding-show-current-subtree)
+ (folding-kbd "\C-s" 'folding-show-current-subtree)
+ (folding-kbd "\C-h" 'folding-hide-current-subtree)
+ (folding-kbd "\C-k" 'folding-marks-kill)
+ (folding-kbd "!" 'folding-show-all)
+ (folding-kbd "\C-d" 'folding-hide-current-entry)
+ (folding-kbd "\C-o" 'folding-show-current-entry)
+ ;; (" " outline-open-sibtopic)
+ ;; ("." outline-open-subtopic)
+ ;; ("," outline-open-supertopic)
+ ;; Other bindings not in allout.el
+ (folding-kbd "\C-a" 'folding-open-buffer)
+ (folding-kbd "\C-q" 'folding-whole-buffer)
+ (folding-kbd "\C-r" 'folding-convert-buffer-for-printing)
+ (folding-kbd "\C-w" 'folding-fold-region)
+ (folding-kbd "I" 'folding-insert-advertise-folding-mode))
+
+;;{{{ goto-line (advice)
+
+(defcustom folding-advice-instantiate t
+ "*In non-nil install advice code. Eg for `goto-line'."
+ :type 'boolean
+ :group 'folding)
+
+(defcustom folding-shift-in-on-goto t
+ "*Flag in folding adviced function `goto-line'.
+If non-nil, folds are entered when going to a given line.
+Otherwise the buffer is unfolded. Can also be set to 'show.
+This variable is used only if `folding-advice-instantiate' was
+non-nil when folding was loaded.
+
+See also `folding-goto-key'."
+ :type 'boolean
+ :group 'folding)
+
+(when folding-advice-instantiate
+ (eval-when-compile (require 'advice))
+ ;; By Robert Marshall <rxmarsha A T bechtel com>
+ (defadvice goto-line (around folding-goto-line first activate)
+ "Go to line ARG, entering folds if `folding-shift-in-on-goto' is t.
+It attempts to keep the buffer in the same visibility state as before."
+ (let () ;; (oldposn (point))
+ ad-do-it
+ (if (and folding-mode
+ (or (folding-point-folded-p (point))
+ (<= (point) (point-min-marker))
+ (>= (point) (point-max-marker))))
+ (let ((line (ad-get-arg 0)))
+ (if folding-shift-in-on-goto
+ (progn
+ (folding-show-all)
+ (goto-char 1)
+ (and (< 1 line)
+ (not (folding-use-overlays-p))
+ (re-search-forward "[\n\C-m]" nil 0 (1- line)))
+ (let ((goal (point)))
+ (while (prog2 (beginning-of-line)
+ (if (eq folding-shift-in-on-goto 'show)
+ (progn
+ (folding-show-current-entry t t)
+ (folding-point-folded-p goal))
+ (folding-shift-in t))
+ (goto-char goal)))
+ (folding-narrow-to-region
+ (and folding-narrow-by-default (point-min))
+ (point-max) t)))
+ (if (or folding-stack (folding-point-folded-p (point)))
+ (folding-open-buffer))))))))
+
+;;}}}
+
+(defun folding-bind-foldout-compatible-keys ()
+ "Bind keys for `folding-mode' compatible with Foldout mode.
+
+The variable `folding-mode-prefix-key' contains the prefix keys,
+the default is C - c @."
+ (interactive)
+ (folding-kbd "\C-z" 'folding-shift-in)
+ (folding-kbd "\C-x" 'folding-shift-out))
+
+;;; This function is here, just in case we ever would like to add
+;;; `hideif' support to folding mode. Currently, it is only used to
+;;; which keys shouldn't be used.
+
+;;(defun folding-bind-hideif-compatible-keys ()
+;; "Bind keys for `folding-mode' compatible with Hideif mode.
+;;
+;;The variable `folding-mode-prefix-key' contains the prefix keys,
+;;the default is C-c@."
+;; (interactive)
+;; ;; Keys defined by `hideif'
+;; ;; (folding-kbd "d" 'hide-ifdef-define)
+;; ;; (folding-kbd "u" 'hide-ifdef-undef)
+;; ;; (folding-kbd "D" 'hide-ifdef-set-define-alist)
+;; ;; (folding-kbd "U" 'hide-ifdef-use-define-alist)
+;;
+;; ;; (folding-kbd "h") 'hide-ifdefs)
+;; ;; (folding-kbd "s") 'show-ifdefs)
+;; ;; (folding-kbd "\C-d") 'hide-ifdef-block)
+;; ;; (folding-kbd "\C-s") 'show-ifdef-block)
+;;
+;; ;; (folding-kbd "\C-q" 'hide-ifdef-toggle-read-only)
+;; )
+
+;;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .
+
+;; Not used for modern Emacsen.
+(defvar folding-saved-local-keymap nil
+ "Keymap used to save non-folding keymap.
+(so it can be restored when folding mode is turned off.)")
+
+;;;###autoload
+(defcustom folding-default-keys-function 'folding-bind-default-keys
+ "*Function or list of functions used to define keys for Folding mode.
+Possible values are:
+ folding-bind-default-key
+ The standard keymap.
+
+ `folding-bind-backward-compatible-keys'
+ Keys used by older versions of Folding mode. This function
+ does not conform to Emacs 19.29 style conversions concerning
+ key bindings. The prefix key is C - c
+
+ `folding-bind-outline-compatible-keys'
+ Define keys compatible with Outline mode.
+
+ `folding-bind-foldout-compatible-keys'
+ Define some extra keys compatible with Foldout.
+
+All except `folding-bind-backward-compatible-keys' used the value of
+the variable `folding-mode-prefix-key' as prefix the key.
+The default is C - c @"
+ :type 'function
+ :group 'folding)
+
+;; Not yet implemented:
+;; folding-bind-hideif-compatible-keys
+;; Define some extra keys compatible with hideif.
+
+;;;###autoload
+(defcustom folding-default-mouse-keys-function 'folding-bind-default-mouse
+ "*Function to bind default mouse keys to `folding-mode-map'."
+ :type 'function
+ :group 'folding)
+
+(defvar folding-mode-menu nil
+ "Keymap containing the menu for Folding mode.")
+
+(defvar folding-mode-menu-name "Fld" ;; Short menu name
+ "Name of pull down menu.")
+
+;;}}}
+;;{{{ setup: hooks
+
+;;; ......................................................... &v-hooks ...
+
+(defcustom folding-mode-hook nil
+ "*Hook called when Folding mode is entered.
+
+A hook named `<major-mode>-folding-hook' is also called, if it
+exists. Eg., `c-mode-folding-hook' is called whenever Folding mode is
+started in C mode."
+ :type 'hook
+ :group 'folding)
+
+(defcustom folding-load-hook nil
+ "*Hook run when file is loaded."
+ :type 'hook
+ :group 'folding)
+
+;;}}}
+;;{{{ setup: user config
+
+;;; ........................................................ &v-Config ...
+
+(defvar folding-narrow-by-default t
+ "If t (default) things like isearch will enter folds. If nil the
+folds will be opened, but not entered.")
+
+;; Q: should this inherit mouse-yank-at-point's value? maybe not.
+(defvar folding-mouse-yank-at-point t
+ "If non-nil, mouse activities are done at point instead of 'mouse cursor'.
+Behaves like `mouse-yank-at-point'.")
+
+(defcustom folding-folding-on-startup t
+ "*If non-nil, buffers are folded when starting Folding mode."
+ :type 'boolean
+ :group 'folding)
+
+(defcustom folding-internal-margins 1
+ "*Number of blank lines left next to fold mark when tidying folds.
+
+This variable is local to each buffer. To set the default value for all
+buffers, use `set-default'.
+
+When exiting a fold, and at other times, `folding-tidy-inside' is invoked
+to ensure that the fold is in the correct form before leaving it. This
+variable specifies the number of blank lines to leave between the
+enclosing fold marks and the enclosed text.
+
+If this value is nil or negative, no blank lines are added or removed
+inside the fold marks. A value of 0 (zero) is valid, meaning leave no
+blank lines.
+
+See also `folding-tidy-inside'."
+ :type 'boolean
+ :group 'folding)
+
+(make-variable-buffer-local 'folding-internal-margins)
+
+(defvar folding-mode-string " Fld"
+ "Buffer-local variable that hold the fold depth description.")
+
+(set-default 'folding-mode-string " Fld")
+
+;; Sets `folding-mode-string' appropriately. This allows the Folding mode
+;; description in the mode line to reflect the current fold depth.
+
+(defconst folding-inside-string " " ; was ' inside ',
+ "Mode line addition to show 'inside' levels of fold.")
+
+;;;###autoload
+(defcustom folding-inside-mode-name "Fld"
+ "*Mode line addition to show inside levels of 'fold' ."
+ :type 'string
+ :group 'folding)
+
+(defcustom folding-check-folded-file-function
+ 'folding-check-folded
+ "*Function that return t or nil after examining if the file is folded."
+ :type 'function
+ :group 'folding)
+
+(defcustom folding-check-allow-folding-function
+ 'folding-check-if-folding-allowed
+ "*Function that return t or nil after deciding if automatic folding."
+ :type 'function
+ :group 'folding)
+
+;;;###autoload
+(defcustom folding-mode-string "Fld"
+ "*The minor mode string displayed when mode is on."
+ :type 'string
+ :group 'folding)
+
+;;;###autoload
+(defcustom folding-mode-hook-no-regexp "RMAIL"
+ "*Regexp which disable automatic folding mode turn on for certain files."
+ :type 'string
+ :group 'folding)
+
+;;; ... ... ... ... ... ... ... ... ... ... ... ... ... .... &v-tables ...
+
+(defcustom folding-behave-table
+ '((close folding-hide-current-entry)
+ (open folding-show-current-entry) ; Could also be `folding-shift-in'.
+ (up folding-shift-out)
+ (other folding-mouse-call-original))
+ "*Table of of logical commands and their associated functions.
+If you want fold to behave like `folding-shift-in', when it 'open'
+a fold, you just change the function entry in this table.
+
+Table form:
+ '( (LOGICAL-ACTION CMD) (..) ..)"
+ :type '(repeat
+ (symbol :tag "logical action")
+ (function :tag "callback"))
+ :group 'folding)
+
+;;; ... ... ... ... ... ... ... ... ... ... ... ... ... ..... &v-marks ...
+
+;;;###autoload
+(defvar folding-mode-marks-alist nil
+ "List of (major-mode . fold mark) default combinations to use.
+When Folding mode is started, the major mode is checked, and if there
+are fold marks for that major mode stored in `folding-mode-marks-alist',
+those marks are used by default. If none are found, the default values
+of \"{{{ \" and \"}}}\" are used.
+
+Use function `folding-add-to-marks-list' to add more fold marks. The function
+also explains the alist use in details.
+
+Use function `folding-set-local-variables' if you change the current mode's
+folding marks during the session.")
+
+;;}}}
+;;{{{ setup: private
+
+;;; ....................................................... &v-private ...
+
+(defvar folding-narrow-placeholder nil
+ "Internal. Mark where \"%n\" used to be in `mode-line-format'.
+Must be nil.")
+
+(defvar folding-bottom-mark nil
+ "Internal marker of the true bottom of a fold.")
+
+(defvar folding-bottom-regexp nil
+ "Internal. Regexp marking the bottom of a fold.")
+
+(defvar folding-regexp nil
+ "Internal. Regexp for hunting down the `folding-top-mark' even in comments.")
+
+(defvar folding-secondary-top-mark nil
+ "Internal. Additional stuff that can be inserted as part of a top marker.")
+
+(defvar folding-top-mark nil
+ "Internal. The actual string marking the top of a fold.")
+
+(defvar folding-top-regexp nil
+ "Internal.
+Regexp describing the string beginning a fold, possible with
+leading comment thingies and like that.")
+
+(defvar folded-file nil
+ "Enter folding mode when this file is loaded.
+(buffer local, use from a local variables list).")
+
+(defvar folding-calling-original nil
+ "Internal. Non-nil when original mouse binding is executed.")
+
+(defvar folding-narrow-overlays nil
+ "Internal. Keep the list of overlays.")
+(make-variable-buffer-local 'folding-narrow-overlays)
+
+(defcustom folding-allow-overlays nil
+ "*If non-nil use overlay code. If nil, then selective display is used.
+Note, that this code is highly experimental and will not most likely do what
+you expect. using value t will not change folding to use overlays
+completely. This variable was introduced to experiment with the overlay
+interface, but the work never finished and it is unlikely that it
+will continued any later time. Folding at present state is designed
+too highly for selective display to make the change worthwhile."
+ :type 'boolean
+ :group 'folding)
+
+;;}}}
+;;{{{ Folding install
+
+(defun folding-easy-menu-define ()
+ "Define folding easy menu."
+ (interactive)
+ (easy-menu-define
+ folding-mode-menu
+ (if folding-xemacs-p
+ nil
+ (list folding-mode-map))
+ "Folding menu"
+ (list
+ folding-mode-menu-name
+ ["Enter Fold" folding-shift-in t]
+ ["Exit Fold" folding-shift-out t]
+ ["Show Fold" folding-show-current-entry t]
+ ["Hide Fold" folding-hide-current-entry t]
+ "----"
+ ["Show Whole Buffer" folding-open-buffer t]
+ ["Fold Whole Buffer" folding-whole-buffer t]
+ ["Show subtree" folding-show-current-subtree t]
+ ["Hide subtree" folding-hide-current-subtree t]
+ ["Display fold name" folding-display-name t]
+ "----"
+ ["Move previous" folding-previous-visible-heading t]
+ ["Move next" folding-next-visible-heading t]
+ ["Pick fold" folding-pick-move t]
+ ["Next action (context)" folding-context-next-action t]
+ "----"
+ ["Foldify region" folding-fold-region t]
+ ["Open or close folds in region" folding-region-open-close t]
+ ["Open folds to top level" folding-show-all t]
+ "----"
+ ["Comment text in fold" folding-comment-fold t]
+ ["Convert for printing(temp buffer)"
+ folding-convert-buffer-for-printing t]
+ ["Convert to major-mode folds" folding-convert-to-major-folds t]
+ ["Move comments inside folds in region"
+ folding-all-comment-blocks-in-region t]
+ ["Delete fold marks in this fold" folding-marks-kill t]
+ ["Insert folding URL reference"
+ folding-insert-advertise-folding-mode t]
+ "----"
+ ["Toggle enter and exit mode" folding-toggle-enter-exit t]
+ ["Toggle show and hide" folding-toggle-show-hide t]
+ "----"
+ ["Folding mode off" folding-mode t])))
+
+(defun folding-install-keymaps ()
+ "Install keymaps."
+ (unless folding-mode-map
+ (setq folding-mode-map (make-sparse-keymap)))
+ (unless folding-mode-prefix-map
+ (setq folding-mode-prefix-map (make-sparse-keymap)))
+ (if (listp folding-default-keys-function)
+ (mapcar 'funcall folding-default-keys-function)
+ (funcall folding-default-keys-function))
+ (funcall folding-default-mouse-keys-function)
+ (folding-easy-menu-define)
+ (define-key folding-mode-map
+ folding-mode-prefix-key folding-mode-prefix-map)
+ ;; Install the keymap into `minor-mode-map-alist'. The keymap will
+ ;; be activated as soon as the variable `folding-mode' is set to
+ ;; non-nil.
+ (let ((elt (assq 'folding-mode minor-mode-map-alist)))
+ ;; Always remove old map before adding new definitions.
+ (if elt
+ (setq minor-mode-map-alist
+ (delete elt minor-mode-map-alist)))
+ (push (cons 'folding-mode folding-mode-map) minor-mode-map-alist))
+ ;; Update minor-mode-alist
+ (or (assq 'folding-mode minor-mode-alist)
+ (push '(folding-mode folding-mode-string) minor-mode-alist))
+ ;; Needed for XEmacs
+ (or (fboundp 'buffer-disable-undo)
+ (fset 'buffer-disable-undo (symbol-function 'buffer-flush-undo))))
+
+(defun folding-uninstall-keymaps ()
+ "Uninstall keymaps."
+ (let ((elt (assq 'folding-mode minor-mode-map-alist)))
+ (if elt
+ (setq minor-mode-map-alist
+ (delete elt minor-mode-map-alist)))
+ (if (setq elt (assq 'folding-mode minor-mode-alist))
+ (setq minor-mode-alist
+ (delete elt minor-mode-alist)))
+ (folding-uninstall-hooks)))
+
+(defun folding-install (&optional uninstall)
+ "Install or UNINSTALL folding."
+ (interactive "P")
+ (cond
+ (uninstall
+ (folding-uninstall-keymaps)
+ (folding-uninstall-hooks))
+ (t
+ (folding-install-keymaps))))
+
+(defun folding-uninstall ()
+ "Uninstall folding."
+ (interactive)
+ (folding-install 'uninstall)
+ ;; Unwrap all buffers.
+ (dolist (buffer (buffer-list))
+ (with-current-buffer buffer
+ (goto-char (point-min))
+ (when (or folding-mode
+ ;; To be sure, check this at the same time
+ ;; Somebody may have just done
+ ;; (setq folding-mode nil), which is bad thing.
+ ;; Setting variable won't restore the buffer.
+ (re-search-forward "{{{" nil t))
+ (turn-off-folding-mode)))))
+
+;;}}}
+;;{{{ code: misc
+
+(defsubst folding-get-mode-marks (&optional mode)
+ "Return fold markers for MODE. default is for current `major-mode'.
+
+Return:
+ \(beg-marker end-marker\)"
+ (interactive)
+ (let* (elt)
+ (unless (setq elt (assq (or mode major-mode)
+ folding-mode-marks-alist))
+ (error "Folding error: mode is not in `folding-mode-marks-alist'"))
+ (list (nth 1 elt) (nth 2 elt) (nth 3 elt))))
+
+(defun folding-region-has-folding-marks-p (beg end)
+ "Check is there is fold mark in region BEG END."
+ (save-excursion
+ (goto-char beg)
+ (when (memq (folding-mark-look-at) '(1 11))
+ (goto-char end)
+ (memq (folding-mark-look-at) '(end end-in)))))
+
+;;; - Thumb rule: because "{{{" if more meaningful, all returns values
+;;; are of type integerp if it is found.
+;;;
+(defun folding-mark-look-at (&optional mode)
+ "Check status of current line. Does it contain a fold mark?.
+
+MODE
+
+ 'move move over fold mark
+
+Return:
+
+ 0 1 numberp, line has fold begin mark
+ 0 = closed, 1 = open,
+ 11 = open, we're inside fold, and this is top marker
+
+ 'end end mark
+
+ 'end-in end mark, inside fold, floor marker
+
+ nil no fold marks .."
+ (let* (case-fold-search
+ (marks (folding-get-mode-marks))
+ (stack folding-stack)
+ (bm (regexp-quote (nth 0 marks))) ;begin mark
+ (em (concat "^[ \t\n]*" (regexp-quote (nth 1 marks))))
+ (bm-re (concat
+ (concat "^[ \t\n]*" bm)
+ (if (and nil
+ (string=
+ " " (substring (nth 0 marks)
+ (length (nth 1 marks)))))
+ ;; Like "}}} *"
+ "*"
+ "")))
+ ret
+ point)
+ (save-excursion
+ (beginning-of-line)
+ (cond
+ ((looking-at bm-re)
+ (setq point (point))
+ (cond
+ ((looking-at (concat "^[ \t\n]*" bm "[^\r\n]*\r")) ;; closed
+ (setq ret 0))
+ (t ;; open fold marker
+ (goto-char (point-min))
+ (cond
+ ((and stack ;; we're inside fold
+ ;; allow spaces
+ (looking-at (concat "[ \t\n]*" bm)))
+ (setq ret 11))
+ (t
+ (setq ret 1))))))
+ ((looking-at em)
+ (setq point (point))
+ ;; - The stack is a list if we've entered inside fold. There
+ ;; is no text after fold END mark
+ ;; - At bol ".*\n[^\n]*" doesn't work but "\n[^\n]*" at eol does??
+ (cond
+ ((progn
+ (end-of-line)
+ (or (and stack (eobp)) ;normal ending
+ (and stack ;empty newlines only, no text ?
+ (not (looking-at "\n[^ \t\n]*")))))
+ (setq ret 'end-in))
+ (t ;all rest are newlines
+ (setq ret 'end))))))
+ (cond
+ ((and mode point)
+ (goto-char point)
+ ;; This call breaks if there is no marks on the point,
+ ;; because there is no parameter 'nil t' in call.
+ ;; --> there is error in this function if that happens.
+ (beginning-of-line)
+ (re-search-forward (concat bm "\\|" em))
+ (backward-char 1)))
+ ret))
+
+(defsubst folding-mark-look-at-top-mark-p ()
+ "Check if line contain folding top marker."
+ (integerp (folding-mark-look-at)))
+
+(defsubst folding-mark-look-at-bottom-mark-p ()
+ "Check if line contain folding bottom marker."
+ (symbolp (folding-mark-look-at)))
+
+(defun folding-act (action &optional event)
+ "Execute logical ACTION based on EVENT.
+
+References:
+ `folding-behave-table'"
+ (let* ((elt (assoc action folding-behave-table)))
+ (if elt
+ (funcall (nth 1 elt) event)
+ (error "Folding mode (folding-act): Unknown action %s" action))))
+
+(defun folding-region-open-close (beg end &optional close)
+ "Open all folds inside region BEG END. Close if optional CLOSE is non-nil."
+ (interactive "r\nP")
+ (let* ((func (if (null close)
+ 'folding-show-current-entry
+ 'folding-hide-current-entry))
+ tmp)
+ (save-excursion
+ ;; make sure the beg is first.
+ (if (> beg end) ;swap order
+ (setq tmp beg beg end end tmp))
+ (goto-char beg)
+ (while (and
+ ;; the folding-show-current-entry/hide will move point
+ ;; to beg-of-line So we must move to the end of
+ ;; line to continue search.
+ (if (and close
+ (eq 0 (folding-mark-look-at))) ;already closed ?
+ t
+ (funcall func)
+ (end-of-line)
+ t)
+ (folding-next-visible-heading)
+ (< (point) end))))))
+
+(defun fold-marks-kill ()
+ "If over fold, open fold and kill beginning and end fold marker.
+Return t ot nil if marks were removed."
+ (interactive)
+ (if (not (folding-mark-look-at))
+ (when (interactive-p)
+ (message "Folding: Cursor not over fold. Can't removed fold marks.")
+ nil)
+ (multiple-value-bind (beg end)
+ (folding-show-current-entry)
+ (let* ((kill-whole-line t))
+ ;; must be done in this order, because point moves after kill.
+ (goto-char end)
+ (beginning-of-line)
+ (kill-line)
+ (goto-char beg)
+ (beginning-of-line)
+ (kill-line)
+ ;; Return status
+ t))))
+
+(defun folding-hide-current-subtree ()
+ "Call `folding-show-current-subtree' with argument 'hide."
+ (interactive)
+ (folding-show-current-subtree 'hide))
+
+(defun folding-show-current-subtree (&optional hide)
+ "Show or HIDE all folds inside current fold.
+Point must be over beginning fold mark."
+ (interactive "P")
+ (let* ((stat (folding-mark-look-at 'move))
+ (beg (point))
+ end)
+ (cond
+ ((memq stat '(0 1 11)) ;It's BEG fold
+ (when (eq 0 stat) ;it was closed
+ (folding-show-current-entry)
+ (goto-char beg)) ;folding-pick-move needs point at fold
+ (save-excursion
+ (if (folding-pick-move)
+ (setq end (point))))
+ (if (and beg end)
+ (folding-region-open-close beg end hide)))
+ (t
+ (if (interactive-p)
+ (message "point is not at fold beginning."))))))
+
+(defun folding-display-name ()
+ "Show current active fold name."
+ (interactive)
+ (let* ((pos (folding-find-folding-mark))
+ name)
+ (when pos
+ (save-excursion
+ (goto-char pos)
+ (if (looking-at ".*[{]+") ;Drop "{" mark away.
+ (setq pos (match-end 0)))
+ (setq name (buffer-substring
+ pos
+ (progn
+ (end-of-line)
+ (point))))))
+ (if name
+ (message (format "fold:%s" name)))))
+
+;;}}}
+;;{{{ code: events
+
+(defun folding-event-posn (act event)
+ "According to ACT read mouse EVENT struct and return data from it.
+Event must be simple click, no dragging.
+
+ACT
+ 'mouse-point return the 'mouse cursor' point
+ 'window return window pointer
+ 'col-row return list (col row)"
+ (cond
+ ((not folding-xemacs-p)
+ ;; short Description of FSF mouse event
+ ;;
+ ;; EVENT : (mouse-3 (#<window 34 on *scratch*> 128 (20 . 104) -23723628))
+ ;; event-start : (#<window 34 on *scratch*> 128 (20 . 104) -23723628))
+ ;; ^^^MP
+ ;; mp = mouse point
+ (let* ((el (funcall (symbol-function 'event-start) event)))
+ (cond
+ ((eq act 'mouse-point)
+ (nth 1 el)) ;is there macro for this ?
+ ((eq act 'window)
+ (funcall (symbol-function 'posn-window) el))
+ ((eq act 'col-row)
+ (funcall (symbol-function 'posn-col-row) el))
+ (t
+ (error "Unknown request" act)))))
+
+ (folding-xemacs-p
+ (cond
+ ((eq act 'mouse-point)
+ (funcall (symbol-function 'event-point) event))
+ ((eq act 'window)
+ (funcall (symbol-function 'event-window) event))
+ ;; Must be tested! (However, it's not used...)
+ ((eq act 'col-row)
+ (list (funcall (symbol-function 'event-x) event)
+ (funcall (symbol-function 'event-y) event)))
+ (t
+ (error "Unknown request" act))))
+ (t
+ (error "This version of Emacs can't handle events."))))
+
+(defmacro folding-interactive-spec-p ()
+ "Preserve region during `interactive'.
+In XEmacs user could also set `zmacs-region-stays'."
+ (if folding-xemacs-p
+ ;; preserve selected region
+ `'(interactive "_p")
+ `'(interactive "p")))
+
+(defmacro folding-mouse-yank-at-p ()
+ "Check if user use \"yank at mouse point\" feature.
+
+Please see the variable `folding-mouse-yank-at-point'."
+ 'folding-mouse-yank-at-point)
+
+(defun folding-mouse-point (&optional event)
+ "Return mouse's working point. Optional EVENT is mouse click.
+When used on XEmacs, return nil if no character was under the mouse."
+ (if (or (folding-mouse-yank-at-p)
+ (null event))
+ (point)
+ (folding-event-posn 'mouse-point event)))
+
+;;}}}
+
+;;{{{ code: hook
+
+(defun folding-is-hooked ()
+ "Check if folding hooks are installed."
+ (and (memq 'folding-mode-write-file write-file-hooks)
+ (memq 'folding-mode-find-file find-file-hooks)))
+
+;;;###autoload
+(defun folding-uninstall-hooks ()
+ "Remove hooks set by folding."
+ (turn-off-folding-mode)
+ (remove-hook 'finder-mode-hook 'folding-mode)
+ (remove-hook 'write-file-hooks 'folding-mode-write-file)
+ (remove-hook 'find-file-hooks 'folding-mode-find-file))
+
+;;;###autoload
+(defun folding-install-hooks ()
+ "Install folding hooks."
+ (folding-mode-add-find-file-hook)
+ (add-hook 'finder-mode-hook 'folding-mode)
+ (or (memq 'folding-mode-write-file write-file-hooks)
+ (add-hook 'write-file-hooks 'folding-mode-write-file 'end)))
+
+;;;###autoload
+(defun folding-keep-hooked ()
+ "Make sure hooks are in their places."
+ (unless (folding-is-hooked)
+ (folding-uninstall-hooks)
+ (folding-install-hooks)))
+
+;;}}}
+;;{{{ code: Mouse handling
+
+(defun folding-mouse-call-original (&optional event)
+ "Execute original mouse function using mouse EVENT.
+
+Do nothing if original function does not exist.
+
+Does nothing when called by a function which has earlier been called
+by us.
+
+Sets global:
+ `folding-calling-original'"
+ (interactive "@e") ;; Was "e"
+ ;; Without the following test we could easily end up in a endless
+ ;; loop in case we would call a function which would call us.
+ ;;
+ ;; (An easy constructed example is to bind the function
+ ;; `folding-mouse-context-sensitive' to the same mouse button both in
+ ;; `folding-mode-map' and in the global map.)
+ (if folding-calling-original
+ nil
+ ;; `folding-calling-original' is global
+ (setq folding-calling-original t)
+ (unwind-protect
+ (progn
+ (or event
+ (setq event last-input-event))
+ (let (mouse-key)
+ (cond
+ ((not folding-xemacs-p)
+ (setq mouse-key (make-vector 1 (car-safe event))))
+ (folding-xemacs-p
+ (setq mouse-key
+ (vector
+ (append
+ (event-modifiers event)
+ (list (intern
+ (format "button%d"
+ (funcall
+ (symbol-function 'event-button)
+ event))))))))
+ (t
+ (error "This version of Emacs can't handle events.")))
+ ;; Test string: http://www.csd.uu.se/~andersl
+ ;; andersl A T csd uu se
+ ;; (I have `ark-goto-url' bound to the same key as
+ ;; this function.)
+ ;;
+ ;; turn off folding, so that we can see the real
+ ;; function behind it.
+ ;;
+ ;; We have to restore the current buffer, otherwise the
+ ;; let* won't be able to restore the old value of
+ ;; folding-mode. In my environment, I have bound a
+ ;; function which starts mail when I click on an e-mail
+ ;; address. When returning, the current buffer has
+ ;; changed.
+ (let* ((folding-mode nil)
+ (orig-buf (current-buffer))
+ (orig-func (key-binding mouse-key)))
+ ;; call only if exist
+ (when orig-func
+ ;; Check if the original function has arguments. If
+ ;; it does, call it with the event as argument.
+ (unwind-protect
+ (progn
+ (setq this-command orig-func)
+ (call-interactively orig-func))
+;;; #untested, but included here for further reference
+;;; (cond
+;;; ((not (string-match "mouse" (symbol-name orig-func)))
+;;; (call-interactively orig-func))
+;;; ((string-match "^mouse" (symbol-name orig-func))
+;;; (funcall orig-func event))
+;;; (t
+;;; ;; Some other package's mouse command,
+;;; ;; should we do something special here for
+;;; ;; somebody?
+;;; (funcall orig-func event)))
+ (set-buffer orig-buf))))))
+ ;; This is always executed, even if the above generates an error.
+ (setq folding-calling-original nil))))
+
+(defun folding-mouse-context-sensitive (event)
+ "Perform some operation depending on the context of the mouse pointer.
+EVENT is mouse event.
+
+The variable `folding-behave-table' contains a mapping between contexts and
+operations to perform.
+
+The following contexts can be handled (They are named after the
+natural operation to perform on them):
+
+ open - A folded fold.
+ close - An open fold, which isn't the one current topmost one.
+ up - The topmost visible fold.
+ other - Anything else.
+
+Note that the `pointer' can be either the buffer point, or the mouse
+pointer depending in the setting of the user option
+`folding-mouse-yank-at-point'."
+ (interactive "e")
+ (let* ( ;; - Get mouse cursor point, or point
+ (point (folding-mouse-point event))
+ state)
+ (if (null point)
+ ;; The user didn't click on any text.
+ (folding-act 'other event)
+ (save-excursion
+ (goto-char point)
+ (setq state (folding-mark-look-at)))
+ (cond
+ ((eq state 0)
+ (folding-act 'open event))
+ ((eq state 1)
+ (folding-act 'close event))
+ ((eq state 11)
+ (folding-act 'up event))
+ ((eq 'end state)
+ (folding-act 'close))
+ ((eq state 'end-in)
+ (folding-act 'up event))
+ (t
+ (folding-act 'other event))))))
+
+;;; FIXME: #not used, the pick move handles this too
+(defun folding-mouse-move (event)
+ "Move down if sitting on fold mark using mouse EVENT.
+
+Original function behind the mouse is called if no FOLD action wasn't
+taken."
+ (interactive "e")
+ (let* ( ;; - Get mouse cursor point, or point
+ (point (folding-mouse-point event))
+ state)
+ (save-excursion
+ (goto-char point)
+ (beginning-of-line)
+ (setq state (folding-mark-look-at)))
+ (cond
+ ((not (null state))
+ (goto-char point)
+ (folding-next-visible-heading) t)
+ (t
+ (folding-mouse-call-original event)))))
+
+(defun folding-mouse-pick-move (event)
+ "Pick movement if sitting on beg/end fold mark using mouse EVENT.
+If mouse if at the `beginning-of-line' point, then always move up.
+
+Original function behind the mouse is called if no FOLD action wasn't
+taken."
+ (interactive "e")
+ (let* ( ;; - Get mouse cursor point, or point
+ (point (folding-mouse-point event))
+ state)
+ (save-excursion
+ (goto-char point)
+ (setq state (folding-mark-look-at)))
+ (cond
+ ((not (null state))
+ (goto-char point)
+ (if (= point
+ (save-excursion (beginning-of-line) (point)))
+ (folding-previous-visible-heading)
+ (folding-pick-move)))
+ (t
+ (folding-mouse-call-original event)))))
+
+;;}}}
+;;{{{ code: engine
+
+(defun folding-set-mode-line ()
+ "Update modeline with fold level."
+ (if (null folding-stack)
+ (kill-local-variable 'folding-mode-string)
+ (make-local-variable 'folding-mode-string)
+ (setq folding-mode-string
+ (if (eq 'folded (car folding-stack))
+ (concat
+ folding-inside-string "1" folding-inside-mode-name)
+ (concat
+ folding-inside-string
+ (int-to-string (length folding-stack))
+ folding-inside-mode-name)))))
+
+(defun folding-clear-stack ()
+ "Clear the fold stack, and release all the markers it refers to."
+ (let ((stack folding-stack))
+ (setq folding-stack nil)
+ (while (and stack (not (eq 'folded (car stack))))
+ (set-marker (car (car stack)) nil)
+ (set-marker (cdr (car stack)) nil)
+ (setq stack (cdr stack)))))
+
+(defun folding-check-if-folding-allowed ()
+ "Return non-nil when buffer allowed to be folded automatically.
+When buffer is loaded it may not be desirable to fold it immediately,
+because the file may be too large, or it may contain fold marks, that
+really are not _real_ folds. (Eg. RMAIL saved files may have the
+marks)
+
+This function returns t, if it's okay to proceed checking the fold status
+of file. Returning nil means that folding should not touch this file.
+
+The variable `folding-check-allow-folding-function' normally contains this
+function. Change the variable to use your own scheme."
+
+ (or (let ((file (get 'find-file-noselect 'folding)))
+ ;; When a file reference is "pushed" is a C-h v buffer that says:
+ ;; test is a Lisp function in `~/foo/tmp/test.el' A flag gets set
+ ;; (see adviced code) and we must not fold this buffer, because
+ ;; it will be immediately searched.
+ (and file
+ (not (string-match (regexp-quote file)
+ (or buffer-file-name "")))))
+ ;; Do not fold these files
+ (null (string-match folding-mode-hook-no-regexp (buffer-name)))))
+
+(defun folding-mode-find-file ()
+ "One of the funcs called whenever a `find-file' is successful.
+It checks to see if `folded-file' has been set as a buffer-local
+variable, and automatically starts Folding mode if it has.
+
+This allows folded files to be automatically folded when opened.
+
+To make this hook effective, the symbol `folding-mode-find-file-hook'
+should be placed at the end of `find-file-hooks'. If you have
+some other hook in the list, for example a hook to automatically
+uncompress or decrypt a buffer, it should go earlier on in the list.
+
+See also `folding-mode-add-find-file-hook'."
+ (let* ((check-fold folding-check-folded-file-function)
+ (allow-fold folding-check-allow-folding-function))
+ ;; Turn mode on only if it's allowed
+ (if (funcall allow-fold)
+ (or (and (and check-fold (funcall check-fold))
+ (folding-mode 1))
+ (and (assq 'folded-file (buffer-local-variables))
+ folded-file
+ (folding-mode 1)
+ (kill-local-variable 'folded-file)))
+ ;; In all other cases, unfold buffer.
+ (if folding-mode
+ (folding-mode -1)))))
+
+;;;###autoload
+(defun folding-mode-add-find-file-hook ()
+ "Append `folding-mode-find-file-hook' to the list `find-file-hooks'.
+
+This has the effect that afterwards, when a folded file is visited, if
+appropriate Emacs local variable entries are recognized at the end of
+the file, Folding mode is started automatically.
+
+If `inhibit-local-variables' is non-nil, this will not happen regardless
+of the setting of `find-file-hooks'.
+
+To declare a file to be folded, put `folded-file: t' in the file's
+local variables. eg., at the end of a C source file, put:
+
+/*
+Local variables:
+folded-file: t
+*/
+
+The local variables can be inside a fold."
+ (interactive)
+ (or (memq 'folding-mode-find-file find-file-hooks)
+ (add-hook 'find-file-hooks 'folding-mode-find-file 'end)))
+
+(defun folding-mode-write-file ()
+ "Folded files must be controlled by folding before saving.
+This function turns on the folding mode if it is not activated.
+It prevents 'binary pollution' upon save."
+ (let* ((check-func folding-check-folded-file-function)
+ (no-re folding-mode-hook-no-regexp)
+ (bn (or (buffer-name) "")))
+ (if (and (not (string-match no-re bn))
+ (boundp 'folding-mode)
+ (null folding-mode)
+ (and check-func (funcall check-func)))
+ (progn
+ ;; When folding mode is turned on it also 'folds' whole
+ ;; buffer... can't avoid that, since it's more important
+ ;; to save safely
+ (folding-mode 1)))
+ ;; hook returns nil, good habit
+ nil))
+
+(defun folding-check-folded ()
+ "Function to determine if this file is in folded form."
+ (let* ( ;; Could use folding-top-regexp , folding-bottom-regexp ,
+ ;; folding-regexp But they are not available at load time.
+ (folding-re1 "^.?.?.?{{{")
+ (folding-re2 "[\r\n].*}}}"))
+ (save-excursion
+ (goto-char (point-min))
+ ;; If we found both, we assume file is folded
+ (and (re-search-forward folding-re1 nil t)
+ ;; if file is folded, there are \r's
+ (search-forward "\r" nil t)
+ (re-search-forward folding-re2 nil t)))))
+
+;;}}}
+
+;;{{{ code: Folding mode
+
+(defun folding-font-lock-keywords (&optional mode)
+ "Return folding font-lock keywords for MODE."
+ ;; Add support mode-by-mode basis. Check if mode is already
+ ;; handled from the property list.
+ (multiple-value-bind (beg end)
+ (folding-get-mode-marks (or mode major-mode))
+ (setq beg (concat "^[ \t]*" (regexp-quote beg) "[^\r\n]+"))
+ (setq end (concat "^[ \t]*" (regexp-quote end)))
+ (list
+ ;; the `t' says to overwrite any previous highlight.
+ ;; => Needed because folding marks are in comments.
+ (list beg 0 folding-font-lock-begin-mark t)
+ (list end 0 folding-font-lock-end-mark t))))
+
+(defun folding-font-lock-support-instantiate (&optional mode)
+ "Add fold marks with `font-lock-add-keywords'."
+ (or mode
+ (setq mode major-mode))
+ ;; Hide function from Byte Compiler.
+ (let* ((function 'font-lock-add-keywords))
+ (when (fboundp function)
+ (funcall function
+ mode
+ (folding-font-lock-keywords mode))
+ ;; In order to see new keywords font lock must be restarted.
+ (dolist (buffer (buffer-list))
+ (with-current-buffer buffer
+ (when (and (eq major-mode mode)
+ (or font-lock-mode
+ ;; Hide variable from byte compiler.
+ (let ((sym 'global-font-lock-mode))
+ (and (boundp sym)
+ (symbol-value sym)))))
+ ;; #todo: should we use font-lock-fontify-buffer instead?
+ (font-lock-mode -1)
+ (font-lock-mode 1)))))))
+
+(defun folding-font-lock-support ()
+ "Add font lock support."
+ (let* ((list (get 'folding-mode 'font-lock)))
+ (unless (memq major-mode list)
+ ;; Support added, update known list
+ (push major-mode list)
+ (put 'folding-mode 'font-lock list)
+ (folding-font-lock-support-instantiate major-mode))))
+
+(defun folding-set-local-variables ()
+ "Set local fold mark variables.
+If you're going to change the beginning and end mark in
+`folding-mode-marks-alist'; you must call this function."
+ (set (make-local-variable 'folding-stack) nil)
+ (make-local-variable 'folding-top-mark)
+ (make-local-variable 'folding-secondary-top-mark)
+ (make-local-variable 'folding-top-regexp)
+ (make-local-variable 'folding-bottom-mark)
+ (make-local-variable 'folding-bottom-regexp)
+ (make-local-variable 'folding-regexp)
+ (or (and (boundp 'folding-top-regexp)
+ folding-top-regexp
+ (boundp 'folding-bottom-regexp)
+ folding-bottom-regexp)
+ (let ((folding-marks (assq major-mode
+ folding-mode-marks-alist)))
+ (if folding-marks
+ (setq folding-marks (cdr folding-marks))
+ (setq folding-marks '("{{{" "}}}")))
+ (apply 'folding-set-marks folding-marks))))
+
+;;;###autoload
+(defun turn-off-folding-mode ()
+ "Turn off folding."
+ (folding-mode -1))
+
+;;;###autoload
+(defun turn-on-folding-mode ()
+ "Turn on folding."
+ (folding-mode 1))
+
+;;;###autoload
+(defun folding-mode (&optional arg inter)
+ "A folding-editor-like minor mode. ARG INTER.
+
+These are the basic commands that Folding mode provides:
+
+\\{folding-mode-map}
+
+Keys starting with `folding-mode-prefix-key'
+
+\\{folding-mode-prefix-map}
+
+ folding-convert-buffer-for-printing:
+ `\\[folding-convert-buffer-for-printing]'
+ Makes a ready-to-print, formatted, unfolded copy in another buffer.
+
+ Read the documentation for the above functions for more information.
+
+Overview
+
+ Folds are a way of hierarchically organizing the text in a file, so
+ that the text can be viewed and edited at different levels. It is
+ similar to Outline mode in that parts of the text can be hidden from
+ view. A fold is a region of text, surrounded by special \"fold marks\",
+ which act like brackets, grouping the text. Fold mark pairs can be
+ nested, and they can have titles. When a fold is folded, the text is
+ hidden from view, except for the first line, which acts like a title
+ for the fold.
+
+ Folding mode is a minor mode, designed to cooperate with many other
+ major modes, so that many types of text can be folded while they are
+ being edited (eg., plain text, program source code, Texinfo, etc.).
+
+Folding-mode function
+
+ If Folding mode is not called interactively (`(interactive-p)' is nil),
+ and it is called with two or less arguments, all of which are nil, then
+ the point will not be altered if `folding-folding-on-startup' is set
+ and `folding-whole-buffer' is called. This is generally not a good
+ thing, as it can leave the point inside a hidden region of a fold, but
+ it is required if the local variables set \"mode: folding\" when the
+ file is first read (see `hack-local-variables').
+
+ Not that you should ever want to, but to call Folding mode from a
+ program with the default behavior (toggling the mode), call it with
+ something like `(folding-mode nil t)'.
+
+Fold marks
+
+ For most types of folded file, lines representing folds have \"{{{\"
+ near the beginning. To enter a fold, move the point to the folded line
+ and type `\\[folding-shift-in]'. You should no longer be able to see
+ the rest of the file, just the contents of the fold, which you couldn't
+ see before. You can use `\\[folding-shift-out]' to leave a fold, and
+ you can enter and exit folds to move around the structure of the file.
+
+ All of the text is present in a folded file all of the time. It is just
+ hidden. Folded text shows up as a line (the top fold mark) with \"...\"
+ at the end. If you are in a fold, the mode line displays \"inside n
+ folds Narrow\", and because the buffer is narrowed you can't see outside
+ of the current fold's text.
+
+ By arranging sections of a large file in folds, and maybe subsections
+ in sub-folds, you can move around a file quickly and easily, and only
+ have to scroll through a couple of pages at a time. If you pick the
+ titles for the folds carefully, they can be a useful form of
+ documentation, and make moving though the file a lot easier. In
+ general, searching through a folded file for a particular item is much
+ easier than without folds.
+
+Managing folds
+
+ To make a new fold, set the mark at one end of the text you want in the
+ new fold, and move the point to the other end. Then type
+ `\\[folding-fold-region]'. The text you selected will be made into a
+ fold, and the fold will be entered. If you just want a new, empty fold,
+ set the mark where you want the fold, and then create a new fold there
+ without moving the point. Don't worry if the point is in the middle of
+ a line of text, `folding-fold-region' will not break text in the middle
+ of a line. After making a fold, the fold is entered and the point is
+ positioned ready to enter a title for the fold. Do not delete the fold
+ marks, which are usually something like \"{{{\" and \"}}}\". There may
+ also be a bit of fold mark which goes after the fold title.
+
+ If the fold markers get messed up, or you just want to see the whole
+ unfolded file, use `\\[folding-open-buffer]' to unfolded the whole
+ file, so you can see all the text and all the marks. This is useful for
+ checking/correcting unbalanced fold markers, and for searching for
+ things. Use `\\[folding-whole-file]' to fold the buffer again.
+
+ `folding-shift-out' will attempt to tidy the current fold just before
+ exiting it. It will remove any extra blank lines at the top and bottom,
+ \(outside the fold marks). It will then ensure that fold marks exists,
+ and if they are not, will add them (after asking). Finally, the number
+ of blank lines between the fold marks and the contents of the fold is
+ set to 1 (by default).
+
+Folding package customizations
+
+ If the fold marks are not set on entry to Folding mode, they are set to
+ a default for current major mode, as defined by
+ `folding-mode-marks-alist' or to \"{{{ \" and \"}}}\" if none are
+ specified.
+
+ To bind different commands to keys in Folding mode, set the bindings in
+ the keymap `folding-mode-map'.
+
+ The hooks `folding-mode-hook' and `<major-mode-name>-folding-hook' are
+ called before folding the buffer and applying the key bindings in
+ `folding-mode-map'. This is a good hook to set extra or different key
+ bindings in `folding-mode-map'. Note that key bindings in
+ `folding-mode-map' are only examined just after calling these hooks;
+ new bindings in those maps only take effect when Folding mode is being
+ started. The hook `folding-load-hook' is called when Folding mode is
+ loaded into Emacs.
+
+Mouse behavior
+
+ If you want folding to detect point of actual mouse click, please see
+ variable `folding-mouse-yank-at-p'.
+
+ To customise the mouse actions, look at `folding-behave-table'."
+ (interactive)
+
+ (let ((new-folding-mode
+ (if (not arg)
+ (not folding-mode)
+ (> (prefix-numeric-value arg) 0))))
+ (or (eq new-folding-mode
+ folding-mode)
+ (if folding-mode
+ (progn
+ ;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ progn ^^^
+ ;; turn off folding
+ (if (null (folding-use-overlays-p))
+ (setq selective-display nil))
+ (folding-clear-stack)
+ (folding-narrow-to-region nil nil)
+ (folding-subst-regions (list 1 (point-max)) ?\r ?\n)
+
+ ;; Restore "%n" (Narrow) in the mode line
+ (setq mode-line-format
+ (mapcar
+ (function
+ (lambda (item)
+ (if (equal item 'folding-narrow-placeholder)
+ "%n" item)))
+ mode-line-format)))
+ ;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ else ^^^
+ (cond
+ ((folding-use-overlays-p)
+ ;; This may be Emacs specific; how about XEmacs?
+ ;;
+ ;; make line-move-ignore-invisible buffer local, matches
+ ;; outline.el, and the 21 pre-release gets upset if this is
+ ;; defined globally in shell buffer...
+ (make-local-variable 'line-move-ignore-invisible)
+ (setq line-move-ignore-invisible t
+ buffer-invisibility-spec '((t . t))))
+ (t
+ (setq selective-display t)
+ (setq selective-display-ellipses t)))
+ (unless (assq 'folding-mode minor-mode-alist)
+ ;; User has not run folding-install or he did call
+ ;; folding-uninstall which completely wiped package out.
+ ;; => anyway now he calls us, so be there for him
+ (folding-install))
+ (folding-keep-hooked) ;set hooks if not there
+ (widen)
+ (setq folding-narrow-overlays nil)
+ (folding-set-local-variables)
+ (folding-font-lock-support)
+ (unwind-protect
+ (let ((hook-symbol (intern-soft
+ (concat
+ (symbol-name major-mode)
+ "-folding-hook"))))
+ (run-hooks 'folding-mode-hook)
+ (and hook-symbol
+ (run-hooks hook-symbol)))
+ (folding-set-mode-line))
+ (and folding-folding-on-startup
+ (if (or (interactive-p)
+ arg
+ inter)
+ (folding-whole-buffer)
+ (save-excursion
+ (folding-whole-buffer))))
+ (folding-narrow-to-region nil nil t)
+ ;; Remove "%n" (Narrow) from the mode line
+ (setq mode-line-format
+ (mapcar
+ (function
+ (lambda (item)
+ (if (equal item "%n")
+ 'folding-narrow-placeholder item)))
+ mode-line-format))))
+ (setq folding-mode new-folding-mode)
+ (if folding-mode
+ (easy-menu-add folding-mode-menu)
+ (easy-menu-remove folding-mode-menu))))
+
+;;}}}
+;;{{{ code: setting fold marks
+
+;; You think those "\\(\\)" pairs are peculiar? Me too. Emacs regexp
+;; stuff has a bug; sometimes "\\(.*\\)" fails when ".*" succeeds, but
+;; only in a folded file! Strange bug! Must check it out sometime.
+
+(defun folding-set-marks (top bottom &optional secondary)
+ "Set the folding top and bottom mark for the current buffer.
+
+Input:
+
+ TOP The topmost fold mark. Comment start + fold begin string.
+ BOTTOM The bottom fold mark Comment end + fold end string.
+ SECONDARY Usually the comment end indicator for the mode. This
+ is inserted by `folding-fold-region' after the fold top mark,
+ and is presumed to be put after the title of the fold.
+
+Example:
+
+ html-mode:
+
+ top: \"<!-- [[[ \"
+ bot: \"<!-- ]]] -->\"
+ sec: \" -->\"
+
+Notice that the top marker needs to be closed with SECONDARY comment end string.
+
+Various regular expressions are set with this function, so don't set the
+mark variables directly."
+ (set (make-local-variable 'folding-top-mark)
+ top)
+ (set (make-local-variable 'folding-bottom-mark)
+ bottom)
+ (set (make-local-variable 'folding-secondary-top-mark)
+ secondary)
+ (set (make-local-variable 'folding-top-regexp)
+ (concat "\\(^\\|\r+\\)[ \t]*"
+ (regexp-quote folding-top-mark)))
+ (set (make-local-variable 'folding-bottom-regexp)
+ (concat "\\(^\\|\r+\\)[ \t]*"
+ (regexp-quote folding-bottom-mark)))
+ (set (make-local-variable 'folding-regexp)
+ (concat "\\(^\\|\r\\)\\([ \t]*\\)\\(\\("
+ (regexp-quote folding-top-mark)
+ "\\)\\|\\("
+ (regexp-quote folding-bottom-mark)
+ "[ \t]*\\(\\)\\($\\|\r\\)\\)\\)")))
+
+;;}}}
+;;{{{ code: movement
+
+(defun folding-next-visible-heading (&optional direction)
+ "Move up/down fold headers.
+Backward if DIRECTION is non-nil returns nil if not moved = no next marker."
+ (interactive)
+ (let* ((begin-mark (nth 0 (folding-get-mode-marks)))
+ case-fold-search)
+ (if direction
+ (re-search-backward (concat "^" (regexp-quote begin-mark)) nil t)
+ (re-search-forward (concat "^" (regexp-quote begin-mark)) nil t))))
+
+(defun folding-previous-visible-heading ()
+ "Move upward fold headers."
+ (interactive)
+ (beginning-of-line)
+ (folding-next-visible-heading 'backward))
+
+(defun folding-find-folding-mark (&optional end-fold)
+ "Search backward to find beginning fold. Skips subfolds.
+Optionally searches forward to find END-FOLD mark.
+
+Return:
+
+ nil
+ point position of fold mark"
+ (let* (case-fold-search
+ (elt (folding-get-mode-marks))
+ (bm (regexp-quote (nth 0 elt))) ; markers defined for mode
+ (em (regexp-quote (nth 1 elt))) ; markers defined for mode
+ (re (concat "^" bm "\\|^" em))
+ (count 0)
+ stat
+ moved)
+ (save-excursion
+ (cond
+ (end-fold
+ (folding-end-of-line)
+ ;; We must skip over inner folds
+ (while (and (null moved)
+ (re-search-forward re nil t))
+ (setq stat (folding-mark-look-at))
+ (cond
+ ((symbolp stat)
+ (setq count (1- count))
+ (if (< count 0) ;0 or less means no middle folds
+ (setq moved t)))
+ ((memq stat '(1 11)) ;BEG fold
+ (setq count (1+ count))))) ;; end while
+ (when moved
+ (forward-char -3)
+ (setq moved (point))))
+ (t
+ (while (and (null moved)
+ (re-search-backward re nil t))
+ (setq stat (folding-mark-look-at))
+ (cond
+ ((memq stat '(1 11))
+ (setq count (1- count))
+ (if (< count 0) ;0 or less means no middle folds
+ (setq moved (point))))
+ ((symbolp stat)
+ (setq count (1+ count)))))
+ (when moved ;What's the result
+ (forward-char 3)
+ (setq moved (point))))))
+ moved))
+
+(defun folding-pick-move ()
+ "Pick the logical movement on fold mark.
+If at the end of fold, then move to the beginning and vice versa.
+
+If placed over closed fold moves to the next fold. When no next
+folds are visible, stops moving.
+
+Return:
+ t if moved"
+ (interactive)
+ (let* (case-fold-search
+ (elt (folding-get-mode-marks))
+ (bm (nth 0 elt)) ; markers defined for mode
+ (stat (folding-mark-look-at))
+ moved)
+ (cond
+ ((eq 0 stat) ;closed fold
+ (when (re-search-forward (concat "^" (regexp-quote bm)) nil t)
+ (setq moved t)
+ (forward-char 3)))
+ ((symbolp stat) ;End fold
+ (setq moved (folding-find-folding-mark)))
+ ((integerp stat) ;Beg fold
+ (setq moved (folding-find-folding-mark 'end-fold))))
+ (if (integerp moved)
+ (goto-char moved))
+ moved))
+
+;;; Idea by Scott Evans <gse A T antisleep com>
+(defun folding-context-next-action ()
+ "Take next action according to point and context.
+If point is at:
+
+ Begin Fold : toggle open - close
+ End Fold : close
+ inside : fold current level."
+ (interactive)
+ (let ((state (folding-mark-look-at)))
+ (cond
+ ((eq state 0)
+ (folding-act 'open))
+ ((eq state 1)
+ (folding-act 'close))
+ ((eq state 11)
+ (folding-act 'up))
+ ((eq 'end state)
+ (folding-act 'close))
+ ((eq state 'end-in)
+ (folding-act 'up))
+ (t
+ (folding-act 'other)))))
+
+(defun folding-forward-char-1 (&optional arg)
+ "See `folding-forward-char-1' for ARG."
+ (if (eq arg 1)
+ ;; Do it a faster way for arg = 1.
+ (if (eq (following-char) ?\r)
+ (let ((saved (point))
+ (inhibit-quit t))
+ (end-of-line)
+ (if (not (eobp))
+ (forward-char)
+ (goto-char saved)
+ (error "End of buffer")))
+ ;; `forward-char' here will do its own error if (eobp).
+ (forward-char))
+ (if (> 0 (or arg (setq arg 1)))
+ (folding-backward-char (- arg))
+ (let (goal saved)
+ (while (< 0 arg)
+ (skip-chars-forward "^\r" (setq goal (+ (point) arg)))
+ (if (eq goal (point))
+ (setq arg 0)
+ (if (eobp)
+ (error "End of buffer")
+ (setq arg (- goal 1 (point))
+ saved (point))
+ (let ((inhibit-quit t))
+ (end-of-line)
+ (if (not (eobp))
+ (forward-char)
+ (goto-char saved)
+ (error "End of buffer"))))))))))
+
+(defmacro folding-forward-char-macro ()
+ `(defun folding-forward-char (&optional arg)
+ "Move point right ARG characters, skipping hidden folded regions.
+Moves left if ARG is negative. On reaching end of buffer, stop and
+signal error."
+ ,(folding-interactive-spec-p)
+ ;; (folding-preserve-active-region)
+ (folding-forward-char-1 arg)))
+
+(folding-forward-char-macro)
+
+(defun folding-backward-char-1 (&optional arg)
+ "See `folding-backward-char-1' for ARG."
+ (if (eq arg 1)
+ ;; Do it a faster way for arg = 1.
+ ;; Catch the case where we are in a hidden region, and bump into a \r.
+ (if (or (eq (preceding-char) ?\n)
+ (eq (preceding-char) ?\r))
+ (let ((pos (1- (point)))
+ (inhibit-quit t))
+ (forward-char -1)
+ (beginning-of-line)
+ (skip-chars-forward "^\r" pos))
+ (forward-char -1))
+ (if (> 0 (or arg (setq arg 1)))
+ (folding-forward-char (- arg))
+ (let (goal)
+ (while (< 0 arg)
+ (skip-chars-backward "^\r\n" (max (point-min)
+ (setq goal (- (point) arg))))
+ (if (eq goal (point))
+ (setq arg 0)
+ (if (bobp)
+ (error "Beginning of buffer")
+ (setq arg (- (point) 1 goal)
+ goal (point))
+ (let ((inhibit-quit t))
+ (forward-char -1)
+ (beginning-of-line)
+ (skip-chars-forward "^\r" goal)))))))))
+
+(defmacro folding-backward-char-macro ()
+ `(defun folding-backward-char (&optional arg)
+ "Move point right ARG characters, skipping hidden folded regions.
+Moves left if ARG is negative. On reaching end of buffer, stop and
+signal error."
+ ,(folding-interactive-spec-p)
+ ;; (folding-preserve-active-region)
+ (folding-backward-char-1 arg)))
+
+(folding-backward-char-macro)
+
+(defmacro folding-end-of-line-macro ()
+ `(defun folding-end-of-line (&optional arg)
+ "Move point to end of current line, but before hidden folded region.
+ARG is line count.
+
+Has the same behavior as `end-of-line', except that if the current line
+ends with some hidden folded text (represented by an ellipsis), the
+point is positioned just before it. This prevents the point from being
+placed inside the folded text, which is not normally useful."
+ ,(folding-interactive-spec-p)
+ ;;(interactive "p")
+ ;; (folding-preserve-active-region)
+ (if (or (eq arg 1)
+ (not arg))
+ (beginning-of-line)
+ ;; `forward-line' also moves point to beginning of line.
+ (forward-line (1- arg)))
+ (skip-chars-forward "^\r\n")))
+
+(folding-end-of-line-macro)
+
+(defun folding-skip-ellipsis-backward ()
+ "Move the point backwards out of folded text.
+
+If the point is inside a folded region, the cursor is displayed at the
+end of the ellipsis representing the folded part. This function checks
+to see if this is the case, and if so, moves the point backwards until
+it is just outside the hidden region, and just before the ellipsis.
+
+Returns t if the point was moved, nil otherwise."
+ (interactive)
+ (let ((pos (point))
+ result)
+ (save-excursion
+ (beginning-of-line)
+ (skip-chars-forward "^\r" pos)
+ (or (eq pos (point))
+ (setq pos (point)
+ result t)))
+ (goto-char pos)
+ result))
+
+;;}}}
+
+;;{{{ code: Moving in and out of folds
+
+;;{{{ folding-shift-in
+
+(defun folding-shift-in (&optional noerror)
+ "Open and enter the fold at or around the point.
+
+Enters the fold that the point is inside, wherever the point is inside
+the fold, provided it is a valid fold with balanced top and bottom
+marks. Returns nil if the fold entered contains no sub-folds, t
+otherwise. If an optional argument NOERROR is non-nil, returns nil if
+there are no folds to enter, instead of causing an error.
+
+If the point is inside a folded, hidden region (as represented by an
+ellipsis), the position of the point in the buffer is preserved, and as
+many folds as necessary are entered to make the surrounding text
+visible. This is useful after some commands eg., search commands."
+ (interactive)
+ (labels
+ ((open-fold nil
+ (let ((data (folding-show-current-entry noerror t)))
+ (and data
+ (progn
+ (when folding-narrow-by-default
+ (setq folding-stack
+ (if folding-stack
+ (cons (cons (point-min-marker) (point-max-marker))
+ folding-stack)
+ '(folded)))
+ (folding-set-mode-line))
+ (folding-narrow-to-region (car data) (nth 1 data)))))))
+ (let ((goal (point)))
+ (while (folding-skip-ellipsis-backward)
+ (beginning-of-line)
+ (open-fold)
+ (goto-char goal))
+ (when (not folding-narrow-by-default)
+ (widen)))))
+
+;;}}}
+;;{{{ folding-shift-out
+
+(defun folding-shift-out (&optional event)
+ "Exits the current fold with EVENT."
+ (interactive)
+ (if folding-stack
+ (progn
+ (folding-tidy-inside)
+ (cond
+ ((folding-use-overlays-p)
+ (folding-subst-regions
+ (list (overlay-end (car folding-narrow-overlays))
+ (overlay-start (cdr folding-narrow-overlays))) ?\n ?\r)
+ ;; So point is correct in other windows.
+ (goto-char (overlay-end (car folding-narrow-overlays))))
+ (t
+ (folding-subst-regions (list (point-min) (point-max)) ?\n ?\r)
+ ;; So point is correct in other window
+ (goto-char (point-min))))
+
+ (if (eq (car folding-stack) 'folded)
+ (folding-narrow-to-region nil nil t)
+ (folding-narrow-to-region (marker-position (car (car folding-stack)))
+ (marker-position (cdr (car folding-stack))) t))
+ (and (consp (car folding-stack))
+ (set-marker (car (car folding-stack)) nil)
+ (set-marker (cdr (car folding-stack)) nil))
+ (setq folding-stack (cdr folding-stack)))
+ (error "Outside all folds"))
+ (folding-set-mode-line))
+
+;;}}}
+;;{{{ folding-show-current-entry
+
+(defun folding-show-current-entry (&optional event noerror noskip)
+ "Opens the fold that the point is on, but does not enter it.
+EVENT and optional arg NOERROR means don't signal an error if there is
+no fold, just return nil. NOSKIP means don't jump out of a hidden
+region first.
+
+Returns ((START END SUBFOLDS-P). START and END indicate the extents of
+the fold that was shown. If SUBFOLDS-P is non-nil, the fold contains
+subfolds."
+ (interactive)
+ (or noskip
+ (folding-skip-ellipsis-backward))
+ (let ((point (point))
+ backward forward start end subfolds-not-p)
+ (unwind-protect
+ (or (and (integerp
+ (car-safe (setq backward (folding-skip-folds t))))
+ (integerp
+ (car-safe (setq forward (folding-skip-folds nil))))
+ (progn
+ (goto-char (car forward))
+ (skip-chars-forward "^\r\n")
+ (setq end (point))
+ (skip-chars-forward "\r\n")
+ (not (and folding-stack (eobp))))
+ (progn
+ (goto-char (car backward))
+ (skip-chars-backward "^\r\n")
+ (setq start (point))
+ (skip-chars-backward "\r\n")
+ (not (and folding-stack (bobp))))
+ (progn
+ (setq point start)
+ ;; Avoid holding the list through a GC.
+ (setq subfolds-not-p
+ (not (or (cdr backward)
+ (cdr forward))))
+ (folding-subst-regions
+ (append backward (nreverse forward))
+ ?\r ?\n)
+ (list start end (not subfolds-not-p))))
+ (if noerror
+ nil
+ (error "Not on a fold")))
+ (goto-char point))))
+
+;;}}}
+;;{{{ folding-hide-current-entry
+
+(defun folding-toggle-enter-exit ()
+ "Run folding-shift-in or folding-shift-out depending on current line's contents."
+ (interactive)
+ (beginning-of-line)
+ (let ((current-line-mark (folding-mark-look-at)))
+ (if (and (numberp current-line-mark)
+ (= current-line-mark 0))
+ (folding-shift-in)
+ (folding-shift-out))))
+
+(defun folding-toggle-show-hide ()
+ "Run folding-show-current-entry or folding-hide-current-entry depending on current line's contents."
+ (interactive)
+ (beginning-of-line)
+ (let ((current-line-mark (folding-mark-look-at)))
+ (if (and (numberp current-line-mark)
+ (= current-line-mark 0))
+ (folding-show-current-entry)
+ (folding-hide-current-entry))))
+
+(defun folding-hide-current-entry (&optional event)
+ "Close the fold around the point using EVENT.
+Undo effect of `folding-show-current-entry'."
+ (interactive)
+ (folding-skip-ellipsis-backward)
+ (let (start end)
+ (if (and (integerp (setq start (car-safe (folding-skip-folds t))))
+ (integerp (setq end (car-safe (folding-skip-folds nil)))))
+ (if (and folding-stack
+ (or (eq start (point-min))
+ (eq end (point-max))))
+ ;;(error "Cannot hide current fold")
+ (folding-shift-out)
+ (goto-char start)
+ (skip-chars-backward "^\r\n")
+ (folding-subst-regions (list start end) ?\n ?\r))
+ (error "Not on a fold"))))
+
+;;}}}
+;;{{{ folding-show-all
+
+(defun folding-show-all ()
+ "Exits all folds, to the top level."
+ (interactive)
+ (while folding-stack
+ (folding-shift-out)))
+
+;;}}}
+;;{{{ folding-goto-line
+
+(defun folding-goto-line (line)
+ "Go to LINE, entering as many folds as possible."
+ (interactive "NGoto line: ")
+ (folding-show-all)
+ (goto-char 1)
+ (and (< 1 line)
+ (re-search-forward "[\n\C-m]" nil 0 (1- line)))
+ (let ((goal (point)))
+ (while (prog2 (beginning-of-line)
+ (folding-shift-in t)
+ (goto-char goal))))
+ (folding-narrow-to-region
+ (and folding-narrow-by-default (point-min))
+ (point-max) t))
+
+;;}}}
+
+;;}}}
+;;{{{ code: Searching for fold boundaries
+
+;;{{{ folding-skip-folds
+
+(defun folding-skip-folds (backward &optional outside)
+ "Skips forward through the buffer (backward if BACKWARD is non-nil)
+until it finds a closing fold mark or the end of the buffer. The
+point is not moved. Jumps over balanced folding-mark pairs on the way.
+Returns t if the end of buffer was found in an unmatched folding-mark
+pair, otherwise a list.
+
+If the point is actually on an fold start mark, the mark is ignored;
+if it is on an end mark, the mark is noted. This decision is
+reversed if BACKWARD is non-nil. If optional OUTSIDE is non-nil and
+BACKWARD is nil, either mark is noted.
+
+The first element of the list is a position in the end of the closing
+fold mark if one was found, or nil. It is followed by (END START)
+pairs (flattened, not a list of pairs). The pairs indicating the
+positions of folds skipped over; they are positions in the fold
+marks, not necessarily at the ends of the fold marks. They are in
+the opposite order to that in which they were skipped. The point is
+left in a meaningless place. If going backwards, the pairs are
+\(START END) pairs, as the fold marks are scanned in the opposite
+order.
+
+Works by maintaining the position of the top and bottom marks found
+so far. They are found separately using a normal string search for
+the fixed part of a fold mark (because it is faster than a regexp
+search if the string does not occur often outside of fold marks),
+checking that it really is a proper fold mark, then considering the
+earliest one found. The position of the other (if found) is
+maintained to avoid an unnecessary search at the next iteration."
+ (let ((first-mark (if backward folding-bottom-mark folding-top-mark))
+ (last-mark (if backward folding-top-mark folding-bottom-mark))
+ (top-re folding-top-regexp)
+ (depth 0)
+ pairs point
+ temp
+ start
+ first
+ last
+ case-fold-search)
+ ;; Ignore trailing space?
+ (when nil
+ (when (and (stringp first-mark)
+ (string-match "^\\(.*[^ ]+\\) +$" first-mark))
+ (setq first-mark (match-string 1 first-mark)))
+ (when (and (stringp last-mark)
+ (string-match "^\\(.*[^ ]+\\) +$" last-mark))
+ (setq last-mark (match-string 1 last-mark)))
+ (when (and (stringp top-re)
+ (string-match "^\\(.*[^ ]+\\) +$" top-re))
+ (setq top-re (match-string 1 top-re))))
+ (save-excursion
+ (skip-chars-backward "^\r\n")
+ (unless outside
+ (and (eq (preceding-char) ?\r)
+ (forward-char -1))
+ (if (looking-at top-re)
+ (if backward
+ (setq last (match-end 1))
+ (skip-chars-forward "^\r\n"))))
+ (while (progn
+ ;; Find last first, prevents unnecessary searching
+ ;; for first.
+ (setq point (point))
+ (or last
+ (while (and (if backward
+ (search-backward last-mark first t)
+ (search-forward last-mark first t))
+ (progn
+ (setq temp (point))
+ (goto-char (match-beginning 0))
+ (skip-chars-backward " \t")
+ (and (not
+ (setq last
+ (if (eq (preceding-char) ?\r)
+ temp
+ (and (bolp) temp))))
+ (goto-char temp)))))
+ (goto-char point))
+ (or first
+ (while (and (if backward
+ (search-backward first-mark last t)
+ (search-forward first-mark last t))
+ (progn
+ (setq temp (point))
+ (goto-char (match-beginning 0))
+ (skip-chars-backward " \t")
+ (and (not
+ (setq first
+ (if (eq (preceding-char) ?\r)
+ temp
+ (and (bolp) temp))))
+ (goto-char temp))))))
+ ;; Return value of conditional says whether to
+ ;; iterate again.
+ (if (not last)
+ ;; Return from this with the result.
+ (not (setq pairs (if first t (cons nil pairs))))
+ (if (and first
+ (if backward
+ (> first last)
+ (< first last)))
+ (progn
+ (goto-char first)
+ (if (eq 0 depth)
+ (setq start first
+ first nil
+ depth 1) ;; non-nil value, loop again.
+ (setq first nil
+ ;; non-nil value => loop again
+ depth (1+ depth))))
+ (goto-char last)
+ (if (eq 0 depth)
+ (not (setq pairs (cons last pairs)))
+ (or (< 0 (setq depth (1- depth)))
+ (setq pairs (cons last (cons start pairs))))
+ (setq last nil)
+ t)))))
+ pairs)))
+
+;;}}}
+
+;;}}}
+;;{{{ code: Functions that actually modify the buffer
+
+;;{{{ folding-fold-region
+
+(defun folding-fold-region (start end)
+ "Places fold mark at the beginning and end of a specified region.
+The region is specified by two arguments START and END. The point is
+left at a suitable place ready to insert the title of the fold.
+
+The fold markers are intended according to mode."
+ (interactive "r")
+ (and (< end start)
+ (setq start (prog1 end
+ (setq end start))))
+ (setq end (set-marker (make-marker) end))
+ (goto-char start)
+ (beginning-of-line)
+ (setq start (point))
+ (insert-before-markers folding-top-mark)
+ ;; XEmacs latex-mode, after (tex-site), indents the whole
+ ;; fold 50 characters right. Don't do that.
+ (unless (string-match "latex" (symbol-name major-mode))
+ (indent-according-to-mode))
+ (let ((saved-point (point)))
+ (and folding-secondary-top-mark
+ (insert-before-markers folding-secondary-top-mark))
+ (insert-before-markers ?\n)
+ (goto-char (marker-position end))
+ (set-marker end nil)
+ (and (not (bolp))
+ (eq 0 (forward-line))
+ (eobp)
+ (insert ?\n))
+ (insert folding-bottom-mark)
+ (unless (string-match "latex" (symbol-name major-mode))
+ (indent-according-to-mode))
+ (insert ?\n)
+ (setq folding-stack (if folding-stack
+ (cons (cons (point-min-marker)
+ (point-max-marker))
+ folding-stack)
+ '(folded)))
+ (folding-narrow-to-region start (1- (point)))
+ (goto-char saved-point)
+ (folding-set-mode-line))
+ (save-excursion (folding-tidy-inside)))
+
+;;}}}
+;;{{{ folding-tidy-inside
+
+;; Note to self: The long looking code for checking and modifying those
+;; blank lines is to make sure the text isn't modified unnecessarily.
+;; Don't remove it again!
+
+(defun folding-tidy-inside ()
+ "Add or remove blank lines at the top and bottom of the current fold.
+Also adds fold marks at the top and bottom (after asking), if they are not
+there already. The amount of space left depends on the variable
+`folding-internal-margins', which is one by default."
+ (interactive)
+ (if buffer-read-only nil
+ (let ()
+;;; (top-re (if (string-match "^\\(.*\\) $" folding-top-mark)
+;;; (match-string 1 folding-top-mark)
+;;; folding-top-mark))
+ (if (folding-use-overlays-p)
+ (goto-char (- (overlay-end (car folding-narrow-overlays)) 1))
+ (goto-char (point-min)))
+ (and (eolp)
+ (progn (skip-chars-forward "\n\t ")
+ (delete-region (point-min) (point))))
+ (and (if (let (case-fold-search) (folding-mark-look-at-top-mark-p))
+ (progn (forward-line 1)
+ (and (eobp) (insert ?\n))
+ t)
+ (and (y-or-n-p "Insert missing folding-top-mark? ")
+ (progn (insert (concat folding-top-mark
+ "<Replaced missing fold top mark>"
+ (or folding-secondary-top-mark "")
+ "\n"))
+ t)))
+ folding-internal-margins
+ (<= 0 folding-internal-margins)
+ (let* ((p1 (point))
+ (p2 (progn (skip-chars-forward "\n") (point)))
+ (p3 (progn (skip-chars-forward "\n\t ")
+ (skip-chars-backward "\t " p2) (point))))
+ (if (eq p2 p3)
+ (or (eq p2 (setq p3 (+ p1 folding-internal-margins)))
+ (if (< p2 p3)
+ (newline (- p3 p2))
+ (delete-region p3 p2)))
+ (delete-region p1 p3)
+ (or (eq 0 folding-internal-margins)
+ (newline folding-internal-margins)))))
+ (if (folding-use-overlays-p)
+ (goto-char (overlay-start (cdr folding-narrow-overlays)))
+ (goto-char (point-max)))
+ (and (bolp)
+ (progn (skip-chars-backward "\n")
+ (delete-region (point) (point-max))))
+ (beginning-of-line)
+ (and (or (let (case-fold-search) (folding-mark-look-at-bottom-mark-p))
+ (progn (goto-char (point-max)) nil)
+ (and (y-or-n-p "Insert missing folding-bottom-mark? ")
+ (progn
+ (insert (concat "\n" folding-bottom-mark))
+ (beginning-of-line)
+ t)))
+ folding-internal-margins
+ (<= 0 folding-internal-margins)
+ (let* ((p1 (point))
+ (p2 (progn (skip-chars-backward "\n") (point)))
+ (p3 (progn (skip-chars-backward "\n\t ")
+ (skip-chars-forward "\t " p2) (point))))
+ (if (eq p2 p3)
+ (or (eq p2 (setq p3 (- p1 1 folding-internal-margins)))
+ (if (> p2 p3)
+ (newline (- p2 p3))
+ (delete-region p2 p3)))
+ (delete-region p3 p1)
+ (newline (1+ folding-internal-margins))))))))
+
+;;}}}
+
+;;}}}
+;;{{{ code: Operations on the whole buffer
+
+;;{{{ folding-whole-buffer
+
+(defun folding-whole-buffer ()
+ "Folds every fold in the current buffer.
+Fails if the fold markers are not balanced correctly.
+
+If the buffer is being viewed in a fold, folds are repeatedly exited to
+get to the top level first (this allows the folds to be tidied on the
+way out). The buffer modification flag is not affected, and this
+function will work on read-only buffers."
+
+ (interactive)
+ (message "Folding buffer...")
+ (let ((narrow-min (point-min))
+ (narrow-max (point-max))
+ folding-list)
+ (save-excursion
+ (widen)
+ (goto-char 1)
+ (setq folding-list (folding-skip-folds nil t))
+ (narrow-to-region narrow-min narrow-max)
+ (and (eq t folding-list)
+ (error
+ "Cannot fold whole buffer -- unmatched begin-fold mark `%s' ´%s'"
+ (current-buffer)
+ folding-top-mark))
+ (and (integerp (car folding-list))
+ (error
+ "Cannot fold whole buffer -- extraneous end-fold mark `%s' `%s'"
+ (current-buffer)
+ folding-bottom-mark))
+ (folding-show-all)
+ (widen)
+ (goto-char 1)
+ ;; Do the modifications forwards.
+ (folding-subst-regions (nreverse (cdr folding-list)) ?\n ?\r))
+ (beginning-of-line)
+ (folding-narrow-to-region nil nil t)
+ (message "Folding buffer... done")))
+
+;;}}}
+;;{{{ folding-open-buffer
+
+(defun folding-open-buffer ()
+ "Unfolds the entire buffer, leaving the point where it is.
+Does not affect the buffer-modified flag, and can be used on read-only
+buffers."
+ (interactive)
+ (message "Unfolding buffer...")
+ (folding-clear-stack)
+ (folding-set-mode-line)
+ (unwind-protect
+ (progn
+ (widen)
+ (folding-subst-regions (list 1 (point-max)) ?\r ?\n))
+ (folding-narrow-to-region nil nil t))
+ (message "Unfolding buffer... done"))
+
+;;}}}
+;;{{{ folding-convert-buffer-for-printing
+
+(defun folding-convert-buffer-for-printing (&optional buffer pre-title post-title pad)
+ "Remove folds from a buffer, for printing.
+
+It copies the contents of the (hopefully) folded buffer BUFFER into a
+buffer called `*Unfolded: <Original-name>*', removing all of the fold
+marks. It keeps the titles of the folds, however, and numbers them.
+Subfolds are numbered in the form 5.1, 5.2, 5.3 etc., and the titles are
+indented to eleven characters.
+
+It accepts four arguments. BUFFER is the name of the buffer to be
+operated on, or a buffer. nil means use the current buffer. PRE-TITLE
+is the text to go before the replacement fold titles, POST-TITLE is the
+text to go afterwards. Finally, if PAD is non-nil, the titles are all
+indented to the same column, which is eleven plus the length of
+PRE-TITLE. Otherwise just one space is placed between the number and
+the title."
+ (interactive (list (read-buffer "Remove folds from buffer: "
+ (buffer-name)
+ t)
+ (read-string "String to go before enumerated titles: ")
+ (read-string "String to go after enumerated titles: ")
+ (y-or-n-p "Pad section numbers with spaces? ")))
+ (set-buffer (setq buffer (get-buffer buffer)))
+ (setq pre-title (or pre-title "")
+ post-title (or post-title ""))
+ (or folding-mode
+ (error "Must be in Folding mode before removing folds"))
+ (let* ((new-buffer (get-buffer-create (concat "*Unfolded: "
+ (buffer-name buffer)
+ "*")))
+ (section-list '(1))
+ (section-prefix-list '(""))
+
+ (secondary-mark-length (length folding-secondary-top-mark))
+
+ (secondary-mark folding-secondary-top-mark)
+ (mode major-mode)
+
+ ;; [jari] Aug 14 1997
+ ;; Regexp doesn't allow "footer text" like, so we add one more
+ ;; regexp to loosen the end criteria
+ ;;
+ ;; {{{ Subsubsection 1
+ ;; }}} Subsubsection 1
+ ;;
+ ;; was: (regexp folding-regexp)
+ ;;
+ (regexp
+ (concat "\\(^\\|\r\\)\\([ \t]*\\)\\(\\("
+ (regexp-quote folding-top-mark)
+ "\\)\\|\\("
+ (regexp-quote folding-bottom-mark)
+ "[ \t]*.*\\(\\)\\($\\|\r\\)\\)\\)"))
+ title
+ prefix)
+ ;; was obsolete function: (buffer-flush-undo new-buffer)
+ (buffer-disable-undo new-buffer)
+ (save-excursion
+ (set-buffer new-buffer)
+ (delete-region (point-min)
+ (point-max)))
+ (save-restriction
+ (widen)
+ (copy-to-buffer new-buffer (point-min) (point-max)))
+ (display-buffer new-buffer t)
+ (set-buffer new-buffer)
+ (subst-char-in-region (point-min) (point-max) ?\r ?\n)
+ (funcall mode)
+ (while (re-search-forward regexp nil t)
+ (if (match-beginning 4)
+ (progn
+ (goto-char (match-end 4))
+
+ ;; - Move after start fold and read the title from there
+ ;; - Then move back and kill the fold mark
+ ;;
+ (setq title
+ (buffer-substring (point)
+ (progn (end-of-line)
+ (point))))
+ (delete-region (save-excursion
+ (goto-char (match-beginning 4))
+ (skip-chars-backward "\n\r")
+ (point))
+ (progn
+ (skip-chars-forward "\n\r")
+ (point)))
+ (and (<= secondary-mark-length
+ (length title))
+ (string-equal secondary-mark
+ (substring title
+ (- secondary-mark-length)))
+ (setq title (substring title
+ 0
+ (- secondary-mark-length))))
+ (setq section-prefix-list
+ (cons (setq prefix (concat (car section-prefix-list)
+ (int-to-string (car section-list))
+ "."))
+ section-prefix-list))
+ (or (cdr section-list)
+ (insert ?\n))
+ (setq section-list (cons 1
+ (cons (1+ (car section-list))
+ (cdr section-list))))
+ (setq title (concat prefix
+ (if pad
+ (make-string
+ (max 2 (- 8 (length prefix))) ? )
+ " ")
+ title))
+ (message "Reformatting: %s%s%s"
+ pre-title
+ title
+ post-title)
+ (insert "\n\n"
+ pre-title
+ title
+ post-title
+ "\n\n"))
+ (goto-char (match-beginning 5))
+ (or (setq section-list (cdr section-list))
+ (error "Too many bottom-of-fold marks"))
+
+ (setq section-prefix-list (cdr section-prefix-list))
+ (delete-region (point)
+ (progn
+ (forward-line 1)
+ (point)))))
+ (and (cdr section-list)
+ (error
+ "Too many top-of-fold marks -- reached end of file prematurely"))
+ (goto-char (point-min))
+ (buffer-enable-undo)
+ (set-buffer-modified-p nil)
+ (message "All folds reformatted.")))
+
+;;}}}
+;;}}}
+
+;;{{{ code: Standard fold marks for various major modes
+
+;;{{{ A function to set default marks, `folding-add-to-marks-list'
+
+(defun folding-add-to-marks-list (mode top bottom
+ &optional secondary noforce message)
+ "Add/set fold mark list for a particular major mode.
+When called interactively, asks for a `major-mode' name, and for
+fold marks to be used in that mode. It adds the new set to
+`folding-mode-marks-alist', and if the mode name is the same as the current
+major mode for the current buffer, the marks in use are also changed.
+
+If called non-interactively, arguments are MODE, TOP, BOTTOM and
+SECONDARY. MODE is the symbol for the major mode for which marks are
+being set. TOP, BOTTOM and SECONDARY are strings, the three fold marks
+to be used. SECONDARY may be nil (as opposed to the empty string), but
+the other two must be non-empty strings, and is an optional argument.
+
+Two other optional arguments are NOFORCE, meaning do not change the
+marks if marks are already set for the specified mode if non-nil, and
+MESSAGE, which causes a message to be displayed if it is non-nil. This
+is also the message displayed if the function is called interactively.
+
+To set default fold marks for a particular mode, put something like the
+following in your .emacs:
+
+\(folding-add-to-marks-list 'major-mode \"(** {{{ \" \"(** }}} **)\" \" **)\")
+
+Look at the variable `folding-mode-marks-alist' to see what default settings
+already apply.
+
+`folding-set-marks' can be used to set the fold marks in use in the current
+buffer without affecting the default value for a particular mode."
+ (interactive
+ (let* ((mode (completing-read
+ (concat "Add fold marks for major mode ("
+ (symbol-name major-mode)
+ "): ")
+ obarray
+ (function
+ (lambda (arg)
+ (and (commandp arg)
+ (string-match "-mode\\'"
+ (symbol-name arg)))))
+ t))
+ (mode (if (equal mode "")
+ major-mode
+ (intern mode)))
+ (object (assq mode folding-mode-marks-alist))
+ (old-top (and object
+ (nth 1 object)))
+ top
+ (old-bottom (and object
+ (nth 2 object)))
+ bottom
+ (secondary (and object
+ (nth 3 object)))
+ (prompt "Top fold marker: "))
+ (and (equal secondary "")
+ (setq secondary nil))
+ (while (not top)
+ (setq top (read-string prompt (or old-top "{{{ ")))
+ (and (equal top "")
+ (setq top nil)))
+ (setq prompt (concat prompt
+ top
+ ", Bottom marker: "))
+ (while (not bottom)
+ (setq bottom (read-string prompt (or old-bottom "}}}")))
+ (and (equal bottom "")
+ (setq bottom nil)))
+ (setq prompt (concat prompt
+ bottom
+ (if secondary
+ ", Secondary marker: "
+ ", Secondary marker (none): "))
+ secondary (read-string prompt secondary))
+ (and (equal secondary "")
+ (setq secondary nil))
+ (list mode top bottom secondary nil t)))
+ (let ((object (assq mode folding-mode-marks-alist)))
+ (if (and object
+ noforce
+ message)
+ (message "Fold markers for `%s' are already set."
+ (symbol-name mode))
+ (if object
+ (or noforce
+ (setcdr object (if secondary
+ (list top bottom secondary)
+ (list top bottom))))
+ (setq folding-mode-marks-alist
+ (cons (if secondary
+ (list mode top bottom secondary)
+ (list mode top bottom))
+ folding-mode-marks-alist)))
+ (and message
+ (message "Set fold marks for `%s' to \"%s\" and \"%s\"."
+ (symbol-name mode)
+ (if secondary
+ (concat top "name" secondary)
+ (concat top "name"))
+ bottom)
+ (and (eq major-mode mode)
+ (folding-set-marks top bottom secondary))))))
+
+;;}}}
+;;{{{ Set some useful default fold marks
+
+(folding-add-to-marks-list 'ada-mode "-- {{{" "-- }}}" nil t)
+(folding-add-to-marks-list 'asm-mode "; {{{" "; }}}" nil t)
+(folding-add-to-marks-list 'awk-mode "# {{{" "# }}}" nil t)
+(folding-add-to-marks-list 'Bison-mode "/* {{{" "/* }}} */" " */" t)
+(folding-add-to-marks-list 'LaTeX-mode "%{{{" "%}}}" nil t)
+(folding-add-to-marks-list 'TeX-mode "%{{{" "%}}}" nil t)
+(folding-add-to-marks-list 'bibtex-mode "%{{{" "%}}} */" nil t)
+(folding-add-to-marks-list 'bison-mode "/* {{{" "/* }}} */" " */" t)
+(folding-add-to-marks-list 'c++-mode "// {{{" "// }}}" nil t)
+(folding-add-to-marks-list 'c-mode "/* {{{" "/* }}} */" " */" t)
+(folding-add-to-marks-list 'dcl-mode "! {{{" "! }}}" nil t)
+(folding-add-to-marks-list 'change-log-mode "{{{" "}}}" nil t)
+(folding-add-to-marks-list 'cperl-mode "# {{{" "# }}}" nil t)
+(folding-add-to-marks-list 'emacs-lisp-mode ";;{{{" ";;}}}" nil t)
+(folding-add-to-marks-list 'erlang-mode "%%{{{" "%%}}}" nil t)
+(folding-add-to-marks-list 'finder-mode "{{{" "}}}" nil t)
+(folding-add-to-marks-list 'fortran-mode "! {{{" "! }}}" nil t)
+(folding-add-to-marks-list 'f90-mode "! {{{" "! }}}" nil t)
+(folding-add-to-marks-list 'generic-mode ";# " ";\$" nil t)
+(folding-add-to-marks-list 'gofer-mode "-- {{{" "-- }}}" nil t)
+(folding-add-to-marks-list 'html-mode "<!-- [[[ " "<!-- ]]] -->" " -->" t)
+(folding-add-to-marks-list 'icon-mode "# {{{" "# }}}" nil t)
+(folding-add-to-marks-list 'indented-text-mode "{{{" "}}}" nil t)
+(folding-add-to-marks-list 'java-mode "// {{{" "// }}}" nil t)
+(folding-add-to-marks-list 'javascript-mode "// {{{" "// }}}" nil t)
+(folding-add-to-marks-list 'jde-mode "// {{{" "// }}}" nil t)
+(folding-add-to-marks-list 'ksh-mode "# {{{" "# }}}" nil t)
+(folding-add-to-marks-list 'latex-mode "%{{{" "%}}}" nil t)
+(folding-add-to-marks-list 'lisp-interaction-mode ";;{{{" ";;}}}" nil t)
+(folding-add-to-marks-list 'lisp-mode ";;{{{" ";;}}}" nil t)
+(folding-add-to-marks-list 'm4-mode "# {{{" "# }}}" nil t)
+(folding-add-to-marks-list 'makefile-mode "# {{{" "# }}}" nil t)
+(folding-add-to-marks-list 'matlab-mode "%%%{{{" "%%%}}}" nil t)
+(folding-add-to-marks-list 'meta-mode "% {{{" "% }}}" nil t)
+(folding-add-to-marks-list 'ml-mode "(* {{{" "(* }}} *)" " *)" t)
+(folding-add-to-marks-list 'modula-2-mode "(* {{{" "(* }}} *)" " *)" t)
+(folding-add-to-marks-list 'nroff-mode "\\\\ {{{" "\\\\ }}}" nil t)
+(folding-add-to-marks-list 'occam-mode "-- {{{" "-- }}}" nil t)
+(folding-add-to-marks-list 'orwell-mode "{{{" "}}}" nil t)
+(folding-add-to-marks-list 'pascal-mode "{ ((( " "{ ))) }" " }" t)
+(folding-add-to-marks-list 'php-mode "// {{{" "// }}}" nil t)
+(folding-add-to-marks-list 'perl-mode "# {{{" "# }}}" nil t)
+(folding-add-to-marks-list 'plain-TeX-mode "%{{{" "%}}}" nil t)
+(folding-add-to-marks-list 'plain-tex-mode "%{{{" "%}}}" nil t)
+(folding-add-to-marks-list 'prolog-mode "% {{{" "% }}}" nil t)
+(folding-add-to-marks-list 'rexx-mode "/* {{{" "/* }}} */" " */" t)
+(folding-add-to-marks-list 'sh-mode "# {{{" "# }}}" nil t)
+(folding-add-to-marks-list 'sh-script-mode "# {{{" "# }}}" nil t)
+(folding-add-to-marks-list 'shellscript-mode "# {{{" "# }}}" nil t)
+(folding-add-to-marks-list 'sgml-mode "<!-- [[[ " "<!-- ]]] -->" " -->" t)
+(folding-add-to-marks-list 'simula-mode "! {{{" "! }}}" nil t)
+(folding-add-to-marks-list 'sml-mode "(* {{{" "(* }}} *)" " *)" t)
+(folding-add-to-marks-list 'sql-mode "-- {{{" "-- }}}" nil t)
+(folding-add-to-marks-list 'tcl-mode "#{{{" "#}}}" nil t)
+(folding-add-to-marks-list 'tex-mode "%{{{" "%}}}" nil t)
+(folding-add-to-marks-list 'texinfo-mode "@c {{{" "@c {{{endfold}}}" " }}}" t)
+(folding-add-to-marks-list 'text-mode "{{{" "}}}" nil t)
+(folding-add-to-marks-list 'vhdl-mode "# {{{" "# }}}" nil t)
+(folding-add-to-marks-list 'xerl-mode "%%{{{" "%%}}}" nil t)
+(folding-add-to-marks-list 'xrdb-mode "! {{{" "! }}}" nil t)
+
+;; heavy shell-perl-awk programmer in fundamental-mode need # prefix...
+
+(folding-add-to-marks-list 'fundamental-mode "# {{{" "# }}}" nil t)
+
+;;}}}
+
+;;}}}
+
+;;{{{ code: Gross, crufty hacks that seem necessary
+
+;; ----------------------------------------------------------------------
+;; The functions here have been tested with Emacs 18.55, Emacs 18.58,
+;; Epoch 4.0p2 (based on Emacs 18.58) and XEmacs 19.6.
+
+;; Note that XEmacs 19.6 can't do selective-display, and its
+;; "invisible extents" don't work either, so Folding mode just won't
+;; work with that version.
+
+;; They shouldn't do the wrong thing with later versions of Emacs, but
+;; they might not have the special effects either. They may appear to
+;; be excessive; that is not the case. All of the peculiar things these
+;; functions do is done to avoid some side-effect of Emacs' internal
+;; logic that I have met. Some of them work around bugs or unfortunate
+;; (lack of) features in Emacs. In most cases, it would be better to
+;; move this into the Emacs C code.
+
+;; Folding mode is designed to be simple to cooperate with as many
+;; things as possible. These functions go against that principle at the
+;; coding level, but make life for the user bearable.
+
+;;{{{ folding-subst-regions
+
+;; Substitute newlines for carriage returns or vice versa.
+;; Avoid excessive file locking.
+
+;; Substitutes characters in the buffer, even in a read-only buffer.
+;; Takes LIST, a list of regions specified as sequence in the form
+;; (START1 END1 START2 END2 ...). In every region specified by each
+;; pair, substitutes each occurence of character FIND by REPLACE.
+
+;; The buffer-modified flag is not affected, undo information is not
+;; kept for the change, and the function works on read-only files. This
+;; function is much more efficient called with a long sequence than
+;; called for each region in the sequence.
+
+;; If the buffer is not modified when the function is called, the
+;; modified-flag is set before performing all the substitutions, and
+;; locking is temporarily disabled. This prevents Emacs from trying to
+;; make then delete a lock file for *every* substitution, which slows
+;; folding considerably, especially on a slow networked filesystem.
+;; Without this, on my system, folding files on startup (and reading
+;; other peoples' folded files) takes about five times longer. Emacs
+;; still locks the file once for this call under those circumstances; I
+;; can't think of a way around that, but it isn't really a problem.
+
+;; I consider these problems to be a bug in `subst-char-in-region'.
+
+(defun folding-subst-regions (list find replace)
+ "Substitute \\r and \\n using LIST FIND REPLACE."
+ (let ((buffer-read-only buffer-read-only) ;; Protect read-only flag.
+ (modified (buffer-modified-p))
+ (font-lock-mode nil)
+ (lazy-lock-mode nil)
+ (overlay-p (folding-use-overlays-p))
+ (ask1 (symbol-function 'ask-user-about-supersession-threat))
+ (ask2 (symbol-function 'ask-user-about-lock)))
+ (if lazy-lock-mode ;; no-op: Byte compiler silencer
+ (setq lazy-lock-mode t))
+ (unwind-protect
+ (progn
+ (setq buffer-read-only nil)
+ (or modified
+ (progn
+ (fset 'ask-user-about-supersession-threat
+ '(lambda (&rest x) nil))
+ (fset 'ask-user-about-lock
+ '(lambda (&rest x) nil))
+ (set-buffer-modified-p t))) ; Prevent file locking in the loop
+ (while list
+ (if overlay-p
+ (folding-flag-region (car list) (nth 1 list) (eq find ?\n))
+ (subst-char-in-region (car list) (nth 1 list) find replace t))
+ (setq list (cdr (cdr list)))))
+ ;; buffer-read-only is restored by the let.
+ ;; Don't want to change MODIFF time if it was modified before.
+ (or modified
+ (unwind-protect
+ (set-buffer-modified-p nil)
+ (fset 'ask-user-about-supersession-threat ask1)
+ (fset 'ask-user-about-lock ask2))))))
+
+;;}}}
+;;{{{ folding-narrow-to-region
+
+;; Narrow to region, without surprising displays.
+
+;; Similar to `narrow-to-region', but also adjusts window-start to be
+;; the start of the narrowed region. If an optional argument CENTRE is
+;; non-nil, the window-start is positioned to leave the point at the
+;; centre of the window, like `recenter'. START may be nil, in which
+;; case the function acts more like `widen'.
+
+;; Actually, all the window-starts for every window displaying the
+;; buffer, as well as the last_window_start for the buffer are set. The
+;; points in every window are set to the point in the current buffer.
+;; All this logic is necessary to prevent the display getting really
+;; weird occasionally, even if there is only one window. Try making
+;; this function like normal `narrow-to-region' with a touch of
+;; `recenter', then moving around lots of folds in a buffer displayed in
+;; several windows. You'll see what I mean.
+
+;; last_window_start is set by making sure that the selected window is
+;; displaying the current buffer, then setting the window-start, then
+;; making the selected window display another buffer (which sets
+;; last_window_start), then setting the selected window to redisplay the
+;; buffer it displayed originally.
+
+;; Note that whenever window-start is set, the point cannot be moved
+;; outside the displayed area until after a proper redisplay. If this
+;; is possible, centre the display on the point.
+
+;; In Emacs 19; Epoch or XEmacs, searches all screens for all
+;; windows. In Emacs 19, they are called "frames".
+
+(defun folding-narrow-to-region (&optional start end centre)
+ "Narrow to region START END, possibly CENTRE."
+ (let* ((the-window (selected-window))
+ (selected-buffer (window-buffer the-window))
+ (window-ring the-window)
+ (window the-window)
+ (point (point))
+ (buffer (current-buffer))
+ temp)
+ (unwind-protect
+ (progn
+ (unwind-protect
+ (progn
+ (if (folding-use-overlays-p)
+ (if start
+ (folding-narrow-aux start end t)
+ (folding-narrow-aux nil nil nil))
+ (if start
+ (narrow-to-region start end)
+ (widen)))
+
+ (setq point (point))
+ (set-window-buffer window buffer)
+
+ (while (progn
+ (and (eq buffer (window-buffer window))
+ (if centre
+ (progn
+ (select-window window)
+ (goto-char point)
+ (vertical-motion
+ (- (lsh (window-height window) -1)))
+ (set-window-start window (point))
+ (set-window-point window point))
+ (set-window-start window (or start 1))
+ (set-window-point window point)))
+
+ (not (eq (setq window (next-window window nil t))
+ window-ring)))))
+ nil ;; epoch screen
+ (select-window the-window)) ;; unwind-protect INNER
+ ;; Set last_window_start.
+ (unwind-protect
+ (if (not (eq buffer selected-buffer))
+ (set-window-buffer the-window selected-buffer)
+ (if (get-buffer "*scratch*")
+ (set-window-buffer the-window (get-buffer "*scratch*"))
+ (set-window-buffer
+ the-window (setq temp (generate-new-buffer " *temp*"))))
+ (set-window-buffer the-window buffer))
+ (and temp
+ (kill-buffer temp))))
+ ;; Undo this side-effect of set-window-buffer.
+ (set-buffer buffer)
+ (goto-char (point)))))
+
+;;}}}
+
+;;}}}
+
+;;{{{ code: folding-end-mode-quickly
+
+(defun folding-end-mode-quickly ()
+ "Replace all ^M's with linefeeds and widen a folded buffer.
+Only has any effect if Folding mode is active.
+
+This should not in general be used for anything. It is used when changing
+major modes, by being placed in kill-mode-tidy-alist, to tidy the buffer
+slightly. It is similar to `(folding-mode 0)', except that it does not
+restore saved keymaps etc. Repeat: Do not use this function. Its
+behaviour is liable to change."
+ (and (boundp 'folding-mode)
+ (assq 'folding-mode
+ (buffer-local-variables))
+ folding-mode
+ (progn
+ (if (folding-use-overlays-p)
+ (folding-narrow-to-region nil nil)
+ (widen))
+ (folding-clear-stack)
+ (folding-subst-regions (list 1 (point-max)) ?\r ?\n))))
+
+;;{{{ folding-eval-current-buffer-open-folds
+
+(defun folding-eval-current-buffer-open-folds (&optional printflag)
+ "Evaluate all of a folded buffer as Lisp code.
+Unlike `eval-current-buffer', this function will evaluate all of a
+buffer, even if it is folded. It will also work correctly on non-folded
+buffers, so is a good candidate for being bound to a key if you program
+in Emacs-Lisp.
+
+It works by making a copy of the current buffer in another buffer,
+unfolding it and evaluating it. It then deletes the copy.
+
+Programs can pass argument PRINTFLAG which controls printing of output:
+nil means discard it; anything else is stream for print."
+ (interactive)
+ (if (or (and (boundp 'folding-mode)
+ folding-mode))
+ (let ((temp-buffer
+ (generate-new-buffer (buffer-name))))
+ (message "Evaluating unfolded buffer...")
+ (save-restriction
+ (widen)
+ (copy-to-buffer temp-buffer 1 (point-max)))
+ (set-buffer temp-buffer)
+ (subst-char-in-region 1 (point-max) ?\r ?\n)
+ (let ((real-message-def (symbol-function 'message))
+ (suppress-eval-message))
+ (fset 'message
+ (function
+ (lambda (&rest args)
+ (setq suppress-eval-message t)
+ (fset 'message real-message-def)
+ (apply 'message args))))
+ (unwind-protect
+ (eval-current-buffer printflag)
+ (fset 'message real-message-def)
+ (kill-buffer temp-buffer))
+ (or suppress-eval-message
+ (message "Evaluating unfolded buffer... Done"))))
+ (eval-current-buffer printflag)))
+
+;;}}}
+
+;;}}}
+
+;;{{{ code: ISearch support, walks in and out of folds
+
+;; This used to be a package of it's own.
+;; Requires Emacs 19 or XEmacs. Does not work under Emacs 18.
+
+;;{{{ Variables
+
+(defcustom folding-isearch-install t
+ "*When non-nil, the isearch commands will handle folds."
+ :type 'boolean
+ :group 'folding)
+
+(defvar folding-isearch-stack nil
+ "Temporary storage for `folding-stack' during isearch.")
+
+;; Lists of isearch commands to replace
+
+;; These do normal searching.
+
+(defvar folding-isearch-normal-cmds
+ '(isearch-repeat-forward
+ isearch-repeat-backward
+ isearch-toggle-regexp
+ isearch-toggle-case-fold
+ isearch-delete-char
+ isearch-abort
+ isearch-quote-char
+ isearch-other-control-char
+ isearch-other-meta-char
+ isearch-return-char
+ isearch-exit
+ isearch-printing-char
+ isearch-whitespace-chars
+ isearch-yank-word
+ isearch-yank-line
+ isearch-yank-kill
+ isearch-*-char
+ isearch-\|-char
+ isearch-mode-help
+ isearch-yank-x-selection
+ isearch-yank-x-clipboard)
+ "List if isearch commands doing normal search.")
+
+;; Enables the user to edit the search string
+
+;; Missing, present in XEmacs isearch-mode.el. Not necessary?
+;; isearch-ring-advance-edit, isearch-ring-retreat-edit, isearch-complete-edit
+;; isearch-nonincremental-exit-minibuffer, isearch-yank-x-selection,
+;; isearch-yank-x-clipboard
+
+(defvar folding-isearch-edit-enter-cmds
+ '(isearch-edit-string
+ isearch-ring-advance
+ isearch-ring-retreat
+ isearch-complete) ; (Could also stay in search mode!)
+ "List of isearch commands which enters search string edit.")
+
+;; Continues searching after editing.
+
+(defvar folding-isearch-edit-exit-cmds
+ '(isearch-forward-exit-minibuffer ; Exits edit
+ isearch-reverse-exit-minibuffer
+ isearch-nonincremental-exit-minibuffer)
+ "List of isearch commands which exits search string edit.")
+
+;;}}}
+;;{{{ Keymaps (an Isearch hook)
+
+(defvar folding-isearch-mode-map nil
+ "Modified copy of the isearch keymap.")
+
+;; Create local copies of the keymaps. The `isearch-mode-map' is
+;; copied to `folding-isearch-mode-map' while `minibuffer-local-isearch-map'
+;; is made local. (Its name is used explicitly.)
+;;
+;; Note: This is called every time the search is started.
+
+(defun folding-isearch-hook-function ()
+ "Update the isearch keymaps for usage with folding mode."
+ (if (and (boundp 'folding-mode) folding-mode)
+ (let ((cmds (append folding-isearch-normal-cmds
+ folding-isearch-edit-enter-cmds
+ folding-isearch-edit-exit-cmds)))
+ (setq folding-isearch-mode-map (copy-keymap isearch-mode-map))
+ (make-local-variable 'minibuffer-local-isearch-map)
+ ;; Make sure the destructive operations below doesn't alter
+ ;; the global instance of the map.
+ (setq minibuffer-local-isearch-map
+ (copy-keymap minibuffer-local-isearch-map))
+ (setq folding-isearch-stack folding-stack)
+ (while cmds
+ (substitute-key-definition
+ (car cmds)
+ (intern (concat "folding-" (symbol-name (car cmds))))
+ folding-isearch-mode-map)
+ (substitute-key-definition
+ (car cmds)
+ (intern (concat "folding-" (symbol-name (car cmds))))
+ minibuffer-local-isearch-map)
+ (setq cmds (cdr cmds)))
+ ;; Install our keymap
+ (cond
+ (folding-xemacs-p
+ (let ((f 'set-keymap-name))
+ (funcall f folding-isearch-mode-map 'folding-isearch-mode-map))
+ ;; Later version of XEmacs (21.2+) use overriding-local-map
+ ;; for isearch keymap rather than fiddling with
+ ;; minor-mode-map-alist. This is so isearch keymaps take
+ ;; precedence over extent-local keymaps. We will support
+ ;; both ways here. Keymaps will be restored as side-effect
+ ;; of isearch-abort and isearch-quit
+ (cond
+ ;; if overriding-local-map is in use
+ ((and (boundp 'overriding-local-map) overriding-local-map)
+ (set-keymap-parent folding-isearch-mode-map overriding-local-map)
+ (setq overriding-local-map folding-isearch-mode-map))
+ ;; otherwise fiddle with minor-mode-map-alist
+ (t
+ (setq minor-mode-map-alist
+ (cons (cons 'isearch-mode folding-isearch-mode-map)
+ (delq (assoc 'isearch-mode minor-mode-map-alist)
+ minor-mode-map-alist))))))
+ ((boundp 'overriding-terminal-local-map)
+ (funcall (symbol-function 'set)
+ 'overriding-terminal-local-map folding-isearch-mode-map))
+ ((boundp 'overriding-local-map)
+ (setq overriding-local-map folding-isearch-mode-map))))))
+
+;; Undoes the `folding-isearch-hook-function' function.
+
+(defun folding-isearch-end-hook-function ()
+ "Actions to perform at the end of isearch in folding mode."
+ (when (and (boundp 'folding-mode) folding-mode)
+ (kill-local-variable 'minibuffer-local-isearch-map)
+ (setq folding-stack folding-isearch-stack)))
+
+(when folding-isearch-install
+ (add-hook 'isearch-mode-hook 'folding-isearch-hook-function)
+ (add-hook 'isearch-mode-end-hook 'folding-isearch-end-hook-function))
+
+;;}}}
+;;{{{ Normal search routines
+
+;; Generate the replacement functions of the form:
+;; (defun folding-isearch-repeat-forward ()
+;; (interactive)
+;; (folding-isearch-general 'isearch-repeat-forward))
+
+(let ((cmds folding-isearch-normal-cmds))
+ (while cmds
+ (eval
+ (` (defun (, (intern (concat "folding-" (symbol-name (car cmds))))) ()
+ "Automatically generated"
+ (interactive)
+ (folding-isearch-general (quote (, (car cmds)))))))
+ (setq cmds (cdr cmds))))
+
+;; The HEART! Executes command and updates the foldings.
+;; This is capable of detecting a `quit'.
+
+(defun folding-isearch-general (function)
+ "Execute isearch command FUNCTION and adjusts the folding."
+ (let* ((quit-isearch nil)
+ (area-beg (point-min))
+ (area-end (point-max))
+ pos)
+ (cond
+ (t
+ (save-restriction
+ (widen)
+ (condition-case nil
+ (funcall function)
+ (quit (setq quit-isearch t)))
+ (setq pos (point)))
+ ;; Situation
+ ;; o user has folded buffer
+ ;; o He manually narrows, say to function !
+ ;; --> there is no fold marks at the beg/end --> this is not a fold
+ (condition-case nil
+ ;; "current mode has no fold marks..."
+ (folding-region-has-folding-marks-p area-beg area-end)
+ (error (setq quit-isearch t)))
+ (folding-goto-char pos)))
+ (if quit-isearch
+ (signal 'quit '(isearch)))))
+
+;;}}}
+;;{{{ Edit search string support
+
+(defvar folding-isearch-current-buffer nil
+ "The buffer we are editing, so we can widen it when in minibuffer.")
+
+;; Functions which enters edit mode.
+
+(defun folding-isearch-edit-string ()
+ "Replace `isearch-edit-string' when in `folding-mode'."
+ (interactive)
+ (folding-isearch-start-edit 'isearch-edit-string))
+
+(defun folding-isearch-ring-advance ()
+ "Replace `isearch-ring-advance' when in `folding-mode'."
+ (interactive)
+ (folding-isearch-start-edit 'isearch-ring-advance))
+
+(defun folding-isearch-ring-retreat ()
+ "Replace `isearch-ring-retreat' when in `folding-mode'."
+ (interactive)
+ (folding-isearch-start-edit 'isearch-ring-retreat))
+
+(defun folding-isearch-complete ()
+ "Replace `isearch-complete' when in `folding-mode'."
+ (interactive)
+ (folding-isearch-start-edit 'isearch-complete))
+
+;; Start and wait for editing. When (funcall fnk) returns
+;; we are back in interactive search mode.
+;;
+;; Store match data!
+
+(defun folding-isearch-start-edit (function)
+ "Edit with function FUNCTION."
+ (let (pos)
+ (setq folding-isearch-current-buffer (current-buffer))
+ (save-restriction
+ (funcall function)
+ ;; Here, we are widened, by folding-isearch-*-exit-minibuffer.
+ (setq pos (point)))
+ (folding-goto-char pos)))
+
+;; Functions which exits edit mode.
+
+;; The `widen' below will be caught by the `save-restriction' above, thus
+;; this will not cripple `folding-stack'.
+
+(defun folding-isearch-forward-exit-minibuffer ()
+ "Replace `isearch-forward-exit-minibuffer' when in `folding-mode'."
+ (interactive)
+ ;; Make sure we can continue searching outside narrowing.
+ (save-excursion
+ (set-buffer folding-isearch-current-buffer)
+ (widen))
+ (isearch-forward-exit-minibuffer))
+
+(defun folding-isearch-reverse-exit-minibuffer ()
+ "Replace `isearch-reverse-exit-minibuffer' when in `folding-mode'."
+ (interactive)
+ ;; Make sure we can continue searching outside narrowing.
+ (save-excursion
+ (set-buffer folding-isearch-current-buffer)
+ (widen))
+ (isearch-reverse-exit-minibuffer))
+
+(defun folding-isearch-nonincremental-exit-minibuffer ()
+ "Replace `isearch-reverse-exit-minibuffer' when in `folding-mode'."
+ (interactive)
+ ;; Make sure we can continue searching outside narrowing.
+ (save-excursion
+ (set-buffer folding-isearch-current-buffer)
+ (widen))
+ (isearch-nonincremental-exit-minibuffer))
+
+;;}}}
+;;{{{ Special XEmacs support
+
+;; In XEmacs, all isearch commands must have the property `isearch-command'.
+
+(if folding-xemacs-p
+ (let ((cmds (append folding-isearch-normal-cmds
+ folding-isearch-edit-enter-cmds
+ folding-isearch-edit-exit-cmds)))
+ (while cmds
+ (put (intern (concat "folding-" (symbol-name (car cmds))))
+ 'isearch-command t)
+ (setq cmds (cdr cmds)))))
+
+;;}}}
+;;{{{ General purpose function.
+
+(defun folding-goto-char (pos)
+ "Goto character POS, changing fold if necessary."
+ ;; Make sure POS is inside the visible area of the buffer.
+ (goto-char pos)
+ (if (eq pos (point)) ; Point inside narrowed area?
+ nil
+ (folding-show-all) ; Fold everything and goto top.
+ (goto-char pos))
+ ;; Enter if point is folded.
+ (if (folding-point-folded-p pos)
+ (progn
+ (folding-shift-in) ; folding-shift-in can change the pos.
+ (setq folding-isearch-stack folding-stack)
+ (setq folding-stack '(folded))
+ (goto-char pos))))
+
+(defun folding-point-folded-p (pos)
+ "Non-nil when POS is not visible."
+ (if (folding-use-overlays-p)
+ (let ((overlays (overlays-at (point)))
+ (found nil))
+ (while (and (not found) (overlayp (car overlays)))
+ (setq found (overlay-get (car overlays) 'fold)
+ overlays (cdr overlays)))
+ found)
+ (save-excursion
+ (goto-char pos)
+ (beginning-of-line)
+ (skip-chars-forward "^\r" pos)
+ (not (eq pos (point))))))
+
+;;}}}
+
+;;}}}
+;;{{{ code: Additional functions
+
+(defvar folding-comment-folding-table
+ '((c-mode
+ folding-comment-c-mode
+ folding-uncomment-c-mode))
+ "Table of functions to comment and uncomment folds.
+Function is called with two arguments:
+
+ number start of fold mark
+ marker end of fold mark
+
+Function must return:
+
+ (beg . end) start of fold, end of fold
+
+Table Format:
+ '((MAJOR-MODE COMMENT-FUNCTION UNCOMMENT-FUNCTION) ..)")
+
+(defun folding-insert-advertise-folding-mode ()
+ "Insert Small text describing where to the get the folding at point.
+This may be useful 'banner' to inform other people why your code
+is formatted like it is and how to view it correctly."
+ (interactive)
+ (let* ((prefix "")
+ (re (or comment-start-skip
+ (and comment-start
+ (concat "^[ \t]*" comment-start "+[ \t]*")))))
+
+ (when re
+ (save-excursion
+ (beginning-of-line)
+ (when (or (re-search-forward re nil t)
+ (progn
+ (goto-char (point-min))
+ (re-search-forward re nil t)))
+ (setq prefix (match-string 0)))))
+
+ (beginning-of-line)
+ (dolist (line
+ (list
+ "File layout controlled by Emacs folding.el available at: "
+ folding-package-url-location))
+ (insert "\n" prefix line))))
+
+(defun folding-uncomment-mode-generic (beg end tag)
+ "In region (BEG . END) remove two TAG lines."
+ (re-search-forward tag (marker-position end))
+ (beginning-of-line)
+ (kill-line 1)
+ (re-search-forward tag (marker-position end))
+ (beginning-of-line)
+ (kill-line 1)
+ (cons beg end))
+
+(defun folding-comment-mode-generic (beg end tag1 &optional tag2)
+ "Return (BEG . END) and Add two TAG1 and TAG2 lines."
+ (insert tag1)
+ (goto-char (marker-position end))
+ (insert (or tag2 tag1))
+ (cons beg end))
+
+(defun folding-uncomment-c-mode (beg end)
+ "Uncomment region BEG END."
+ (folding-uncomment-mode-generic
+ beg end (regexp-quote " comment /* FOLDING -COM- */")))
+
+(defun folding-comment-c-mode (beg end)
+ "Comment region BEG END."
+ (let* ((tag " /* FOLDING -COM- */"))
+ (folding-comment-mode-generic
+ beg end
+ (concat "#if comment" tag "\n")
+ (concat "#endif comment" tag "\n"))))
+
+(defun folding-comment-fold (&optional uncomment)
+ "Comment or UNCOMMENT all text inside single fold.
+If there are subfolds this function won't work as expected.
+User must know that there are no subfolds.
+
+The heading has -COM- at the end when the fold is commented.
+Point must be over fold heading {{{ when function is called.
+
+Note:
+
+ You can use this function only in modes that do _not_ have
+ `comment-end'. Ie. don't use this function in modes like C (/* */), because
+ nested comments are not allowed. See this:
+
+ /* {{{ fold */
+ code /* comment of the code */
+ /* }}} */
+
+ Fold can't know how to comment the `code' inside fold, because comments
+ do not nest.
+
+Implementation detail:
+
+ {{{ FoldHeader-COM-
+
+ If the fold header has -COM- at the end, then the fold is supposed to
+ be commented. And if there is no -COM- then fold will be considered
+ as normal fold. Do not loose or add the -COM- yourself or it will
+ confuse the state of the fold.
+
+References:
+
+ `folding-comment-folding-table'"
+ (interactive "P")
+ (let* ((state (folding-mark-look-at 'move))
+ (closed (eq 0 state))
+ (id "-COM-")
+ (opoint (point))
+ (mode-elt (assq major-mode folding-comment-folding-table))
+ comment
+ ret
+ beg
+ end)
+ (unless mode-elt
+ (if (stringp (nth 2 (folding-get-mode-marks major-mode)))
+ (error "\
+Folding: function usage error, mode with `comment-end' is not supported.")))
+ (when (or (null comment-start)
+ (not (string-match "[^ \t\n]" comment-start)))
+ (error "Empty comment-start."))
+ (unless (memq state '( 0 1 11))
+ (error "Incorrect fold state. Point must be over {{{."))
+ ;; There is nothing to do if this fold heading does not have
+ ;; the ID when uncommenting the fold.
+ (setq state (looking-at (concat ".*" id)))
+ (when (or (and uncomment state)
+ (and (null uncomment) (null state)))
+ (when closed (save-excursion (folding-show-current-entry)))
+ (folding-pick-move) ;Go to end
+ (beginning-of-line)
+ (setq end (point-marker))
+ (goto-char opoint) ;And off the fold heading
+ (forward-line 1)
+ (setq beg (point))
+ (setq comment (concat comment-start id))
+ (cond
+ (mode-elt
+ (setq ret
+ (if uncomment
+ (funcall (nth 2 mode-elt) (point) end)
+ (funcall (nth 1 mode-elt) (point) end)))
+ (goto-char (cdr ret)))
+ (uncomment
+ (while (< (point) (marker-position end))
+ (if (looking-at comment)
+ (delete-region (point) (match-end 0)))
+ (forward-line 1)))
+ (t
+ (while (< (point) (marker-position end))
+ (if (not (looking-at comment))
+ (insert comment))
+ (forward-line 1))))
+ (setq end nil) ;kill marker
+ ;; Remove the possible tag from the fold name line
+ (goto-char opoint)
+ (setq id (concat (or comment-start "") id (or comment-end "")))
+ (if (re-search-forward (regexp-quote id) beg t)
+ (delete-region (match-beginning 0) (match-end 0)))
+ (when (null uncomment)
+ (end-of-line)
+ (insert id))
+ (if closed
+ (folding-hide-current-entry))
+ (goto-char opoint))))
+
+(defun folding-convert-to-major-folds ()
+ "Convert fold mark items according to `major-mode'.
+This function replaces all fold markings }}} and {{{
+with major mode's fold marks.
+
+As a side effect also corrects all foldings to standard notation.
+Eg. following, where correct folding-beg should be \"#{{{ \"
+Note that /// marks foldings.
+
+ /// ;wrong fold
+ # /// ;too many spaces, fold format error
+ # ///title ;ok, but title too close
+
+ produces
+
+ #///
+ #///
+ #/// title
+
+You must 'unfold' whole buffer before using this function."
+ (interactive)
+ (let (case-fold-search
+ (bm "{{{") ; begin match mark
+ (em "}}}") ;
+ el ; element
+ b ; begin
+ e ; end
+ e2 ; end2
+ pp)
+ (catch 'out ; is folding active/loaded ??
+ (unless (setq el (folding-get-mode-marks major-mode))
+ (throw 'out t)) ; ** no mode found
+ ;; ok , we're in business. Search whole buffer and replace.
+ (setq b (elt el 0)
+ e (elt el 1)
+ e2 (or (elt el 2) ""))
+ (save-excursion
+ (goto-char (point-min)) ; start from the beginning of buffer
+ (while (re-search-forward (regexp-quote bm) nil t)
+ ;; set the end position for fold marker
+ (setq pp (point))
+ (beginning-of-line)
+ (if (looking-at (regexp-quote b)) ; should be mode-marked; ok, ignore
+ (goto-char pp) ; note that beg-of-l cmd, move rexp
+ (delete-region (point) pp)
+ (insert b)
+ (when (not (string= "" e2))
+ (unless (looking-at (concat ".*" (regexp-quote e2)))
+ ;; replace with right fold mark
+ (end-of-line)
+ (insert e2)))))
+ ;; handle end marks , identical func compared to prev.
+ (goto-char (point-min))
+ (while (re-search-forward (regexp-quote em)nil t)
+ (setq pp (point))
+ (beginning-of-line)
+ (if (looking-at (regexp-quote e))
+ (goto-char pp)
+ (delete-region (point) (progn (end-of-line) (point)))
+ (insert e)))))))
+
+(defun folding-all-comment-blocks-in-region (beg end)
+ "Put all comments in folds inside BEG END.
+Notice: Make sure there is no interfering folds inside the area,
+because the results may and up corrupted.
+
+This only works for modes that DO NOT have `comment-end'.
+The `comment-start' must be left flushed in order to counted in.
+
+After this
+
+ ;; comment
+ ;; comment
+
+ code
+
+ ;; comment
+ ;; comment
+
+ code
+
+The result will be:
+
+ ;; {{{ 1
+
+ ;; comment
+ ;; comment
+
+ ;; }}}
+
+ code
+
+ ;; {{{ 2
+
+ ;; comment
+ ;; comment
+
+ ;; }}}
+
+ code"
+ (interactive "*r")
+
+ (unless comment-start
+ (error "Folding: Mode does not define `comment-start'"))
+
+ (when (and (stringp comment-end)
+ (string-match "[^ \t]" comment-end))
+ (error "Folding: Mode defines non-empty `comment-end'."))
+ (let* ((count 0)
+ (comment-regexp (concat "^" comment-start))
+ (marker (point-marker))
+ done)
+ (multiple-value-bind (left right ignore)
+ (folding-get-mode-marks)
+ ;; Bytecomp silencer: variable ignore bound but not referenced
+ (if ignore (setq ignore ignore))
+ ;; %%%{{{ --> "%%%"
+ (string-match (concat (regexp-quote comment-start) "+") left)
+ (save-excursion
+ (goto-char beg)
+ (beginning-of-line)
+ (while (re-search-forward comment-regexp nil t)
+ (move-marker marker (point))
+ (setq done nil)
+ (beginning-of-line)
+ (forward-line -1)
+ ;; 2 previous lines Must not contain FOLD beginning already
+ (unless (looking-at (regexp-quote left))
+ (forward-line -1)
+ (unless (looking-at (regexp-quote left))
+ (goto-char (marker-position marker))
+ (beginning-of-line)
+ (insert left " " (int-to-string count) "\n\n")
+ (incf count)
+ (setq done t)))
+ (goto-char (marker-position marker))
+ (when done
+ ;; Try finding pat of the comment block
+ (if (not (re-search-forward "^[ \t]*$" nil t))
+ (goto-char end))
+ (open-line 1)
+ (forward-line 1)
+ (insert right "\n")))))))
+
+;;}}}
+;;{{{ code: Overlay support
+
+(defun folding-use-overlays-p ()
+ "Should folding use overlays?."
+ (if folding-allow-overlays
+ (if folding-xemacs-p
+ ;; See if we can load overlay.el library that comes in 19.15
+ ;; This call returns t or nil if load was successful
+ ;; Note: is there provide statement? Load is so radical
+ ;;
+ (load "overlay" 'noerr)
+ t)))
+
+(defun folding-flag-region (from to flag)
+ "Hide or show lines from FROM to TO, according to FLAG.
+If FLAG is nil then text is shown, while if FLAG is t the text is hidden."
+ (let ((inhibit-read-only t)
+ overlay)
+ (save-excursion
+ (goto-char from)
+ (end-of-line)
+ (cond
+ (flag
+ (setq overlay (make-overlay (point) to))
+ (folding-make-overlay-hidden overlay))
+ (t
+ (if (fboundp 'hs-discard-overlays)
+ (funcall (symbol-function 'hs-discard-overlays)
+ (point) to 'invisible t)))))))
+
+(defun folding-make-overlay-hidden (overlay)
+ "Make OVERLAY hidden."
+ (overlay-put overlay 'fold t)
+ ;; (overlay-put overlay 'intangible t)
+ (overlay-put overlay 'invisible t)
+ (overlay-put overlay 'owner 'folding))
+
+(defun folding-narrow-aux (start end arg)
+ "Narrow. Make overlay from `point-min' to START.
+And from END t `point-min'. If ARG is nil, delete overlays."
+ (if (null arg)
+ (cond
+ (folding-narrow-overlays
+ (delete-overlay (car folding-narrow-overlays))
+ (delete-overlay (cdr folding-narrow-overlays))
+ (setq folding-narrow-overlays nil)))
+ (let ((overlay-beg (make-overlay (point-min) start))
+ (overlay-end (make-overlay end (point-max))))
+ (overlay-put overlay-beg 'folding-narrow t)
+ (overlay-put overlay-beg 'invisible t)
+ (overlay-put overlay-beg 'owner 'folding)
+ (overlay-put overlay-end 'folding-narrow t)
+ (overlay-put overlay-end 'invisible t)
+ (overlay-put overlay-end 'owner 'folding)
+ (setq folding-narrow-overlays (cons overlay-beg overlay-end)))))
+
+;;}}}
+
+;;{{{ code: end of file tag, provide
+
+(folding-install)
+
+(provide 'folding)
+(provide 'folding-isearch) ;; This used to be a separate package.
+
+(run-hooks 'folding-load-hook)
+
+;;}}}
+
+;;; folding.el ends here
--- /dev/null
+;;; tiny-autoload-loaddefs-other.el -- loaddef definitions of program files
+;; Generate date: 2002-01-02
+;; This file is automatically generated. Do not Change.
+
+(provide 'tiny-autoload-loaddefs-other)
+
+\f
+;;;### (autoloads (set-modified-alist modify-alist remove-alist set-alist
+;;;;;; del-alist put-alist) "alist" "alist.el" (14456 65500))
+;;; Generated autoloads from alist.el
+
+(autoload (quote put-alist) "alist" "\
+Modify ALIST to set VALUE to ITEM.
+If there is a pair whose car is ITEM, replace its cdr by VALUE.
+If there is not such pair, create new pair (ITEM . VALUE) and
+return new alist whose car is the new pair and cdr is ALIST.
+[tomo's ELIS like function]" nil nil)
+
+(autoload (quote del-alist) "alist" "\
+If there is a pair whose key is ITEM, delete it from ALIST.
+[tomo's ELIS emulating function]" nil nil)
+
+(autoload (quote set-alist) "alist" "\
+Modify a alist indicated by SYMBOL to set VALUE to ITEM." nil nil)
+
+(autoload (quote remove-alist) "alist" "\
+Remove ITEM from the alist indicated by SYMBOL." nil nil)
+
+(autoload (quote modify-alist) "alist" "\
+Modify alist DEFAULT into alist MODIFIER." nil nil)
+
+(autoload (quote set-modified-alist) "alist" "\
+Modify a value of a symbol SYM into alist MODIFIER.
+The symbol SYM should be alist. If it is not bound,
+its value regard as nil." nil nil)
+
+;;;***
+\f
+;;;### (autoloads (c-comment-edit c-comment-edit-at-point) "c-comment-edit2"
+;;;;;; "c-comment-edit2.el" (15378 27670))
+;;; Generated autoloads from c-comment-edit2.el
+
+(defvar c-comment-leader " *" "\
+*Leader used when rebuilding edited C comments. The value of this variable
+should be a two-character string. Values of \" \", \" *\" and \"**\"
+produce the comment styles:
+ /* /* /*
+ ... * ... ** ...
+ ... * ... ** ...
+ */ */ */
+respectively.")
+
+(autoload (quote c-comment-edit-at-point) "c-comment-edit2" "\
+Edit C comment at point.
+If point is inside of a comment, the comment is edited. Otherwise, a new
+comment is created at point.
+" t nil)
+
+(autoload (quote c-comment-edit) "c-comment-edit2" "\
+Edit multi-line C comments.
+This command allows the easy editing of a multi-line C comment like this:
+ /*
+ * ...
+ * ...
+ */
+The comment may be indented or flush with the left margin.
+
+If point is within a comment, that comment is used. Otherwise the
+comment to be edited is found by searching forward from point.
+
+With one \\[universal-argument] searching starts after moving back one
+ paragraph.
+With two \\[universal-argument]'s searching starts at the beginning of the
+ current or proceeding C function.
+With three \\[universal-argument]'s searching starts at the beginning of the
+ current page.
+With four \\[universal-argument]'s searching starts at the beginning of the
+ current buffer (clipping restrictions apply).
+
+Once located, the comment is copied into a temporary buffer, the comment
+leaders and delimiters are stripped away and the resulting buffer is
+selected for editing. The major mode of this buffer is controlled by
+the variable `c-comment-edit-mode'.
+
+Use \\[c-comment-edit-end] when you have finished editing the comment. The
+comment will be inserted into the original buffer with the appropriate
+delimiters and indention, replacing the old version of the comment. If
+you don't want your edited version of the comment to replace the
+original, use \\[c-comment-edit-abort]." t nil)
+
+;;;***
+\f
+;;;### (autoloads (cm-install-default cm-minibuffer-completion-help
+;;;;;; cm-load-hook) "complete-menu" "complete-menu.el" (15011 59622))
+;;; Generated autoloads from complete-menu.el
+
+(defvar cm-load-hook (quote (cm-install-default)) "\
+*Hook run when file has been loaded.")
+
+(autoload (quote cm-minibuffer-completion-help) "complete-menu" "\
+List completions in a menu and copy selction into minibuffer" t nil)
+
+(autoload (quote cm-install-default) "complete-menu" "\
+Install the X-menuing feature. With ARG, remove X-menuing. VERB.
+Note: installation is only possible in X envinronment." t nil)
+
+;;;***
+\f
+;;;### (autoloads (dired-sort-default-keys dired-resort dired-sort-by-size
+;;;;;; dired-sort-by-field dired-sort-by-type dired-sort-by-date)
+;;;;;; "dired-sort" "dired-sort.el" (15381 10582))
+;;; Generated autoloads from dired-sort.el
+
+(autoload (quote dired-sort-by-date) "dired-sort" "\
+In dired, sort the lines by date, newest first.
+With ARG, sorts oldest first." t nil)
+
+(autoload (quote dired-sort-by-type) "dired-sort" "\
+Sort by type, ARG means reverse." t nil)
+
+(autoload (quote dired-sort-by-field) "dired-sort" "\
+In dired, sort the lines by FIELD (defaults to the mode field)." t nil)
+
+(autoload (quote dired-sort-by-size) "dired-sort" "\
+In dired, sort the lines by file size, largest first.
+With ARG, sorts in the reverse order (smallest first).
+All directories are grouped together at the head of the buffer,
+and other file types are also grouped." t nil)
+
+(autoload (quote dired-resort) "dired-sort" "\
+In dired, change the sorting of lines. Prompt for the KIND of sorting.
+Non-interactively, takes a sort-kind, and an optional argument for
+the associated function. To get a list of such arguments interactively,
+call read-dired-resort-args. ARGS are passed to sort." t nil)
+
+(autoload (quote dired-sort-default-keys) "dired-sort" "\
+Define default bindings to dired map." t nil)
+
+(add-hook (quote dired-mode-hook) (quote dired-sort-default-keys) (quote end))
+
+;;;***
+\f
+;;;### (autoloads (with-expect) "expect" "expect.el" (14954 14938))
+;;; Generated autoloads from expect.el
+
+(autoload (quote with-expect) "expect" "\
+Set things up for communication with PROGRAM.
+FORMS will be evaluated in the normal manner. To talk to the process,
+use `expect' and `expect-send'. See the manual for full documentation.
+This macro returns nil.
+
+If PROGRAM is a string, start that program. If PROGRAM is a list, use
+the first element of that list as the program and the remainder as the
+parameters. If PROGRAM is a process, talk to that process.
+
+PROGRAM will be started up in a new, fresh temporary buffer. The
+buffer will be killed upon completion. If PROGRAM is a process,
+a new buffer won't be created, and the buffer won't be killed upon
+completion." nil (quote macro))
+
+;;;***
+\f
+;;;### (autoloads (fnexpand-complete) "fnexpand" "fnexpand.el" (15378
+;;;;;; 27670))
+;;; Generated autoloads from fnexpand.el
+
+(defvar fnexpand-executable-enable nil "\
+*if non-nil, then try to expand executable files too.
+Beware, this may be time consuming.")
+
+(autoload (quote fnexpand-complete) "fnexpand" "\
+Expand the file name, env var or command near point" t nil)
+
+;;;***
+\f
+;;;### (autoloads (folding-mode turn-on-folding-mode turn-off-folding-mode
+;;;;;; folding-mode-add-find-file-hook folding-keep-hooked folding-install-hooks
+;;;;;; folding-uninstall-hooks folding-mode-hook-no-regexp folding-mode-string
+;;;;;; folding-inside-mode-name folding-default-mouse-keys-function
+;;;;;; folding-default-keys-function) "folding" "folding.el" (15407
+;;;;;; 51274))
+;;; Generated autoloads from folding.el
+
+(defvar folding-mode nil "\
+When Non nil, Folding mode is active in the current buffer.")
+
+(defvar folding-default-keys-function (quote folding-bind-default-keys) "\
+*Function or list of functions used to define keys for Folding mode.
+Possible values are:
+ folding-bind-default-key
+ The standard keymap.
+
+ `folding-bind-backward-compatible-keys'
+ Keys used by older versions of Folding mode. This function
+ does not conform to Emacs 19.29 style conversions concerning
+ key bindings. The prefix key is C - c
+
+ `folding-bind-outline-compatible-keys'
+ Define keys compatible with Outline mode.
+
+ `folding-bind-foldout-compatible-keys'
+ Define some extra keys compatible with Foldout.
+
+All except `folding-bind-backward-compatible-keys' used the value of
+the variable `folding-mode-prefix-key' as prefix the key.
+The default is C - c @")
+
+(defvar folding-default-mouse-keys-function (quote folding-bind-default-mouse) "\
+*Function to bind default mouse keys to `folding-mode-map'.")
+
+(defvar folding-inside-mode-name "Fld" "\
+*Mode line addition to show inside levels of 'fold' .")
+
+(defvar folding-mode-string "Fld" "\
+*The minor mode string displayed when mode is on.")
+
+(defvar folding-mode-hook-no-regexp "RMAIL" "\
+*Regexp which disable automatic folding mode turn on for certain files.")
+
+(defvar folding-mode-marks-alist nil "\
+List of (major-mode . fold mark) default combinations to use.
+When Folding mode is started, the major mode is checked, and if there
+are fold marks for that major mode stored in `folding-mode-marks-alist',
+those marks are used by default. If none are found, the default values
+of \"{{{ \" and \"}}}\" are used.
+
+Use function `folding-add-to-marks-list' to add more fold marks. The function
+also explains the alist use in details.
+
+Use function `folding-set-local-variables' is you change the current mode's
+folding marks during the session.")
+
+(autoload (quote folding-uninstall-hooks) "folding" "\
+Remove hooks set by folding." t nil)
+
+(autoload (quote folding-install-hooks) "folding" "\
+Install folding hooks." t nil)
+
+(autoload (quote folding-keep-hooked) "folding" "\
+Make sure hooks are in their places." nil nil)
+
+(autoload (quote folding-mode-add-find-file-hook) "folding" "\
+Append `folding-mode-find-file-hook' to the list `find-file-hooks'.
+
+This has the effect that afterwards, when a folded file is visited, if
+appropriate Emacs local variable entries are recognized at the end of
+the file, Folding mode is started automatically.
+
+If `inhibit-local-variables' is non-nil, this will not happen regardless
+of the setting of `find-file-hooks'.
+
+To declare a file to be folded, put `folded-file: t' in the file's
+local variables. eg., at the end of a C source file, put:
+
+/*
+Local variables:
+folded-file: t
+*/
+
+The local variables can be inside a fold." t nil)
+
+(autoload (quote turn-off-folding-mode) "folding" "\
+Turn on folding." nil nil)
+
+(autoload (quote turn-on-folding-mode) "folding" "\
+Turn on folding." nil nil)
+
+(autoload (quote folding-mode) "folding" "\
+A folding-editor-like minor mode. ARG INTER.
+
+These are the basic commands that Folding mode provides:
+
+\\{folding-mode-map}
+
+Keys starting with `folding-mode-prefix-key'
+
+\\{folding-mode-prefix-map}
+
+ folding-convert-buffer-for-printing:
+ `\\[folding-convert-buffer-for-printing]'
+ Makes a ready-to-print, formatted, unfolded copy in another buffer.
+
+ Read the documentation for the above functions for more information.
+
+Overview
+
+ Folds are a way of hierarchically organizing the text in a file, so
+ that the text can be viewed and edited at different levels. It is
+ similar to Outline mode in that parts of the text can be hidden from
+ view. A fold is a region of text, surrounded by special \"fold marks\",
+ which act like brackets, grouping the text. Fold mark pairs can be
+ nested, and they can have titles. When a fold is folded, the text is
+ hidden from view, except for the first line, which acts like a title
+ for the fold.
+
+ Folding mode is a minor mode, designed to cooperate with many other
+ major modes, so that many types of text can be folded while they are
+ being edited (eg., plain text, program source code, Texinfo, etc.).
+
+Folding-mode function
+
+ If Folding mode is not called interactively (`(interactive-p)' is nil),
+ and it is called with two or less arguments, all of which are nil, then
+ the point will not be altered if `folding-folding-on-startup' is set
+ and `folding-whole-buffer' is called. This is generally not a good
+ thing, as it can leave the point inside a hidden region of a fold, but
+ it is required if the local variables set \"mode: folding\" when the
+ file is first read (see `hack-local-variables').
+
+ Not that you should ever want to, but to call Folding mode from a
+ program with the default behavior (toggling the mode), call it with
+ something like `(folding-mode nil t)'.
+
+Fold marks
+
+ For most types of folded file, lines representing folds have \"{{{\"
+ near the beginning. To enter a fold, move the point to the folded line
+ and type `\\[folding-shift-in]'. You should no longer be able to see
+ the rest of the file, just the contents of the fold, which you couldn't
+ see before. You can use `\\[folding-shift-out]' to leave a fold, and
+ you can enter and exit folds to move around the structure of the file.
+
+ All of the text is present in a folded file all of the time. It is just
+ hidden. Folded text shows up as a line (the top fold mark) with \"...\"
+ at the end. If you are in a fold, the mode line displays \"inside n
+ folds Narrow\", and because the buffer is narrowed you can't see outside
+ of the current fold's text.
+
+ By arranging sections of a large file in folds, and maybe subsections
+ in sub-folds, you can move around a file quickly and easily, and only
+ have to scroll through a couple of pages at a time. If you pick the
+ titles for the folds carefully, they can be a useful form of
+ documentation, and make moving though the file a lot easier. In
+ general, searching through a folded file for a particular item is much
+ easier than without folds.
+
+Managing folds
+
+ To make a new fold, set the mark at one end of the text you want in the
+ new fold, and move the point to the other end. Then type
+ `\\[folding-fold-region]'. The text you selected will be made into a
+ fold, and the fold will be entered. If you just want a new, empty fold,
+ set the mark where you want the fold, and then create a new fold there
+ without moving the point. Don't worry if the point is in the middle of
+ a line of text, `folding-fold-region' will not break text in the middle
+ of a line. After making a fold, the fold is entered and the point is
+ positioned ready to enter a title for the fold. Do not delete the fold
+ marks, which are usually something like \"{{{\" and \"}}}\". There may
+ also be a bit of fold mark which goes after the fold title.
+
+ If the fold markers get messed up, or you just want to see the whole
+ unfolded file, use `\\[folding-open-buffer]' to unfolded the whole
+ file, so you can see all the text and all the marks. This is useful for
+ checking/correcting unbalanced fold markers, and for searching for
+ things. Use `\\[folding-whole-file]' to fold the buffer again.
+
+ `folding-shift-out' will attempt to tidy the current fold just before
+ exiting it. It will remove any extra blank lines at the top and bottom,
+ (outside the fold marks). It will then ensure that fold marks exists,
+ and if they are not, will add them (after asking). Finally, the number
+ of blank lines between the fold marks and the contents of the fold is
+ set to 1 (by default).
+
+Folding package customisations
+
+ If the fold marks are not set on entry to Folding mode, they are set to
+ a default for current major mode, as defined by
+ `folding-mode-marks-alist' or to \"{{{ \" and \"}}}\" if none are
+ specified.
+
+ To bind different commands to keys in Folding mode, set the bindings in
+ the keymap `folding-mode-map'.
+
+ The hooks `folding-mode-hook' and `<major-mode-name>-folding-hook' are
+ called before folding the buffer and applying the key bindings in
+ `folding-mode-map'. This is a good hook to set extra or different key
+ bindings in `folding-mode-map'. Note that key bindings in
+ `folding-mode-map' are only examined just after calling these hooks;
+ new bindings in those maps only take effect when Folding mode is being
+ started. The hook `folding-load-hook' is called when Folding mode is
+ loaded into Emacs.
+
+Mouse behavior
+
+ If you want folding to detect point of actual mouse click, please see
+ variable `folding-mouse-yank-at-p'.
+
+ To customise the mouse actions, look at `folding-behave-table'." t nil)
+
+;;;***
--- /dev/null
+;;; load-path.el --- Used for compiling Emacs lisp files
+
+;;; Commentary:
+
+;;
+;; File id
+;;
+;; Copyright (C) 1997-2007 Jari Aalto
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2 of
+;; the License, or (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be
+;; useful, but WITHOUT ANY WARRANTY; without even the implied
+;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;; PURPOSE. See the GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public
+;; License along with program; see the file COPYING. If not,
+;; write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+;;
+;; Description
+;;
+;; This file part of the Tiny Tools Kit for Emacs: collection of
+;; various utilities.
+;;
+;; Before compiling, this file is included via -l FILE switch and it
+;; defines correct load path in order to find the files that are needed
+;; in compilation. If your private directory is not in ~/elisp or
+;; ~/lisp then add new path to the place shown below.
+
+;;; Code:
+
+(require 'cl)
+(setq debug-on-error nil) ;; Must be like this in batch byte compile
+
+(autoload 'ti::package-autoload-create-on-file "tinylib")
+(autoload 'ti::package-autoload-loaddefs-build-recursive "tinylib")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;
+;; PLEASE CONFIFURE THIS `dolist' to include paths in your system
+;;
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(dolist (path
+ '(
+
+ ;; Define any new path HERE. It won't matter if you
+ ;; define non-exiting paths, they are stripped away.
+ ;;
+ ;; some users prefer the directory called ~/lisp istead of
+ ;; ~/elisp (Emacs Lisp)
+
+ "~/elisp"
+ "~/lisp"
+
+ ;; Unix: Posisbly the best is to have
+ ;; this directory to be a symbolic link to latest distribution
+ ;;
+ ;; Win32: Symbolic links don't work, change this to the absolute
+ ;; path of the kit location directories.
+
+ "~/elisp/tiny"
+ "~/elisp/tiny/lisp"
+ "~/elisp/tiny/lisp/tiny"
+ "~/elisp/tiny/lisp/other"
+
+ ;; Any other directories that you have in you ~/elips or
+
+ "/usr/share/site-lisp"
+ "/usr/share/site-lisp/net"
+
+ ;; The best way to keep up with the development is to
+ ;; use CVS. See BBDB and Gnus sites for CVS.
+
+ "/usr/share/site-lisp/net/cvs-packages"
+ "/usr/share/site-lisp/net/cvs-packages/bbdb/lisp"
+ "/usr/share/site-lisp/net/cvs-packages/gnus/lisp"
+
+ ;; Any other directories that you have in you ~/elips or
+ ;; site wide /usr/share/site-lisp or under /opt hierarchy
+
+ "~/elisp/other"
+ "~/elisp/bbdb/lisp" ;usually symbolic link to latest
+ "~/elisp/rc"
+ "."
+ ".."
+ "../other"
+ "../.."))
+ (when (file-exists-p path)
+ (pushnew (expand-file-name path) load-path :test 'string=)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;
+;; LOAD PATH self-check
+;;
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tiny-tmp-load-path-print (&optional function eval)
+ "Print `load-path' using `function'.
+Default is `message'. Eval optional EVAL."
+ (let ((i 0))
+ (if eval
+ (eval eval))
+ (dolist (path load-path)
+ (if function
+ (funcall function " %d %s" i path)
+ (message " %d %s" i path))
+ (incf i))))
+
+(eval-and-compile
+ ;; Remove comment if you want to see the load path
+ ;; before compiling starts. The printed path (order) may give a clue
+ ;; why compile might have failed.
+
+ ;; (tiny-tmp-load-path-print)
+
+ ;; Check that load-path is in order
+ (let ((path (locate-library "tinylibm")))
+ (if path
+ nil ;; (message "FOUND: %s" path)
+ (tiny-tmp-load-path-print)
+ (message
+ "\
+ ** Can't find library [tinylibm]. Please update
+ file [load-path.el] which sets up load-path for compilation purposes."))))
+
+;;; load-path.el ends here
--- /dev/null
+;;; tiny-autoload-loaddefs-tiny.el -- loaddef definitions of program files
+;; Generate date: 2002-01-02
+;; This file is automatically generated. Do not Change.
+
+(provide 'tiny-autoload-loaddefs-tiny)
+
+\f
+;;;### (autoloads (tiny-setup-autoload-read tiny-setup-display tiny-setup-all
+;;;;;; tiny-setup) "tiny-setup" "tiny-setup.el" (15411 19366))
+;;; Generated autoloads from tiny-setup.el
+
+(autoload (quote tiny-setup) "tiny-setup" "\
+Tiny Tools initial setup controller. See Message buffer for results.
+
+Please make sure you have run the makefile.pl with build option
+\"all\" or \"autoload\". You can verify this by finding files which
+contain word \"loaddefs\".
+
+Autoload statements are always defined when this function is called,
+so even if you do not define any options to be installed, they will be
+available in callable functions that trigger loading packages. This
+means, that you an call e.g function \\[tinytab-mode] and the call
+will trigger loading package tinytab.el
+
+Please notice, that this central setup function configures only the
+essential packages, even with TYPE and FEATURE-LIST. The listing
+\\[tiny-setup-display] lists many packages that are not loaded
+or set up in any default way because a) package's scope is very narrow
+and it may not interest the majority b) there is no sensible autoload
+and it requires manual settings: tinyload.el and tinypath.el are
+good example of this. c) package is a library and it has been
+taken cared of by other means.
+
+Remember that all functions are autoloaded and accessible, although
+packages marked <no options> may not have default configurations. Here is
+sample listing that you may expect from \\[tiny-setup-display] which
+displays then content of `tiny-setup-:option-table' when no tiny-setup
+configure options are not defined and you should load the package as
+instructed in the file itself:
+
+ ..
+ tinychist <no options defined to install>
+ ...
+ Command history save/restore utility.
+ tinyload <no options defined to install>
+ Load set of packages when Emacs is idle (lazy load).
+ tinylock <no options defined to install>
+ Simple emacs locking utility.
+ ...
+ tinynbr <no options defined to install>
+ Number conversion minor mode oct/bin/hex.
+ ...
+ tinypath <no options defined to install>
+ Manage Emacs startup dynamically.
+
+Here is one way to install packages: a) configure paths automatically b)
+load default setup and enable some extra features c) define
+delayed loading for some packages that you use most of the time.
+
+ (load \"/ABSOLUTE-PATH/tinypath.el\")
+
+ ;; Define \"ready to use packages\"
+
+ (require 'tiny-setup)
+
+ (tinypath-setup
+ 'all ;; Activate default features safely
+ '(tinyeat--bind ;; plus features that you want
+ tinydesk--bind
+ tinydiff--bind
+ tinydired--autoload
+ tinyeat--bindforce
+ ..))
+
+ ;; Delayed loading of these packages, when Emacs goes idle.
+
+ (setq tinyload-:load-list
+ '(\"tinyadvice\" ;; NOTE: for Emacs only.
+ \"tinymy\"
+ \"tinymail\"
+ \"tinygnus\"
+ \"tinyigrep\"
+ ..))
+
+ (require 'tinyload)
+
+Here is yet another example. The `tiny-setup' function can configure
+only the very basic features, so some defaults for packages
+has been changed before they are loaded (look into each file
+for interesting things that you may find).
+
+ ;; First, configure some package MANUALLY
+
+ (ti::add-hooks 'tinytf-:mode-define-keys-hook
+ '(tinytf-mode-define-keys tinytf-mode-define-f-keys))
+
+ (setq tinymy-:define-key-force t)
+ (setq tinyef-:mode-key \"\\C-cmr\")
+
+ (setq tinylock-:auto-lock-interval1 45) ;in minutes
+
+ (setq tinyef-:mode-key-table
+ '(
+ (?[ . step-delete-back) ;KEY -- action symbol
+ (?] . step-delete-fwd)
+ (?* . chunk-delete)
+ (?; . move-back)
+ (?' . move-fwd)
+ (?~ . e-tilde)
+ (?/ . e-slash)
+ (?$ . e-dollar)))
+
+ ;; After that, let the contral configure tool do the rest
+
+ (require 'tiny-setup)
+
+ (tiny-setup
+ 'all
+ '(tinymy--bind-bindextra
+ tinytab--bindforce-bindextra
+ tinysearch--bindmousemeta
+ tinyreplace--bindemacs
+ tinyeat--bindforce))
+
+The major TYPE of installation can be one of the following:
+
+ 'autoload
+
+ Setup packages so that they are loaded when the options are needed,
+ but do not define any key-bindings that already exist. This will
+ bind free keys to trigger loading packages.
+
+ 'all
+
+ Configure with all options on. This will affect free key-bindings.
+
+ nil
+
+ Autoload files are loaded (functions are ready for calling), but
+ no defaults are configured unless OPTION-LIST is set.
+
+Alternatively, you can select from OPTION-LIST what packages and what
+options inside it will be installed. See list of packages and their
+options with command \\[tiny-setup-display]
+
+ The syntax for each package is the same and the symbol passed is
+ composed from keywords:
+
+ <package>-- Name of package affected, like `tinyeat--'.
+
+ bind Bind default keys. This will set package
+ to autoload state so that when the binding is called,
+ package gets loaded.
+
+ bindforce Overwrite any existing binding. This is like bind, but
+ without a check.
+
+ bindemacs Bind keys that are known to be occupied in Emacs.
+
+ load Load package. If you're tempted to use this,
+ use more efficient method described in tinyload.el.
+ Packages that have complex setup or which
+ can't be autoloaded easily are categorized as \"load\".
+
+ autoload Configure package so, that it will get loaded if option
+ related to package is needed.
+
+ For example, to enable options in tinyadvice.el and tinyurl.el, you could
+ send option list below. Notice that multiple options for a package
+ are separated by single dashes.
+
+ (require 'tiny-setup)
+ (tinypath-setup 'all '(tinyadvice--load tinyurl--autoload-bind ...))
+ | | |
+ | | Option 2.
+ | Option 1.
+ Package." t nil)
+
+(autoload (quote tiny-setup-all) "tiny-setup" "\
+Setup all tools with TYPE." t nil)
+
+(autoload (quote tiny-setup-display) "tiny-setup" "\
+List all packages and available setup options.
+With Argument, like, \\[universal-argument], list NO-DESCRIPTIONS." t nil)
+
+(autoload (quote tiny-setup-autoload-read) "tiny-setup" "\
+Read all autoloads. Makefile must have been run for this to work.
+Syntax in Tiny Tools kit bin/ directory: perl makefile.pl autoload." nil nil)
+
+;;;***
+\f
+;;;### (autoloads nil "tinyadvice" "tinyadvice.el" (15384 58070))
+;;; Generated autoloads from tinyadvice.el
+ (autoload 'tinyadvice-version "tinyadvice" "Display commentary." t)
+
+;;;***
+\f
+;;;### (autoloads (tinyappend-yank tinyappend-kill tinyappend-beg
+;;;;;; tinyappend-end) "tinyappend" "tinyappend.el" (15378 27670))
+;;; Generated autoloads from tinyappend.el
+ (autoload 'tinyappend-version "tinyappend" "Display commentary." t)
+
+(autoload (quote tinyappend-end) "tinyappend" "\
+Store region BEG END with MSG or current line to the end of `tinyappend-:buffer'." t nil)
+
+(autoload (quote tinyappend-beg) "tinyappend" "\
+Store BEG END with MSG or current line to the beginning of `tinyappend-:buffer'." t nil)
+
+(autoload (quote tinyappend-kill) "tinyappend" "\
+Kill `tinyappend-:buffer' buffer." t nil)
+
+(autoload (quote tinyappend-yank) "tinyappend" "\
+Yank `tinyappend-:buffer' to the current position. Optionally KILL `tinyappend-:buffer'." t nil)
+
+;;;***
+\f
+;;;### (autoloads (tinybookmark-mouse tinybookmark-keyboard tinybookmark-mouse-parse
+;;;;;; tinybookmark-keyboard-parse tinybookmark-parse tinybookmark-insert
+;;;;;; tinybookmark-repeat tinybookmark-forward tinybookmark-backward)
+;;;;;; "tinybookmark" "tinybookmark.el" (15378 27670))
+;;; Generated autoloads from tinybookmark.el
+
+(autoload (quote tinybookmark-backward) "tinybookmark" "\
+Search book mark line backward." t nil)
+
+(autoload (quote tinybookmark-forward) "tinybookmark" "\
+Search book mark line forward or optionally BACK." t nil)
+
+(autoload (quote tinybookmark-repeat) "tinybookmark" "\
+Repeats character or string sequence STR COUNT times.
+
+COUNT can be:
+
+ 0 repeat until position 79 or COL , or if the STR is not single
+ character, until fits below COL
+ \"\" interactive insert, as long as user presses RET or SPACE.
+
+STRICT has effect only if COL is given:
+
+ nil insert as long as STR fits below COL
+ t insert strictly up till COL and cut away portion
+ of STR if necessary" t nil)
+
+(autoload (quote tinybookmark-insert) "tinybookmark" "\
+Add book mark until the end of line.
+Normally line is filled as long as the pattern fits below max column,
+but if the optional argument is given, it will be filled in _full_ ,
+truncating if necessary. To see an example, try with some _long_
+pattern.
+
+Input:
+
+ TXT book mark name
+ SEP separator string that is repeated.
+ STRICT
+ 0 strict is nil in spite of `tinybookmark-:insert-strict'
+ 1 strict is t in spite of `tinybookmark-:insert-strict'
+ nil use default value in `tinybookmark-:insert-strict'
+
+References:
+
+ `tinybookmark-:insert-strict'" t nil)
+
+(autoload (quote tinybookmark-parse) "tinybookmark" "\
+Builds up book mark list and store it to cache.
+
+Return:
+
+ t cache was built.
+ nil book marks not found or error happened. Cache untouched." t nil)
+
+(autoload (quote tinybookmark-keyboard-parse) "tinybookmark" "\
+Reparse book marks." nil nil)
+
+(autoload (quote tinybookmark-mouse-parse) "tinybookmark" "\
+Reparse book mark list. This function is called from mouse binding.
+Called with mouse EVENT. VERB displays message." t nil)
+
+(autoload (quote tinybookmark-keyboard) "tinybookmark" "\
+Pass ARG to `tinybookmark-mouse'." t nil)
+
+(autoload (quote tinybookmark-mouse) "tinybookmark" "\
+Display book mark pop up menu. Use mouse EVENT.
+Optional ARG
+ list \\[universal-argument], reparse list" t nil)
+
+;;;***
+\f
+;;;### (autoloads (tinybuffer-next-buffer tinybuffer-previous-buffer
+;;;;;; tinybuffer-iswitch-to-buffer) "tinybuffer" "tinybuffer.el"
+;;;;;; (15378 27670))
+;;; Generated autoloads from tinybuffer.el
+ (autoload 'tinybuffer-version "tinybuffer" "Display commentary." t)
+
+(autoload (quote tinybuffer-iswitch-to-buffer) "tinybuffer" "\
+Switch to buffer when RETURN/SPACE/TAB pressed.
+Show buffer at echo area. ESC to cancel prompt.
+
+Note:
+
+ The startup time of calling this function may be high, because it has
+ to build list of choices and possibly filter out unwanted buffers.
+
+References:
+
+ `tinybuffer-:iswitch-to-buffer-keys' keys to scroll buffer list" t nil)
+
+(autoload (quote tinybuffer-previous-buffer) "tinybuffer" "\
+Switch to previous buffer in current window." t nil)
+
+(autoload (quote tinybuffer-next-buffer) "tinybuffer" "\
+Switch to the other buffer (2nd in list-buffer) in current window." t nil)
+
+;;;***
+\f
+;;;### (autoloads (tinycache-flush tinycache-flush-all-compilation
+;;;;;; tinycache-mode tinycache-buffer-list-mark-cache-off tinycache-buffer-list-mark-deleted
+;;;;;; tinycache-buffer-list-unmark tinycache-buffer-list-mark)
+;;;;;; "tinycache" "tinycache.el" (15378 27670))
+;;; Generated autoloads from tinycache.el
+ (autoload 'tinycache-version "tinycache" "Display commentary." t)
+
+(autoload (quote tinycache-buffer-list-mark) "tinycache" "\
+Mark Cached files in buffer list." t nil)
+
+(autoload (quote tinycache-buffer-list-unmark) "tinycache" "\
+Mark Cached files in buffer list." t nil)
+
+(autoload (quote tinycache-buffer-list-mark-deleted) "tinycache" "\
+Mark Cached files in buffer list." t nil)
+
+(autoload (quote tinycache-buffer-list-mark-cache-off) "tinycache" "\
+Mark files whose cache property has been turned off." t nil)
+
+(autoload (quote tinycache-mode) "tinycache" "\
+Toggle cache flag for this buffer with ARG.
+If the file does not belong to compile cache, calling this function
+does nothing. If the file is in the cache, the modeline displays mode name.
+
+Removing the file from cache means that the file is not killed when
+the cache is flushed with \\[tinycache-flush]." t nil)
+
+(autoload (quote tinycache-flush-all-compilation) "tinycache" "\
+Kill all cached files by stepping through all compilation buffers. VERB." t nil)
+
+(autoload (quote tinycache-flush) "tinycache" "\
+Kill buffers listed in `tinycache-:cache'. VERB.
+You must be in the Compilation/Dired buffer to execute this command.
+
+If you're not in dired buffer, function tries to find compilation
+buffer and kill compilation cached files." t nil)
+
+;;;***
+\f
+;;;### (autoloads nil "tinychist" "tinychist.el" (15407 48240))
+;;; Generated autoloads from tinychist.el
+ (autoload 'tinychist-version "tinychist" "Display commentary." t)
+
+;;;***
+\f
+;;;### (autoloads (tinycomment-indent-for-comment) "tinycomment"
+;;;;;; "tinycomment.el" (15378 27670))
+;;; Generated autoloads from tinycomment.el
+ (autoload 'tinycomment-version "tinycomment" "Display commentary." t)
+
+(autoload (quote tinycomment-indent-for-comment) "tinycomment" "\
+Alternative to standard `indent-for-comment'.
+Relies on file extension
+and doesn't need specific mode to be turned on. Temporary buffers
+that has no file name cannot be identified by this function, so
+it passes control directly to mode. There is a chance you might not
+even notice that this function is working on the background.
+
+Verbose warnings are enabled by `tinycomment-:comment-notify'
+Special cases are handled by tinycomment-:comment-extra* variables
+Version info is on \\[tinycomment-version]." t nil)
+
+;;;***
+\f
+;;;### (autoloads nil "tinycompile" "tinycompile.el" (15378 27670))
+;;; Generated autoloads from tinycompile.el
+ (autoload 'tinycompile-version "tinycompile" "Display commentary." t)
+ (autoload 'turn-on-tinycompile-mode "tinycompile" "" t)
+ (autoload 'turn-off-tinycompile-mode "tinycompile" "" t)
+ (autoload 'tinycompile-mode "tinycompile" "" t)
+ (autoload 'tinycompile-commentary "tinycompile" "" t)
+
+;;;***
+\f
+;;;### (autoloads nil "tinydesk" "tinydesk.el" (15411 18780))
+;;; Generated autoloads from tinydesk.el
+ (autoload 'tinydesk-version "tinydesk" "Display commentary." t)
+
+;;;***
+\f
+;;;### (autoloads (tinydiff-diff tinydiff-diff-show-noask tinydiff-diff-show)
+;;;;;; "tinydiff" "tinydiff.el" (15407 48240))
+;;; Generated autoloads from tinydiff.el
+ (autoload 'tinydiff-version "tinydiff" "Display commentary." t)
+ (autoload 'tinydiff-mode "tinydiff" "" t)
+ (autoload 'turn-on-tinydiff-mode "tinydiff" "" t)
+ (autoload 'turn-off-tinydiff-mode "tinydiff" "" t)
+ (autoload 'tinydiff-commentary "tinydiff" "" t)
+ (autoload 'tinydiff-debug-toggle "tinydiff" "" t)
+
+(autoload (quote tinydiff-diff-show) "tinydiff" "\
+Generate diff CMD for the buffer and show it in the other window.
+Lets user to edit option in the command line." t nil)
+
+(autoload (quote tinydiff-diff-show-noask) "tinydiff" "\
+Generate diff CMD for the buffer. Guess all parameters." t nil)
+
+(autoload (quote tinydiff-diff) "tinydiff" "\
+Run diff on buffer, possibly using rcsdiff if file is version controlled.
+Inserts contents into register.
+
+The version control is determined by searching RCS strings 'Id' or 'Log'
+
+Input:
+
+ CMD diff command
+ SHOW show the results
+ NO-ASK run diff without asking any questions.
+ VERB enable verbose messages
+
+References:
+
+ `tinydiff-:extra-diff-program'
+ `tinydiff-:diff-buffer'
+ `tinydiff-:diff-options'
+
+Return:
+
+ nil ,the no-ask parameter could not determine right diff.
+ buffer ,the shell output buffer. Note, that the diff may have
+ failed, in that case the buffer does not hold valid output." nil nil)
+
+;;;***
+\f
+;;;### (autoloads (tinydired-switch-to-some-ange-ftp-buffer tinydired-kill-all-ange-buffers
+;;;;;; tinydired-kill-all-ange-and-dired-buffers tinydired-kill-dired-and-ange-session
+;;;;;; tinydired-load-all-marked-files tinydired-refresh-view tinydired-mark-vc-files-in-Emacs
+;;;;;; tinydired-mark-today-files tinydired-pop-to-buffer tinydired-leave-only-lines
+;;;;;; tinydired-kill-lines tinydired-kill-unmarked-lines tinydired-last-file
+;;;;;; tinydired-first-file tinydired-first-line tinydired-pgdown
+;;;;;; tinydired-pgup tinydired-marks-restore tinydired-marks-save
+;;;;;; tinydired-shorten-links tinydired-lenghten-links tinydired-dired-do-shell-command
+;;;;;; tinydired-one-dir-up tinydired-marked-revert-files tinydired-mark-files-in-Emacs
+;;;;;; tinydired-read-dir-as-is tinydired-ediff tinydired-hook-control)
+;;;;;; "tinydired" "tinydired.el" (15378 27670))
+;;; Generated autoloads from tinydired.el
+
+(autoload (quote tinydired-hook-control) "tinydired" "\
+Add hooks to dired mode. Optional REMOVE all hooks inserted by package." t nil)
+
+(autoload (quote tinydired-ediff) "tinydired" "\
+Compare file at point with file FILE using `ediff'.
+FILE defaults to the file at the mark.
+The prompted-for file is the first file given to `ediff'.
+With prefix arg, prompt for second argument SWITCHES,
+ which is options for `diff'." t nil)
+
+(autoload (quote tinydired-read-dir-as-is) "tinydired" "\
+Read the directory without any filtering." t nil)
+
+(autoload (quote tinydired-mark-files-in-Emacs) "tinydired" "\
+Mark all files in current directory that are in Emacs." t nil)
+
+(autoload (quote tinydired-marked-revert-files) "tinydired" "\
+Revert ie. replace files in Emacs with true copies in directory.
+If ARG is non-nil, remove any marks if file was loaded.
+
+Exceptions:
+ Only reload files in Emacs whose modify flag is non-nil.
+ If file does not exist in Emacs, do nothing." t nil)
+
+(autoload (quote tinydired-one-dir-up) "tinydired" "\
+Go up one directory." t nil)
+
+(autoload (quote tinydired-dired-do-shell-command) "tinydired" "\
+Like `dired-do-shell-command', but run running command in dired ange-ftp.
+This is not remote shell, but instead it
+transfers the file to your local system and then executes the dired
+command on the file.
+
+Remember: Every time you run this command this files are copied _blindly_
+to your local directory. No file cache information is kept.
+
+Input:
+
+ COMMAND
+ ARG
+
+References:
+
+ `tinydired-:tmp-dir'" t nil)
+
+(autoload (quote tinydired-lenghten-links) "tinydired" "\
+Opposite to `tinydired-shorten-links'.
+This may take a while, because the whole directory structure must
+be read again." t nil)
+
+(autoload (quote tinydired-shorten-links) "tinydired" "\
+Shortens all linked files. The link part is removed." t nil)
+
+(autoload (quote tinydired-marks-save) "tinydired" "\
+Save mark list to private storage.
+Use this function if you know next operation will remove the marks.
+You can get the marks back with `tinydired-marks-restore'." t nil)
+
+(autoload (quote tinydired-marks-restore) "tinydired" "\
+Restore mark list saved by `tinydired-marks-save'." t nil)
+
+(autoload (quote tinydired-pgup) "tinydired" "\
+Move cursor to _last_ file in dired mode." t nil)
+
+(autoload (quote tinydired-pgdown) "tinydired" "\
+Move cursor up." t nil)
+
+(autoload (quote tinydired-first-line) "tinydired" "\
+Move to first _line_ in dired." t nil)
+
+(autoload (quote tinydired-first-file) "tinydired" "\
+Move to first file in dired." t nil)
+
+(autoload (quote tinydired-last-file) "tinydired" "\
+Move to last file in dired." t nil)
+
+(autoload (quote tinydired-kill-unmarked-lines) "tinydired" "\
+Remove unmarked lines. Ignore directories and symlinks." t nil)
+
+(autoload (quote tinydired-kill-lines) "tinydired" "\
+Delete lines matching RE." t nil)
+
+(autoload (quote tinydired-leave-only-lines) "tinydired" "\
+Leave only lines matching RE. Directory lines are skipped.
+You can easily undo this with reverting the buffer (dired \"g\")." t nil)
+
+(autoload (quote tinydired-pop-to-buffer) "tinydired" "\
+Pop to buffer if it exists in Emacs." t nil)
+
+(autoload (quote tinydired-mark-today-files) "tinydired" "\
+Mark all files, not dirs, that are created today.
+Point sits on first today file. If no today's files are found, point stays
+on current filename." t nil)
+
+(autoload (quote tinydired-mark-vc-files-in-Emacs) "tinydired" "\
+Mark all files in the current _view_ that are in Emacs _and_ in VC control.
+Optionally UNMARK. VERB." t nil)
+
+(autoload (quote tinydired-refresh-view) "tinydired" "\
+Refresh current dired view.
+If you have used `tinydired-leave-only-lines' and have done some changes to
+the files. You can use this function to re-read the current view.
+
+The dired \"g\" will load full view back. This instead caches the
+current view, executes read, and deletes lines that weren't in the
+cache --> you get refreshed view. All this may take a while...
+
+Input:
+
+ VERB Verbose messages
+
+Return:
+
+ t if refreshed
+ nil" t nil)
+
+(autoload (quote tinydired-load-all-marked-files) "tinydired" "\
+Load all marked files into Emacs.
+Does not load files which are already in Emacs.
+If ARG is non-nil, remove mark if file was loaded. VERB." t nil)
+
+(autoload (quote tinydired-kill-dired-and-ange-session) "tinydired" "\
+Kill the current dired buffer and possible ange-ftp buffer. VERB.
+This is like `dired-delete-and-exit'." t nil)
+
+(autoload (quote tinydired-kill-all-ange-and-dired-buffers) "tinydired" "\
+Kill all ange-ftp buffers _and_ all remote dired buffers. VERB." t nil)
+
+(autoload (quote tinydired-kill-all-ange-buffers) "tinydired" "\
+Kill all ange-ftp process buffers.
+If you want to kill one buffer at a time, use
+`tinydired-switch-to-some-ange-ftp-buffer' to switch to individual buffer
+and use \\[kill-buffer] to kill session.
+
+This function is primarily used for cleanups. After a while
+you may end up with many ftp session and it's nice if
+you can get rid of them fast.
+
+Don't worry about the dired buffers, Ange will automatically
+create connection, if you use \"g\" -- rever-buffer, in a dired
+that is associated with ange-ftp." t nil)
+
+(autoload (quote tinydired-switch-to-some-ange-ftp-buffer) "tinydired" "\
+Gather all ange FTP buffers and offer completion menu.
+If there is only one Ange buffer, switches to it without asking." t nil)
+
+;;;***
+\f
+;;;### (autoloads (tinyeat-eat tinyeat-delete-paragraph tinyeat-kill-buffer-lines
+;;;;;; tinyeat-kill-buffer-lines-min tinyeat-kill-line-back tinyeat-kill-line
+;;;;;; tinyeat-delete-whole-word tinyeat-join-lines tinyeat-forward-preserve
+;;;;;; tinyeat-forward tinyeat-backward-preserve tinyeat-backward
+;;;;;; tinyeat-zap-line tinyeat-erase-buffer) "tinyeat" "tinyeat.el"
+;;;;;; (15378 27672))
+;;; Generated autoloads from tinyeat.el
+ (autoload 'tinyeat-version "tinyeat" "Display commentary." t)
+ (autoload 'tinyeat-debug-toggle "tinyeat" "" t)
+ (autoload 'tinyeat-debug-show "tinyeat" "" t)
+
+(autoload (quote tinyeat-erase-buffer) "tinyeat" "\
+Erase buffer." t nil)
+
+(autoload (quote tinyeat-zap-line) "tinyeat" "\
+Kill whole line, including the final newline." t nil)
+
+(autoload (quote tinyeat-backward) "tinyeat" "\
+Eat backward. See `tinyeat-eat'." t nil)
+
+(autoload (quote tinyeat-backward-preserve) "tinyeat" "\
+Eat forward, but handle spaces differently. See `tinyeat-eat'." t nil)
+
+(autoload (quote tinyeat-forward) "tinyeat" "\
+Eat forward. See `tinyeat-eat' function." t nil)
+
+(autoload (quote tinyeat-forward-preserve) "tinyeat" "\
+Eat forward, but handle spaces differently. See `tinyeat-eat'." t nil)
+
+(autoload (quote tinyeat-join-lines) "tinyeat" "\
+Join this and next line with one space, and go to the joint." t nil)
+
+(autoload (quote tinyeat-delete-whole-word) "tinyeat" "\
+Delete word at point. Cursor at whitespace, calls `fixup-whitespace'.
+
+References:
+
+ `tinyeat-:eat-full-word-charset'" t nil)
+
+(autoload (quote tinyeat-kill-line) "tinyeat" "\
+Same as `kill-line', except the killed text isn't put into cut buffer.
+This way you can retain mouse selection in cut buffer.
+This only interests people who can use mouse." t nil)
+
+(autoload (quote tinyeat-kill-line-back) "tinyeat" "\
+Like `kill-line' but backward." t nil)
+
+(autoload (quote tinyeat-kill-buffer-lines-min) "tinyeat" "\
+Kill until `point-min'. Optionally BACK." t nil)
+
+(autoload (quote tinyeat-kill-buffer-lines) "tinyeat" "\
+Kill to the `point-max' or BACK to the `point-min' with ARG." t nil)
+
+(autoload (quote tinyeat-delete-paragraph) "tinyeat" "\
+Delete current paragraph, separated by empty lines." t nil)
+
+(autoload (quote tinyeat-eat) "tinyeat" "\
+Eat *appropriate* text forward, if BACK then backward.
+
+The optional SPACE-PRESERVE changes the space eating (VERB).
+
+A. when it is NIL and BACK is anything. * marks the cursor.
+ text1 text1 * text2 text2
+ --> text1 text1 text2 text2 ;one space left
+
+B. when it is NON-NIL and BACK nil
+ text1 text1 * text2 text2
+ --> text1 text1 *text2 text2 ;delete right spaces
+
+C. when it is NON-NIL and BACK t
+ text1 text1 * text2 text2
+ text1 text1* text2 text2 ;delete left spaces
+
+References:
+
+ `tinyeat-:non-word-chars'" t nil)
+
+;;;***
+\f
+;;;### (autoloads nil "tinyef" "tinyef.el" (15378 27672))
+;;; Generated autoloads from tinyef.el
+ (autoload 'tinyef-mode "tinyef" "" t)
+ (autoload 'turn-off-tinyef-mode "tinyef" "" t)
+ (autoload 'turn-on-tinyef-mode "tinyef" "" t)
+ (autoload 'tinyef-commentary "tinyef" "" t)
+ (autoload 'tinyef-version "tinyef" "" t)
+
+;;;***
+\f
+;;;### (autoloads (tinygnus-nslookup-save tinygnus-mark-deleted tinygnus-install)
+;;;;;; "tinygnus" "tinygnus.el" (15409 63832))
+;;; Generated autoloads from tinygnus.el
+ (autoload 'tinygnus-debug-toggle "tinygnus" "" t)
+ (autoload 'tinygnus-debug-show "tinygnus" "" t)
+ (autoload 'tinygnus-version "tinygnus" "Display commentary." t)
+ (autoload 'tinygnus-summary-install-mode "tinygnus" "" t)
+ (autoload 'tinygnus-summary-mode "tinygnus" "" t)
+ (autoload 'turn-on-tinygnus-summary-mode "tinygnus" "" t)
+ (autoload 'turn-off-tinygnus-summary-mode "tinygnus" "" t)
+ (autoload 'tinygnus-summary-commentary "tinygnus" "" t)
+ (autoload 'tinygnus-summary-version "tinygnus" "" t)
+ (autoload 'tinygnus-group-install-mode "tinygnus" "" t)
+ (autoload 'tinygnus-group-mode "tinygnus" "" t)
+ (autoload 'turn-on-tinygnus-group-mode "tinygnus" "" t)
+ (autoload 'turn-off-tinygnus-group-mode "tinygnus" "" t)
+ (autoload 'tinygnus-group-commentary "tinygnus" "" t)
+ (autoload 'tinygnus-group-version "tinygnus" "" t)
+
+(autoload (quote tinygnus-install) "tinygnus" "\
+Install package. Optionally UNINSTALL." t nil)
+
+(autoload (quote tinygnus-mark-deleted) "tinygnus" "\
+Mark current article expirable(mail) or deleted(news)." t nil)
+
+(autoload (quote tinygnus-nslookup-save) "tinygnus" "\
+READ or save `tinygnus-:nslookup-table' to `tinygnus-:nslookup-file'.
+See function `tinygnus-article-ube-send-to-postmasters'." t nil)
+
+;;;***
+\f
+;;;### (autoloads (tinyhotlist-remove tinyhotlist-add tinyhotlist-control
+;;;;;; tinyhotlist-control-kbd tinyhotlist-load-hotlist tinyhotlist-save-hotlist)
+;;;;;; "tinyhotlist" "tinyhotlist.el" (15384 58070))
+;;; Generated autoloads from tinyhotlist.el
+
+(autoload (quote tinyhotlist-save-hotlist) "tinyhotlist" "\
+Call `tinyhotlist-load-hotlist' with arg to save hotlist. ARGS are ignored." t nil)
+
+(autoload (quote tinyhotlist-load-hotlist) "tinyhotlist" "\
+Load or SAVE hotlist configuration from `tinyhotlist-:hotlist-file'.
+When the hotlist file is loaded, only valid entries from there
+are selected to `tinyhotlist-:cache': If File does not exist, it is dropped.
+
+Return:
+
+ nil t" t nil)
+
+(autoload (quote tinyhotlist-control-kbd) "tinyhotlist" "\
+Same as `tinyhotlist-control' with ARG, but you can call this from keyboard." t nil)
+
+(autoload (quote tinyhotlist-control) "tinyhotlist" "\
+Control center of hotlist. Use mouse EVENT to position popup.
+
+Optional ARG can be:
+
+ nil show the hotlist
+ 0 kill all members from hotlist.
+ 9 kill all, but initalize with defaults.
+ nbr any number, add current active buffer to hotlist
+ - negative number, remove item from hotlist. Eg. hit \\[universal-argument] -
+ 1 x \\[universal-argument] remove current buffer from hotlist
+ 2 x \\[universal-argument] Save hotlist
+ 3 x \\[universal-argument] load hotlist." t nil)
+
+(autoload (quote tinyhotlist-add) "tinyhotlist" "\
+Add current buffer to hotlist." t nil)
+
+(autoload (quote tinyhotlist-remove) "tinyhotlist" "\
+Remove current buffer from hotlist." t nil)
+
+;;;***
+\f
+;;;### (autoloads (tinyigrep-menu) "tinyigrep" "tinyigrep.el" (15382
+;;;;;; 22904))
+;;; Generated autoloads from tinyigrep.el
+
+(autoload (quote tinyigrep-menu) "tinyigrep" "\
+Igrep command menu." t nil)
+
+;;;***
+\f
+;;;### (autoloads (tinyindent-mode tinyindent-tt-mode) "tinyindent"
+;;;;;; "tinyindent.el" (15378 27672))
+;;; Generated autoloads from tinyindent.el
+ (autoload 'tinyindent-version "tinyindent" "Display commentary." t)
+
+(autoload (quote tinyindent-tt-mode) "tinyindent" "\
+Toggle variable `tinyindent-tt-mode' with ARG. See description in `tinyindent-mode'." t nil)
+
+(autoload (quote tinyindent-mode) "tinyindent" "\
+Toggle relative indentation mode with ARG.
+
+Indentation is determined according to previous lines. Special
+indent happens only at the beginning of line, where user is asked if
+he wants to have relative or \"hard\" indentation.
+
+Abount function `tinyindent-tt-mode'
+
+This isn't really mode. It just turns one flag on in `tinyindent-mode', so that
+it behaves a little differently. If the `tinyindent-mode' is not running, it
+wiil be turned on. turning off `tinyindent-tt-mode' _does_not_ end `tinyindent-mode'.
+
+Sometimes you want to control between 'hard' tab and 'soft' tab, ie.
+relative indent. This mode causes second character to be read after
+tab key is hit. The following happens:
+
+TAB TAB inserts hard tab
+TAB SPC indent relative without inserting space char.
+TAB x indents relative and inserting character x
+
+\\{tinyindent-:mode-map}" t nil)
+
+;;;***
+\f
+;;;### (autoloads (ti::compat-timer-control) "tinylib" "tinylib.el" (15411
+;;;;;; 18540))
+;;; Generated autoloads from tinylib.el
+
+(autoload (quote ti::compat-timer-control) "tinylib" "\
+With `run-at-time' TIME REPEAT FUNCTION keep or remove timer. VERB." nil nil)
+
+;;;***
+\f
+;;;### (autoloads (ti::ck-do ti::ck-debug-toggle) "tinylibck" "tinylibck.el"
+;;;;;; (15378 27672))
+;;; Generated autoloads from tinylibck.el
+
+(autoload (quote ti::ck-debug-toggle) "tinylibck" "\
+Turn debug on or off with ARG. See buffer `ti::ck-:debug-buffer'." t nil)
+
+(autoload (quote ti::ck-do) "tinylibck" "\
+Transform key binding to XEmacs or Emacs in current environment.
+on current emacs. This enables you to have same key binding file
+for both emacs versions. You can write key bindings either in XEmacs
+or Emacs style.
+
+ In Emacs : (ti::ck-do '(meta up)) --> [M-up]
+ In XEmacs: (ti::ck-do [M-up]) --> '(meta up)
+
+This function does the conversion only if it needs to, and returns
+immediately if no conversion is needed. This should minimise performance
+penalty.
+
+Input:
+ KEY key sequence
+ XE flag. If this is nil, then Emacs env. is assumed. However
+ `ti::ck-:xemacs-flag' is obeyed if it is non-nil.
+ If non-nil, then XEmacs env. is assumed and conversion to
+ XEmacs like bindings are done." nil nil)
+
+;;;***
+\f
+;;;### (autoloads (ti::id-info) "tinylibid" "tinylibid.el" (15378
+;;;;;; 27672))
+;;; Generated autoloads from tinylibid.el
+
+(autoload (quote ti::id-info) "tinylibid" "\
+Try to identify buffer type.
+
+Function doesn't rely on mode, because that doesn't necessarily tell what
+the buffer holds. Many users still program their shell scripts in
+`fundamental-mode' or so. This means that `major-mode' isn't checked,
+because calling function can do it easily.
+
+If this function returns nil, _then_ it's probably the time to check
+the `major-mode'.
+
+The normal order of evaluation is as follows:
+- First line in the file
+- Whole filename including path = `buffer-file-name'
+- File name extension
+- `buffer-name' is checked. [temporary buffer has no file name]
+- Whole buffer is searched for RE texts
+
+Input:
+
+ MODE flag, controls return value format
+ VARIABLE-LOOKUP flag, read buffer type from cache. (From previous call)
+ VERB if non-nil, verbose messages allowed.
+
+Return values:
+
+ when optional MODE = nil
+ Some appropriate _string_ that represents the content. notice that this
+ string is usually generalised description, _but_ it the file has special
+ 1st line in form of -*-..-*- the string is direct mode name string.
+
+ when optional MODE = non-nil
+ Return possible mode name as _symbol_
+
+ when VARIABLE is non-nil, the variable `ti::id-:info' is read instead.
+ If it has non-nil value, the value is returned, otherwise full buffer
+ is parsed again and variable's value is updated.
+
+References:
+
+ `ti::id-func-alist' order of evaluation.
+ `ti::id-:info' buffer local variable updated during every call." t nil)
+
+;;;***
+\f
+;;;### (autoloads (ti::menu-menu ti::menu-set-doc-string ti::menu-add)
+;;;;;; "tinylibmenu" "tinylibmenu.el" (15378 27672))
+;;; Generated autoloads from tinylibmenu.el
+
+(autoload (quote ti::menu-add) "tinylibmenu" "\
+Add to menu MENU-SYMBOL elt (CH . CELL). Optionally DELETE.
+
+Example:
+
+ (ti::menu-add 'ti::menu-:menu-sample ?2 nil 'delete)
+ (ti::menu-add 'ti::menu-:menu-sample ?t '( (my-test 1 2 3)))
+
+Return:
+
+ nil no add done due to existing CELL
+ no remove due to non-existing CELL" nil nil)
+
+(autoload (quote ti::menu-set-doc-string) "tinylibmenu" "\
+Use MENU-SYMBOL and set its DOC-STRING.
+
+Example:
+
+ (ti::menu-set-doc-string 'ti::menu-:menu-sample \"?=help, 1=test1, t=myTest\")" nil nil)
+
+(autoload (quote ti::menu-menu) "tinylibmenu" "\
+The menu navigation engine.
+
+Input:
+
+ MENU-SYMBOL variable symbol containing menu items
+ PFX-ARG the prefix arg user ppossibly passed to menu
+
+References:
+
+ `ti::menu-:menu-sample' Show how the menu is constructed.
+ `ti::menu-:prefix-arg' Copy of current prefix arg" nil nil)
+
+;;;***
+\f
+;;;### (autoloads (ti::text-mark-region ti::text-unmark-region ti::text-mouse-unmark-region
+;;;;;; ti::text-mouse-mark-region ti::text-re-search-backward ti::text-re-search-forward
+;;;;;; ti::text-buffer ti::text-looking-at ti::text-re-search) "tinylibt"
+;;;;;; "tinylibt.el" (15378 27672))
+;;; Generated autoloads from tinylibt.el
+
+(autoload (quote ti::text-re-search) "tinylibt" "\
+Highlight found text with search face.
+
+Note:
+
+ The beginning of match and end of match will have
+ property 'rear-nonsticky t, so that adding characters before of after
+ text, won't inherit the face.
+
+Input:
+
+ RE str regexp
+ DIRECTION bool non-nil means backward
+ LEVEL nbr which subexpression in re to highlight, default is 0
+ MAXP nbr last search point [default until bob/eob]
+
+ FACE sym face symbol
+ if symbol is 'null then set face to value nil
+ or if this is list; then it must be properly list
+ of format '(PROP PROP-VAL PROP PROP-VAL ..)
+
+ MODE nbr signify that function should highlight all matches
+ that occur within LEVEL..NBR
+ if you have lot's of xx(match)yy|zz(match)tt|
+ the subexpression are counted from left to to
+ right: 1,2 ...
+ SAVE-UNDO flag non-nil means that the highlight information is
+ recorded for undo. This flag in on if function is
+ called interactively. NOTE: the undo information is
+ saved only if something was matched.
+
+Return:
+
+ nil No match
+ nbr start of match at LEVEL." nil nil)
+
+(autoload (quote ti::text-looking-at) "tinylibt" "\
+Highlight found RE at LEVEL with FACE-OR-PLIST.
+The LEVEL is subexpression to highlight. PLIST means property list." t nil)
+
+(autoload (quote ti::text-buffer) "tinylibt" "\
+Highlight RE and sub LEVEL in whole buffer, starting from `point-min'.
+Preserve point.
+
+See `ti::text-re-search' for descriptions of FACE MODE and SAVE-UNDO." t nil)
+
+(autoload (quote ti::text-re-search-forward) "tinylibt" "\
+Search RE and highlight forward until `point-max'.
+Optional prefix arg tells which subexpression LEVEL to match that
+function should highlight. point is preserved during call.
+
+See `ti::text-re-search' for descriptions of FACE MODE SAVE-UNDO." t nil)
+
+(autoload (quote ti::text-re-search-backward) "tinylibt" "\
+Search RE and highlight backward until `point-min'.
+Optional prefix arg tells which subexpression LEVEL to match that
+function should highlight. point is preserved during call.
+
+See `ti::text-re-search' for descriptions of FACE MODE SAVE-UNDO." t nil)
+
+(autoload (quote ti::text-mouse-mark-region) "tinylibt" "\
+Highlight region BEG END. EVENT is mouse event." t nil)
+
+(autoload (quote ti::text-mouse-unmark-region) "tinylibt" "\
+Remove highlight from region BEG END. EVENT is mouse event." t nil)
+
+(autoload (quote ti::text-unmark-region) "tinylibt" "\
+Remove highlight from region BEG END." t nil)
+
+(autoload (quote ti::text-mark-region) "tinylibt" "\
+Highlight BEG END. With optional prefix arg REMOVE all matching FACE." t nil)
+
+;;;***
+\f
+;;;### (autoloads nil "tinylisp" "tinylisp.el" (15407 17982))
+;;; Generated autoloads from tinylisp.el
+ (autoload 'tinylisp-elp-summary-mode "tinylisp" t t)
+ (autoload 'turn-on-tinylisp-elp-summary-mode "tinylisp" t t)
+ (autoload 'turn-off-tinylisp-elp-summary-mode "tinylisp" t t)
+ (autoload 'tinylisp-version "tinylisp" "Display commentary" t)
+
+;;;***
+\f
+;;;### (autoloads (tinyload-loader-process tinyload-install) "tinyload"
+;;;;;; "tinyload.el" (15378 27672))
+;;; Generated autoloads from tinyload.el
+
+(autoload (quote tinyload-install) "tinyload" "\
+Install package or REMOVE.
+This function removes any previous TinyLoad timer process and resets
+the list pointer to 0." t nil)
+
+(autoload (quote tinyload-loader-process) "tinyload" "\
+Load packages defined in `tinyload-:load-list'.
+If called interactively, FORCE loading all packages in the list." t nil)
+
+;;;***
+\f
+;;;### (autoloads (tinylock-lock tinylock-history) "tinylock" "tinylock.el"
+;;;;;; (15378 27674))
+;;; Generated autoloads from tinylock.el
+ (autoload 'tinylock-version "tinylock" "Display commentary." t)
+
+(autoload (quote tinylock-history) "tinylock" "\
+Displays login history. Optionally to given buffer BUFFER." t nil)
+
+(autoload (quote tinylock-lock) "tinylock" "\
+Lock Emacs with PSW password and MSG.
+Message is displayed if LOCK-NOW is nil.
+If LOCK-NOW is non-nil emacs is immediately locked with PSW." t nil)
+
+;;;***
+\f
+;;;### (autoloads (tinymacro-assign tinymacro-end-kbd-macro-and-assign)
+;;;;;; "tinymacro" "tinymacro.el" (15378 27674))
+;;; Generated autoloads from tinymacro.el
+ (autoload 'tinymacro-version "tinymacro" "Display commentary." t)
+
+(autoload (quote tinymacro-end-kbd-macro-and-assign) "tinymacro" "\
+Terminate reading macro and assign it to key." t nil)
+
+(autoload (quote tinymacro-assign) "tinymacro" "\
+Name last macro and assigns it to user defined KEY.
+Runs tinymacro-:macro-assigned-hook if key macro gets installed.
+The query options should be turned off if you call this within
+function, since it always return nil if the options are on.
+
+Input:
+
+ KEY Should be valid emacs key-bind-sequence/key-vector
+ VERB Boolean, verbose messages
+
+Return:
+
+ t is assigned
+ nil not assigned `keyboard-quit'" t nil)
+
+;;;***
+\f
+;;;### (autoloads (tinymail-on-off-toggle tinymail-mail tinymail-deactivate-and-send-to-you)
+;;;;;; "tinymail" "tinymail.el" (15411 20732))
+;;; Generated autoloads from tinymail.el
+ (autoload 'tinymail-version "tinymail" "Display commentary." t)
+ (autoload 'tinymail-mode "tinymail" "" t)
+ (autoload 'turn-on-tinymail-mode "tinymail" "" t)
+ (autoload 'turn-off-tinymail-mode "tinymail" "" t)
+ (autoload 'tinymail-commentary "tinymail" "" t)
+
+(autoload (quote tinymail-deactivate-and-send-to-you) "tinymail" "\
+Deactivate TIMI and change To field to point to your address.
+This function is normally used when you use mailing lists. See
+documentation in the tinymail.el or call \\[tinymail-version]." t nil)
+
+(autoload (quote tinymail-mail) "tinymail" "\
+Prepare mail mode.
+Add or changes Cc, FF, X-Sender-Info fields on the fly while you're
+composing the message.
+
+Input:
+
+ DISABLE Disables package.
+ VERB print verbose message.
+
+References:
+
+ `tinymail-:feature-hook'." nil nil)
+
+(autoload (quote tinymail-on-off-toggle) "tinymail" "\
+Toggle TIMI mode on and off by Changing spacing of To field.
+This affects automatic Cc and X-Sender-Info tracking.
+ARG behaves like mode argument.
+
+Without arg, this toggless Cc tracking, with prefix argument,
+it toggless both Cc and X-Sender-Info tracking." t nil)
+
+;;;***
+\f
+;;;### (autoloads (tinymailbox-message-to-file tinymailbox-message-to-folder
+;;;;;; tinymailbox-copy-body tinymailbox-copy tinymailbox-delete
+;;;;;; tinymailbox-begin) "tinymailbox" "tinymailbox.el" (15407
+;;;;;; 48240))
+;;; Generated autoloads from tinymailbox.el
+ (autoload 'tinymailbox-version "tinymailbox" "Display commentary" t)
+ (autoload 'tinymailbox-install-mode "tinymailbox" "" t)
+ (autoload 'tinymailbox-mode "tinymailbox" "" t)
+ (autoload 'turn-on-tinymailbox-mode "tinymailbox" "" t)
+ (autoload 'turn-off-tinymailbox-mode "tinymailbox" "" t)
+ (autoload 'tinymailbox-commentary "tinymailbox" "" t)
+ (autoload 'tinymailbox-forward "tinymailbox" "Go to next message." t)
+ (autoload 'tinymailbox-backward "tinymailbox" "Go to previous message." t)
+
+(autoload (quote tinymailbox-begin) "tinymailbox" "\
+Move to message begin. Optionally BACKWARD." t nil)
+
+(autoload (quote tinymailbox-delete) "tinymailbox" "\
+Delete current message. point must be inside message." t nil)
+
+(autoload (quote tinymailbox-copy) "tinymailbox" "\
+Copy current message. point must be inside message." t nil)
+
+(autoload (quote tinymailbox-copy-body) "tinymailbox" "\
+Copy body of current message. point must be inside message." t nil)
+
+(autoload (quote tinymailbox-message-to-folder) "tinymailbox" "\
+File current message by appending it to FILE." t nil)
+
+(autoload (quote tinymailbox-message-to-file) "tinymailbox" nil t nil)
+
+;;;***
+\f
+;;;### (autoloads (tinymy-buffer-file-chmod tinymy-install tinymy-define-keys-extra
+;;;;;; tinymy-define-keys) "tinymy" "tinymy.el" (15407 17982))
+;;; Generated autoloads from tinymy.el
+ (autoload 'tinymy-version "tinymy" "Display commentary." t)
+
+(autoload (quote tinymy-define-keys) "tinymy" "\
+Install keys." t nil)
+
+(autoload (quote tinymy-define-keys-extra) "tinymy" "\
+Define extra global keys." t nil)
+ (autoload 'tinymy-install-files "tinymy" "" t)
+
+(autoload (quote tinymy-install) "tinymy" "\
+Configures Emacs variables and bindings." t nil)
+
+(autoload (quote tinymy-buffer-file-chmod) "tinymy" "\
+Toggle current buffer's Read-Write permission permanently on disk. VERB.
+Does nothing if buffer is not visiting a file or file is not owned by us." t nil)
+
+;;;***
+\f
+;;;### (autoloads nil "tinynbr" "tinynbr.el" (15381 6616))
+;;; Generated autoloads from tinynbr.el
+ (autoload 'tinynbr-version "tinynbr" "Display commentary." t)
+ (autoload 'tinynbr-mode "tinynbr" "" t)
+ (autoload 'turn-on-tinynbr-mode "tinynbr" "" t)
+ (autoload 'tun-off-tinynbr-mode "tinynbr" "" t)
+ (autoload 'tinynbr-commentary "tinynbr" "" t)
+ (autoload 'tinynbr-int-to-hex "tinynbr" "" t)
+ (autoload 'tinynbr-int-to-oct "tinynbr" "" t)
+ (autoload 'tinynbr-int-to-bin "tinynbr" "" t)
+ (autoload 'tinynbr-hex-to-int "tinynbr" "" t)
+ (autoload 'tinynbr-oct-to-int "tinynbr" "" t)
+ (autoload 'tinynbr-bin-to-int "tinynbr" "" t)
+
+;;;***
+\f
+;;;### (autoloads nil "tinypad" "tinypad.el" (15378 27674))
+;;; Generated autoloads from tinypad.el
+ (autoload 'tinypad-mode "tinypad" "" t)
+ (autoload 'turn-on-tinypad-mode "tinypad" "" t)
+ (autoload 'turn-off-tinypad-mode "tinypad" "" t)
+ (autoload 'tinypad-version "tinypad" "Display commentary." t)
+
+;;;***
+\f
+;;;### (autoloads (tinypage-go-next tinypage-go-previous tinypage-yank-after
+;;;;;; tinypage-yank-before tinypage-yank tinypage-cut tinypage-copy
+;;;;;; tinypage-select tinypage-region-action) "tinypage" "tinypage.el"
+;;;;;; (15378 27674))
+;;; Generated autoloads from tinypage.el
+ (autoload 'tinypage-version "tinypage" "Display commentary." t)
+ (autoload 'tinypage-mode "tinypage" "" t)
+ (autoload 'turn-on-tinypage-mode "tinypage" "" t)
+ (autoload 'turn-off-tinypage-mode "tinypage" "" t)
+ (autoload 'tinypage-commentary "tinypage" "" t)
+
+(autoload (quote tinypage-region-action) "tinypage" "\
+Execute action ACT. Return t or nil. VERB." nil nil)
+
+(autoload (quote tinypage-select) "tinypage" "\
+Select page. If sitting on page Marker, use page below. VERB." t nil)
+
+(autoload (quote tinypage-copy) "tinypage" "\
+Select page. If sitting on page Marker, use page below. VERB." t nil)
+
+(autoload (quote tinypage-cut) "tinypage" "\
+Select page. If sitting on page Marker, use page below. VERB." t nil)
+
+(autoload (quote tinypage-yank) "tinypage" "\
+Yank page from register. VERB." t nil)
+
+(autoload (quote tinypage-yank-before) "tinypage" "\
+Yank page from register, but _before_ current page. VERB." t nil)
+
+(autoload (quote tinypage-yank-after) "tinypage" "\
+Yank page from register, but _after_ current page.
+Optionally BEFORE with MSG and VERB." t nil)
+
+(autoload (quote tinypage-go-previous) "tinypage" "\
+Go to previous page. VERB." t nil)
+
+(autoload (quote tinypage-go-next) "tinypage" "\
+Go to next page, optionally BACK. Return point if moved. VERB." t nil)
+
+;;;***
+\f
+;;;### (autoloads nil "tinypair" "tinypair.el" (15384 58070))
+;;; Generated autoloads from tinypair.el
+ (autoload 'tinypair-version "tinypair" "Display commentary." t)
+ (autoload 'tinypair-mode "tinypair" "" t)
+ (autoload 'turn-on-tinypair-mode "tinypair" "" t)
+ (autoload 'turn-off-tinypair-mode "tinypair" "" t)
+ (autoload 'tinypair-commentary "tinypair" "" t)
+
+;;;***
+\f
+;;;### (autoloads (tinypath-report-mode) "tinypath" "tinypath.el"
+;;;;;; (15407 48240))
+;;; Generated autoloads from tinypath.el
+
+(autoload (quote tinypath-report-mode) "tinypath" "\
+Major mode to help working with `tinypath-cache-duplicate-report'. VERB.
+
+\\{tinypath-report-mode-map}" t nil)
+
+;;;***
+\f
+;;;### (autoloads (tinyperl-pod-grep-and-make-faq-answer tinyperl-pod-grep
+;;;;;; tinyperl-pod-by-manpage tinyperl-pod-find-file tinyperl-pod-by-module
+;;;;;; tinyperl-module-find-file tinyperl-perldoc tinyperl-pod-kill-buffers
+;;;;;; turn-on-tinyperl-mode-all-buffers tinyperl-install) "tinyperl"
+;;;;;; "tinyperl.el" (15407 48240))
+;;; Generated autoloads from tinyperl.el
+ (autoload 'tinyperl-version "tinyperl" "Display commentary." t)
+
+(autoload (quote tinyperl-install) "tinyperl" "\
+Install tinyperl.
+
+Input:
+
+ FORCE If non-nil, rebuild all variables and
+ save new `(tinyperl-cache-file-name)'.
+ If nil, read saved variables from `(tinyperl-cache-file-name)'.
+
+ VERB Allow verbose messaegs." t nil)
+
+(autoload (quote turn-on-tinyperl-mode-all-buffers) "tinyperl" "\
+Turn function `tinyperl-mode' on in every perl buffer. Optionally turn OFF." t nil)
+ (autoload 'tinyperl-mode "tinyperl" "" t)
+ (autoload 'turn-on-tinyperl-mode "tinyperl" "" t)
+ (autoload 'turn-off-tinyperl-mode "tinyperl" "" t)
+ (autoload 'tinyperl-commentary "tinyperl" "" t)
+ (autoload 'tinyperl-pod-view-mode "tinyperl" "" t)
+ (autoload 'turn-on-tinyperl-pod-view-mode "tinyperl" "" t)
+ (autoload 'turn-off-tinyperl-pod-view-mode "tinyperl" "" t)
+ (autoload 'tinyperl-pod-write-mode "tinyperl" "" t)
+ (autoload 'turn-on-tinyperl-pod-write-mode "tinyperl" "" t)
+ (autoload 'turn-off-tinyperl-pod-write-mode "tinyperl" "" t)
+
+(autoload (quote tinyperl-pod-kill-buffers) "tinyperl" "\
+Kill all temporary POD buffers." t nil)
+
+(autoload (quote tinyperl-perldoc) "tinyperl" "\
+Run perldoc with STRING. First try with -f then without it.
+Show content in `tinyperl-:perldoc-buffer'. If buffer is visible in
+some other frame, the cursor is not moved there. Only contents is updated.
+
+The last used STRING is cached and if called next time with same
+string, the shell command is not called unless FORCE is non-nil.
+
+Input:
+
+ STRING Seach string
+ FORCE Force calling shell although answer cached
+ VERB flag, Allow verbose messages
+
+References:
+
+ `tinyperl-:perldoc-hook'" t nil)
+
+(autoload (quote tinyperl-module-find-file) "tinyperl" "\
+Load Perl MODULE source." t nil)
+
+(autoload (quote tinyperl-pod-by-module) "tinyperl" "\
+Show pod manual page for MODULE or load MODULE.
+
+Input:
+
+ MODULE The Perl module as it appears in `use' statement,
+ like Getopt::Long the '.pm' is automatically added.
+ MODE If non-nil, load source file, not pod." t nil)
+
+(autoload (quote tinyperl-pod-find-file) "tinyperl" "\
+Run pod2text on FILE and create new buffer: '*pod' + FILE + '*'.
+If file contains pod documentation section, it will be formatted nicely." t nil)
+
+(autoload (quote tinyperl-pod-by-manpage) "tinyperl" "\
+Display pod for FILE." t nil)
+
+(autoload (quote tinyperl-pod-grep) "tinyperl" "\
+Grep REGEXP from perl pod files.
+This is your way to find what pages contain references to the items you're
+looking for. However if you select the file from compile buffer, it is
+in the unconverted format (.pod). A better would be to momorize the
+pod file name, like
+
+ perlre.pod:165: \\Z Match at only e
+
+And call immediately \\[tinyperl-pod-by-manpage] and view `perlre' in
+more pleasant manner. Few C-s searches or \\[occur] will take you
+to the correct position." t nil)
+
+(autoload (quote tinyperl-pod-grep-and-make-faq-answer) "tinyperl" "\
+Grep REGEXP from perl pod files.
+
+This function also gathers all =head topics that match the REGEXP.
+You can use generated page as an answer to 'Has this this question
+been answered in FAQ'" t nil)
+
+;;;***
+\f
+;;;### (autoloads (tinypgp-hide-show-toggle tinypgp-xpgp-header-toggle
+;;;;;; tinypgp-xpgp-header-mode-toggle tinypgp-crypt-region tinypgp-crypt-mail
+;;;;;; tinypgp-decrypt-region tinypgp-decrypt-mail tinypgp-encrypt-region
+;;;;;; tinypgp-encrypt-region-sign tinypgp-encrypt-mail tinypgp-encrypt-mail-sign
+;;;;;; tinypgp-sign-region tinypgp-sign-mail tinypgp-sign-loose-info
+;;;;;; tinypgp-sign-mail-auto-mode) "tinypgp" "tinypgp.el" (15411
+;;;;;; 18642))
+;;; Generated autoloads from tinypgp.el
+ (autoload 'tinypgp-newnym-req-acksend "tinypgp" "" t)
+ (autoload 'tinypgp-newnym-req-sigsend "tinypgp" "" t)
+ (autoload 'tinypgp-newnym-req-cryptrecv "tinypgp" "" t)
+ (autoload 'tinypgp-newnym-req-fixedsize "tinypgp" "" t)
+ (autoload 'tinypgp-newnym-req-disable "tinypgp" "" t)
+ (autoload 'tinypgp-newnym-req-fingerkey "tinypgp" "" t)
+ (autoload 'tinypgp-newnym-req-nobcc "tinypgp" "" t)
+
+(autoload (quote tinypgp-sign-mail-auto-mode) "tinypgp" "\
+Toggle autosigning mode according to ARG.
+
+Input:
+ 0, -1 off
+ nil toggle
+ t, 1 on
+
+ 'push-on Record previous value and turn on auto signing.
+ 'push-off Record previous value and turn off auto signing.
+ 'pop pop previous autosign value.
+
+Return:
+ nil autosigning off
+ non-nil autosigning on" t nil)
+
+(autoload (quote tinypgp-sign-loose-info) "tinypgp" "\
+Loose signature info.
+Input:
+ VERB Verbose messages." t nil)
+
+(autoload (quote tinypgp-sign-mail) "tinypgp" "\
+Sign message in mail buffer.
+
+Input:
+
+ REGISTER flag, if non-bil store the signature to register.
+ This is the prefix arg user passes to program.
+ This will automatically turn off X-pgp.
+ USER key-id
+ VERB allow verbose messages
+ NOXPGP Prohibit X-Pgp
+
+Notes:
+
+ if VERB is non-nil (set in interactive call), the pubring is
+ changed if it the information is on the cache." t nil)
+
+(autoload (quote tinypgp-sign-region) "tinypgp" "\
+Sign region.
+
+Input:
+
+ BEG END ints, region
+ VERB flag, verbose messages
+ OPTIONS string, flags to add to the real pgp command.
+ NOERR flag, return nil or t only
+ REGISTER flag, save results to register
+ AS-IS flag, if non-nil. no buffer modification is done.
+ Normally would delete whitespaces at the end of lines.
+" t nil)
+
+(autoload (quote tinypgp-encrypt-mail-sign) "tinypgp" "\
+See `tinypgp-encrypt-mail'. Raise parameter 'sign'.
+SINGLE-OR-LIST NO-REPLACE SIGN-PWD OPTIONS VERB NOERR." t nil)
+
+(autoload (quote tinypgp-encrypt-mail) "tinypgp" "\
+Encrypt mail buffer.
+
+Input:
+
+ SINGLE-OR-LIST List of key-ids. Interactive call reads To,CC,BCC.
+ NO-REPLACE prefix arg, store result to `tinypgp-:register'.
+ SIGN-FLAG if non-nil, sign at the same time as you encrypt.
+ OPTIONS Additional pgp option string.
+ VERB If non-nil, verbose messages.
+ NOERR If non-nil, do not call error.
+
+Function call note:
+
+ [interactive]
+ In case the EMAIL address you're sending doesn't have entry in your
+ keyring, but you know that person has a PGP public key, then
+ please remove the email address prior calling this function and
+ it will prompt you a string to match for USER.
+
+ If this function is called interactively, it tries to set right
+ pubring by querying cache and other keyrings (user prompted)
+ Also the `tinypgp-:pgp-exe-interactive-option' is suppressed if
+ `tinypgp-:r-mode-indication-flag' is non-nil
+
+ Normally the To field's address is read and used for encryption.
+ However, if you are _on_ line that has email address in format
+ <foo@site.com> then your are asked if you want to use this email
+ instead. You can complete between this and To address.
+
+ [when called as lisp function]
+ Be sure to take precaution when passing OPTIONS if the message is
+ sent to remailer. Any extra keyword, like 'Comment:'
+ may reveal your identity.
+
+ SINGLE-OR-LIST is not processed with `tinypgp-key-id-conversion'.
+ You should call it manually if you want to respect user's
+ substitution definitions.
+
+ [Genenal note]
+ If there are multiple recipiens in the To, CC, BCC field the
+ last keyring in the `tinypgp-pubring-table' is used when doing the
+ encryption.
+
+Input:
+
+ single-or-list list of email addresses or KEY ID's
+ no-replace flag, do not replace area with encryption
+ options string, extra options passed to pgp exe
+ verb flag, allow printing messages." t nil)
+
+(autoload (quote tinypgp-encrypt-region-sign) "tinypgp" "\
+Same as `tinypgp-encrypt-region' but raise 'sign' parameter.
+BEG END USER NO-REPLACE SIGN-PWD OPTIONS VERB" t nil)
+
+(autoload (quote tinypgp-encrypt-region) "tinypgp" "\
+Encrypt region.
+
+Input:
+
+ BEG END region
+ USER key-id (possibly email) or list of keyIds.
+ NO-REPLACE prefix arg, store results to `tinypgp-:register'
+ SIGN-PWD if non-nil string, Sign at the same time as you encrypt.
+ OPTIONS Additional option string for PGP.
+ VERB If non-nil, Verbose messages." t nil)
+
+(autoload (quote tinypgp-decrypt-mail) "tinypgp" "\
+Decrypt mail buffer.
+The PGP data in the buffer is detected by reading the CTB bits:
+see pgpformat.doc in pgp documentation.
+
+Input:
+
+ NO-REPLACE flag, prefix arg instructs to show the cotent in
+ separate buffer. See refrerence note too.
+ If this is 'preview and verb argument is nil-nil,
+ then automatically show content is different buffer.
+
+ TYPE nil or \"pgp\" --> PGP encrypted
+ \"base64\" --> base64 signed and
+ \"conventional\" --> encrypted with conventional key.
+
+ VERB Verbose mode.
+
+References:
+
+ `tinypgp-:pgp-encrypted-p-function'
+ `tinypgp-:decrypt-arg-interpretation' for interactive calls
+ `tinypgp-:pgp-decrypt-arg-function' for interactive calls
+ `tinypgp-:user-identity-table'" t nil)
+
+(autoload (quote tinypgp-decrypt-region) "tinypgp" "\
+Decrypt region. Signal error is there is no decrypt message.
+
+Input:
+
+ BEG END int, region
+ NO-REPLACE flag, store contents to `tinypgp-:register'.
+ If values is 'review and verb is non-nil, also display
+ content in separate buffer. Calls `tinypgp-view-register'
+ TYPE string, Decrypt type: conventional, base64 or pgp
+ VERB flag, verbose messages" t nil)
+
+(autoload (quote tinypgp-crypt-mail) "tinypgp" "\
+Crypt mail buffer.
+
+Input:
+
+ PASSWORD pass phrase
+ NO-REPLACE store contents to `tinypgp-:register'.
+ COMMENT Additional comment added
+ VERB verbose messages" t nil)
+
+(autoload (quote tinypgp-crypt-region) "tinypgp" "\
+Crypt region.
+
+Input:
+
+ BEG END region
+ PASSWORD pass phrase
+ NO-REPLACE store contents to `tinypgp-:register'.
+ COMMENT The comment string.
+ VERB verbose messages" t nil)
+
+(autoload (quote tinypgp-xpgp-header-mode-toggle) "tinypgp" "\
+Toggle X-pgp header mode with ARG.
+
+References
+ `tinypgp-:header-sign-table' ,this variable overrides the signing mode." t nil)
+
+(autoload (quote tinypgp-xpgp-header-toggle) "tinypgp" "\
+Togle moving signature FROM/TO headers." t nil)
+
+(autoload (quote tinypgp-hide-show-toggle) "tinypgp" "\
+Togle hiding and showing the PGP signature." t nil)
+
+;;;***
+\f
+;;;### (autoloads (turn-on-tinyprocmail-mode-all-buffers turn-off-tinyprocmail-mode-all-buffers)
+;;;;;; "tinyprocmail" "tinyprocmail.el" (15378 27674))
+;;; Generated autoloads from tinyprocmail.el
+ (autoload 'tinyprocmail-mode "tinyprocmail" "" t)
+ (autoload 'turn-on-tinyprocmail-mode "tinyprocmail" "" t)
+ (autoload 'turn-off-tinyprocmail-mode "tinyprocmail" "" t)
+ (autoload 'tinyprocmail-commentary "tinyprocmail" "" t)
+ (autoload 'tinyprocmail-version "tinyprocmail" "" t)
+ (autoload 'tinyprocmail-output-mode "tinyprocmail" "" t)
+ (autoload 'turn-on-tinyprocmail-output-mode "tinyprocmail" "" t)
+ (autoload 'turn-off-tinyprocmail-output-mode "tinyprocmail" "" t)
+ (autoload 'tinyprocmail-install-files "tinyprocmail" t t)
+
+(autoload (quote turn-off-tinyprocmail-mode-all-buffers) "tinyprocmail" "\
+Call `turn-on-tinyprocmail-mode-all-buffers' with parameter `off'. VERB." t nil)
+
+(autoload (quote turn-on-tinyprocmail-mode-all-buffers) "tinyprocmail" "\
+Turn on or OFF function `tinyprocmail-mode' for all procmail buffers. VERB.
+Procmail files start with `rc.' or end to `.rc' and file content
+must match `^:0'." t nil)
+
+;;;***
+\f
+;;;### (autoloads (tinyreplace-latex-math-replace tinyreplace-latex-blk-replace
+;;;;;; tinyreplace-replace-forward tinyreplace-replace-region tinyreplace-replace-over-files-compile-buffer
+;;;;;; tinyreplace-symmetry-toggle tinyreplace-define-keys-compile-map
+;;;;;; tinyreplace-menu) "tinyreplace" "tinyreplace.el" (15382 22904))
+;;; Generated autoloads from tinyreplace.el
+
+(autoload (quote tinyreplace-menu) "tinyreplace" "\
+Run `tinyreplace-:menu'." t nil)
+
+(autoload (quote tinyreplace-define-keys-compile-map) "tinyreplace" "\
+Define key bindings." t nil)
+
+(autoload (quote tinyreplace-symmetry-toggle) "tinyreplace" "\
+Toggle variable` tinyreplace-:symmetry' with ARG. VERB." t nil)
+
+(autoload (quote tinyreplace-replace-over-files-compile-buffer) "tinyreplace" "\
+Read all files forward in buffer that is in compile buffer format.
+Perform replace over the found files. Checks Out files that are
+RCS controlled if necessary.
+
+Line format:
+
+ /DIR/DIR/FILE: matched text
+
+Input:
+
+ See function `tinyreplace-replace-1'
+ BEG END STR1 STR2 &OPTIONAL FUNC VERB" t nil)
+
+(autoload (quote tinyreplace-replace-region) "tinyreplace" "\
+In region BEG END, find STR1 and replace with STR2." t nil)
+
+(autoload (quote tinyreplace-replace-forward) "tinyreplace" "\
+Find STR1 and replace with STR2 from current point forward.
+See source code of function `tinyreplace-args-keymap-create' what key bindings
+you can use. Normally C - l yanks, and \"\\\" key deletes line." t nil)
+
+(autoload (quote tinyreplace-latex-blk-replace) "tinyreplace" "\
+Select latex block areas for replace.
+
+Input:
+
+ STR1 STR2 Find and replace with.
+ BLK Block delimiter to find
+ BEG-RE END-RE Region bound regexps." t nil)
+
+(autoload (quote tinyreplace-latex-math-replace) "tinyreplace" "\
+Find STR1 and replace with STR2 inside latex math blocks." t nil)
+
+;;;***
+\f
+;;;### (autoloads (tinyrmail-rmail-summary-by-labels-and) "tinyrmail"
+;;;;;; "tinyrmail.el" (15378 27676))
+;;; Generated autoloads from tinyrmail.el
+ (autoload 'tinyrmail-version "tinyrmail" "Display commentary." t)
+ (autoload 'tinyrmail-install-files "tinyrmail" t t)
+
+(autoload (quote tinyrmail-rmail-summary-by-labels-and) "tinyrmail" "\
+Display a summary of all messages with one or more LABELS.
+LABELS should be a string containing the desired labels, separated by commas.
+This summary is prduced by _ANDING_ the labels." t nil)
+
+;;;***
+\f
+;;;### (autoloads (tinyscroll-control tinyscroll-list tinyscroll-timer-process-control)
+;;;;;; "tinyscroll" "tinyscroll.el" (15411 18598))
+;;; Generated autoloads from tinyscroll.el
+ (autoload 'tinyscroll-version "tinyscroll" "Commentary." t)
+
+(autoload (quote tinyscroll-timer-process-control) "tinyscroll" "\
+Keep the auto scroll process and timer process alive.
+Optionally DELETE auto scroll process. VERB." t nil)
+
+(autoload (quote tinyscroll-list) "tinyscroll" "\
+Show list of active auto scroll buffers.
+Buffers are listed inecho-area if they fit there, otherwise in separate buffer.
+
+If optional PRINT flag is non-nil, always generate report to temporary buffer.
+If list if empty, do nothing.
+
+Return:
+
+ t report generated to temporary buffer
+ nil no report" t nil)
+
+(autoload (quote tinyscroll-control) "tinyscroll" "\
+Turn on auto scroll on/off for current buffer.
+If this command is called from `tinyscroll-:tmp-buffer' then the current
+word in the line is read and offered for default buffer name.
+
+Input:
+
+ BUFFER-OR-POINTER buffer to scroll
+ OFF flag, prefix arg; is non-nil turn scrolling off
+ VERB flag, allow verbose messages." t nil)
+
+;;;***
+\f
+;;;### (autoloads (tinysearch-search-word-backward tinysearch-search-word-forward
+;;;;;; ) "tinysearch" "tinysearch.el"
+;;;;;; (15382 30960))
+;;; Generated autoloads from tinysearch.el
+
+(autoload (quote tinysearch-search-word-forward) "tinysearch" "\
+Search word at point forward." t nil)
+
+(autoload (quote tinysearch-search-word-backward) "tinysearch" "\
+Search word at point backward." t nil)
+
+;;;***
+\f
+;;;### (autoloads (tinytab-return-key-mode tinytab-tab-del-key tinytab-tab-key)
+;;;;;; "tinytab" "tinytab.el" (15378 27676))
+;;; Generated autoloads from tinytab.el
+ (autoload 'tinytab-mode "tinytab" "" t)
+ (autoload 'turn-on-tinytab-mode "tinytab" "" t)
+ (autoload 'turn-off-tinytab-mode "tinytab" "" t)
+ (autoload 'tinytab-commentary "tinytab" "" t)
+ (autoload 'tinytab-version "tinytab" "" t)
+
+(autoload (quote tinytab-tab-key) "tinytab" "\
+Main function for TAB key. See variable `tinytab-:tab-insert-hook'." t nil)
+
+(autoload (quote tinytab-tab-del-key) "tinytab" "\
+Main function for TAB key. See variable `tinytab-:tab-delete-hook'." t nil)
+
+(autoload (quote tinytab-return-key-mode) "tinytab" "\
+Toggle auto indent MODE / regular newline mode. VERB." t nil)
+
+;;;***
+\f
+;;;### (autoloads (tinytag-post-command tinytag-main-mouse tinytag-main
+;;;;;; tinytag-install-sample-database-c tinytag-install-sample-database-java
+;;;;;; tinytag-install) "tinytag" "tinytag.el" (15411 18378))
+;;; Generated autoloads from tinytag.el
+
+(autoload (quote tinytag-install) "tinytag" "\
+Install package. Optionally UNINSTALL." t nil)
+
+(autoload (quote tinytag-install-sample-database-java) "tinytag" "\
+Install Java database from Sub JDK documentation." t nil)
+
+(autoload (quote tinytag-install-sample-database-c) "tinytag" "\
+Install c/C++ database from file tintytag.el." t nil)
+
+(autoload (quote tinytag-main) "tinytag" "\
+Run `tinytag-:try-hook' until some of the functions return non-nil." t nil)
+
+(autoload (quote tinytag-main-mouse) "tinytag" "\
+See `tinytag-main'. Function is called with mouse EVENT." t nil)
+
+(autoload (quote tinytag-post-command) "tinytag" "\
+Activates only if `tinytag-:set-database-hook' wakes up.
+Show the database definition for the current word under point.
+
+References:
+
+ `tinytag-:noerror'
+ `tinytag-:post-command-hook-wakeup'
+ `tinytag-:set-database-hook'" nil nil)
+
+;;;***
+\f
+;;;### (autoloads (turn-on-tinytf-mode-maybe tinytf-mode-define-f-keys)
+;;;;;; "tinytf" "tinytf.el" (15411 20766))
+;;; Generated autoloads from tinytf.el
+ (autoload 'tinytf-version "tinytf" "Display commentary." t)
+ (autoload 'tinytf-install-mode "tinytf" "" t)
+ (autoload 'tinytf-mode "tinytf" "" t)
+ (autoload 'turn-on-tinytf-mode "tinytf" "" t)
+ (autoload 'turn-off-tinytf-mode "tinytf" "" t)
+ (autoload 'tinytf-commentary "tinytf" "" t)
+
+(autoload (quote tinytf-mode-define-f-keys) "tinytf" "\
+Define default F key to `tinytf-:mode-map'." t nil)
+ (autoload 'tinytf-install-files "tinytf" t t)
+
+(autoload (quote turn-on-tinytf-mode-maybe) "tinytf" "\
+Turn on mode function `tinytf-mode' if TOC entry is found." nil nil)
+
+;;;***
+\f
+;;;### (autoloads (tinyurl-install tinyurl-mode-1 turn-on-tinyurl-mode-mail
+;;;;;; turn-on-tinyurl-mode-1-maybe turn-on-turn-off-tinyurl-mode-1-maybe)
+;;;;;; "tinyurl" "tinyurl.el" (15380 59900))
+;;; Generated autoloads from tinyurl.el
+ (autoload 'tinyurl-version "tinyurl" "Display commentary." t)
+ (autoload 'tinyurl-debug-toggle "tinyurl" "" t)
+ (autoload 'tinyurl-mode "tinyurl" "" t)
+ (autoload 'turn-on-tinyurl-mode "tinyurl" "" t)
+ (autoload 'turn-off-tinyurl-mode "tinyurl" "" t)
+ (autoload 'tinyurl-commentary "tinyurl" "" t)
+
+(autoload (quote turn-on-turn-off-tinyurl-mode-1-maybe) "tinyurl" "\
+Activate or Deactivate `tinyurl-mode-1' in current buffer.
+Try to find ftp, http or email is found.
+The value of `tinyurl-:exclude-function' is consulted first." nil nil)
+
+(autoload (quote turn-on-tinyurl-mode-1-maybe) "tinyurl" "\
+Activate `tinyurl-mode-1' in current buffer if ftp, http or email is found.
+This function is meant to be used in eg. Article display
+hooks in Mail Agents.
+
+References:
+
+ The value of `tinyurl-:exclude-function' is consulted first." nil nil)
+
+(autoload (quote turn-on-tinyurl-mode-mail) "tinyurl" "\
+Turn on `tinyurl-mode-1' and make `tinyurl-:mouse-yank-at-point' local." nil nil)
+
+(autoload (quote tinyurl-mode-1) "tinyurl" "\
+Turn mode on or off with mode ARG for current buffer only.
+If you want to turn on or off globally, use function `tinyurl-mode'." t nil)
+
+(autoload (quote tinyurl-install) "tinyurl" "\
+Install or `UNINSTALL package." t nil)
+
+;;;***
+\f
+;;;### (autoloads nil "tinyvc" "tinyvc.el" (15378 27676))
+;;; Generated autoloads from tinyvc.el
+ (autoload 'tinyvc-mode "tinyvc" "" t)
+ (autoload 'turn-on-tinyvc-mode "tinyvc" "" t)
+ (autoload 'turn-off-tinyvc-mode "tinyvc" "" t)
+ (autoload 'tinyvc-commentary "tinyvc" "" t)
+ (autoload 'tinyvc-version "tinyvc" "" t)
+
+;;;***
+\f
+;;;### (autoloads (tinyxreg-jump-to-register-mouse tinyxreg-jump-to-register
+;;;;;; tinyxreg-remove-register tinyxreg-point-to-register tinyxreg-point-to-register-mouse
+;;;;;; tinyxreg-trash tinyxreg-remove-reg) "tinyxreg" "tinyxreg.el"
+;;;;;; (15378 27676))
+;;; Generated autoloads from tinyxreg.el
+ (autoload 'tinyxreg-version "tinyxreg" "Display commentary." t)
+
+(autoload (quote tinyxreg-remove-reg) "tinyxreg" "\
+Remove register CHAR from stored window and point lists.
+ARG suggests looking in window list." t nil)
+
+(autoload (quote tinyxreg-trash) "tinyxreg" "\
+Empties both window and point caches." t nil)
+
+(autoload (quote tinyxreg-point-to-register-mouse) "tinyxreg" "\
+Call `tinyxreg-point-to-register' using mouse EVENT." t nil)
+
+(autoload (quote tinyxreg-point-to-register) "tinyxreg" "\
+Store point to CHAR and to X-popup list.
+With prefix ARG, store current frame configuration. VERBOSE enables
+message printing.
+
+Use \\[tinyxreg-point-to-register] to go to that location or restore the
+configuration." t nil)
+
+(autoload (quote tinyxreg-remove-register) "tinyxreg" "\
+Remove register from popup list.
+See `tinyxreg-jump-to-register-mouse' for more." t nil)
+
+(autoload (quote tinyxreg-jump-to-register) "tinyxreg" "\
+Call `tinyxreg-jump-to-register-mouse' with REMOVE." t nil)
+
+(autoload (quote tinyxreg-jump-to-register-mouse) "tinyxreg" "\
+Displays list of registers using mouse EVENT.
+Restore register or optionally REMOVE register from X-list.
+Input:
+
+ EVENT mouse event
+ REMOVE flag, if non-nil, remove register.
+ VERB flag, Allow verbose messages." t nil)
+
+;;;***
--- /dev/null
+;;; tiny-setup.el --- Tiny Tools configure center.
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 2001-2007 Jari Aalto
+;; Keywords: extensions
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+
+;; Look at the code with folding.el
+
+;; COPYRIGHT NOTICE
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;; Nothing to install. Load this file.
+
+;;}}}
+
+;;{{{ Documentation
+
+;;; Commentary:
+
+;; Preface, overview of options
+;;
+;; This file will configure all Tiny Tool files. The alternative method
+;; is to look into each package individually and to follow instructions
+;; there to set up the files.
+;;
+;; To use this file, see control function `tinypath-setup' for
+;; full description. Try this:
+;;
+;; M-x RET load-library RET tiny-setup RET
+;; C-h f tinypath-setup
+;; M-x tinypath-setup-display
+;;
+;; M-x tiny-setup RET Default 'all setup
+;;
+;; To setup all tools from $HOME/.emacs, use:
+;;
+;; (load "~/path/to/tinypath.el") ;; Emacs autosetup, SEE THIS!
+;; (require 'tiny-setup) ;; control center
+;; (tiny-setup 'all) ;; configure all at once.
+;;
+;; To activate individual features:
+;;
+;; (tiny-setup nil '(tinymy--defadvice)) ;; Add smart M-x compile
+;;
+;; After you have loaded this file, have a look at the *Messages*
+;, (Emacs) or *Message-Log* (XEmcs) buffers, where you can find
+;; messgaes from the setup procedure.
+;;
+;; Emacs 21.x news: Windowed Emacs modeline contains new feature,
+;; where you can activate and deactivate minor modes. Shoot
+;; modeline with your mouse and follow message: "Mouse-3: minor
+;; mode menu". Minor modes available here are installed to that menu.
+;;
+;; Administration
+;;
+;; This part should concern the maintainer only.
+;;
+;; Autoload files
+;;
+;; If *loaddef* files were not included in the package or if they were
+;; mistakenly deleted. The tiny-setup.el startup is not possible
+;; without the autoload files.
+;;
+;; To generate autoloads recursively, call function
+;; `tiny-setup-autoload-batch-update' with the ROOT
+;; directory of your lisp files. The only requirement is that each
+;; directory name is unique, because the generated autoload file name
+;; contains directory name: *tiny-autoload-loaddefs-DIRNAME.el*
+;;
+;; Compilation check
+;;
+;; To check for possible leaks in code, ran the byte compilation
+;; function from shell by using XEmacs compiler. The Emacs byte
+;; compiler is not that good in findings all errors.
+;; See function `tiny-setup-compile-kit-all'.
+;;
+;; Profiling
+;;
+;; To check how much time each file load would take, see function
+;; `tiny-setup-test-load-time-libraries'. Here are results as of
+;; 2001-03-18 running Win9x/512Meg/400Mhz, Emacs 20.7, non-compiled
+;; files:
+;;
+;; Timing tinyliba, took 2.025000 secs (autoloads)
+;; Timing tinylibb, took 0.011000 secs
+;; Timing tinylibm, took 0.977000 secs
+;; Timing tinylib, took 0.982000 secs
+;; Timing tinylibxe, took 0.000000 secs
+;; Timing tinylibid, took 0.006000 secs
+;; Timing tinylibo, took 0.005000 secs
+;; Timing tinylibt, took 0.011000 secs
+;; total time is 4.027999997138977 seconds
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+(eval-when-compile
+ (require 'cl))
+
+(require 'tinyliba)
+
+(eval-and-compile
+ (defvar font-lock-mode)
+ (defvar mode-line-mode-menu) ;; Emacs only
+ (autoload 'tinydebian-install "tinydebian" "" t)
+ (autoload 'tinydesk-edit-state-file "tinydesk" "" t)
+ (autoload 'tinydesk-unload "tinydesk" "" t)
+ (autoload 'tinydesk-save-state "tinydesk" "" t)
+ (autoload 'tinydesk-recover-state "tinydesk" "" t)
+ (autoload 'byte-compile-file "bytecomp")
+ (autoload 'tinylisp-install "tinylisp" "" t)
+ (autoload 'turn-on-tinylisp-mode "tinylisp" "" t)
+ (autoload 'ti::mail-mailbox-p "tinylibmail")
+ (autoload 'turn-on-tinymailbox-mode "tinymailbox" "" t)
+ (autoload 'turn-on-tinymailbox-mode-maybe "tinymailbox" "" t)
+ (autoload 'folding-uninstall "folding" "" t)
+ (autoload 'folding-install-hooks "folding")
+ (autoload 'turn-on-folding-mode "folding" "" t)
+ (autoload 'dired-sort-default-keys "dired-sort")
+ (autoload 'tinymy-define-keys-extra "tinymy")
+ (autoload 'tinymy-compile-run-command-advice "tinymy" "" t)
+ (autoload 'tinymy-define-keys "tinymy")
+ (autoload 'tinyef-minibuffer-define-key-extras "tinyef" "" t)
+ (autoload 'turn-on-tinyef-mode "tinyef" "" t)
+ (autoload 'turn-on-tinypair-mode "tinypair" "" t)
+ (autoload 'turn-off-tinypair-mode "tinypair" "" t)
+ (autoload 'turn-on-tinyperl-mode-all-buffers "tinyperl" "" t)
+ (autoload 'tinyrmail-install "tinyrmail" "" t)
+ (autoload 'turn-on-tinycompile-mode "tinycompile" "" t)
+ (autoload 'tinytag-install-sample-databases "tinytag" "" t)
+ (autoload 'turn-on-tinytf-mode "tinytf" "" t)
+ (autoload 'turn-on-tinyurl-mode "tinyurl" "" t))
+
+;; Copy from tinylib.el
+(defmacro tiny-setup-ti::macrov-mode-line-mode-menu (mode-symbol text)
+ "Add MODE-SYMBOL to minor mode list in Emacs mode line menu."
+ (let ((sym (vector (intern (symbol-name (` (, mode-symbol)))))))
+ (` (when (boundp 'mode-line-mode-menu) ;; Emacs 21.1
+ (define-key mode-line-mode-menu (, sym)
+ '(menu-item (, text)
+ (, mode-symbol)
+ :button (:toggle . (, mode-symbol))))))))
+
+(defvar tiny-setup-load-hook nil
+ "*Hook run when package is loaded.")
+
+(defconst tiny-setup-:library-compile-order
+ '("tinylibenv.el"
+ "tinyliba.el"
+ "tinylibm.el"
+ "tinylibb.el")
+ "Order of compilation of the libraries.
+This variable is list of REGEXPS.")
+
+(defconst tiny-setup-:library-compile-exclude
+ '("tinylib-ad.el") ;; adviced functions
+ "Libraries not to compile.")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;
+;; SETUP CHOICES
+;;
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; See list of file descriptions with this bash script:
+;;
+;; head -1 $(ls *el | sort) | grep ';;'
+
+(defconst tiny-setup-:option-table
+ '(("dired-sort"
+ ("Dired sort package. Defines `s' key prefix to dired.")
+ ("autoload"))
+
+ ("folding"
+ ("Folding content management package. Detect {{{ and }}}.")
+ ("autoload"))
+
+ ("tinyadvice"
+ "Collection of advised functions."
+ ("load"))
+
+ ("tinyappend"
+ "A simple text gathering to buffer utility."
+ ("bind" "bindforce"))
+
+ ("tinybookmark"
+ "Keep file in organized sections."
+ ("bind"))
+
+ ("tinybuffer"
+ "Change buffers in current window."
+ ("bind" "bindforce"))
+
+ ("tinycache"
+ "Maintain a cache of visited files [compile, dired]."
+ ())
+
+ ("tinychist"
+ "Command history save/restore utility."
+ ())
+
+ ("tinycygwin"
+ "Cygwin bug reporting interface and other Cygwin utilities."
+ ()) ;;#todo:
+
+ ("tinycomment"
+ "Smart comment setting utility."
+ ("autoload" "bind"))
+
+ ("tinycompile"
+ "Compile buffer additions. Minor mode."
+ ("autoload"))
+
+ ("tinydesk"
+ "Save and restore files between Emacs sessions."
+ ("activate" "bind" "bindforce"))
+
+ ("tinydiff"
+ "Diff and patch minor mode. Browsing, patching."
+ ("autoload" "bind" "bindforce"))
+
+ ("tinydebian"
+ "Debian Linux utilities for system administrator. Bug reports etc."
+ ("autoload" "load"))
+
+ ("tinydired"
+ "Dired enhancements. Background Ange ftp support."
+ ("autoload"))
+
+ ("tinyeat"
+ "Eat blocks of text at point, forward and backward."
+ ("bind" "bindforce"))
+
+ ("tinyef"
+ "(E)lectric (f)ile minor mode. Easy C-x C-f filename composing."
+ ("autoload" "bindextra"))
+
+ ("tinygnus"
+ "Gnus Plug-in. Additional functions. Spam complain and more."
+ ("autoload"))
+
+ ("tinyhotlist"
+ "Hot-list of important buffers and files. Entry can be ange-ftp or dired too."
+ ("autoload" "bind" "bindforce" "bindmouse" "bindmouseforce"))
+
+ ("tinyigrep"
+ "Top level interface to igrep.el."
+ ("autoload" "bind" "bindforce"))
+
+ ;; there is nothing to setup in libraries. These are already
+ ;; autoloaded in tinyliba.el
+
+ ("tinylib-ad"
+ "Library of advised functions. Backward compatibility."
+ ())
+ ("tinylib"
+ "Library of general functions."
+ ())
+ ("tinyliba"
+ "Library for (a)utoload definitions."
+ ())
+ ("tinylibb"
+ "Library of (b)ackward compatible functions."
+ ())
+ ("tinylibck"
+ "Library to (c)onvert (k)eybindings for XEmacs or Emacs."
+ ())
+ ("tinylibenv"
+ "Library for environment check functions."
+ ())
+ ("tinylibid"
+ "Library for (Id)entifying buffer, regardless of mode."
+ ())
+ ("tinylibm"
+ "Library of s(m)all macros or functions."
+ ())
+ ("tinylibmenu"
+ "Library for echo-area menu."
+ ())
+ ("tinylibmail"
+ "Library of (m)ail and news (t)ool functions."
+ ())
+ ("tinylibo"
+ "Library for handling (o)verlays."
+ ())
+ ("tinylibt"
+ "Library for handling text properties."
+ ())
+ ("tinylibxe"
+ "Library for Emacs and XEmacs emulation."
+ ())
+ ("tinyliby"
+ "Library of functions related to Emacs s(y)stem."
+ ("defalias"))
+
+ ("tinylisp"
+ "Emacs lisp programming help grab-bag."
+ ("autoload" "activate"))
+
+ ("tinyload"
+ "Load set of packages when Emacs is idle (lazy load)."
+ ())
+
+ ;; This asks lock password at startup, can't define "load" option
+ ;; for this for unattended load.
+
+ ("tinylock"
+ "Simple Emacs locking utility."
+ ()) ;;#todo:
+
+ ("tinylpr"
+ "Easy Emacs lpr command handling, pop-up, completions."
+ ("bind"))
+
+ ("tinymacro"
+ "Fast way to assign newly created macro to a key. Redefines C-x )"
+ ("bind" "bindforce"))
+
+ ("tinymail"
+ "Mail add-ons. Report incoming mail, passwd, BBDB complete."
+ ("autoload"))
+
+ ("tinymailbox"
+ "Berkeley style mailbox browsing minor mode."
+ ("autoload"))
+
+ ("tinymy"
+ "Collection of user (`my') functions. Simple solutions."
+ ("load" "bind" "bindforce" "defalias" "defadvice"))
+
+ ("tinynbr"
+ "Number conversion minor mode oct/bin/hex."
+ ("autoload")) ;; Already autoloaded. M-x turn-on-tinynbr-mode
+
+ ("tinypad"
+ "Emulate Windows notepad with extra menu."
+ ("autoload"))
+
+ ("tinypage"
+ "Handling ^L pages. Select, cut, copy, renumber headings etc."
+ ("autoload" "bind"))
+
+ ("tinypair"
+ "Self insert character (pa)irs () \"\" '' <>."
+ ("autoload" "activate"))
+
+ ;; Please see the documentation in this file
+ ;; LOAD tinypath.el AS VERY FIRST PACKAGE. Before even tiny-setup.pl
+
+ ("tinypath"
+ "Manage Emacs startup dynamically."
+ ())
+
+ ("tinyperl"
+ "Grab-bag of Perl language utilities. Pod documentation browser."
+ ("autoload"))
+
+ ("tinypgp"
+ "PGP minor mode, remailing, keyring management."
+ ())
+
+ ("tinyprocmail"
+ "Procmail minor mode and coding checker. See http://www.procmail.org/"
+ ("autoload"))
+
+ ("tinyreplace"
+ "Handy query-replace, area, case preserve, words."
+ ("bind"))
+
+ ("tinyrmail"
+ "RMAIL add-ons, pgp, mime labels, Spam complaint."
+ ("autoload"))
+
+ ("tinyscroll"
+ "Enable or Disable auto-scroll for any buffer."
+ ("autoload"))
+
+ ("tinysearch"
+ "Grab and search word under cursor."
+ ("bind" "bindforce" "bindmousealt" "bindmousemeta"))
+
+ ("tinytab"
+ "Programmed TAB minor mode."
+ ("autoload" "bind" "bindforce" "bindextra" "bindextraforce"))
+
+ ("tinytag"
+ "Coding help. E.g. show Java/Perl/C++ function call syntax while coding."
+ ("autoload"))
+
+ ("tinytf"
+ "Document layout tool for '(T)echnical text (F)ormat."
+ ("autoload"))
+
+ ("tinyurl"
+ "Mark and jump to any URL on current line. Support also C, C++, Perl, Elisp."
+ ("autoload" "bind"))
+
+ ("tinyvc"
+ "CVS and RCS log minor mode. Check-out, Check-in."
+ ("autoload"))
+
+ ("tinyxreg"
+ "Restore points and window configurations stored in register via X-popup."
+ ("bind")))
+ "Packages and options. This variable is not user configurable.
+Format is:
+ '((PACKAGE ((OPTION-STR ..) ..))).")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;
+;; USER SPACE: CONFIGURE SETUP FOR ALL FILES
+;;
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tiny-setup (&optional type option-list)
+ "Tiny Tools setup controller. See Message buffer for results.
+
+Please make sure you have run the makefile.pl with build option
+\"all\" or \"autoload\". You can verify this by finding files which
+contain word \"loaddefs\".
+
+Autoload statements are always defined when this function is called,
+so even if you do not define any options to be installed, they will be
+available in callable functions that trigger loading packages. This
+means, that you an call e.g function \\[tinytab-mode] and the call
+will trigger loading package tinytab.el
+
+Please notice, that this central setup function configures only the
+essential packages, even with TYPE and FEATURE-LIST. The listing
+\\[tiny-setup-display] lists many packages that are not loaded
+or set up in any default way because a) package's scope is very narrow
+and it may not interest the majority b) there is no sensible autoload
+and it requires manual settings: tinyload.el and tinypath.el are
+good example of this. c) package is a library and it has been
+taken cared of by other means.
+
+Remember that all functions are autoloaded and accessible, although
+packages marked <no options> may not have default configurations. Here is
+sample listing that you may expect from \\[tiny-setup-display] which
+displays then content of `tiny-setup-:option-table' when no tiny-setup
+configure options are not defined and you should load the package as
+instructed in the file itself:
+
+ ..
+ tinychist <no options defined to install>
+ ...
+ Command history save/restore utility.
+ tinyload <no options defined to install>
+ Load set of packages when Emacs is idle (lazy load).
+ tinylock <no options defined to install>
+ Simple emacs locking utility.
+ ...
+ tinynbr <no options defined to install>
+ Number conversion minor mode oct/bin/hex.
+ ...
+ tinypath <no options defined to install>
+ Manage Emacs startup dynamically.
+
+Here is one way to install packages: a) configure paths automatically b)
+load default setup and enable some extra features c) define
+delayed loading for some packages that you use most of the time.
+
+ (load \"/ABSOLUTE-PATH/tinypath.el\")
+
+ ;; Define \"ready to use packages\"
+
+ (require 'tiny-setup)
+
+ (tinypath-setup
+ 'all ;; Activate default features safely
+ ;; plus features that you want
+ '(tinyeat--bind
+ tinydesk--bindforce
+ tinymy--defadvice ;; Make M-x compile smarter
+ tinydiff--bind
+ tinydired--autoload
+ tinyef--bindextra
+ tinyeat--bindforce
+ tinymacro--bindforce
+ tinydesk--bindforce
+ tinypair--activate
+ tinylisp--activate ;; turn on on in all .el buffers
+ ..))
+
+ ;; Delayed loading of these packages, when Emacs goes idle.
+
+ (setq tinyload-:load-list
+ '(\"tinyadvice\" ;; NOTE: for Emacs only.
+ \"tinymy\"
+ \"tinymail\"
+ \"tinygnus\"
+ \"tinyigrep\"
+ ..))
+
+ (require 'tinyload)
+
+Here is yet another example. The `tiny-setup' function can configure only
+the very basic features. You can manually set default values before
+packages are loaded (look into each file for interesting things).
+
+ ;; First, configure few packages MANUALLY
+
+ (require 'tinylibm)
+
+ (ti::add-hooks 'tinytf-:mode-define-keys-hook
+ '(tinytf-mode-define-keys tinytf-mode-define-f-keys))
+
+ (setq tinymy-:define-key-force t)
+ (setq tinyef-:mode-key \"\\C-cmr\")
+
+ (setq tinylock-:auto-lock-interval1 45) ;in minutes
+
+ (setq tinyef-:mode-key-table
+ '((?\[ . step-delete-back) ;KEY -- action symbol
+ (?\] . step-delete-fwd)
+ (?\* . chunk-delete)
+ (?\; . move-back)
+ (?\' . move-fwd)
+ (?\~ . e-tilde)
+ (?\/ . e-slash)
+ (?\$ . e-dollar)))
+
+ ;; After that, let the central configure tool do the rest
+
+ (require 'tiny-setup)
+
+ (tiny-setup
+ 'all
+ '(tinymy--bind-bindemacs
+ tinytab--bindforce-bindextra
+ tinyreplace--bindemacs
+ tinyeat--bindforce))
+
+The major TYPE of installation can be one of the following:
+
+ 'autoload
+
+ Setup packages so that they are loaded when the options are needed,
+ but do not define any key-bindings that already exist. This will
+ bind free keys to trigger loading packages.
+
+ 'all
+
+ Configure with all options on. This will affect free key-bindings.
+
+ nil
+
+ Autoload files (functions are ready for calling), but
+ no defaults are configured unless OPTION-LIST is set.
+
+Alternatively, you can select from OPTION-LIST what packages and what
+options inside it will be installed. See list of packages and their
+options with command \\[tiny-setup-display]
+
+ The syntax for each package is the same and the symbol passed is
+ composed from keywords:
+
+ <package>-- Name of package affected, like `tinyeat--'.
+
+ activate Activate feature in all related buffers.
+ Like turning on `tinylisp-mode' in all Emacs lisp
+ buffers or `tinyperl-mode' in all perl files.
+
+ bind Bind default keys. This will arrange package
+ to an autoload state. When a certain key is pressed,
+ package is loaded.
+
+ bindforce Overwrite any existing Emacs binding. This is like
+ bind, but without a safe check.
+
+ bindemacs Bind keys that are known to be occupied in Emacs.
+
+ load Load package. If you're tempted to use this,
+ consider investing to more efficient method described
+ in tinyload.el. Packages that have complex setup or
+ which can't be autoloaded easily are categorized as
+ \"load\".
+
+ autoload Configure package so that it will get loaded if function
+ related to a package is needed.
+
+ For example, to enable options in tinyadvice.el and tinyurl.el, you could
+ send option list below. Notice that multiple options for a package
+ are separated by single dashes.
+
+ (require 'tiny-setup)
+ (tinypath-setup 'all '(tinyadvice--load tinyurl--autoload-bind ...))
+ | | |
+ | | Option 2.
+ | Option 1.
+ Package."
+ (interactive)
+ (when (and (interactive-p)
+ (eq type nil)
+ (eq option-list nil))
+ (setq type 'all))
+ (tiny-setup-autoload-read)
+ (cond
+ ((eq type 'all)
+ (tiny-setup-all nil))
+ ((eq type 'autoload)
+ (tiny-setup-all 'autoload-bind)))
+ (when option-list
+ (tiny-setup-option-process option-list))
+ (message "TinySetup: Done.%s"
+ (if (ti::xemacs-p)
+ " See buffer \" *Message-Log*\""
+ " See buffer *Messages*")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tiny-setup-option-process (option-list)
+ "Process OPTION-LIST described in `tiny-setup'.
+OPTION-LIST items items are in form:
+
+ PACKAGE--OPTION-OPTION-OPTION-..
+
+Like
+
+ '(tinymy--bind-bindextra)
+ | |
+ | option 2
+ option 1
+
+See also `tiny-setup-:option-table'."
+ (dolist (elt option-list)
+ (let* ((name (symbol-name elt))
+ (package (if (string-match "\\(^[^ \t-]+\\)--" name)
+ (match-string 1 name))))
+ (if package
+ (tiny-setup-package package elt)
+ (message "TinySetup: Invalid setup option format %s" name)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tiny-setup-all (&optional type)
+ "Setup all tools with TYPE."
+ (dolist (elt tiny-setup-:option-table)
+ (tiny-setup-package (car elt) type)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tiny-setup-display (&optional no-descriptions)
+ "List all packages and available setup options.
+With Argument, like, \\[universal-argument], list NO-DESCRIPTIONS."
+ (interactive "P")
+ (let* ((buffer (get-buffer-create "*tiny-setup*")))
+ (with-current-buffer buffer
+ (erase-buffer)
+ (insert "package Supported install options\n"
+ "----------- "
+ (make-string 30 ?-)
+ "\n")
+ (dolist (elt tiny-setup-:option-table)
+ (insert (format "%-20s %s\n%-20s %s\n"
+ (car elt)
+ (if (null (tiny-setup-nth-options elt))
+ "<no options defined to install>"
+ (mapconcat
+ 'identity
+ (sort (tiny-setup-nth-options elt) 'string<)
+ " "))
+ ""
+ (tiny-setup-nth-description elt))))
+ (insert "
+The options can be installed by adding code like this to .emacs:
+
+ (require 'tiny-setup)
+ (tinypath-setup nil '(tinyadvice--load tinyurl--autoload-bind ...))
+")
+ (goto-char (point-min))
+ (display-buffer (current-buffer)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tiny-setup-error-macro 'lisp-indent-function 0)
+(put 'tiny-setup-error-macro 'edebug-form-spec '(body))
+(defmacro tiny-setup-error-macro (&rest body)
+ "Show error."
+ (` (progn
+ (pop-to-buffer (get-buffer-create "*TinySetup Error*"))
+ (,@ body))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tiny-setup-dolist-buffer-list 'lisp-indent-function 0)
+(put 'tiny-setup-dolist-buffer-list 'edebug-form-spec '(body))
+(defmacro tiny-setup-dolist-buffer-list (&rest body)
+ "Run BODY in each buffer."
+ (`
+ (dolist (buffer (buffer-list))
+ (with-current-buffer buffer
+ (,@ body)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tiny-setup-autoload-read ()
+ "Read all autoloads. Makefile must have been run for this to work.
+Syntax in Tiny Tools kit bin/ directory: perl makefile.pl autoload."
+ (condition-case err
+ (progn
+ ;; It's better to use `load' and not `require' because user may run
+ ;; makefile again.
+ (load "tiny-autoload-loaddefs-tiny")
+ (load "tiny-autoload-loaddefs-other"))
+ (error
+ (let* ((str
+ (format
+ (concat
+ "\
+TinySetup: Error in reading autoload loaddefs. %s
+
+Symptoms: load-path:
+
+ Please check that your `load-path' contains directories
+ tiny/lisp/tiny and tiny/lisp/other.
+
+ To check your load path, run \\[tinypath-load-path-display]
+ or run this lisp code:
+
+ (insert (prin1-to-string load-path))
+ |
+ Put cursor here and press
+ C-u C-x C-e
+
+Symptoms: autoload files:
+
+ Check that the tiny-autoload*el files are present in these directories.
+ If there is no autoload files, create them by running makefile:
+
+ cd bin/
+ perl makefile.pl --verbose 2 autoload.
+
+Symptoms: compiled files
+
+ There may be problem with compiled tiny-autoload*.elc files.
+ Please remove all *.elc files and try again.")
+ (prin1-to-string err))))
+ ;; Write to *Message* buffer
+ (message str)
+ (tiny-setup-error-macro
+ (insert str
+ "
+
+Symptoms for tinypath.el usage:
+
+ If you use tinypath.el, it may be possible that it didn't find the
+ default ~/elisp or ~/lisp directories. Please move all your Emacs setup
+ files under one of these directories. Alternatively set the location
+ of your private lisp with:
+
+ (require 'cl)
+
+ (setq tinypath-:load-path-root '(\"~/your-lisp-dir-location\"))
+ (pushnew \"/ABSOLUTE/INSTALLATION-PATH/HERE\"
+ load-path
+ :test 'string=)
+ (load \"tinypath\")
+
+ (require 'tiny-setup)
+ (tiny-setup 'all)
+
+ Refer to doc/txt/README.txt in tiny-tools kit and
+ \\[tinypath-version] documentation for more instructions how to let
+ tinypath.el set the `load-path' automatically."))
+ (error str)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tiny-setup-option-strings (type)
+ "Return list of options from symbol TYPE."
+ (setq type (symbol-name type))
+ (if (not (string-match "--\\(.*\\)" type))
+ type
+ (split-string (match-string 1 type) "[-]")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tiny-setup-package-require (package)
+ (message "TinySetup: %s loaded." package)
+ (unless (featurep (intern package))
+ (message "TinySetup: %s LOADED." package)
+ (require (intern package))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tiny-setup-package-option-p (package opt option-list)
+ "Check if PACKAGE and OPT is part of user requested OPTION-LIST."
+ (let (ret)
+ (dolist (elt option-list)
+ (when (string= elt opt)
+ (setq ret t)
+ (return)))
+ (unless ret
+ (message "TinySetup: [%s] No option [] found for `%s'"
+ package
+ (if (eq 1 (length option-list))
+ (car option-list)
+ (prin1-to-string option-list))))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tiny-setup-package (package &optional type)
+ "Activate PACKAGE with TYPE.
+If TYPE is nil, activate all options that do not contain word
+`force' or `load'."
+ (let* ((req-options (and type
+ (tiny-setup-option-strings type)))
+ (list (tiny-setup-package-options package)))
+ (cond
+ ((null list)
+ (message "TinySetup: %-15s No options to configure."
+ package))
+ (t
+ (unless req-options ;; nil, activate almost all
+ (dolist (option list)
+ (unless (string-match "^load\\|force" option)
+ (push option req-options))))
+ (let* (function
+ sym)
+ (dolist (option req-options)
+ (cond
+ ((not (member option list))
+ (message "TinySetup: Unknown option %s. Choose from %s"
+ option
+ (prin1-to-string list)))
+ (t
+ (setq function (format "tiny-setup-%s-%s" package option))
+ (setq sym (intern-soft function))
+ (cond
+ ((and (null sym)
+ (string= option "load"))
+ (tiny-setup-package-require package))
+ ((null sym)
+ (message "TinySetup: ERROR Unknown function %s"
+ function))
+ (t
+ (setq function sym)
+ (message "TinySetup: %-15s configured with `%s'" package option)
+ (funcall function)))))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tiny-setup-nth-options (elt)
+ "Return option list from ELT."
+ (nth 2 elt))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tiny-setup-nth-description (elt)
+ "Return option list from ELT."
+ (nth 1 elt))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tiny-setup-package-options (package)
+ "Return list of options for PACKAGE."
+ (let ((elt (assoc package tiny-setup-:option-table)))
+ (when elt
+ (tiny-setup-nth-options elt))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tiny-setup-define-key-1
+ (key keymap function &optional prefix str force)
+ "Define KEY to KEYMAP using FUNCTION if not yet occupied.
+
+Input:
+
+ KEY Key definitions
+ KEYMAP The map.
+ FUNCTION function to bind
+ PREFIX Message prefix. Like \"Package:\" who requested change.
+ STR Human readable key definition. Shown to user.
+ FORCE Override key definition without a check."
+ (setq str (if (stringp str)
+ (format "\"%s\"" str)
+ ""))
+ (let ((def (lookup-key keymap key)))
+ (cond
+ (force
+ (message "%sKey %-10s%s set to `%s' (FORCED, was `%s')."
+ (or prefix "")
+ (prin1-to-string key)
+ str
+ (symbol-name function)
+ def)
+ (define-key keymap key function))
+ (t
+ (cond
+ ((or (eq def function)
+ (memq def '(nil ignore))
+ ;; Lookup key returns NBR if the sequence of keys exceed
+ ;; the last keymap prefix
+ ;; C-cck --> C-cc is undefined, so there is no C-c c map yet
+ (integerp def))
+ (message "%sKey %-10s%s set to `%s'."
+ (or prefix "")
+ (prin1-to-string key)
+ str
+ (symbol-name function))
+ (define-key keymap key function))
+ (t
+ (message
+ "%sKey %-10s%s already has a definition `%s'. Not set to `%s'"
+ (or prefix "")
+ (prin1-to-string key)
+ str
+ (prin1-to-string def)
+ (symbol-name function))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tiny-setup-define-key (key keymap function &optional str force)
+ "Define KEY to KEYMAP using FUNCTION. Display STR and FORCE binding."
+ (tiny-setup-define-key-1
+ key keymap function "TinySetup: " str force))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tiny-setup-alist-search (alist regexp)
+ "Search ALIST for REGEXP."
+ (dolist (elt alist)
+ (if (string-match regexp (car elt))
+ (return elt))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tiny-setup-aput (sym regexp key value &optional force)
+ "Search SYM's for REGEXP and set KEY to VALUE if not found.
+This function effectively compares each key in SYM to REGEXP and
+if there is no matches, it adds new (KEY . VALUE) pair.
+
+Useful, if something needs to be added to the `auto-mode-alist', but
+previous definitions must be preserved."
+ (let* ((found (tiny-setup-alist-search (symbol-value sym) regexp)))
+ (cond
+ ((and found
+ (eq (cdr found) value))
+ (message "TinySetup: `%s' now contains (%s . %s)"
+ (symbol-name sym)
+ key
+ value))
+ (found
+ (message "TinySetup: `%s' already contains %s. Not set to (%s . %s)"
+ (symbol-name sym)
+ (prin1-to-string found)
+ key
+ value))
+ (t
+ (message "TinySetup: `%s' now contains (%s . %s)"
+ (symbol-name sym)
+ key
+ value))
+ (push (cons key value) (symbol-value sym)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tiny-setup-defalias (symbol definition)
+ "Like `defalias' but with verbose messages."
+ (message "TinySetup: defalias `%s' => `%s'"
+ (symbol-name symbol)
+ (symbol-name definition))
+ (defalias symbol definition))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;
+;; TIMING UTILITIES
+;; These are admistrative utilies for package maintainer(s)
+;;
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tiny-setup-time-difference (a b)
+ "Calculate difference between times A and B.
+The input must be in form of '(current-time)'
+The returned value is difference in seconds.
+E.g. if you want to calculate days; you'd do
+\(/ (ti::date-time-difference a b) 86400) ;; 60sec * 60min * 24h"
+ (multiple-value-bind (s0 s1 s2) a
+ (setq a (+ (* (float (ash 1 16)) s0)
+ (float s1) (* 0.0000001 s2))))
+ (multiple-value-bind (s0 s1 s2) b
+ (setq b (+ (* (float (ash 1 16)) s0)
+ (float s1) (* 0.0000001 s2))))
+ (- a b))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defvar tiny-setup-:time nil)
+(put 'tiny-setup-time-this 'lisp-indent-function 0)
+(put 'tiny-setup-time-this 'edebug-form-spec '(body))
+(defmacro tiny-setup-time-this (&rest body)
+ "Run BODY with and time execution. Time is in `my-:tmp-time-diff'."
+ (`
+ (let* ((tmp-time-A (current-time))
+ tmp-time-B)
+ (,@ body)
+ (setq tmp-time-B (current-time))
+ (setq tiny-setup-:time
+ (tiny-setup-time-difference tmp-time-B tmp-time-A)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tiny-setup-time-load-file (file)
+ "Time lisp FILE loading."
+ (interactive "fload file and time it: ")
+ (tiny-setup-time-this
+ (load file))
+ (message "Tiny: Timing %-15s took %12f secs" file tiny-setup-:time))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tiny-setup-test-load-time-libraries ()
+ "Time package load times."
+ (interactive)
+ (message "\n\n** Tiny setup: timing test start\n")
+ (message "load-path: %s"
+ (prin1-to-string load-path))
+ (let* ((path (locate-library "tinylib.el"))
+ (time-a (current-time))
+ time-b)
+ (if (not path)
+ (message "Tiny: [timing] Can't find tinylib.el along `load-path'")
+ (setq path (file-name-directory path))
+ (dolist (pkg (directory-files path 'full "^tinylib.*el"))
+ (tiny-setup-time-load-file pkg))
+ (setq time-b (current-time))
+ (message "Tiny: total time is %s seconds"
+ (tiny-setup-time-difference time-b time-a))
+ (display-buffer "*Messages*"))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tiny-setup-test-load-all ()
+ "Load each package to check against errors."
+ (interactive)
+ (message "\n\n** Tiny setup: load test start\n")
+ (let* ((path (locate-library "tinylib.el")))
+ (if (not path)
+ (message "Tiny: [load test] Can't find tinylib.el along `load-path'")
+ (setq path (file-name-directory path))
+ (dolist (pkg (directory-files path 'full "^tiny.*el"))
+ (load pkg))
+ (display-buffer "*Messages*"))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;
+;; AUTOLOAD UTILITIES
+;; These are admistrative utilies for package maintainer(s)
+;;
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tiny-setup-directory-last (dir)
+ "Return last directory name in DIR. /dir1/dir2/ -> dir2."
+ (if (string-match "[/\\]\\([^/\\]+\\)[/\\]?$" dir)
+ (match-string 1 dir)
+ ""))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tiny-setup-directory-to-file-name (dir template)
+ "Make file name from NAME and TEMPLATE. <template>-<last-dir>.el."
+ (concat
+ (file-name-as-directory dir)
+ template
+ (tiny-setup-directory-last dir)
+ ".el"))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-tmp-autoload-file-footer (file &optional end)
+ "Return 'provide and optional END of the file marker."
+ (concat
+ (format
+ "\n(provide '%s)\n\n"
+ (file-name-sans-extension (file-name-nondirectory file)))
+ (if end
+ (format ";; End of file %s\n"
+ (file-name-nondirectory (file-name-nondirectory file)))
+ "")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tiny-setup-directories (list)
+ "Return only directories from LIST."
+ (let* (ret)
+ (dolist (elt list)
+ (when (and (file-directory-p elt)
+ ;; Drop . ..
+ (not (string-match
+ "[/\\]\\.+$\\|CVS\\|RCS"
+ elt)))
+ (push elt ret)))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;; (tiny-setup-autoload-build-functions "~/elisp/tiny/lisp/tiny")
+;;; (tiny-setup-autoload-build-functions "~/elisp/tiny/lisp/other")
+;;;
+(defun tiny-setup-autoload-build-functions (dir &optional regexp)
+ "Build all autoloads in DIR-LIST, except for files matching REGEXP.
+Store the autoloads to tiny-DIR-autoload.el"
+ (let* (make-backup-files ;; Do not make backups
+ (backup-enable-predicate 'ignore) ;; Really, no backups
+ (files (directory-files
+ dir
+ 'full
+ "\\.el$"))
+ ;; There is no mistake in name here: it is "tiny-autoload-DIRNAME".
+ ;; the other autoload generater will generate
+ ;; "tiny-autoload-loaddefs-DIRNAME"
+ (to-file (tiny-setup-directory-to-file-name dir "tiny-autoload-"))
+ (name (file-name-nondirectory to-file)))
+ (when files
+ (with-temp-buffer
+ (insert
+ (format ";;; %s -- " name)
+ "Autoload definitions of program files in Tiny Tools Kit\n"
+ ";; Generate date: " (format-time-string "%Y-%m-%d" (current-time))
+ "\n\
+;; This file is automatically generated. Do not Change.
+;; Read README.txt in the Tiny Tools doc/ directory for instructions."
+ "\n\n")
+ (dolist (file files)
+ (if (and (stringp regexp)
+ (string-match regexp file))
+ (message "Tiny: Ignoring autoload creation for %s" file)
+ (ti::package-autoload-create-on-file
+ file (current-buffer) 'no-show)))
+ (insert (tinypath-tmp-autoload-file-footer to-file 'eof))
+ (let ((backup-inhibited t))
+ (write-region (point-min) (point-max) to-file))
+ to-file))
+ (message "TinySetup: Updated ALL autoloads in dir %s" dir)))
+
+;;; ----------------------------------------------------------------------
+;;; This is autoload generator will generate ALL, that means ALL,
+;;; autoloads from EVERY function and macro.
+;;; The implementation is in tinylib.el
+;;;
+;;; (tiny-setup-autoload-build-functions-all "~/elisp/tiny/lisp/")
+;;;
+(defun tiny-setup-autoload-build-functions-all (dir)
+ "Build all autoloads recursively below DIR."
+ (interactive "Dautoload build root dir: ")
+ (let* ((dirs (tiny-setup-directories
+ (directory-files
+ (expand-file-name dir)
+ 'abs)))
+ (regexp "tinylib\\|autoload"))
+ (cond
+ (dirs
+ (tiny-setup-autoload-build-functions dir regexp)
+ (dolist (dir dirs)
+ (tiny-setup-autoload-build-functions-all dir)))
+ (t
+ (tiny-setup-autoload-build-functions dir regexp)))))
+
+;;; ----------------------------------------------------------------------
+;;; (tiny-setup-autoload-build-loaddefs-tiny-tools "~/elisp/tiny/lisp/" t)
+;;; (tiny-setup-autoload-build-loaddefs-tiny-tools "~/elisp/tiny/lisp/other" t)
+;;;
+(defun tiny-setup-autoload-build-loaddefs-tiny-tools (dir &optional force)
+ "Build Tiny Tools autoloads below DIR. FORCE recreates everything."
+ (interactive "DAutoload root: \nP")
+ (ti::package-autoload-loaddefs-build-recursive
+ dir
+ "autoload\\|loaddefs" ;; Exclude these files
+ force
+ (function
+ (lambda (dir)
+ (tiny-setup-directory-to-file-name
+ (or dir
+ (error "TinySetup: No DIR"))
+ "tiny-autoload-loaddefs-")))))
+
+;;; ----------------------------------------------------------------------
+;;; This is autoload generator will generate ONLY functions marked
+;;; with special ### autoload tag. The implementation used is in
+;;; core Emacs package autoload.el
+;;;
+;;; (tiny-setup-autoload-batch-update "~/elisp/tiny/lisp/" 'force)
+;;;
+;;; This function is invoked from the perl makefile.pl with the
+;;; ROOT directory as sole argument in Emacs command line.
+;;;
+;;; The build command from prompt is
+;;;
+;;; $ perl makefile.pl --verbose 2 --binary emacs autoload
+;;;
+(defun tiny-setup-autoload-batch-update (&optional dir force)
+ "Update autoloads in batch mode. Argument in command line is DIR. FORCE."
+ (interactive "DAutoload dir to update: ")
+ (unless dir
+ (setq dir (pop command-line-args-left))
+ (setq force t))
+ (if dir ;Require slash
+ (setq dir (file-name-as-directory dir)))
+ (unless dir
+ (message "Tiny: From what directory to make recursively autoloads?")
+ ;; Self generate error for command line ...
+ (error 'tiny-setup-autoload-batch-update))
+ (message "TinySetup: Generating all autoloads under %s" dir)
+ (let* ((default-directory (expand-file-name dir)))
+ (message "Tiny: tiny-setup-autoload-batch-update %s" default-directory)
+ (when (not (string-match "^[/~]\\|^[a-zA-Z]:[/\\]"
+ default-directory))
+ (message "Tiny: Autoload directory must be absolute path name.")
+ (error 'tiny-setup-autoload-batch-update))
+ (tiny-setup-autoload-build-loaddefs-tiny-tools
+ default-directory force)))
+ ;; This would generate second set of autoloads. Don't do that any more,
+ ;; rely on Emacs autoload.el instead.
+ ;; (tiny-setup-autoload-build-functions-all default-directory)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;
+;; PACKAGE BYTE COMPILATION
+;; These are admistrative utilies for package maintainer(s)
+;;
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tiny-setup-file-list-lisp (dir)
+ "Return all lisp files under DIR."
+ (directory-files dir 'full "\\.el$"))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tiny-setup-file-list-lisp-compiled (dir)
+ "Return all compiled lisp files under DIR."
+ (directory-files dir 'full "\\.elc$"))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tiny-setup-directory-recursive-macro 'lisp-indent-function 1)
+(put 'tiny-setup-directory-recursive-macro 'edebug-form-spec '(body))
+(defmacro tiny-setup-directory-recursive-macro (directory &rest body)
+ "Start from DIRECTORY and run BODY recursively in each directories.
+
+Following variables are set during BODY:
+
+`dir' Directrory name
+`dir-list' All directories under `dir'."
+ (`
+ (flet ((recurse
+ (dir)
+ (let* ((dir-list (tiny-setup-directory-list dir)))
+ (,@ body)
+ (when dir-list
+ (dolist (elt dir-list)
+ (recurse elt))))))
+ (recurse (, directory)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tiny-setup-directory-list (dir)
+ "Return all directories under DIR."
+ (let (list)
+ (dolist (elt (directory-files dir 'full))
+ (when (and (file-directory-p elt)
+ (not (string-match "[\\/]\\.\\.?$" elt)))
+ (push elt list)))
+ list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tiny-setup-compile-directory (dir &optional function)
+ "Compile all isp files in DIRECTORY.
+Optional FUNCTION is passed one argument FILE, and it should return
+t or nil if file is to be compiled."
+ (dolist (file (tiny-setup-file-list-lisp dir))
+ (when (or (null function)
+ (funcall function file))
+ (byte-compile-file file))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tiny-setup-compile-directory-recursive (root &optional function)
+ "Compile all files under ROOT directory.
+Optional FUNCTION is passed one argument FILE, and it should return
+t or nil if file is to be compiled."
+ (tiny-setup-directory-recursive-macro root
+ (message "TinySetup: compiling directory %s" dir)
+ (tiny-setup-compile-directory
+ dir function)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tiny-setup-compile-directory-delete-recursive (root)
+ "Delete all compiled files under ROOT directory recursively."
+ (tiny-setup-directory-recursive-macro root
+ (dolist (file (tiny-setup-file-list-lisp-compiled dir))
+ (message "TinySetup: deleting compiled file %s" file)
+ (delete-file file))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tiny-setup-compile-kit-libraries (dir)
+ "Compile tiny tools libraries"
+ (tiny-setup-directory-recursive-macro dir
+ (let ((libs (directory-files dir 'abs-path "tinylib.*\\.el$")))
+ (when libs ;; Found correct directory
+ (message "TinySetup: compiling libraries in right order.")
+ (let ((default-directory dir)
+ compile-file)
+ ;; There is certain order of compilation. Low level libraries first.
+ (dolist (regexp tiny-setup-:library-compile-order)
+ (when (setq compile-file ;; compile these first
+ (find-if (function
+ (lambda (elt)
+ (string-match regexp elt)))
+ libs))
+ (setq libs (delete compile-file libs))
+ (byte-compile-file compile-file)))
+ (message "TinySetup: compiling rest of the libraries.")
+ (dolist (file libs) ;; Rest of the libraries
+ (cond
+ ((find-if (function
+ (lambda (regexp)
+ (string-match regexp file)))
+ tiny-setup-:library-compile-exclude)
+ (message "TinySetup: ignoring library %s" file))
+ (t
+ (byte-compile-file file)))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tiny-setup-compile-kit-all (&optional dir)
+ "Compile tiny tools kit under DIR.
+This function can be called from shell command line, where the
+last argument is the DIR from where to start compiling.
+
+Notice that there is `.' at the end of call to `tiny-setup-compile-kit-all':
+
+$ cd root-dir
+$ find . -name \"*elc\" -exec rm {} \\;
+$ emacs -batch -l load-path.el -l tiny-setup.el -f tiny-setup-compile-kit-all .
+
+If only the libraries need compilation, use this command:
+
+$ emacs -batch -l load-path.el -l tiny-setup.el -f -eval '(tiny-setup-compile-kit-libraries \".\")
+
+If only one file needs to be compiled:
+
+$ emacs -batch -l load-path.el -l tiny-setup.el -f -eval batch-byte-compile <file>"
+ (interactive "D[compile] installation root dir: ")
+ (unless dir
+ (setq dir (car-safe command-line-args-left)))
+ (if dir ;Require slash
+ (setq dir (file-name-as-directory dir))
+ (error "Compile under which DIR? Give parameter"))
+ (message "tinySetup: byte compiling root %s" dir)
+ ;; Remove compiled files first
+ (tiny-setup-compile-directory-delete-recursive dir)
+ ;; Libraries first
+ (tiny-setup-compile-kit-libraries dir)
+ ;; The rest follows, it doesn't matter if libs are are compiled twice.
+ (tiny-setup-compile-directory-recursive
+ dir
+ (function
+ (lambda (x)
+ (not (string-match "tinylib" x))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;
+;; USER SPACE: KIT AND PACKAGE CONFIGURATION
+;;
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun tiny-setup-folding-autoload-find-file-hook ()
+ "Install folding if file includes {{{ and }}}.
+Do nothing if folding is already installed."
+ (if (or (fboundp 'folding-install)
+ (featurep 'folding))
+ ;; Remove ourself from the `find-file-hooks'.
+ (remove-hook 'find-file-hooks
+ 'tiny-setup-folding-autoload-find-file-hook)
+ (let* ((start (concat "\\("
+ (regexp-quote (or comment-start "dummy"))
+ "\\)+"))
+ (regexp (concat "^" start "{{{ \\|^" start "}}}")))
+ (when (ti::re-search-check regexp)
+ (folding-install-hooks)
+ (turn-on-folding-mode)))))
+
+(defun tiny-setup-folding-autoload ()
+ "Autoload."
+ (defvar folding-mode nil)
+ (tiny-setup-ti::macrov-mode-line-mode-menu
+ folding-mode "Outline (Folding)")
+ (add-hook 'find-file-hooks
+ 'tiny-setup-folding-autoload-find-file-hook))
+
+(defun tiny-setup-dired-sort-autoload ()
+ "Autoload."
+ (add-hook 'dired-mode-hook 'dired-sort-default-keys 'end))
+
+(defun tiny-setup-tinyadvice-load ()
+ "Load for Emacs only."
+ (if (ti::emacs-p)
+ (require 'tinyadvice)
+ (message "TinySetup: tinyadvice.el is not for XEmacs. Didn't load.")))
+
+(defun tiny-setup-tinyappend-bind (&optional force)
+ "Bind."
+ ;; non-shift key
+ (tiny-setup-define-key "\C-c+" global-map 'tinyappend-end
+ "C-c+" force)
+ ;; non-shift key
+ (tiny-setup-define-key "\C-c_" global-map 'tinyappend-beg
+ "C-c_" force)
+ (tiny-setup-define-key "\C-c-" global-map 'tinyappend-kill
+ "C-c-" force)
+ (tiny-setup-define-key "\C-c|" global-map 'tinyappend-yank
+ "C-c|" force))
+
+(defun tiny-setup-tinyappend-bindforce ()
+ "Bind."
+ (tiny-setup-tinyappend-bind 'force))
+
+(defun tiny-setup-tinybookmark-defalias ()
+ "Defalias."
+ ;; (tiny-setup-defalias 'tinybookmark-insert 'bm)
+ nil)
+
+(defun tiny-setup-tinybookmark-bind ()
+ "Bind."
+ (if (ti::emacs-p)
+ (tiny-setup-define-key [(?\e) (control mouse-1)]
+ global-map 'tinybookmark-mouse)
+ (tiny-setup-define-key [(control meta button1)]
+ global-map 'tinybookmark-mouse))
+
+ ;; (tiny-setup-define-key [(?\e) (control shift mouse-1)]
+ ;; global-map 'tinybookmark-mouse-parse)
+
+ (tiny-setup-define-key [(shift left)]
+ global-map 'tinybookmark-backward)
+ (tiny-setup-define-key [(shift right)]
+ global-map 'tinybookmark-forward))
+
+(defun tiny-setup-tinycache-activate ()
+ "Autoload activate package."
+ (add-hook 'compilation-mode-hook
+ '(lambda () (require 'tinycache)))
+ (when (ti::emacs-p)
+ (add-hook 'dired-mode-hook
+ '(lambda () (require 'tinycache))))
+ (eval-after-load "compile"
+ '(progn (require 'tinycache)))
+ (eval-after-load "dired"
+ '(progn (require 'tinycache))))
+
+(defun tiny-setup-tinybuffer-bind (&optional force)
+ "Bind."
+ (tiny-setup-define-key [(control <)]
+ global-map 'tinybuffer-previous-buffer
+ nil force)
+ (tiny-setup-define-key [(control >)]
+ global-map 'tinybuffer-next-buffer
+ nil force)
+ (tiny-setup-define-key [(control meta <)]
+ global-map 'tinybuffer-iswitch-to-buffer
+ nil force)
+ (tiny-setup-define-key [(control meta >)]
+ global-map 'tinybuffer-sort-mode-toggle
+ nil force))
+
+(defun tiny-setup-tinybuffer-bindforce ()
+ "Bind."
+ (tiny-setup-tinybuffer-bind 'force))
+
+(defun tiny-setup-tinycomment-autoload ()
+ "Autoload."
+ (autoload 'tinycomment-indent-for-comment "tinycomment" "" t))
+
+(defun tiny-setup-tinycomment-bind (&optional force)
+ "Bind."
+ (tiny-setup-define-key
+ [(meta ?\;)]
+ global-map
+ 'tinycomment-indent-for-comment "M-;"
+ (or force
+ ;; Override default. In Emacs 21.2 this is more intelligent
+ ;; function comment-dwim
+ (eq (lookup-key global-map [(meta ?\;)])
+ 'indent-for-comment))))
+
+(defun tiny-setup-tinycompile-autoload ()
+ "Autoload."
+ (add-hook 'compilation-mode-hook 'turn-on-tinycompile-mode 'append)
+ (dolist (buffer (buffer-list))
+ (with-current-buffer buffer
+ (when (memq major-mode '(compilation-mode))
+ (turn-on-tinycompile-mode)))))
+
+(defun tiny-setup-tinydesk-bind (&optional force)
+ "Bind with optional FORCE."
+ (message "TinySetup: [tinydesk] binding keys in `ctl-x-4-map'")
+ (tiny-setup-define-key
+ "S" ctl-x-4-map
+ 'tinydesk-save-state nil force) ;; free in 19.28
+ (tiny-setup-define-key
+ "R" ctl-x-4-map
+ 'tinydesk-recover-state nil force) ;; Free in 21.2
+ (tiny-setup-define-key
+ "E" ctl-x-4-map
+ 'tinydesk-edit-state-file nil force) ;; free in 19.28
+ (tiny-setup-define-key
+ "U" ctl-x-4-map
+ 'tinydesk-unload nil force)) ;; free in 19.28
+
+(defun tiny-setup-tinydesk-bindforce ()
+ "Bind."
+ (tiny-setup-tinydesk-bind 'force))
+
+(defun tiny-setup-tinydesk-activate ()
+ "Activate.")
+
+(defun tiny-setup-tinydiff-autoload ()
+ "Autoload."
+ (tiny-setup-aput 'auto-mode-alist
+ "diff" "\\.diff\\'" 'turn-on-tinydiff-mode)
+ (tiny-setup-aput 'auto-mode-alist
+ "patch" "\\.patch\\'" 'turn-on-tinydiff-mode))
+
+(defun tiny-setup-tinydiff-bind (&optional force)
+ "Bind keys."
+ (tiny-setup-define-key
+ "\C-cD"
+ global-map 'tinydiff-diff-show "C-cD" force)
+ (tiny-setup-define-key
+ "\C-cP"
+ global-map 'tinydiff-patch "C-cP" force))
+
+(defun tiny-setup-tinydiff-bindforce ()
+ "Bind keys."
+ (tiny-setup-tinydiff-bind 'force))
+
+(defun tiny-setup-tinydebian-autoload ()
+ "Autoload."
+ (autoload 'tinydebian-bug-report-mail "tinydebian" "" t))
+
+(defun tiny-setup-tinydebian-load ()
+ "Load."
+ (require 'tinydebian)
+ (tinydebian-install))
+
+(defun tiny-setup-tinydired-autoload ()
+ "Autoload. This is for Emacs only.
+You may want to set
+
+ (setq tinydired-:force-add-keys 'override)."
+ (if (ti::xemacs-p)
+ (message "\
+TinySetup: tinydired.el works only with Emacs. Package not loaded.")
+ (add-hook 'tinydired-:load-hook 'tinydired-hook-control)
+ (add-hook 'dired-mode-hook '(lambda () (require 'tinydired) nil))
+ ;; If dired is already loaded, install immediately
+ (dolist (buffer (buffer-list))
+ (with-current-buffer buffer
+ (when (memq major-mode '(dired-mode))
+ (require 'tinydired)
+ (return))))))
+
+(defun tiny-setup-tinyeat-bind (&optional force)
+ "Bind."
+
+ (message "\
+TinySetup: [NOTE] The automatic setup will not make much much good,
+ because no default Emacs keys are redefined. tinyeat.el
+ package delete keys are installed only if you call function
+ `tinyeat-install-default-bindings' directly.")
+
+ ;; These are REAL difficult choices, because almost every keyboard
+ ;; interprets backspace differently.
+
+ (tiny-setup-define-key [(control backspace)]
+ global-map 'tinyeat-forward-preserve
+ nil force)
+ (tiny-setup-define-key [(control delete)]
+ global-map 'tinyeat-forward-preserve
+ nil force)
+
+ (tiny-setup-define-key [(control shift delete)]
+ global-map 'tinyeat-delete-paragraph
+ nil force)
+
+ (tiny-setup-define-key [(control shift backspace)]
+ global-map 'tinyeat-delete-paragraph
+ nil force)
+
+ (tiny-setup-define-key [(shift backspace)]
+ global-map 'tinyeat-delete-whole-word
+ nil force)
+
+ (tiny-setup-define-key [(meta delete)]
+ global-map 'tinyeat-erase-buffer
+ nil force)
+
+ (tiny-setup-define-key [(alt control k)]
+ global-map 'tinyeat-zap-line
+ nil force)
+
+ (unless (ti::compat-window-system)
+ (tiny-setup-define-key
+ [(control meta ?h)]
+ global-map 'tinyeat-erase-buffer nil force))
+
+ (when (fboundp 'read-kbd-macro)
+ (tiny-setup-define-key
+ (read-kbd-macro "ESC DEL")
+ global-map 'tinyeat-erase-buffer "ESC DEL" force)))
+
+(defun tiny-setup-tinyeat-bindforce ()
+ "Bind with override."
+ (tiny-setup-tinyeat-bind 'force))
+
+(defun tiny-setup-tinyef-bindextra ()
+ "Bind extra keys."
+ (if (not (fboundp 'tinyef-minibuffer-define-key-extras))
+ (add-hook 'tinyef-load-hook 'tinyef-minibuffer-define-key-extras)
+ (tinyef-minibuffer-define-key-extras)))
+
+(defun tiny-setup-tinyef-autoload ()
+ "Autoload."
+ (add-hook 'minibuffer-setup-hook 'turn-on-tinyef-mode))
+
+(defun tiny-setup-tinygnus-autoload ()
+ "Autoload."
+ (defvar tinygnus-group-mode nil)
+ (tiny-setup-ti::macrov-mode-line-mode-menu
+ tinygnus-group-mode "Gnus Group mode extras")
+ (defvar tinygnus-summary-mode nil)
+ (tiny-setup-ti::macrov-mode-line-mode-menu
+ tinygnus-summary-mode "Gnus Summary mode extras")
+ (add-hook 'gnus-startup-hook '(lambda () (require 'tinygnus)))
+ (when (featurep 'gnus)
+ ;; Gnus already present
+ (require 'tinygnus)))
+
+(defun tiny-setup-tinyhotlist-autoload ()
+ "Autoload."
+ (add-hook 'tinyhotlist-:load-hook 'tinyhotlist-load-hotlist))
+
+(defun tiny-setup-tinyhotlist-bindmouse (&optional force)
+ "Bind."
+ (if (not (ti::compat-window-system))
+ (message
+ (concat
+ "TinySetup: tinyhotlist.el Mouse binding skipped."
+ "No window system available."))
+ (if (ti::emacs-p)
+ (tiny-setup-define-key
+ [(control shift mouse-3)]
+ global-map
+ 'tinyhotlist-control
+ force)
+ (tiny-setup-define-key
+ [(control shift button3)]
+ global-map
+ 'tinyhotlist-control
+ force))))
+
+(defun tiny-setup-tinyhotlist-bindmouseforce ()
+ "Bind."
+ (tiny-setup-tinyhotlist-bindmouse 'force))
+
+(defun tiny-setup-tinyhotlist-bind (&optional force)
+ "Bind."
+ (tiny-setup-define-key
+ (read-kbd-macro "\C-cH")
+ global-map 'tinyhotlist-control "C-cH" force))
+
+(defun tiny-setup-tinyhotlist-bindforce ()
+ "Bind."
+ (tiny-setup-tinyhotlist-bind))
+
+(defun tiny-setup-tinyigrep-autoload ()
+ "Autoload."
+ (if (featurep 'igrep)
+ (require 'tinyigrep)
+ (eval-after-load "igrep" '(progn (require 'tinyigrep)))))
+
+(defun tiny-setup-tinyigrep-bind (&optional force)
+ "Bind."
+ (tiny-setup-define-key
+ (read-kbd-macro "\C-cG")
+ global-map 'tinyigrep-menu "C-cG" force))
+
+(defun tiny-setup-tinyigrep-bindforce ()
+ "Bind."
+ (tiny-setup-tinyigrep-bind 'force))
+
+(defun tiny-setup-tinyliby-defalias ()
+ "Defalias."
+ ;; Shorter name.
+ (tiny-setup-defalias 'describe-symbols 'ti::system-describe-symbols))
+
+(defun tiny-setup-tinylibt-bind ()
+ "Bind."
+ ;;#todo:
+ ;; (tiny-setup-define-key "\C-ztm" global-map 'ti::text-mark-region) ;; e.g. permanent 'mark'
+ ;; (tiny-setup-define-key "\C-ztu" global-map 'ti::text-unmark-region) ;; remove 'mark'
+ ;; (tiny-setup-define-key "\C-ztc" global-map 'ti::text-clear-buffer-properties)
+ ;; (tiny-setup-define-key "\C-ztb" global-map 'ti::text-buffer)
+ ;; (tiny-setup-define-key "\C-ztU" global-map 'ti::text-undo)
+ nil)
+
+(defun tiny-setup-tinylisp-autoload ()
+ "Autoload."
+ (defvar tinylisp-mode nil)
+ (tiny-setup-ti::macrov-mode-line-mode-menu
+ tinylisp-mode "Emacs Lisp extras")
+ (add-hook 'lisp-mode-hook 'turn-on-tinylisp-mode)
+ (add-hook 'emacs-lisp-mode-hook 'turn-on-tinylisp-mode)
+ (add-hook 'lisp-interaction-mode-hook 'turn-on-tinylisp-mode))
+
+(defun tiny-setup-tinylisp-activate ()
+ "Activate on every lisp buffer."
+ (tiny-setup-tinylisp-autoload) ;; Make sure this is called
+ ;; If this is vanilla emacs which only has one lisp buffer, *scratch*
+ ;; then do not load tinylisp.el. install only hooks.
+ ;;
+ ;; But if there are already any lisp buffers around (count), then
+ ;; be sure to treat also *scratch*.
+ ;;
+ (let ((count 0))
+ (tiny-setup-dolist-buffer-list
+ (when (and (not (string-match "*scratch*" (buffer-name)))
+ (or (string-match "\\.el$" (buffer-name))
+ (memq major-mode '(emacs-lisp-mode
+ lisp-interaction-mode))))
+ (message "TinySetup: activating tinylisp-mode in %s" (buffer-name))
+ (incf count)
+ (turn-on-tinylisp-mode)))
+ (when (> count 0)
+ (with-current-buffer "*scratch*"
+ (turn-on-tinylisp-mode)))))
+
+(defun tiny-setup-tinylpr-bind ()
+ "Bind."
+ ;;#todo:
+ ;; (ti::use-prefix-key "\C-z") ;; Free C-z for us.
+ ;; (tiny-setup-define-key "\C-zp" (ti::definteractive (ti::menu-menu global-map 'tinylpr-:menu)))
+ nil)
+
+(defun tiny-setup-tinymacro-bind (&optional force)
+ "Bind."
+ ;; (tiny-setup-define-key "\C-x(" global-map 'start-kbd-macro)
+
+ ;; We must overwrite this any any case, othewise the packages
+ ;; is not much use. Use 'force unconditionally.
+
+ (tiny-setup-define-key
+ "\C-x)"
+ global-map 'tinymacro-end-kbd-macro-and-assign
+ "C-x)" 'force))
+
+(defun tiny-setup-tinymacro-bindforce ()
+ "Bind."
+ (tiny-setup-tinymacro-bind 'force))
+
+(defun tiny-setup-tinymail-autoload ()
+ "Autoload."
+ (add-hook 'mail-setup-hook 'turn-on-tinymail-mode)
+ (add-hook 'message-mode-hook 'turn-on-tinymail-mode)
+ (add-hook 'tinymail-:mode-hook 'turn-on-tinytab-mode))
+
+(defun tiny-setup-tinymailbox-find-file-hook (&optional disable)
+ "Activate `tinymailbox-mode' on mailbox files."
+ (if (memq 'turn-on-tinymailbox-mode-maybe
+ find-file-hooks)
+ ;; Package has been installed. It handles `find-file-hook'
+ ;; detection better, so remove us.
+ (setq disable t)
+ (when (ti::mail-mailbox-p)
+ (turn-on-tinymailbox-mode-maybe)))
+ (if disable
+ (remove-hook
+ 'find-file-hooks
+ 'tiny-setup-tinymailbox-find-file-hook)))
+
+(defun tiny-setup-tinymailbox-autoload ()
+ "Autoload."
+ (add-hook 'find-file-hooks
+ 'tiny-setup-tinymailbox-find-file-hook)
+ ;; Gnus temporary mailbox files have name "Incoming"
+ (tiny-setup-aput 'auto-mode-alist
+ "Incoming" "Incoming" 'turn-on-tinymailbox-mode)
+ ;; Other mailbox files
+ (tiny-setup-aput 'auto-mode-alist
+ "mbo?x" "\\.mbo?x\\'" 'turn-on-tinymailbox-mode)
+ ;; Typical procmail spool files, like ~/Mail/spool/mail.work.spool
+ (tiny-setup-aput 'auto-mode-alist
+ "spool" "\\.spool\\'" 'turn-on-tinymailbox-mode))
+
+(defun tiny-setup-tinymy-defadvice ()
+ "Activate smart M-x compile support."
+ (tinymy-compile-run-command-advice))
+
+(defun tiny-setup-tinymy-bind ()
+ "Bind."
+ (message
+ "TinySetup: [tinymy] You should call function `tinymy-define-keys'."))
+
+(defun tiny-setup-tinymy-bindforce ()
+ "Bind extra keys that replace Emacs keys."
+
+ (tiny-setup-define-key
+ "\C-xq" global-map 'tinymy-buffer-file-chmod nil 'force)
+
+ (tiny-setup-define-key
+ [(prior)] global-map 'tinymy-scroll-up nil 'force)
+
+ (tiny-setup-define-key
+ [(next)] global-map 'tinymy-scroll-down nil 'force)
+
+ (tiny-setup-define-key
+ [(next)] global-map 'tinymy-scroll-down nil 'force)
+
+ (tiny-setup-define-key
+ [(control right)] global-map 'tinymy-word-forward nil 'force)
+
+ (tiny-setup-define-key
+ [(control left)] global-map 'tinymy-word-backward nil 'force)
+
+ (when (and (boundp 'window-system)
+ (symbol-value 'window-system))
+ (tiny-setup-define-key
+ [(meta f)] global-map 'tinymy-word-forward nil 'force)
+ (tiny-setup-define-key
+ [(meta b)] global-map 'tinymy-word-backward nil 'force))
+
+ (when (boundp 'shared-lisp-mode-map)
+ (defvar shared-lisp-mode-map nil) ;; Byte compiler silencer
+ (tiny-setup-define-key
+ "%" shared-lisp-mode-map 'tinymy-vi-type-paren-match nil 'force))
+
+ (when (boundp 'emacs-lisp-mode-map)
+ (tiny-setup-define-key
+ "%" emacs-lisp-mode-map 'tinymy-vi-type-paren-match nil 'force))
+
+ (when (boundp 'lisp-mode-map)
+ (tiny-setup-define-key
+ "%" lisp-mode-map 'tinymy-vi-type-paren-match nil 'force)))
+
+(defun tiny-setup-tinymy-defalias ()
+ "Bind."
+ ;; Faster prompting for experts
+ (tiny-setup-defalias 'yes-or-no-p 'y-or-n-p))
+
+(defun tiny-setup-tinynbr-autoload ()
+ "Autoload."
+ (defvar tinynbr-mode nil)
+ (tiny-setup-ti::macrov-mode-line-mode-menu
+ tinynbr-mode "Number manipulation"))
+
+(defun tiny-setup-tinypad-autoload ()
+ "Autoload."
+ (defvar tinypad-mode nil)
+ (tiny-setup-ti::macrov-mode-line-mode-menu
+ tinypad-mode "Notepad emulation menu"))
+
+(defun tiny-setup-tinypage-bind ()
+ "Bind."
+ ;;#todo:
+ nil)
+
+(defun tiny-setup-turn-off-tinypair-mode ()
+ "Safeguard to function `turn-off-tinypair-mode'.
+If tinypair.el cannot be found, function `turn-off-tinypair-mode'
+cannot be called. Attempt to do so will yield serious error,
+preventing user to enter minibuffer at all.
+
+To prevent this serious error, package existence is
+verified."
+ (when (locate-library "tinypair")
+ ;; It's safe to call this. Function is already autoloaded.
+ (turn-off-tinypair-mode)))
+
+(defun tiny-setup-tinypair-autoload ()
+ "Autoload."
+ (defvar tinypair-mode nil)
+ (add-hook 'minibuffer-setup-hook 'turn-off-tinypair-mode)
+ (tiny-setup-ti::macrov-mode-line-mode-menu
+ tinypair-mode "Paired insert"))
+
+(defun tiny-setup-tinypair-activate-buffer (mode &optional uninstall)
+ "Activate or deactivate tinypair in buffers."
+ (dolist (buffer (buffer-list))
+ (with-current-buffer buffer
+ (when (eq major-mode mode)
+ (if uninstall
+ (turn-off-tinypair-mode)
+ (turn-on-tinypair-mode))
+ (message "TinySetup: tinypair-mode %s in buffer %s"
+ (if uninstall
+ "turned off"
+ "turned on")
+ (buffer-name))))))
+
+(defun tiny-setup-tinypair-activate (&optional uninstall)
+ "Install to programming modes."
+ ;; In Cperl, CC, Java the "{" key is electric, so we don't
+ ;; install into those buffers.
+ (dolist (mode '(awk-mode-hook
+ emacs-lisp-mode-hook
+ sh-mode-hook))
+ (ti::add-hooks mode 'turn-on-tinypair-mode uninstall)
+ (let ((name (symbol-name mode)))
+ (message "TinySetup: tinypair-mode %s %s"
+ (if uninstall
+ "removed from"
+ "added to")
+ name)
+ (when (and (string-match "^\\(.*-mode\\)" name)
+ (setq mode (intern-soft (match-string 1 name))))
+ ;; Activate in current Emacs
+ (tiny-setup-tinypair-activate-buffer mode uninstall)))))
+
+(defun tiny-setup-tinypage-autoload ()
+ "Autoload."
+ (defvar tinypage-mode nil)
+ (tiny-setup-ti::macrov-mode-line-mode-menu
+ tinypage-mode "Paged ^L mode"))
+
+(defun tiny-setup-tinyperl-autoload ()
+ "Autoload."
+ (defvar tinyperl-mode nil)
+ (tiny-setup-ti::macrov-mode-line-mode-menu
+ tinyperl-mode "Perl extras (pod)")
+ (add-hook 'perl-mode-hook 'turn-on-tinyperl-mode)
+ (add-hook 'cperl-mode-hook 'turn-on-tinyperl-mode)
+ (when (or (featurep 'cperl)
+ (featurep 'perl))
+ (turn-on-tinyperl-mode-all-buffers)))
+
+(defun tiny-setup-tinyprocmail-autoload ()
+ "Autoload."
+ ;; old procmail files start with rc.*
+ (defvar tinyprocmail-mode nil)
+ (tiny-setup-ti::macrov-mode-line-mode-menu
+ tinyprocmail-mode "Procmail recipe coding")
+ (tiny-setup-aput 'auto-mode-alist
+ "procmailrc"
+ "\\.rc\\'\\|^rc\\.\\|procmailrc"
+ 'turn-on-tinyprocmail-mode))
+
+(defun tiny-setup-tinyreplace-bind ()
+ "Bind. Replace M-&"
+ (tiny-setup-define-key [(meta ?&)]
+ global-map
+ 'tinyreplace-menu
+ "Meta-&"))
+
+(defun tiny-setup-tinytag-install-sample-databases ()
+ "Delayd installation of databases."
+ (unless (get 'tinytag-install-sample-databases 'done)
+ (tinytag-install-sample-databases)
+ (tiny-setup-tinytag-hook
+ '(tiny-setup-tinytag-install-sample-databases)
+ 'uninstall)))
+
+(defun tiny-setup-tinytag-hook (hook-list &optional uninstall)
+ "Activate database install."
+ (ti::add-hooks '(java-mode-hook
+ jde-mode-hook
+ c++-mode-hook)
+ hook-list
+ uninstall)
+ (ti::add-hooks '(cc-mode-hook
+ c-mode-hook)
+ hook-list
+ uninstall
+ nil
+ 'check-boundp))
+
+(defun tiny-setup-tinytag-autoload ()
+ "Autoload."
+ (tiny-setup-tinytag-hook
+ '(tinytag-install
+ tiny-setup-tinytag-install-sample-databases)))
+
+(defun tiny-setup-tinyvc-autoload ()
+ "Autoload."
+ ;; This is bit tricky autoload setup, but it is the only way.
+ ;; Otherwise you would have to say (require 'tinyvc),
+ ;; which is not nice at all
+ (defadvice vc-print-log (after tinyvc act)
+ "Run hook `tinyvc-:vc-print-log-hook'."
+ (require 'tinyvc)
+ (run-hooks 'tinyvc-:vc-print-log-hook))
+ (eval-after-load "vc" '(progn (require 'tinyvc))))
+
+(defun tiny-setup-tinyrmail-autoload ()
+ "Autoload."
+ (add-hook 'rmail-mode-hook 'tinyrmail-install)
+ (if (featurep 'rmail)
+ (tinyrmail-install)))
+
+(defun tiny-setup-tinysearch-bindforce ()
+ "Bind search keys.")
+ ;; (tinysearch-install-default-keybindings)
+
+(defun tiny-setup-tinysearch-bindmousealt ()
+ "Bind."
+ (tiny-setup-define-key [(alt control mouse-1)]
+ global-map 'tinysearch-search-word-forward)
+ (tiny-setup-define-key [(alt control shift mouse-1)]
+ global-map 'tinysearch-search-word-backward))
+
+(defun tiny-setup-tinysearch-bindmousemeta ()
+ "Bind."
+ (tiny-setup-define-key [(meta control mouse-1)]
+ global-map 'tinysearch-search-word-forward)
+ (tiny-setup-define-key [(meta control shift mouse-1)]
+ global-map 'tinysearch-search-word-backward))
+
+(defun tiny-setup-tinyscroll-autoload ()
+ "Autoload."
+ (unless (boundp 'compilation-scroll-output)
+ (add-hook 'compilation-mode-hook
+ '(lambda () (require 'tinyscroll) nil))))
+
+(defun tiny-setup-tinytab-autoload ()
+ "Autoload."
+ (defvar tinytab-mode nil)
+ (tiny-setup-ti::macrov-mode-line-mode-menu
+ tinytab-mode "Tab indent mode"))
+
+(defun tiny-setup-tinytab-bind (&optional force)
+ "Bind."
+ (tiny-setup-define-key "\C-cT"
+ global-map 'tinytab-mode "C-cT"
+ force)
+ (tiny-setup-define-key "\C-c\C-m"
+ global-map 'tinytab-return-key-mode "C-c <RET>"
+ force))
+
+(defun tiny-setup-tinytab-bindforce ()
+ "Bind."
+ (tiny-setup-tinytab-bind 'force))
+
+(defun tiny-setup-tinytab-bindextra (&optional force)
+ "Bind."
+ ;; make shift-TAB to toggle mode
+ (tiny-setup-define-key [(control shift backtab)]
+ global-map 'tinytab-mode nil force)
+ (tiny-setup-define-key [(control shift tab)]
+ global-map 'tinytab-mode nil force)
+ (tiny-setup-define-key [(control shift kp-tab)]
+ global-map 'tinytab-mode nil force))
+
+(defun tiny-setup-tinytab-bindextraforce (&optional force)
+ "Bind with FORCE."
+ (tiny-setup-tinytab-bindextra 'force))
+
+;;; .......................................................... &tinytf ...
+
+(defun tiny-setup-tinytf-buffer-type-p ()
+ "Check if bufferi suitable for tinytf.el."
+ (let (case-fold-search)
+ (and (string-match "\\.txt"
+ (or (buffer-file-name) ""))
+ (not (save-excursion
+ ;; Exclude mail buffers:
+ ;; From: me@here.com
+ (goto-char (point-min))
+ (re-search-forward "^[-a-z]+: " nil t)))
+ (or (re-search-forward
+ "^Table [Oo]f [Cc]ontents[ \t]*$" nil t)
+ ;; See if we can find level 1 and 2 headings
+ ;;
+ ;; This Heading here
+ ;;
+ ;; And This Heading here
+ ;;
+ (re-search-forward
+ "^[0-9.]*[A-Z][^ \t\n]+.*[\r\n]+ [A-Z][^ \t\n]" nil t)
+ ;; Try finding wro headers then
+ ;;
+ ;; This is Header
+ ;;
+ ;; And this is header
+ ;;
+ (and (re-search-forward
+ "^[0-9.]*[A-Z][^ \t\n][^ \t\n]+" nil t)
+ (re-search-forward
+ "^[0-9.]*[A-Z][^ \t\n][^ \t\n]+" nil t))))))
+
+(defun tiny-setup-turn-on-tinytf-mode-maybe ()
+ "Turn on mode function `tinytf-mode' as needed."
+ (let (case-fold-search)
+ (cond
+ ((memq 'turn-on-tinytf-mode-maybe find-file-hooks)
+ ;; tinytf is already loaded, remove ourself.
+ (remove-hook 'find-file-hooks 'tiny-setup-turn-on-tinytf-mode-maybe))
+ ((tiny-setup-tinytf-buffer-type-p)
+ (turn-on-tinytf-mode)
+ (remove-hook 'find-file-hooks 'tiny-setup-turn-on-tinytf-mode-maybe)))
+ ;; Hook must return nil
+ nil))
+
+(defun tiny-setup-tinytf-autoload ()
+ "Autoload."
+ (defvar tinytf-mode nil)
+ (tiny-setup-ti::macrov-mode-line-mode-menu
+ tinytf-mode "Technical text")
+ (add-hook 'find-file-hooks 'tiny-setup-turn-on-tinytf-mode-maybe))
+
+;;; ......................................................... &tinyurl ...
+
+(defun tiny-setup-tinyurl-mode-maybe ()
+ "Turn on `tinyurl-mode' as needed."
+ (if (featurep 'tinyurl)
+ ;; TinyUrl has already set up the watchdog.
+ (remove-hook 'find-file-hooks 'tiny-setup-tinyurl-mode-maybe)
+ ;; Use simplistic test here. TinyUrl has much better once it's active.
+ (if (ti::re-search-check "[fh]t?tp://[a-z]+[a-z.]+")
+ (turn-on-tinyurl-mode)))
+ ;; Hook is best to return nil
+ nil)
+
+(defun tiny-setup-tinyurl-autoload ()
+ "Autoload."
+ (defvar tinyurl-mode nil)
+ (tiny-setup-ti::macrov-mode-line-mode-menu
+ tinyurl-mode "Url mode")
+ (add-hook 'find-file-hooks 'tiny-setup-tinyurl-mode-maybe))
+
+(defun tiny-setup-tinyurl-bind ()
+ "Bind."
+ (message "TinySetup: [tinyurl] nothing to bind. Call `tinyurl-mode-1'.")
+ ;;* (tiny-setup-define-key "\C-cmuu" global-map 'tinyurl-mode)
+ ;;* (tiny-setup-define-key "\C-cmu1" global-map 'tinyurl-mode-1)
+ ;;* (tiny-setup-define-key "\C-cmup" global-map 'tinyurl-plugged-mode-toggle)
+ nil)
+
+(defun tiny-setup-tinyxreg-bind ()
+ "Bind."
+ (tiny-setup-define-key "\C-x/"
+ global-map 'tinyxreg-point-to-register "C-x/" 'force)
+ (tiny-setup-define-key "\C-x\\"
+ global-map 'tinyxreg-remove-register "C-x\\")
+ (tiny-setup-define-key "\C-cj"
+ global-map 'tinyxreg-jump-to-register "C-cj" ))
+
+(provide 'tiny-setup)
+(run-hooks 'tiny-setup-load-hook)
+
+;;; tiny-setup.el ends here
--- /dev/null
+;;; tinyadvice.el --- Collection of adviced functions
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 1996-2007 Jari Aalto
+;; Keywords: extensions
+;; Author: Jari Aalto
+;; Maintainer: Jari aalto
+;;
+;; To get information on this program, call M-x tinyadvice-version.
+;; Look at the code with folding.el.
+
+;; COPYRIGHT NOTICE
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;;; Install:
+
+;; ....................................................... &t-install ...
+;; Put this file on your Emacs-Lisp load path, add following into your
+;; ~/.emacs startup file.
+;;
+;; (require 'tinyadvice)
+;;
+;; Loading this package takes lot of time. You might gain more comfortable
+;; Emacs startup "feel" using the following autoload suggestion:
+;;
+;; (require 'tinylib)
+;; (when (ti::emacs-p) ;Do not load in XEmacs
+;; (if (fboundp 'run-with-idle-timer) ;Emacs
+;; (run-with-idle-time (* 4 60) nil '(lambda () (require 'tinyadvice)))
+;; (run-at-time "4 min" nil '(lambda () (require 'tinyadvice)))))
+;;
+;; But before you leap into this, make sure you want to do it.
+;;
+;; CHECK IF YOUR EMACS IS SUPPORTED
+;; THESE ADVICES ARE FOR Emacs, expect trouble in XEmacs.
+;;
+;; Change `tinyadvice-:re' to try advices in non-supported Emacs versions
+;;
+;; This file modifies original Emacs functions, so read the document
+;; carefully to tailor this package for you (enabling/disabling advices)
+;; The best up to date documentation can be generated from this file:
+;;
+;; M-x eval-current-buffer
+;; M-x load-library tinyliby.el
+;; M-x ti::system-get-file-documentation RET tinyadvice.el RET
+;;
+;; If you have any questions, use this function
+;;
+;; M-x tinyadvice-submit-bug-report send bug report or feedback
+;;
+
+;;}}}
+
+;;{{{ Documentation
+
+;; ..................................................... &t-commentary ...
+
+;;; Commentary:
+
+;; Preface, Apr 1996
+;;
+;; What you see here is a selection of adviced functions that have
+;; proven to be extremely useful. Some of them have been written by
+;; the author (if there is no author mentioned) and some of them have
+;; been collected form the emacs newsgroups.
+;;
+;; Here is one example how to to fontify automatically, whenever
+;; compilation buffer runs:
+;;
+;; (add-hook 'tinyadvice-:compile-internal-hook 'my-compile-font-lock)
+;;
+;; (defun my-compile-font-lock ()
+;; "Compile buffer fontifying immediately."
+;; (interactive)
+;; (let* ((buffer tinyadvice-:compile-internal-buffer))
+;; ;; According to buffer you could set up different font
+;; ;; keyword parameters, say for
+;; ;; *compilation*
+;; ;; *grep*
+;; ;; *igrep*
+;; ;; ...
+;; ;; My setup automatically turn on the lazy-lock too, see
+;; ;; font-lock-mode-hook
+;; (with-current-buffer
+;; buffer
+;; (turn-on-font-lock-mode))))
+;;
+;; Note: XEmacs
+;;
+;; These advices are for Emacs and it would be a surprise if they
+;; worked in XEmacs. Use at your own risk. Send fixed XEmacs
+;; compatible advices to maintained if you try them.
+;;
+;; These advises and Emacs releases
+;;
+;; Many of these enhancements could have shipped with the Emacs
+;; itself. And there was a time when these were suggested to be added
+;; to the next Emacs release. For some reason the developers
+;; were not interested in the features at that time.
+;;
+;; How to use this package
+;;
+;; The best way is to load this package, print the whole file and read
+;; the comments about individual functions and how they change things.
+;;
+;; Overview of features
+;;
+;; In general, advices are activated only if Emacs release doesn't have
+;; similar kind of support.
+;;
+;; o `gud' highlights full line
+;; o no dialogs in X for `y-or-n-p' styled questions. You shouldn't
+;; need to lift your hands from keyboard and grab mouse for these
+;; dialog questions.
+;; o Mouse-3 cinfirms window delete (pointing at the mode line)
+;; o `call-last-kbd-macro' ends the current macro
+;; before trying to execute it.
+;; o `debugger-eval-expression', Backtrace buffer's
+;; "e" offers current word for prompt
+;; o `dired-man' , make sure variables are initialized.
+;; o `dired-do-rename' , you can edit the old filename
+;; o `goto-line' and `imenu' now widens automatically before executing
+;; o `rename-buffer' , offers old buffer name for editing
+;; o `recover-file' , offers buffer filename by default
+;; o `switch-to-buffer-other-frame' , selects some non existing frame
+;; o `setenv' , offer completion
+;; o `write-file' , confirm overwrite
+;; o `write-region' , confirm overwrite
+;;
+;; o `C-x' `;' , `indent-for-comment' negative arg deletes comment.
+;; o `C-x' `=' , `what-cursor-position' shows the line number too
+;; o `C-x' `i' , insert buffer offers other window
+;; o `C-x' `C-c' , `save-buffers-kill-emacs' asks confirmation
+;; to prevent accidents (Emacs 21 has this)
+;; o `C-x' `b' , `swich-to-buffer' ask confirmation
+;; for non-existing buffers.
+;; o `C-x' `C-b' , list-buffers puts cursor to "*Buffer List*"
+;;
+;; o compilation: buffer auto scroll (disabled, see 'handling advices')
+;; Smart save feature (only .cc .h files, not
+;; all emacs files). Find-file is done in non dedicated frame.
+;; TAB completes filenames.
+;;
+;; o completion: case sensitive filename completion
+;;
+;; o grep: filename and directory completion with TAB key
+;;
+;; o `vc-print-log', put cursor on the buffer's revision number.
+;; Smarter `vc-mode-line' , shows "b" if version is in the middle.
+;; `vc-register' creates RCS directory if does not exist and
+;; offers checking as "original" file with existing version
+;; numbers (tracking 3rd party sources).
+;; User to set the initial comment when doing 1st CI.
+;; If `tinyadvice-:cvs-buffer-read-only' is nil, then keep.
+;; CVS files in writable mode (the default CVS behavior)
+;;
+;; Handling advices
+;;
+;; If you have some other emacs version that is not supported in
+;; the `tinyadvice-:advice-table' you can modify the regexps in
+;; the list and try if the advice works in your emacs. If it
+;; does, please drop me a mail immediately and I update the
+;; regexp. If some advice annoys you, there is simple method how
+;; you disable advice(s).
+;;
+;; (setq tinyadvice-load-hook
+;; '(tinyadvice-install my-tinyadvice-load-hook))
+;;
+;; (defun my-tinyadvice-load-hook ()
+;; "Configure 'tiny tool's advices' to my taste."
+;; (interactive)
+;; ;; This diables two advices
+;; (tinyadvice-advice 'disable
+;; '(switch-to-buffer mouse-delete-other-windows)))
+;; (require 'tinyadvice)
+;;
+;; Disabling disturbing advice by hand
+;;
+;; If some piece of advice disturbs or causes trouble in your
+;; current emacs session, you can deactivate it
+;; immediately. First you have to know the function name that
+;; generates problems. Say you used `C-x' `C-b'
+;; `switch-to-buffer' and you don't like the confirmation for
+;; non-existent buffers. You can disable this behavior by
+;; calling:
+;;
+;; C-u M-x tinyadvice-advice
+;;
+;; and giving the function name `switch-to-buffer' to it. To
+;; permanently turn it off in your emacs sessions, see previous
+;; lisp code.
+;;
+;; Code note
+;;
+;; You see this in the code:
+;;
+;; (when (tinyadvice-activate-p)
+;; (defadvice ..
+;;
+;; If emacs version is wrong, the advice is _never_ actually
+;; assembled. You can't activate or deactivate this function
+;; with `tinyadvice-advice'.
+;;
+;; Many thanks to, in no particular order:
+;;
+;; Vladimir Alexiev <vladimir@cs.ualberta.ca>
+;; Kevin Rodgers <kevinr@ihs.com>
+;; Ilya Zakharevich <ilya@math.ohio-state.edu>
+;; Peter Breton <pbreton@i-kinetics.com>
+;; T. V. Raman <raman@adobe.com>
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+;;{{{ setup: require
+
+;;; ......................................................... &require ...
+
+(require 'advice)
+(require 'tinylibm)
+
+(eval-and-compile
+ (defvar vc-parent-buffer) ;Emacs vc.el
+ (defvar grep-command)
+ (defvar grep-default)
+ (defvar grep-history)
+ (autoload 'grep-compute-defaults "compile")
+ (when (ti::xemacs-p)
+ (message "\
+** TinyAdvice: You must configure this package manually to XEmacs
+ In general, do not use this packaage on XEmacs.")
+ (load "overlay" 'noerr))) ;19.15+
+
+;;}}}
+;;{{{ setup: public
+
+;;; ......................................................... &v-hooks ...
+
+(defvar tinyadvice-load-hook '(tinyadvice-install)
+ "Hook that is run when package is loaded.")
+
+;;; ........................................................ &v-public ...
+
+(defvar tinyadvice-:cvs-buffer-read-only t
+ "*nil makes CVS buffers writable. Value t preserves vc.el's decision.
+Many times vc.el sets read-only status to CVS buffers when there is no need.
+In default case, CVS itself does not mark files read-only, unlike RCS.
+But if you do \"cvs watch on\" on a tree then when you do \"cvs co tree\" it
+will check files out read-only. You have to do \"cvs edit\" to make them
+writable.
+
+Setting this variable to nil, will override vc.el and
+keep CVS buffers always writable. The t value preserves what vc.el does.")
+
+(defvar tinyadvice-:compile-internal-hook nil
+ "*Hook run after `compile-internal' funtion.
+You can peek variable `tinyadvice-:compile-internal-buffer' too.")
+
+(defvar tinyadvice-:compile-save-re
+ "\\(\\.hh?\\|\\.cc?\\|\\.C?\\|\\.java\\)$"
+ "*Regexp. Case sensitive. Which buffers to save when compiling.")
+
+(defvar tinyadvice-:gud-overlay
+ (when (and (ti::emacs-p)
+ (not (fboundp 'make-extent)))
+ (let* ((ov (make-overlay (point-min) (point-min))))
+ (overlay-put ov 'face 'highlight)
+ ov))
+ "*Gud. Current line overlay.")
+
+(defvar tinyadvice-:find-alternate-file-flag t
+ "*Non-nil means : `buffer-name' in \\[find-file] if no `buffer-file-name'.")
+
+;; Ignore tmp/ dir files
+;; like ~/T ~/TT ~/T1 ~/T2 ~/T.test ~/T1.xx ...
+
+(defconst tinyadvice-:write-file-no-confirm
+ "^/tmp\\|/[Tt][Tt0-9]?\\.?\\|/[Tt]$"
+ "*Do not verify overwriting these files. See advice `write-file'.")
+
+(defvar tinyadvice-:switch-to-buffer-find-file t
+ "*Suggest `find-file' for non-existing buffers in `switch-to-buffer'.")
+
+(defvar tinyadvice-:vc-main-rcs-dir "~/RCS"
+ "Main RCS repository. See advice of function `vc-register'.")
+
+;;; ........................................................ &v-advice ...
+
+(defvar tinyadvice-:re "19\\.2[7-9]\\|19\\.3[0-5]\\|2[01]\\."
+ "General regexp for advices that work in variety of (X)Emacs versions.")
+
+;; - Change the REGEXP is you know the advice works in your emacs ver.
+;; Drop me mail if you change any of these, so that I can update list
+;;
+;; - Functions that have ".", almost always get advice, see the code.
+;; In those rows the regexp value is almost always ignored.
+;;
+;; - If it says ";; always on", then the regexp has no effect,
+;; you have to disable feature by hand, if you don't want it.
+
+(defconst tinyadvice-:advice-table ;alphabetically ordered
+ (list
+ (list 'after-find-file ".") ;;always on
+ (list 'ange-ftp-dired-run-shell-command ".") ;;always on
+
+ (list 'call-last-kbd-macro
+ ".")
+ (list 'compile ".")
+ (list 'compile-internal "2[7-9]") ;;fixed 19.30+
+ (list 'compilation-find-file ".")
+ (list 'shell ".")
+
+ (list 'debugger-eval-expression ".")
+
+ (list 'dired-do-rename ".")
+ (list 'dired-man ".") ;;always
+ (list 'display-time-process-this-message "19" 'xe)
+
+ (list 'exchange-point-and-mark ".")
+ (list 'find-file ".")
+
+ (list 'grep ".")
+ (list 'igrep-read-expression ".")
+ (list 'igrep-read-options ".")
+
+ (list 'find-alternate-file ".")
+ (list 'find-file-literally ".")
+ (list 'find-tag ".")
+ (list 'fill-paragraph "19\.2[0-8]")
+
+ (list 'getenv ".") ;;always on
+ (list 'goto-line ".")
+ (list 'grep ".")
+ (list 'gud-display-line ".") ;;always
+
+ (list 'hkey-help-show ".") ;;hyberbole
+
+ (list 'imenu ".") ;; always
+ (list 'indent-for-comment ".")
+ (list 'insert-buffer tinyadvice-:re)
+ (list 'Info-build-node-completions "19\\.\\|20\\.")
+ (list 'list-buffers ".")
+ (list 'line-move ".")
+
+ (list 'map-y-or-n-p tinyadvice-:re)
+ (list 'mouse-delete-other-windows tinyadvice-:re)
+ (list 'mouse-delete-window tinyadvice-:re)
+ (list 'mouse-wheel-scroll-screen tinyadvice-:re)
+
+ (list 'occur ".")
+ (list 'PC-complete ".") ;;always on
+
+ (list 'recompile ".")
+ (list 'recover-file ".")
+ (list 'rename-buffer tinyadvice-:re)
+
+ (list 'save-buffers-kill-emacs (if (boundp 'confirm-kill-emacs)
+ ;; Do not install in Eamcs 21.x
+ nil
+ "19\\."))
+ (list 'save-some-buffers ".")
+ (list 'sendmail-pre-abbrev-expand-hook tinyadvice-:re)
+ (list 'setenv ".") ;;always on
+ (list 'set-mark-command ".") ;;always on
+ (list 'switch-to-buffer tinyadvice-:re)
+ (list 'switch-to-buffer-other-frame ".")
+
+ (list 'vc-do-command tinyadvice-:re)
+ (list 'vc-mode-line tinyadvice-:re)
+ (list 'vc-print-log "2[89]\\|3[01]") ;;fixed in 19.32
+ (list 'vc-register "19\\.\\|20\\.") ;;fixed in 21.x
+
+ (list 'what-cursor-position tinyadvice-:re)
+ (list 'write-file ".")
+ (list 'write-region ".")
+
+ (list 'y-or-n-p tinyadvice-:re))
+ "*Flag table of enabled advices.
+It is consulted if particular advice can be used in current emacs. Format is
+
+ ((FUNCTION ALLOW-ADVICE-REGEXP [FLAG])
+ (FUNCTION ALLOW-ADVICE-REGEXP)
+ ..)
+
+The FLAG is optional and values can be:
+
+ nil or missing: Only works in Emacs
+ 'xe only works in Xemacs
+ t works both Emacs and XEmacs")
+
+;;}}}
+;;{{{ setup: private
+
+;;; ....................................................... &v-private ...
+
+(defconst tinyadvice-:advice-re "^tinyadvice"
+ "Prefix name used in advices for TinyAdvice package.")
+
+(defconst tinyadvice-:tmp-buffer "*tinyadvice*"
+ "Temporary working buffer.")
+
+(defvar tinyadvice-:compile-internal-buffer nil
+ "The compilation buffer created by `compile-internal'.")
+
+(defvar tinyadvice-:vc-p nil
+ "Variable indicating if file in `vc-do-command' is version controlled.")
+
+;;}}}
+;;{{{ version
+
+;;; ....................................................... &v-version ...
+
+;;;###autoload (autoload 'tinyadvice-version "tinyadvice" "Display commentary." t)
+(eval-and-compile
+ (ti::macrof-version-bug-report
+ "tinyadvice.el"
+ "tinyadvice"
+ tinyadvice-:version-id
+ "$Id: tinyadvice.el,v 2.71 2007/05/07 10:50:07 jaalto Exp $"
+ '(tinyadvice-version-id
+ tinyadvice-:compile-save-re
+ tinyadvice-:write-file-no-confirm
+ tinyadvice-:re)))
+
+;;}}}
+
+;;; ########################################################### &Funcs ###
+
+;;{{{ tinyadvice: misc
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro tinyadvice-elts (elt func re type)
+ "Decode ELT to variables FUNC RE TYPE."
+ (`
+ (setq (, func) (nth 0 (, elt))
+ (, re) (nth 1 (, elt))
+ (, type) (if (eq 3 (length (, elt)))
+ (nth 0 (, elt))
+ nil))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyadvice-match (re &optional type)
+ "Check if RE match emacs version according to TYPE.
+TYPE :
+ nil = Emacs
+ t = XEmacs and Emacs
+ 'xe = XEmacs"
+ (let* ((ver (emacs-version))
+ ret)
+ (when (stringp re)
+ (cond
+ ((and (eq type 'xe)
+ (ti::xemacs-p)
+ (string-match re ver))
+ (setq ret 1))
+ ((and (eq type nil)
+ (ti::emacs-p)
+ (string-match re ver))
+ (setq ret 2))
+ ((and (eq type t)
+ (string-match re ver))
+ (setq ret 3)))
+ ret)))
+
+;;; ----------------------------------------------------------------------
+;;; Testing... (tinyadvice-activate-p 'compile-internal)
+;;;
+(defun tinyadvice-activate-p (func-sym)
+ "Determine if we can advice FUNC-SYM."
+ (let* ((elt (assoc func-sym tinyadvice-:advice-table))
+ func
+ re
+ type)
+ (when elt
+ (tinyadvice-elts elt func re type)
+ ;; XEmacs 19.14 ByteComp, Shut up "bound but not referenced"
+ ;; the `func' is set above.
+ (if func
+ (setq func 'ignore))
+ (tinyadvice-match re type))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyadvice-ad-function-list (&optional string-format)
+ "Return list of tinyadvice ad-functions for current emacs.
+Notice: all functions may not be adviced; this merely
+return entries in the table. See source file's \"Code note\"
+
+If STRING-FORMAT is non nil, then return string list.
+
+Return:
+
+ '(func func ..)
+ '(\"func\" \"func\" ..)"
+ (let* (func
+ re
+ type
+ list)
+ (dolist (member tinyadvice-:advice-table)
+ (tinyadvice-elts member func re type)
+ (when (tinyadvice-match re type)
+ (if string-format
+ (push (symbol-name func) list)
+ (push func list))))
+ list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyadvice-install ()
+ "Activates advices that are listed in `tinyadvice-:advice-table'."
+ (interactive)
+ (tinyadvice-advice nil (tinyadvice-ad-function-list)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;; This is slow, but returns only tinyadvice adviced functions...
+;;;
+;;; (ad-do-advised-functions (func)
+;;; (if (ad-find-some-advice func 'any tinyadvice-:advice-re)
+;;; (push func list)))
+;;;
+;;;
+(defun tinyadvice-advice (&optional disable func-or-list)
+ "Activate or optionally DISABLE tinyadvice advice for FUNC-OR-LIST."
+ (interactive
+ (list
+ current-prefix-arg
+
+ (let* (var)
+ (setq var (completing-read
+ (concat
+ (if current-prefix-arg "un" "")
+ "advice function: ")
+ (ti::list-to-assoc-menu (tinyadvice-ad-function-list 'strings))
+ nil t))
+ (intern-soft var))))
+ ;; This is in fact cheating a little; we check against full advice list,
+ ;; not just "tinyadvice" owned functions.
+ (when (and (symbolp func-or-list)
+ (not (member (list (symbol-name func-or-list))
+ ad-advised-functions )))
+ ;; This makes the call to 'ti::' after this if, unefective
+ (setq func-or-list nil)
+ (if (interactive-p)
+ ;; more accurate: "No advice found..." but since we deal with
+ ;; tinyadvice ones only the following is better.
+ (message "\
+TinyAdvice: Sorry, the function is not advice controlled by TinyAdvice.")))
+ (ti::advice-control
+ func-or-list tinyadvice-:advice-re disable (interactive-p)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyadvice-advice-control (&optional disable verb)
+ "Acivate all TinyAdvice advices. Use extra argument to DISABLE all. VERB."
+ (interactive "P")
+ (or verb
+ (setq verb (interactive-p)))
+ (let* (
+ (re tinyadvice-:advice-re)
+ (doit t)
+ msg)
+ (if verb ;; This is rough! Be sure...
+ (setq
+ doit
+ (y-or-n-p (format
+ "Advices will be turned %s. Are you sure? "
+ (if disable "OFF" "ON")))))
+ (when doit
+ (cond
+ (disable
+ (ad-disable-regexp re) ;only sets flag
+ (setq msg "Tinyadvice: All advices deactivated"))
+ (t
+ (ad-enable-regexp re) ;only sets flag
+ (setq msg "Tinyadvice: All TinyAdvice advices activated")))
+ (ad-update-regexp re)
+ (if verb
+ (message msg)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyadvice-convert-filename (file &optional cautious)
+ "Return normal or compressed filename.
+
+Input:
+
+ FILE full filename
+ CAUTIOUS if non-nil then when in doubt do not change the filename.
+ (e.g. in clash situation, where there is bot un/compressed file)
+
+Return:
+
+ string possibly modified."
+ (interactive)
+ (unless (string-match "\\.Z$\\|\\.gz$" file)
+ (when (and (file-exists-p file)
+ (or (file-exists-p (concat file ".gz"))
+ (file-exists-p (concat file ".Z"))))
+ (message "TinyAdvice: clash, both un/compressed file found. %s " file)
+ (sleep-for 1)
+ (if (and
+ (null cautious) ;only if no cautious mode
+ (setq
+ file
+ (or (ti::file-newer-exist file (concat file ".gz"))
+ (ti::file-newer-exist file (concat file ".Z")))))
+ ;; We must load this package too to enable compress support.
+ (require 'jka-compr))))
+ file)
+
+;;}}}
+
+;;{{{ ange-ftp
+
+;;; ----------------------------------------------------------------------
+;;; log into the remote host as a different user (including root).
+;;;
+(defadvice ange-ftp-dired-run-shell-command (before tinyadvice-rsh-cmd dis)
+ "Launch rsh -l if needed."
+ (setq ange-ftp-remote-shell-file-name
+ (format "rsh -l %s" (nth 1 (ange-ftp-ftp-path default-directory)))))
+
+;;}}}
+;;{{{ built-ins
+
+;;; ........................................................ &built-in ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(when (tinyadvice-activate-p 'rename-buffer)
+ (defadvice rename-buffer (around tinyadvice dis)
+ "Gives old buffer name for editing."
+ (interactive
+ (list
+ (read-from-minibuffer
+ "Rename buffer (to new name): "
+ (buffer-name))))
+ ad-do-it))
+
+;;}}}
+;;{{{ compile
+
+;;; ......................................................... &compile ...
+
+;;; ----------------------------------------------------------------------
+;;; (ad-disable-advice 'compilation-find-file 'before 'tinyadvice)
+;;; (ad-activate 'compilation-find-file)
+;;;
+(defadvice compilation-find-file (before tinyadvice act)
+ "Move to some non dedicated frame."
+ (ti::select-frame-non-dedicated))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defadvice shell (around tinyadvice dis)
+ "If there is *shell* buffer, ask user to give new name for new shell.
+If new buffer name is given, a new shell is created. pressing RET
+doe snot create new buffer, but jumps to existing *shell* buffer."
+ (let* (name
+ prev-name)
+ (when (and
+ (interactive-p)
+ (comint-check-proc "*shell*")
+ (setq
+ name
+ (read-string
+ "Create new shell by typing a buffer name for it [RET = cancel]? "))
+ (not (ti::nil-p name)))
+ (with-current-buffer "*shell*"
+ (rename-uniquely)
+ (setq prev-name (buffer-name))))
+ ad-do-it
+ (when (and (stringp name)
+ (not (string= name "")))
+ (with-current-buffer "*shell*"
+ (rename-buffer name))
+ (with-current-buffer prev-name
+ (rename-buffer "*shell*")))))
+
+;;; ----------------------------------------------------------------------
+;;; See variable `compilation-last-buffer'
+;;; - This has been reported to be corrected in 19.30
+;;;
+(when (and (not (boundp 'compilation-scroll-output))
+ (tinyadvice-activate-p 'compile-internal))
+
+ (defadvice compile-internal (after tinyadvice-scroll dis comp)
+ "Force compile buffer to scroll."
+ (let* ((ob (current-buffer))
+ (obw (get-buffer-window ob t))
+ win)
+ (save-excursion
+ (unless (or (null (setq win (get-buffer-window ad-return-value t)))
+ (null obw))
+ (select-window win)
+ (goto-char (point-max))
+ (select-window obw))))))
+
+;;; ----------------------------------------------------------------------
+;;; "tap" -- listen secretly :-)
+;;;
+(defadvice compile-internal (around tinyadvice-tap-buffer dis comp)
+ "Save compile buffer name to 'tinyadvice-:compile-internal-buffer'.
+See `tinyadvice-:compile-internal-hook'."
+ (prog1
+ ad-do-it
+ (setq tinyadvice-:compile-internal-buffer ad-return-value)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defadvice compile-internal (after tinyadvice-run-hook last act comp)
+ "Run hook 'tinyadvice-:compile-internal-hook'.
+E.g. you can add lazy-lock.el fontifying to that hook."
+ (run-hooks 'tinyadvice-:compile-internal-hook))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyadvice-compile-save-buffers ()
+ "Check what buffers for current compilation target should be saved."
+ (interactive)
+ (let* ((case-fold-search nil) ;case sensitive
+ (re-file tinyadvice-:compile-save-re))
+
+ ;; Save only interesting buffers, don't care about others.
+ (ti::dolist-buffer-list
+ (string-match re-file (buffer-name))
+ nil
+ nil
+ (and (buffer-modified-p)
+ (y-or-n-p (format "Buffer %s modified. Save it? "
+ (buffer-name)))
+ (save-buffer)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defadvice igrep-read-expression (around tinyadvice dis)
+ "Replace function: TAB key completes file names."
+ (setq
+ ad-return-value
+ (let ((default-expression (igrep-default-arg igrep-expression-default)))
+ (if (string= default-expression "")
+ (setq default-expression nil))
+ (ti::file-complete-filename-minibuffer-macro
+ (read-from-minibuffer (igrep-prefix prompt-prefix "Expression: ")
+ default-expression map nil
+ 'igrep-expression-history)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defadvice igrep-read-options (around tinyadvice act)
+ "Replace function: TAB key completes file names."
+ (setq
+ ad-return-value
+ (if (or igrep-read-options
+ (and (consp current-prefix-arg)
+ (memq (prefix-numeric-value current-prefix-arg)
+ '(4 64))))
+ (let ((prompt "Options: "))
+ (ti::file-complete-filename-minibuffer-macro
+ (read-from-minibuffer
+ (igrep-prefix prompt-prefix prompt)
+ (or igrep-options "-")
+ map)))
+ igrep-options)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyadvice-grep-default (arg)
+ "Set default value. This function use dynamically bound variables.
+See `grep' advice."
+ (unless grep-command
+ (grep-compute-defaults))
+ ;; `arg' is bound during M-x grep
+ (when arg
+ (let* ((tag-default
+ (funcall (or find-tag-default-function
+ (get major-mode 'find-tag-default-function)
+ ;; We use grep-tag-default instead of
+ ;; find-tag-default, to avoid loading etags.
+ 'grep-tag-default))))
+ (setq grep-default (or (car grep-history) grep-command))
+ ;; Replace the thing matching for with that around cursor
+ (when (string-match "[^ ]+\\s +\\(-[^ ]+\\s +\\)*\\(\"[^\"]+\"\\|[^ ]+\\)\\(\\s-+\\S-+\\)?" grep-default)
+ (unless (or (match-beginning 3) (not (stringp buffer-file-name)))
+ (setq grep-default (concat grep-default "*."
+ (file-name-extension buffer-file-name))))
+ (setq grep-default (replace-match (or tag-default "")
+ t t grep-default 2))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defadvice grep (around tinyadvice act)
+ "Modify interactive spec: TAB key completes file names."
+ (interactive
+ (let (grep-default (arg current-prefix-arg))
+ (tinyadvice-grep-default arg)
+ (list (ti::file-complete-filename-minibuffer-macro
+ (read-from-minibuffer "Run grep (like this): "
+ (or grep-default
+ grep-command)
+ map nil 'grep-history)))))
+ ad-do-it)
+
+;;; ----------------------------------------------------------------------
+;;; - More smarter buffer saving.
+;;;
+(defadvice compile (around tinyadvice dis)
+ "Replace original function. More smarter buffer saving.
+See function `tinyadvice-compile-save-buffers'.
+In addition, TAB key completes file names."
+ (interactive
+ (if compilation-read-command
+ (list (ti::file-complete-filename-minibuffer-macro
+ (read-from-minibuffer "Compile command: "
+ compile-command map nil
+ '(compile-history . 1))))
+ (list compile-command)))
+ (setq compile-command command)
+
+ (if (null compilation-ask-about-save)
+ (save-some-buffers (not compilation-ask-about-save) nil)
+ (tinyadvice-compile-save-buffers))
+
+ (compile-internal compile-command "No more errors"))
+
+;;; ----------------------------------------------------------------------
+;;; Run compile with the default command line
+;;;
+(defadvice recompile (around tinyadvice dis)
+ "Replace original function.
+More smarter buffer saving, seefunction `tinyadvice-compile-save-buffers'."
+ (interactive)
+ (if (null compilation-ask-about-save)
+ (save-some-buffers (not compilation-ask-about-save) nil)
+ (tinyadvice-compile-save-buffers))
+ (compile-internal compile-command "No more errors"))
+
+;;}}}
+;;{{{ completion and macros
+
+;;; ...................................................... &completion ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defadvice call-last-kbd-macro (before tinyadvice dis)
+ "If still defining a macro, end it before attempting to call-last.
+ This prevents whacking the current definition."
+ (if defining-kbd-macro
+ (end-kbd-macro)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defadvice PC-complete (around tinyadvice dis)
+ "In file name prompt, use case sensitive completion.
+Set `completion-ignore-case' locally to nil."
+ (let* ((completion-ignore-case completion-ignore-case)
+ word)
+ (setq word (or (save-excursion (ti::buffer-read-space-word)) ""))
+
+ (if (string-match "^[/~]" word)
+ (setq completion-ignore-case nil))
+ ad-do-it))
+
+;;}}}
+
+;;{{{ debugger
+
+;;; -------------------------------------------------------- &debugger ---
+;;;
+(defadvice debugger-eval-expression (around tinyadvice dis)
+ "Chnage interactive so that it offer word from buffer."
+ (interactive
+ (list
+ (read-from-minibuffer
+ "(tinyadvice) Eval: "
+ (or (ti::buffer-read-space-word) "")
+ read-expression-map t
+ 'read-expression-history)))
+ ad-do-it)
+
+;;}}}
+;;{{{ dired
+
+;;; ........................................................... &dired ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defadvice dired-mark-read-file-name (around tinyadvice dis)
+ "Instead of asking directory, offer full filename for editing."
+ (if (and dir (string-match "/" dir))
+ (setq dir (dired-get-filename)))
+ ad-do-it)
+
+;;; ----------------------------------------------------------------------
+;;;
+(defadvice dired-do-rename (around tinyadvice act)
+ "Offer editing the current filename.
+Without this advice you don't get the old filename for editing.
+Activates advice 'dired-mark-read-file-name during call."
+ (let* ((ADVICE 'dired-mark-read-file-name))
+ (ad-enable-advice ADVICE 'around 'tinyadvice)
+ (ad-activate ADVICE)
+ ad-do-it
+ (ad-disable-advice ADVICE 'around 'tinyadvice)
+ (ad-activate ADVICE)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defadvice dired-man (before tinyadvice dis)
+ "Make sure man variables are initialized."
+ (require 'man)
+ (Man-init-defvars))
+
+;;}}}
+
+;;{{{ env
+
+;;; ............................................................. &env ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyadvice-read-envvar (prompt &optional require-match)
+ "Read an environment variable name from the minibuffer.
+Prompt with PROMPT and complete from `process-environment'.
+If optional arg REQUIRE-MATCH is non-nil, only defined variable
+names are allowed."
+ (completing-read
+ prompt
+ (mapcar (function
+ (lambda (var=value)
+ (list (substring var=value 0
+ (string-match "=" var=value)))))
+ process-environment)
+ nil
+ require-match))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;; Hangs sometimes, don't know why..
+;;; Currently owned by "my" and disabled. Enable this manyally in load-hook
+;;; if you want to try it.
+;;;
+(defadvice getenv (around my dis)
+ "Offer completion."
+ (interactive (list (tinyadvice-read-envvar "Get environment variable: " t)))
+ ad-do-it
+ (if (and (interactive-p)
+ ad-return-value)
+ (message "%s" ad-return-value)
+ ad-return-value))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defadvice setenv (around tinyadvice dis)
+ "Add interactive completion."
+ (interactive
+ (if current-prefix-arg
+ (list (tinyadvice-read-envvar "Clear environment variable: " t) nil t)
+ (let ((var (tinyadvice-read-envvar "Set environment variable: ")))
+ (list var
+ (read-from-minibuffer
+ (format "Set %s to value: " var)
+ (or (getenv var) ""))))))
+ ad-do-it
+ (if (and (interactive-p) value)
+ (message "%s" value)
+ value))
+
+;;}}}
+;;{{{ grep, tag
+
+;;; ------------------------------------------------------------ &grep ---
+;;;
+(defadvice grep (around tinyadvice dis)
+ "Complete filenames with TAB.
+Read word from the current pointand put it into grep prompt."
+ (interactive
+ (ti::file-complete-filename-minibuffer-macro
+ (list
+ (read-from-minibuffer
+ "(tinyadvice) Run grep: "
+ (concat grep-command (or (ti::buffer-read-space-word) ""))
+ map
+ nil
+ 'grep-history))))
+ ad-do-it)
+
+;;; ----------------------------------------------------------------------
+;;;
+(defadvice find-tag (after tinyadvice-reposition-window act)
+ "Call reposition-window after finding a tag."
+ (reposition-window))
+
+;;}}}
+
+;;{{{ files.el
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; files.el
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; ----------------------------------------------------------------------
+;;; ANGE things...
+;;; - Ange ftp gets "listing" when it tries to guess if the file
+;;; exists or if it's new file. The listing is produced with the call
+;;; `insert-file-contents'
+;;;
+;;; find-file-noselect (filename &optional nowarn)
+;;; ...
+;;; ange-ftp-insert-file-contents
+;;; ..file-exists-p
+;;;
+(defadvice after-find-file (around tinyadvice-file dis)
+ "Suppress call if no `buffer-file-name'. This may happen with ange-ftp."
+ (if buffer-file-name
+ ad-do-it))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defadvice find-file-literally
+ (around tinyadvice-disable-write-file-hooks dis)
+ "Disable `write-file-hooks' so that file can edited and saved in pure manner."
+ ad-do-it
+ (make-local-hook 'write-file-hooks)
+ (setq write-file-hooks nil)
+ ;; (setq indent-tabs-mode t)
+ (message "TinyAdvice: write-file-hooks is now nil in %s" (buffer-name)))
+
+;;; ----------------------------------------------------------------------
+;;; 19.30 doesn't offer the filename, so enable this in all emacs versions
+;;;
+(defadvice find-alternate-file (around tinyadvice dis)
+ "Interactive change: offer buffer filename as default.
+Reference:
+ `tinyadvice-:find-alternate-file-flag'"
+ (interactive
+ (list
+ (read-file-name
+ "find alternate file: "
+ (file-name-directory (or (buffer-file-name)
+ default-directory))
+ nil
+ t
+ (if (buffer-file-name)
+ (file-name-nondirectory (buffer-file-name))
+ (if tinyadvice-:find-alternate-file-flag
+ (buffer-name) "")))))
+ ad-do-it)
+
+;;; ----------------------------------------------------------------------
+;;;
+(defadvice recover-file (around tinyadvice dis)
+ "Offer current buffer's filename in prompt."
+ (interactive
+ (list
+ (read-file-name
+ "(TinyAdvice) Recocer file: "
+ (file-name-directory (or (buffer-file-name)
+ default-directory))
+ nil
+ t
+ (if (buffer-file-name)
+ (file-name-nondirectory (buffer-file-name))
+ (if tinyadvice-:find-alternate-file-flag
+ (buffer-name) "")))))
+ ad-do-it)
+
+;;; ----------------------------------------------------------------------
+;;;
+(defadvice write-file (around tinyadvice-file dis)
+ "File handling additions.
+
+Interactive change:
+
+ Changes the interactive prompt so, that full `buffer-file-name' is given
+ for editing.
+
+Confirm overwrite:
+
+ When called interactively, require confirmation if FILENAME already exists.
+ If FILENAME matches `tinyadvice-:write-file-no-confirm', no confirmation
+ is asked."
+ (interactive
+ ;; Change "Fwrite to file: "
+ (list
+ (read-file-name
+ "write to file: "
+ (or (buffer-file-name)
+ "~/"))))
+
+ (let* ((fn (ad-get-arg 0))
+ ;; Tmp buffers do not have filename
+ (buffer-file (or fn (buffer-file-name) ""))
+ (pass t))
+
+ (if (stringp fn)
+ (setq pass
+ (ti::string-match-case tinyadvice-:write-file-no-confirm fn)))
+
+ (if (or (not (interactive-p)) ;only when user call it, do checks
+ (not (file-exists-p fn))
+ pass
+ (y-or-n-p (format "%s already exists; overwrite it? " fn)))
+ ad-do-it
+ (message "Aborted"))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defadvice write-region (around tinyadvice-file dis)
+ "See `write-file' which explains the advice behavior."
+ (interactive "r\nFwrite region: ")
+ (let* ((fn (ad-get-arg 2))
+ (buffer-file fn)
+ (pass t))
+ (if (stringp fn)
+ (setq pass
+ (ti::string-match-case tinyadvice-:write-file-no-confirm fn)))
+ (if (or (not (interactive-p))
+ (not (file-exists-p fn))
+ pass
+ (y-or-n-p (format "%s already exists; overwrite it? " fn)))
+ ad-do-it
+ (message "Aborted"))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defadvice save-some-buffers (before tinyadvice dis)
+ "Always save changed abbrevs without questions if `save-abbrevs' is set."
+ (when (and save-abbrevs abbrevs-changed)
+ (write-abbrev-file nil)
+ (setq abbrevs-changed nil)))
+
+;;}}}
+;;{{{ fill
+
+;;; ............................................................ &fill ...
+
+;;; ----------------------------------------------------------------------
+;;; In new cc-mode there variable `c-hanging-comment-ender-p'
+;;; which does exactly same than this advice.
+;;;
+;;; We install this advice for older emacs only.
+;;;
+(when (tinyadvice-activate-p 'fill-paragraph)
+
+ (defadvice fill-paragraph (after tinyadvice dis)
+ "Touch C comment filling, otherwise do nothing.
+If the fill was done to C comment. It usually levaes it like this,
+while this advice corrects it a bit and moves the last asterisk to
+the next line.
+
+/* comment ... /* comment ...
+ * ends here. */ * ends here.
+ */
+
+This function does not affect C comments that occupy only one line."
+ (let* (col
+ line)
+ (when (and (save-excursion
+ (beginning-of-line)
+ (and
+ ;; If this is continuing line "*", then search back
+ ;; otw we're at "/*" already
+ ;;
+ (if (looking-at "^[ \t]*[*]")
+ (re-search-backward "^[ \t]*/[*]" nil t)
+ (looking-at "^[ \t]*/[*]"))
+ (re-search-forward "^[ \t]*/[*]" nil t)
+ (setq col (current-column) line (ti::current-line-number))))
+ (re-search-forward "[*]/" nil t)
+ ;; - The "/*" and "*/" must be at different lines,
+ ;; because only then we want to adjust the last "*/"
+ ;; - Skip one line comments.
+ (not (eq (ti::current-line-number) line)))
+ (delete-backward-char 2) (insert "\n")
+ (move-to-column (1- col) t)
+ (insert "*/")))))
+
+;;}}}
+;;{{{ gud
+
+;;; ............................................................. &gud ...
+
+;;; ----------------------------------------------------------------------
+;;; See gud.el
+;;;
+(defadvice gud-display-line (after tinyadvice dis)
+ "Highlight current line."
+ (when (and tinyadvice-:gud-overlay
+ (fboundp 'move-overlay))
+ (let* ((ov tinyadvice-:gud-overlay)
+ (bf (gud-find-file true-file)))
+ (save-excursion
+ (set-buffer bf)
+ (move-overlay
+ ov
+ (line-beginning-position)
+ (line-end-position)
+ (current-buffer))))))
+
+;;}}}
+
+;;{{{ imenu
+
+;;; ........................................................... &imenu ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defadvice imenu (before tinyadvice dis)
+ "Widen the buffer before activating imenu."
+ (widen))
+
+;;}}}
+;;{{{ mail
+
+;;; ............................................................ &mail ...
+
+;;; ----------------------------------------------------------------------
+;;; See mailabbrev.el
+;;;
+(defadvice sendmail-pre-abbrev-expand-hook
+ (around tinyadvice-no-abbrevs-in-body dis)
+ "Do not expand any abbrevs in the message body through `self-insert-command'."
+ (if (or (mail-abbrev-in-expansion-header-p)
+ ;; (not (eq last-command 'self-insert-command)) ; can't be used
+ ;; since last-command is the previous, not the current command
+ (not (integerp last-command-char))
+ (eq (char-syntax last-command-char) ?w)) ; this uses that
+ ;; the last char in {C-x '} {C-x a '} {C-x a e} is `w' syntax
+ ad-do-it
+ (setq abbrev-start-location (point) ; this hack stops expand-abbrev
+ abbrev-start-location-buffer (current-buffer))))
+
+;;}}}
+;;{{{ map-ynp
+
+;;; ......................................................... &map-ynp ...
+
+;; 19.28
+;; - map-ynp.el::map-y-or-n-p Get's loaded in loadup.el, it pops up
+;; an dialog Box of questions if the input is event type and it is
+;; annoying to answer yes/no dialog boxes. It is much quicker to
+;; hit SPACE/DEL for yes/no.
+;; - Hmm actually it looks back what the command was by looking at
+;; `last-nonmenu-event' variable, so I should reset it instead.
+;; - *argh* I was wrong, it is the `y-or-n-p' (built-in) command that pops up
+;; the dialog, anyway the advice works for it too: built-in or not
+;; doesn't matter
+;;
+;; The way to do this in XEmacs is:
+;;
+;; (setq use-dialog-box nil)
+
+(when (and (ti::compat-window-system)
+ (ti::emacs-p))
+ (defadvice map-y-or-n-p (before tinyadvice dis)
+ "Reset any mouse event to key event so that no dialogs are displayed."
+ (if (listp last-nonmenu-event)
+ ;; replace with some harmless value
+ (setq last-nonmenu-event ?\n)))
+ (defadvice y-or-n-p (before tinyadvice dis)
+ "Reset any mouse event to key event so that no dialogs are displayed."
+ (if (listp last-nonmenu-event)
+ ;; replace with some harmless value
+ (setq last-nonmenu-event ?\n))))
+
+;;}}}
+;;{{{ mouse
+
+;;; ........................................................... &mouse ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defadvice mouse-wheel-scroll-screen (around tinyadvice act)
+ "Use tinymy.el scrolling if possible."
+ (if (and (fboundp 'tinymy-scroll-down)
+ (fboundp 'tinymy-scroll-up))
+ (let ((event (ad-get-arg 0)))
+ (ignore-errors
+ (if (< (car (cdr (cdr event))) 0)
+ (tinymy-scroll-down)
+ (tinymy-scroll-up))))
+ ad-do-it))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defadvice mouse-delete-other-windows (around tinyadvice dis)
+ "Confirm window delete."
+ (if (y-or-n-p "Really delete _all_ windows ")
+ ad-do-it
+ (message "")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defadvice mouse-delete-window (around tinyadvice dis)
+ "Confirms window delete."
+ (if (y-or-n-p "Really delete _this_ window ")
+ ad-do-it
+ (message "")))
+
+;;}}}
+;;{{{ replace.el
+
+(defadvice occur (before tinyadvice act)
+ "Iinteractive change: ask if user want the occur to start from `point-min'.
+also Possibly unfold/un-outline the code."
+ (when (and (interactive-p)
+ (not (eq (point) (point-min)))
+ (y-or-n-p "TinyAdvice: Start occur from point-min? "))
+ (if (and (or (and (featurep 'folding)
+ (symbol-value 'folding-mode))
+ (and (and (featurep 'outline)
+ (boundp 'outline-mode))
+ (symbol-value 'outline-mode)))
+ (save-excursion
+ (ti::pmin)
+ (re-search-forward "\r" nil t))
+ (y-or-n-p "TinyAdvice: Open buffer's selective display too? "))
+ (ti::buffer-outline-widen))))
+
+;;}}}
+;;{{{ simple.el
+
+;;; .......................................................... &simple ...
+
+;;; ----------------------------------------------------------------------
+;;; See simple.el
+;;;
+(defadvice exchange-point-and-mark (around tinyadvice-pop-if-prefix dis)
+ "If given prefix, call `set-mark-command' to pop previous mark positions."
+ (if (and current-prefix-arg
+ (interactive-p))
+ (call-interactively 'set-mark-command))
+ ad-do-it)
+
+;;; ----------------------------------------------------------------------
+;;;
+(defadvice goto-line (around tinyadvice dis)
+ "Widen the buffer before and after `goto-line' command."
+ (widen)
+ ad-do-it
+ ;; We do this because, the folding.el sets narrowing in effect,
+ ;; when the goto-line has finished.
+ ;; #todo: should we check featurep 'folding?
+ (widen))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defadvice indent-for-comment (around tinyadvice dis)
+ "Kill the comment with negative prefix."
+ (if (eq current-prefix-arg '-)
+ (kill-comment nil)
+ ad-do-it))
+
+;;; ----------------------------------------------------------------------
+;;; Redefine insert-buffer to insert a visible buffer, if there's one.
+;;;
+(defadvice insert-buffer (before tinyadvice dis)
+ "Use a more reasonable default, the other window's content."
+ (interactive
+ (list
+ (progn
+ (barf-if-buffer-read-only)
+ (read-buffer "Insert buffer: "
+ (if (eq (selected-window)
+ (next-window (selected-window)))
+ (other-buffer (current-buffer))
+ (window-buffer (next-window (selected-window))))
+ t)))))
+
+;;; ----------------------------------------------------------------------
+;;; avoid deactivation of region when buffer end or beginning is reached
+;;;
+(defadvice line-move (around tinyadvice dis)
+ "Avoid deactivation of region. in `beginning-of-buffer' or `end-of-buffer'."
+ (condition-case ()
+ ad-do-it
+ ((beginning-of-buffer end-of-buffer)
+ (if (bobp)
+ (message "Beginning of buffer.")
+ (message "End of buffer.")))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defadvice set-mark-command (around tinyadvice-global-if-negative dis)
+ "If the argument is negative, call `pop-global-mark'."
+ (if (< (prefix-numeric-value current-prefix-arg) 0)
+ (pop-global-mark)
+ ad-do-it))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defadvice what-cursor-position (around tinyadvice dis)
+ "Displays line number info too."
+ ad-do-it
+ ;; we have to use 'princ' because there is percentage mark
+ ;; in returned string and that would run 'message' beserk,
+ ;; since it thinks it's formatting code
+ (princ (concat
+ ad-return-value
+ (int-to-string (ti::widen-safe (ti::current-line-number))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defadvice switch-to-buffer (around tinyadvice dis)
+ "When called interactively: Confirm switch to non-existing buffer.
+
+References:
+
+ `tinyadvice-:switch-to-buffer-find-file'
+ if non-nil, suggest `find-file' for non-existing buffers"
+ (interactive "Bbuffer name: ")
+ (let ((buffer-name (ad-get-arg 0)))
+ (if (or (not (interactive-p)) ;user didn't call us
+ (get-buffer buffer-name)) ;it exists
+ ad-do-it
+ (cond
+ ((y-or-n-p (format "`%s' does not exist, create? " buffer-name))
+ ad-do-it) ;ceate new buffer
+
+ (tinyadvice-:switch-to-buffer-find-file ;is this enabled ?
+ (find-file (read-file-name "(tinyadvice) Find-file: "
+ nil
+ nil
+ nil
+ buffer-name)))))
+ (message ""))) ;clear the echo area
+
+;;; ----------------------------------------------------------------------
+;;;
+(defadvice switch-to-buffer-other-frame (around tinyadvice dis)
+ "Replace function. Don't ever create new frame; reuse some existing frame."
+ (let ((free-frames (ti::window-frame-list nil 'exclude-current))
+ stat)
+ (if (null free-frames)
+ (pop-to-buffer buffer)
+ (cond
+ ((setq stat (ti::window-get-buffer-window-other-frame buffer))
+ ;; buffer is displayed already in some OTHER frame; go to it.
+ (raise-frame (car stat))
+ (select-frame (car stat))
+ (select-window (cdr stat)))
+ (t
+ ;; Go to some free frame and pop up there
+ (raise-frame (car free-frames))
+ (select-frame (car free-frames))
+ (switch-to-buffer buffer))))))
+
+;;}}}
+;;{{{ subr.el
+
+;;; ----------------------------------------------------------------------
+;;;
+(defadvice save-buffers-kill-emacs (around tinyadvice dis)
+ "Redefine `save-buffers-kill-emacs' to prevent accidental logouts."
+ (cond
+ ((and (interactive-p)
+ (y-or-n-p "TinyAdvice: Really quit emacs? "))
+ (message "")
+ ad-do-it)
+ ((not (interactive-p))
+ ad-do-it)))
+
+;;; ----------------------------------------------------------------------
+;;; - This puts cursor to generated list. Propably what we
+;;; want 99% of the time.
+;;;
+(defadvice list-buffers (after tinyadvice dis)
+ "Select buffer list after displaying."
+ (if (interactive-p)
+ (select-window (get-buffer-window "*Buffer List*"))))
+
+;;}}}
+;;{{{ time
+
+;;; ............................................................ &time ...
+
+;;; ----------------------------------------------------------------------
+;;; This is for reporter.el by Barry A. Warsaw in the xemacs distribution
+;;;
+(defadvice display-time-process-this-message (around tinyadvice-no-junk-mail dis)
+ "Suppress message in modeline.
+If display-time-announce-junk-mail-too is nil, suppress the [Junk mail]
+message on the modeline."
+ ((let ((modeline display-time-mail-modeline))
+ ad-do-it
+ (if (and ad-return-value ; junk-p
+ (not display-time-announce-junk-mail-too))
+ ;; restore non-junk modeline
+ (setq display-time-mail-modeline modeline))
+ ad-return-value)))
+
+;;}}}
+;;{{{ vc
+
+;;; .............................................................. &vc ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyadvice-rcs-initial-comment (file)
+ "Add initial comment leader to RCS FILE."
+ (let* (buffer
+ file-type
+ str)
+ (when (and (stringp file) ;if not nil
+ (ti::vc-rcs-file-exists-p file)) ;RCS controlled file
+
+ ;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ type of file ^^^
+
+ (with-current-buffer (get-file-buffer file)
+ (setq file-type (or (ti::id-info nil 'variable)
+ (symbol-name major-mode)))
+ (setq str comment-start))
+
+ ;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ default comment ^^^
+
+ (cond
+ ((string-match "lisp" file-type)
+ (setq str ";; "))
+ ((string-match "c[+]+" file-type)
+ (setq str "// "))
+ ((stringp str) ;original comment, leave it as is
+ nil)
+ (t
+ (setq str "# "))) ;Not set? Suggest shell comment
+
+ ;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ setting comment ^^^
+
+ (unless (ti::nil-p ;only if given something
+ (setq str
+ (read-from-minibuffer
+ "Set RCS comment leader to:" str)))
+ (setq str (format "rcs -c\"%s\" %s" str file)) ;Shell command
+
+ (message "TinyAdvice: setting rcs comment...")
+ (shell-command str "*vc*" )
+
+ ;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ fixing emacs buffer ^^^
+
+ ;; - Now, the rcs -u only modified the delta file in RCS tree,
+ ;; we must take the version out of the tree, so that the new
+ ;; comment setting takes place: Do "co" and reread the file
+ ;; into emacs.
+ ;;
+
+ (message "TinyAdvice: refreshing the file comment...")
+
+ (setq str (format "co %s" file)) ;Easier to debug and print variable
+ (shell-command str)
+
+ (when (setq buffer (get-file-buffer file))
+ (let* (find-file-hooks ;prevent VC this time
+ buffer-read-only
+ enable-local-eval)
+ (set-buffer buffer)
+ (find-alternate-file file)
+ (pop-to-buffer (current-buffer))))
+
+ (when (setq buffer (get-buffer "*VC-log*"))
+ (with-current-buffer buffer
+ ;; Fix this variable, because we reread the file
+ ;; see vc-finish-logentry
+ (setq vc-parent-buffer buffer)))
+ (message "TinyAdvice: refreshing the file comment ...done")))))
+
+;;; ----------------------------------------------------------------------
+;;; AROUND advice has been left to user, therefor the
+;;; combination of BEFORE and AFTER advices.
+;;;
+(defadvice vc-do-command (before tinyadvice-vc dis)
+ "Set flag `tinyadvice-:vc-p' if file is version controlled.
+Used by TinyAdvice after advice to determine if initial
+comment leader needs to be set."
+ ;; - The arg 'file' is nil when vc calls this command with
+ ;; "rcs" nil nil "-V". We are not interested in those cases.
+ (if (stringp file)
+ (setq tinyadvice-:vc-p (or (vc-registered file)
+ (string-match ",v" file)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defadvice vc-do-command (after tinyadvice-vc dis)
+ "Set initial RCS comment leader.
+According to flag `tinyadvice-:vc-p', if file was not version controlled,
+ie. the CheckIn was done first time, ask from user about the initial
+comment leader and set it."
+ (if (and (stringp file)
+ (null tinyadvice-:vc-p)) ;Initial CheckIn
+ (tinyadvice-rcs-initial-comment file)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymy-rcs-p (file)
+ "Check if is registered or can be put to RCS."
+ (or (and (stringp file)
+ (eq 'RCS (vc-file-getprop
+ file
+ 'vc-backend)))
+ (null (ti::vc-dir-p file))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defadvice vc-do-command (around tinyadvice-vc dis)
+ "TinyAdvice Changes.
+Set initial RCS comment leader.
+According to flag `tinyadvice-:vc-p', if file was not version controlled,
+ie. the CheckIn was done first time, ask from user about the initial
+comment leader and set it.
+
+Add flags that user gave in `vc-register' (like -k) for initial login
+which preserver keyword values if needed. User must register file with
+C-x v i for this to take in effect."
+ (let* ((tinyadvice-args (ad-get-args 6))
+ (tinyadvice-flags (get 'vc-register 'tinyadvice-vc-register))
+ (rcs (tinymy-rcs-p file)))
+ (when (and rcs
+ (stringp tinyadvice-flags))
+ ;; Add initial RCS flags that were set in vc-register
+ (setq tinyadvice-args
+ (append tinyadvice-args (split-string tinyadvice-flags)))
+ (put 'vc-register 'tinyadvice-vc-register nil)
+ (when (and (stringp tinyadvice-flags)
+ (string-match "-k" tinyadvice-flags))
+ ;; vc add option -u1.1 for initial version, get rid of version number
+ (setq tinyadvice-args
+ (remove-if
+ (function
+ (lambda (x)
+ (and (stringp x)
+ (string-match "^-u" x))))
+ tinyadvice-args))
+ (push "-u" tinyadvice-args))
+ (ad-set-args 6 tinyadvice-args)))
+ ad-do-it)
+
+;;; ----------------------------------------------------------------------
+;;;
+(defadvice vc-register (before tinyadvice-vc dis)
+ "Ask if check in as \"original\" file if there is already version number.
+If the current file already includes version control information,
+ask from user if the check in should happen using -k which preserves
+the original keyword attributes."
+ (put 'vc-register 'tinyadvice-vc-register nil)
+ (let* ((file (buffer-file-name))
+ (version (and file
+ ;; No previous file
+ (not (ti::vc-rcs-file-exists-p file))
+ (not (ti::vc-cvs-file-exists-p file))
+ (ti::vc-rcs-buffer-version)))
+ ans)
+ (when (and version
+ (eq 'RCS (vc-file-getprop file 'vc-backend))
+ (ti::vc-version-simple-p version)
+ ;; if there
+ (not
+ (ti::nil-p
+ (setq ans
+ (read-string
+ (format "(TinyAdvice: found v%s) ci rcs flags:"
+ version)
+ "-k")))))
+ (put 'vc-register 'tinyadvice-vc-register ans))))
+
+;;; ----------------------------------------------------------------------
+;;; vc-hooks.el , vc-mode-line (file &optional label)
+;;;
+;;; - The string displayed is included in the `vc-mode' variable
+;;; - This function is called by `vc-rcs-status'
+;;;
+(defadvice vc-mode-line (around tinyadvice-vc dis)
+ "Add word 'b' if RCS revision is in the middle of the
+\(b)ranch and not the last one.
+
+Change to CVS: never make buffer read-only if
+`tinyadvice-:cvs-buffer-read-only' is nil."
+ (let* ((vc (and file
+ (vc-registered file)
+ (vc-file-getprop file 'vc-workfile-version)))
+ (file buffer-file-name)
+ (backend (and vc
+ buffer-file-name
+ (vc-file-getprop file 'vc-backend)))
+ ver)
+ (when (and vc
+ ;; #todo: CVS is missing
+ (eq backend 'RCS)
+ (setq ver (ti::vc-rcs-head-version file))
+ (stringp ver)
+ (not (string= vc ver))) ;it's not the same as highest
+ (ad-set-arg 0
+ (format "%s%s"
+ (or (ad-get-arg 0)
+ (and backend
+ (symbol-name backend))
+ "")
+ "b")))
+
+ ad-do-it
+ (when (and vc
+ (null tinyadvice-:cvs-buffer-read-only)
+ (eq 'CVS backend))
+ (setq buffer-read-only nil))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defadvice vc-print-log (around tinyadvice-vc dis)
+ "Position cursor to current revision."
+ (let* (ver)
+ (setq ver (ti::string-match "[.0-9]+" 0 (or vc-mode "")))
+ ad-do-it
+ (when ver
+ ;; the version must end directly,
+ ;; "1.4" must not match "1.4.1.1"
+ ;;
+ ;; Watch out for this statement too, thats why we start
+ ;; searching from the end of buffer.
+ ;; revision 3.4.1.2 locked by: foo;
+ ;;
+ (ti::pmax)
+ (re-search-backward (concat "revision +" ver "[^.]") nil t))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;; - Normally each dir have an RCS dir.
+;;; - But sometimes user want to keep all RCS files in one RCS dir,
+;;; so he just creates symlinks to that main RCS dir.
+;;;
+;;; /dir/RCS main RCS dir
+;;; | |
+;;; dir1/RCS ----| | Symlink 1 points there
+;;; dir2/RCS ------| Symlink 2 points there
+;;;
+;;;
+(defun tinyadvice-vc-register ()
+ "Check if RCS directory is needed before registering a file."
+ (when (and buffer-file-name ;let's not take a risk
+ (null (tinymy-rcs-p buffer-file-name)))
+ (let* ( ;; - Make sure we're looking under right directory:
+ ;; - It is possible that user has given the `cd' command
+ ;; in this buffer e.g. due to compilation.
+ (default-directory (file-name-directory buffer-file-name))
+ ;; Strange things may happen. If there is no RCS directory
+ ;; and you use `ci' then the file appear in _current_
+ ;; directory with name file.txt,v
+ (false (concat buffer-file-name ",v"))
+ rcs
+ cmd)
+ (when (file-exists-p false)
+ (message "TinyAdvice: ** Warning Suspicious rcs file %s" false)
+ (sit-for 5))
+ (when (not (and (file-exists-p "RCS")
+ (file-directory-p "RCS")))
+ (setq rcs (ti::file-make-path default-directory "RCS"))
+ (message "[press esc] No RCS tree in %s" default-directory)
+ (sit-for 7) ;; Make sure user sees the directory name
+ (discard-input)
+ (if (y-or-n-p
+ (concat
+ "Y = Create new RCS dir"
+ (if (not (ti::win32-p))
+ ", N = create symlink to main depository (unix only)? "
+ "")))
+ (make-directory rcs)
+ ;; -- ELSE --
+ (if (ti::win32-p)
+ (error "TinyAdvice: `vc-register' needs a RCS dir.")
+ (if (not (file-exists-p tinyadvice-:vc-main-rcs-dir))
+ (error
+ (format
+ "TinyAdvice: `vc-register' No main RCS dirextory exist: %s"
+ tinyadvice-:vc-main-rcs-dir)))
+ (setq cmd (format "ln -s %s %s"
+ (expand-file-name tinyadvice-:vc-main-rcs-dir)
+ rcs)))
+ (ti::temp-buffer tinyadvice-:tmp-buffer 'clear)
+ (shell-command cmd tinyadvice-:tmp-buffer)
+ (unless (ti::buffer-empty-p tinyadvice-:tmp-buffer)
+ (pop-to-buffer tinyadvice-:tmp-buffer))
+ (message "TinyAdvice: (vc-register) %s" cmd))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defadvice vc-register (before tinyadvice-create-rcs-dir dis)
+ "RCS directory must exist. Ask to create one if it does not exist."
+ (if (not (boundp 'vc-handled-backends)) ;; skip if latest emacs
+ (tinyadvice-vc-register)))
+
+;;}}}
+
+;;{{{ Other
+
+;;; ........................................................... &other ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(mapc
+ (function
+ (lambda (x)
+ (eval
+ (`
+ (defadvice (, x) (around tinyadvice-kill-buffer act)
+ "Kill the buffer if there is no process."
+ (condition-case error
+ ad-do-it
+ (error
+ (if (equal error '(error "Current buffer has no process"))
+ (kill-buffer (current-buffer))))))))))
+ '(term-copy-old-input term-send-input term-send-raw-string))
+
+;;; ----------------------------------------------------------------------
+;;; hyberbole package
+;;;
+(defadvice hkey-help-show (around tinyadvice-shrink-window act)
+ "Shrink auxiliary windows to buffer size.
+For `help-mode',switch `view-mode' off."
+ ;;
+ ;; hkey-help-show is part of Bob Wiener's Hyperbole. In pure emacs
+ ;; a hook is more appropriate: with-output-to-temp-buffer asks the
+ ;; function in the variable temp-buffer-show-function (if non-nil)
+ ;; to take care of the showing. That function also must call
+ ;; temp-buffer-show-hook. Take your pick.
+ ;;
+ (if (and (not current-window) ; second arg
+ (get-buffer-window buffer))
+ (delete-window (get-buffer-window buffer))) ; force recreation
+ ad-do-it
+ (if (and (not current-window) ; second arg
+ (not (one-window-p t))) ; not counting the minibuffer
+ (shrink-window-if-larger-than-buffer (get-buffer-window buffer)))
+ (if (and (eq major-mode 'help-mode)
+ (boundp view-mode) view-mode)
+ (view-exit)))
+
+;;}}}
+
+(provide 'tinyadvice)
+(run-hooks 'tinyadvice-load-hook)
+
+;;; tinyadvice.el ends here
--- /dev/null
+;;; tinyappend.el --- A simple text gathering to buffer utility.
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 1994-2007 Jari Aalto
+;; Keywords: extensions
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program, call M-x tinyappend-version
+;; Look at the code with folding.el
+
+;; COPYRIGHT NOTICE
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;;; Install:
+
+;; ....................................................... &t-install ...
+;; Put this file on your Emacs-Lisp load path, add following into your
+;;
+;; (require 'tinyappend)
+;;
+;; Autoload, prefer this one, your emacs starts quicker.
+;;
+;; (autoload 'tinyappend-beg "tinyappend" "" t)
+;; (autoload 'tinyappend-end "tinyappend" "" t)
+;;
+;; If you do not want the default key bindings, add this before the
+;; require command
+;;
+;; (setq tinyappend-:load-hook nil)
+;;
+;; If you have any questions, suggestions, use this function
+;;
+;; M-x tinyappend-submit-bug-report
+
+;;}}}
+
+;;{{{ Documentation
+
+;; ..................................................... &t-commentary ...
+
+;;; Commentary:
+
+;; Preface, March 1994
+;;
+;; This package does nothing fancy, it gathers text from buffers with
+;; few key bindings. Later you can then peek on that buffer, arrange
+;; text etc. `C-x' `a' is handy when appending data to buffer, but
+;; it's annoying that you have to give "buffer name" all the time This
+;; one adds to buffer "*append*" automatically, creating one if it
+;; doesn't exist.
+;;
+;; I'd strongly recommend you to keep `transient-mark-mode' (Emacs) on
+;; all the time, so that you can see if you're adding a selected
+;; region into the *append* buffer. If the region is not active, these
+;; functions normally add the current line to the *append* buffer.
+;;
+;; Suggested default bindings
+;;
+;; C-c + Append to the end
+;; C-c _ (underscore) Append to the beginning
+;; C-c - Kill (empty) *append* buffer
+;; C-c | Yank text from append buffer
+;;
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+;;{{{ setup: require
+
+;;; ......................................................... &require ...
+
+(require 'tinylibm)
+
+(eval-when-compile (ti::package-use-dynamic-compilation))
+
+(ti::package-defgroup-tiny TinyAppend tinyappend-: extensions
+ "Gather text to separate cut buffer.")
+
+;;}}}
+;;{{{ setup: variables
+
+;;; ......................................................... &v-hooks ...
+
+(defcustom tinyappend-:load-hook nil
+ "*Hook run when file has been loaded."
+ :type 'hook
+ :group 'TinyAppend)
+
+;;; ........................................................ &v-public ...
+;;; User configurable
+
+(defcustom tinyappend-:buffer "~/.append"
+ "*Buffer where to save text.
+If this variable has star at the beginning of name, like *append*,
+it is considered that the buffer doesn't need saving to any file.
+
+Otherwise if file with the same name exists when tinyappend.el is
+being loaded, the buffer will hold the contents of the file
+_only_ if buffer is empty initially."
+ :type 'string
+ :group 'TinyAppend)
+
+;;}}}
+;;{{{ version
+
+;;; ....................................................... &v-version ...
+
+;;;###autoload (autoload 'tinyappend-version "tinyappend" "Display commentary." t)
+(eval-and-compile
+ (ti::macrof-version-bug-report
+ "tinyappend.el"
+ "tinyappend"
+ tinyappend-:version-id
+ "$Id: tinyappend.el,v 2.40 2007/05/01 17:20:42 jaalto Exp $"
+ '(tili-:version-id
+ tinyappend-:load-hook
+ tinyappend-:buffer)))
+
+;;}}}
+
+;;; ########################################################### &funcs ###
+
+;;{{{ code: misc
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyappend-install-default-key-bindings ()
+ "Install default key bindings."
+ (interactive)
+ (global-set-key "\C-c=" 'tinyappend-end) ;; non-shift key
+ (global-set-key "\C-c-" 'tinyappend-beg) ;; non-shift key
+ (global-set-key "\C-c_" 'tinyappend-kill)
+ (global-set-key "\C-c|" 'tinyappend-yank))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro tinyappend-line-area-args (msg)
+ "Return region of current line: (beg end MSG) including newline."
+ (`
+ (list
+ (line-beginning-position)
+ (save-excursion
+ (end-of-line)
+ (ignore-errors (forward-char 1)) ;get newline, unless EOB
+ (point))
+ (, msg))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyappend-get-buffer ()
+ "Create `tinyappend-:buffer' and initializes its content from file if it exists.
+
+Return:
+ buffer pointer"
+ (interactive)
+ (save-excursion
+ (set-buffer (get-buffer-create tinyappend-:buffer))
+ (when (not (char= (aref tinyappend-:buffer 0) ?\* ))
+ (if (and (file-exists-p tinyappend-:buffer) ;history file exists ?
+ (ti::buffer-empty-p))
+ (insert-file-contents tinyappend-:buffer))
+ ;; link to file so that Emacs asks to save the buffer
+ ;; when you quit with C-x C-c
+ (setq buffer-file-name (expand-file-name tinyappend-:buffer))
+ (rename-buffer tinyappend-:buffer)))
+ (get-buffer tinyappend-:buffer))
+
+;;}}}
+;;{{{ code: main
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyappend-append-to-buffer (beg end &optional arg msg verb)
+ "Store BEG END with ARG and MSG to `tinyappend-:buffer'.
+Default is to store the end of buffer. Prefix argument ARG means:
+
+ 0 = kill append buffer
+ \\[universal-argument] = adds to the beginning
+
+VERB allows verbose messages."
+ (ti::verb)
+ (setq msg (or msg ""))
+ (save-excursion
+ (if (not (eq 0 arg))
+ (copy-region-as-kill beg end))
+ (set-buffer (tinyappend-get-buffer))
+
+ (cond ; According to prefix
+ ((eq arg 0) ; yank to the beginning
+ (kill-buffer (current-buffer))
+ (and verb (message (concat "TIA buffer killed"))))
+ ((and (not (null arg)) ; yank to the beginning
+ (listp arg))
+ (goto-char (point-min)) (yank)
+ (if verb
+ (message (format "*appended %s BEG*" msg))))
+ (t
+ (goto-char (point-max)) (yank)
+ (if verb
+ (message (format "*appended %s*" msg)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyappend-end (&optional beg end msg)
+ "Store region BEG END with MSG or current line to the end of `tinyappend-:buffer'."
+ (interactive
+ (if (region-active-p)
+ (list (region-beginning) (region-end) "region")
+ (tinyappend-line-area-args "line")))
+ (tinyappend-append-to-buffer beg end nil msg 'verb))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyappend-beg (&optional beg end msg)
+ "Store BEG END with MSG or current line to the beginning of `tinyappend-:buffer'."
+ (interactive
+ (if (region-active-p)
+ (list (region-beginning) (region-end) "region")
+ (tinyappend-line-area-args "line")))
+ (tinyappend-append-to-buffer beg end '(4) msg 'verb))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyappend-kill ()
+ "Kill `tinyappend-:buffer' buffer."
+ (interactive)
+ (if (get-buffer tinyappend-:buffer)
+ (kill-buffer tinyappend-:buffer)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyappend-yank (&optional kill)
+ "Yank `tinyappend-:buffer' to the current position. Optionally KILL `tinyappend-:buffer'."
+ (interactive "P")
+ (if (null (get-buffer tinyappend-:buffer))
+ (message (concat "Can't yank, there is no buffer: " tinyappend-:buffer))
+ (insert-buffer tinyappend-:buffer)
+ (if kill
+ (tinyappend-kill))))
+
+;;}}}
+
+(if (not (get-file-buffer tinyappend-:buffer))
+ (tinyappend-get-buffer))
+
+(provide 'tinyappend)
+(run-hooks 'tinyappend-:load-hook)
+
+;;; tinyappend.el ends here
--- /dev/null
+;;; tinybookmark.el --- Keep file in organized sections
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 1995-2007 Jari Aalto
+;; Keywords: tools
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program, call M-x tinybookmark-version
+;; Look at the code with folding.el
+
+;; COPYRIGHT NOTICE
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Installation
+
+;;; Install:
+
+;; ........................................................ &t-install ...
+;; Put this file on your Emacs-Lisp load path, add following into your
+;; ~/.emacs startup file
+;;
+;; (require 'tinybookmark)
+;;
+;; or use autoload, your emacs starts up faster, prefered:
+;;
+;; (autoload 'tinybookmark-insert "tinybookmark" "" t)
+;; (autoload 'tinybookmark-repeat "tinybookmark" "" t)
+;; (autoload 'tinybookmark-parse "tinybookmark" "" t)
+;; (autoload 'tinybookmark-forward "tinybookmark" "" t)
+;; (autoload 'tinybookmark-backward "tinybookmark" "" t)
+;; (autoload 'tinybookmark-keyboard "tinybookmark" "" t)
+;; (autoload 'tinybookmark-keyboard-parse "tinybookmark" "" t)
+;;
+;; (when (ti::compat-window-system)
+;; (autoload 'tinybookmark-mouse "tinybookmark" "" t)
+;; (autoload 'tinybookmark-mouse-parse "tinybookmark" "" t))
+;;
+;; To use 'M-x bm' for quick book mark command:
+;;
+;; (defalias 'tinybookmark-insert 'bm)
+;;
+;; Suggested keybindings
+;;
+;; ;; This is for windowed Emacs. It brings up nice pop up menu
+;; ;; In XEmacs tou must use different mouse events: `mouse1down'
+;;
+;; (global-set-key [(?\e) (control mouse-1)] 'tinybookmark-mouse)
+;; (global-set-key [(?\e) (control shift mouse-1)] 'tinybookmark-mouse-parse)
+;;
+;; ;; Keyboard users can move between book marks with these
+;;
+;; (global-set-key [(shift left)] 'tinybookmark-backward)
+;; (global-set-key [(shift right)] 'tinybookmark-forward)
+;;
+;; ;; Or to bavigate with complete menu
+;;
+;; (global-set-key [(shift right)] 'tinybookmark-keyboard)
+;;
+;; BE SURE THAT
+;;
+;; you have defined comment syntax, otherwise the inserted field
+;; won't have proper prefix + endings
+;;
+;; If you have any questions, use function:
+;;
+;; M-x tinybookmark-submit-bug-report
+
+;;}}}
+;;{{{ Documentation
+
+;;; .................................................... &t-commentary ...
+
+;;; Commentary:
+
+;; Preface, feb 1995
+;;
+;; Long ago I used little function I wrote that inserted section
+;; breaks, those that I call `book' `marks'. There was also
+;; `folding.el' to keep the code in separate sections. Findings things
+;; was easy when you just searched either book marks or jumped between
+;; folds. Next *imenu.el* was announced which provided X-pop up for
+;; book marks and adding support to it was the start of this package.
+;;
+;; Overview of features
+;;
+;; o Provide 'setting book marks' functions: Add
+;; repeated characters and sequences up till end of line with
+;; named identifier.
+;; o Automatically parse book marks from file, if it contains
+;; RCS identifier `bookMarkRegexp' which defines book mark syntax for
+;; the file. Uses X-popup [imenu] to show those book marks and
+;; moving between them.
+;;
+;; How to keep files organized
+;;
+;; There are several tools to keep your code organized and they are at
+;; their best if you think how they can co-operate. There is
+;; *folding.el* and *tinybookmark.el*, which might seem to do double
+;; job, since they both divide code into more easily manageable
+;; sections. The key point is that when folding is used, one works
+;; _within_ some special section and possibly want to hide all the
+;; rest of the code. But when jumping easily back and forth on the
+;; buffer, it us *unfolded* and TinyBookmark is used. Now, to confuse
+;; you more, there is also *imenu.el* which can be used to jump inside
+;; code. It can be configured so that it will pick all function names
+;; inside list, and when you want to go to specific function, just
+;; pick one from imenu.
+;;
+;; To summarize:
+;;
+;; o folding.el -- for hide unneeded code,
+;; clear view on the structure
+;; o tinybookmark.el -- Jump between/finding _large_ code sections
+;; o imenu.el -- finding specific function, more detailed control.
+;; o tinyhotlist.el -- Add/remove files from permanent X-popup list
+;;
+;; How to use this package
+;;
+;; There is following function that inserts book mark on the current line
+;;
+;; tinybookmark-insert
+;;
+;; There is also normal repeat function, that fills line with your
+;; pattern:
+;;
+;; tinybookmark-repeat
+;;
+;; Normally the usual book mark separator is the "." <dot> , which
+;; isn't so "noisy" as continuous '-' line. Normally you add some
+;; unused ID character, like '&' at front of real book mark, like
+;; this:
+;;
+;; ;;; .................................. &How-to-use ...
+;; (defun test ()
+;; (progn
+;; ..
+;; (goto-char ..
+;; ;; ^^^^^^^^^^^^^^^^^^^^^^^ sepratorInsideCode ^^^
+;;
+;; The `How-to-use' is book mark, because it has `&' on it, whilst the
+;; latter isn't -- it is used inside code to make it more readable and
+;; The latter on is not included in *imenu*.
+;;
+;; About the book mark identifier naming
+;;
+;; When you name the breaks, keep in mind that when identifiers are
+;; sorted, the ones that start with big letters A-Z show up first, a-z
+;; come next. Allthougt it would be convenient to have all subwords in
+;; capital, it is usually better to start with lowercase letter,
+;; because it's easily unintentionally mix up/down case letters.
+;; Besides you have to reah out for shift to have uppercase.
+;;
+;; ............. breakName ... ;prefered, starting low
+;; ............. BreakName ... ;watch out for mixed case!
+;;
+;; it is also adviced that you choose some common beginning for the
+;; identifier, so that they get sorted nicely. If you define variables
+;; at the beginning of file it might be good idea to attach beginning
+;; letter like `v-' for variables before the real identifier name
+;; begins, like:
+;;
+;; ............. v-globals ...
+;; ............... v-hooks ...
+;;
+;; Of course, we can now use the uppercase letter trick to have them
+;; sorted first in the list, just change `v-' to `V-'. Generally
+;; you should think which ones do you use most, do you leave the
+;; variables alone when you have defined them and mostly work with new
+;; functions? Then the variables can stay at the end of list and
+;; there is no need for `V-' trick. but if you need to access
+;; variables often, then you might want to see variables first in the
+;; list. It's up to your decision how you name the variables and how
+;; you want to see them listed.
+;;
+;; Breaks and sub-break naming
+;;
+;; If you have very large file, you'll probably need major breaks,
+;; level one breaks and possibly level 2 breaks too. To keep the list
+;; well sorted, put the functions into bigger groups and name the
+;; sub-level breaks so that they have some common beginning in respect
+;; to the major break they belong to. Let's see an example where
+;; you're dealing with mail handling. Notice the CAPITAL letter.
+;;
+;; ;; ################################# &h-Header ###
+;; ;; this is beginning block of header handling
+;;
+;; ;; ..................................... &h-cc ...
+;; ;; Some special function here to handle CC
+;; ;; field, killing all recipients, or only
+;; ;; some of them
+;;
+;; ;; .. .. . .. . .. . .. . .. . .. . .. . .. . .. .
+;; ;; More detailed functions under h-cc, Not
+;; ;; named, because there is only 2 small funcs
+;; ;; easily found.
+;;
+;; Again there are couple of points to follow here. All the tricks are
+;; discussed already: the `Big' letter trick put's major break to the
+;; top of imenu list, common beginning keeps the subsections together.
+;;
+;; Example breaks
+;;
+;; Some book mark breaks are proposed here, but you can use whatever you
+;; like. Thumb of rule: be consistent, always use same convention in
+;; your files and consider the "level of noisiness" of your breaks, so that
+;; they build up nicely and the code is easy to read. Too many
+;; _different_ breaks is not good idea, because they clutter the view
+;; fast, instead use variations on a theme: same break character but
+;; varying spaces and continuous character lengths.
+;;
+;; Thumb rule: select 1-3 break chars, and never change them in you
+;; files; your files look alike. Vary the spacing, not the break
+;; characters.
+;;
+;; These are 'noisy breaks' , Major section separators, pick only one
+;; and use it in your files, do not use all three!
+;;
+;; ##############################################################
+;; %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+;; ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
+;;
+;; less noisy breaks
+;;
+;; .`.`.`.`.`.`.`.`.`.`.`.`.`.`.`.`.`.`.`.`.`.`.`.`.`.`.`.`.`.`.`
+;;
+;; .^.^.^.^.^.^.^.^.^.^.^.^.^.^.^.^.^.^.^.^.^.^.^.^.^.^.^.^.^.^.^
+;;
+;; .:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:
+;; .~.~.~.~.~.~.~.~.~.~.~.~.~.~.~.~.~.~.~.~.~.~.~.~.~.~.~.~.~.~.~
+;;
+;;
+;; This is sub section break
+;;
+;; ................................................................
+;;
+;;
+;; This is even lighter subsection break (varying spacing)
+;;
+;; ... ... ... ... ... ... ... ... ... ... ... ... ...
+;;
+;; 'Draw one's attention' break: something special in this section
+;;
+;;
+;; --++-- --++-- --++-- --++-- --++-- --++-- --++-- --++-- --++--
+;;
+;; Internal break 1, inside function, long case statement etc.
+;;
+;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+;;
+;; Internal break 2, to separate long case elements etc.
+;;
+;;
+;; ^^^ ^^^ ^^^ ^^^ ^^^ ^^^ ^^^ ^^^ ^^^ ^^^ ^^^ ^^^ ^^^
+;;
+;; Book Mark cache
+;;
+;; So that imenu works fast, it is not desirable that the breaks are
+;; always parsed from scratch, because it takes time to scan the file
+;; for possible book marks. That's why the information is cached. If
+;; the break cache is empty, the breaks are gathered from buffer and
+;; stored to the cache and when you call the imenu, the cache is
+;; offered to it --> fast response time. When you add new breaks to
+;; the buffer [especially at the beginning of code development], you
+;; may want to call function `tinybookmark-parse' which will empty the
+;; cache and re-read all book marks. If you write lot of code the
+;; points that were cached do no longer represent exact points of book
+;; marks, because they have been sliding off their places. If you want
+;; *always* have updated book mark points, there is variable
+;; `tinybookmark-cache-update' which you can set to 'always, if you
+;; want the cache to be updated always prior showing X-menu. In large
+;; buffer this remarkably slows down the menu appering. See variable
+;; for more choices.
+;;
+;; Automatic book mark detection
+;;
+;; In order book marks to be detected in file, you may define following
+;; RCS identifier [see ident(1)] preferably at the beginning of your
+;; file:
+;;
+;; $BookMarkRegexp:<space>'REGEXP'<space>$
+;;
+;; Be careful so that the identifier is _exactly_ in this form: pay
+;; attention to spaces and (') around the REGEXP. The regular
+;; expression tells what line can be considered as book mark and the
+;; book mark name is indicated in subexpression 1 [\\(.*\\)] , look at
+;; this file, how it is constructed. In order to find all book marks
+;; and build up the cache, it needs to widen the buffer in case the
+;; file is narrowed with some folding or outline editor. When the
+;; cache has been built the buffer's narrowing is restored, so you
+;; shouldn't even notice this. Of course you don't want to find book
+;; marks from your RMAIL file.
+;;
+;; One word about the regexp construction, let's see regexp that
+;; matches the identifier:
+;;
+;; &+\\([^ ]+\\)
+;;
+;; Pay attention to using exclusive regexp, not just '.*'
+;; construction. When you use folding or outline editor the '.*' form
+;; is very ill behaving, because if the line being scanned is
+;; currently folded, IT WILL MATCH WHOLE folded section --> your
+;; identifier surely isn't that one. We can't unfold the sections
+;; during scanning, because if there are subfolds, what editor is on
+;; use .. it's too complex/slow to handle such situations. But using
+;; the exclusive list [^ ] will surely match the identifier, because
+;; it stops when it can find first space. This means that you can't
+;; use _spaces_ inside the identifiers. Cat the words together.
+;;
+;; If the BookMarkRegexp isn't defined in file
+;;
+;; Then the programs tries to search for the default book marks.
+;; See function `tinybookmark-regexp-default' for more.
+;;
+;; Message: Empty cache. Building...
+;;
+;; Do you wonder why you get this message displayed, while you were
+;; sure that you the buffer had cache already? Don't be surprised. This
+;; is totally normal behavior: whenever you switch mode for the
+;; buffer the new mode _kills_ all local variables, including cache
+;; information. Obviously the information must be restored when you
+;; call the hot list again. The cache could have been programmed to be
+;; buffer local, but in the present format only one cache s active at
+;; the time. This was simpler to implement and manage in the code.
+;;
+;; About imenu
+;;
+;; You definitely want to look at the documentation of imenu to find
+;; many more usages for it. It makes your day shine in X-display. You
+;; should also configure few variables for it, like:
+;;
+;; (setq imenu-max-items 20)
+;;
+;; Test run
+;;
+;; Load this file and set those key bindings mentioned. Hit the mouse
+;; bindings and you're running book mark package. Since the break
+;; marks are used in commentary also, the list of book marks are not
+;; in their most informative form, I use following convention to name
+;; book marks;
+;;
+;; 'v-' variable topic
+;; 't-' text topic
+;;
+;; Design thoughts
+;;
+;; Sooner or later someone wonders: "Can't we have sub-breaks listed
+;; nicely with indentation in front lines in X-popup?" Present answer
+;; "No", since it would require keeping track of the 'Main break' and
+;; then seeing if there exist sub-breaks. Immediately this leads to
+;; question "What is the main break?", and if we say main breaks start
+;; with "#|/%" character set we limit the use of breaks. Besides deciding
+;; what are sub-breaks, main-breaks with regexp may be too slow. Besides,
+;; the breaks are intended to to give an *overview* of the buffer.
+;; Please use imenu to find single functions if you don't feel like
+;; tapping couple of pgUp/pgDown after the point is positioned in the break
+;; section.
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+;;{{{ setup: require
+
+;;; ......................................................... &require ...
+
+(require 'tinylibm)
+
+(eval-and-compile
+ (autoload 'imenu--mouse-menu "imenu" "" t)
+ (autoload 'folding-show-current-entry "folding" "" t))
+
+(eval-when-compile (ti::package-use-dynamic-compilation))
+
+(ti::package-defgroup-tiny TinyBookmark tinybookmark-: tools
+ "Minor mode for writing text in 'Technical text format'.
+ Overview of features
+
+ o Provides some 'setting book marks' functions: adding
+ repeated characters and sequences up till end of line with
+ named identifier. (like breaks in this file)
+ o Automatically parses book marks from file, if it contains
+ RCS identifier 'book markRegexp' which defines book mark syntax for
+ the file. Uses X-popup [imenu] for showing those book marks and
+ moving between them.")
+
+;;}}}
+;;{{{ setup: -- hooks
+
+;;; ......................................................... &v-hooks ...
+
+(defcustom tinybookmark-:parse-before-hook nil
+ "*Hook that is run just before the buffer is scanned for book marks."
+ :type 'hook
+ :group 'TinyBookmark)
+
+(defcustom tinybookmark-:load-hook nil
+ "*Hook run when file is loaded."
+ :type 'hook
+ :group 'TinyBookmark)
+
+;;}}}
+;;{{{ setup: user configuration
+
+;;; ........................................................ &v-public ...
+
+(defcustom tinybookmark-:cache-update 'threshold
+ "*Method when to update cache.
+
+nil manual update -- you have to call `tinybookmark-parse'
+'always always update cache when menu displayed.
+'threshold update happens when buffer's total character change
+ exceeds previous value of `tinybookmark-:cache-threshold-val'."
+ :type '(choice
+ (const nil)
+ (const 'always)
+ (const 'threshold))
+ :group 'TinyBookmark)
+
+(defcustom tinybookmark-:cache-threshold-val 100
+ "*When cache is constructed, the total character count is saved.
+When user adds more code, the total count changes accordingly. If the
+difference between current count and last saved count gets bigger than
+this value the cache is re-read."
+ :type 'integer
+ :group 'TinyBookmark)
+
+(defcustom tinybookmark-:re-default-chars "[-~+=*%/|#.,'`^]"
+ "*Default book mark repeat chars."
+ :type 'string
+ :group 'TinyBookmark)
+
+(defcustom tinybookmark-:max-col '(progn (tinybookmark-calc-max-col))
+ "*Last column to extend the break.
+This can be FORM which evaluates to column number"
+ :type 'sexp
+ :group 'TinyBookmark)
+
+(defcustom tinybookmark-:trailer-space-len 3
+ "*How much space is left to the right before the book mark ID ends."
+ :type 'integer
+ :group 'TinyBookmark)
+
+(defcustom tinybookmark-:comment-start-func 'tinybookmark-comment-start
+ "*Function that return appropriate start comment.
+Must return empty string if comment not defined."
+ :type 'function
+ :group 'TinyBookmark)
+
+(defcustom tinybookmark-:comment-end-func 'tinybookmark-comment-end
+ "*Function that return appropriate end comment.
+Must return empty string if comment not defined."
+ :type 'function
+ :group 'TinyBookmark)
+
+(defcustom tinybookmark-:scan-filter-func 'tinybookmark-scan-filter
+ "*Filter out match.
+When building up the book marks from file, there may be false hits,
+or you may look at special lines only. This function accepts three arguments:
+- current line string
+- line beginning point
+- identifier found from line
+
+If the function return nil the line is not added to the cache."
+ :type 'function
+ :group 'TinyBookmark)
+
+(defcustom tinybookmark-:goto-func 'tinybookmark-goto
+ "*Function that handles moving to the point.
+If you have folding in effect around that point you may wish
+to open it in your custom function.
+
+This function receives one argument: POINT"
+ :type 'function
+ :group 'TinyBookmark)
+
+(defcustom tinybookmark-:insert-strict t
+ "*Controls if the book Mark insertion is strict when no argument is given.
+See `tinybookmark-insert'"
+ :type 'boolean
+ :group 'TinyBookmark)
+
+;;}}}
+;;{{{ setup: -- private vars
+
+;;; ....................................................... &v-private ...
+
+(defvar tinybookmark-:cache nil
+ "Private.
+Cache where book marks are stored in alist \(bookMarkName . point\)")
+(make-variable-buffer-local 'tinybookmark-:cache)
+
+;; We don't want cache to be wiped away when major mode changes
+(put 'tinybookmark-:cache 'permanent-local t)
+
+(defvar tinybookmark-:cache-char-count nil
+ "Private. Totals characters in buffer.")
+(make-variable-buffer-local 'tinybookmark-:cache-char-count)
+
+(defvar tinybookmark-:bookmark-regexp nil
+ "Private. Hold buffers book mark regexp.")
+(make-variable-buffer-local 'tinybookmark-:bookmark-regexp)
+
+;;}}}
+;;{{{ setup: -- version
+
+;;; ....................................................... &v-version ...
+
+(eval-and-compile
+ (ti::macrof-version-bug-report
+ "tinybookmark.el"
+ "tinybookmark"
+ tinybookmark-:version-id
+ "$Id: tinybookmark.el,v 2.42 2007/05/01 17:20:42 jaalto Exp $"
+ '(tinybookmark-:version-id
+ tinybookmark-:parse-before-hook
+ tinybookmark-:load-hook
+ tinybookmark-:cache
+ tinybookmark-:cache-char-count
+ tinybookmark-:bookmark-regexp
+ tinybookmark-:cache-update
+ tinybookmark-:cache-threshold-val
+ tinybookmark-:max-col
+ tinybookmark-:trailer-space-len
+ tinybookmark-:comment-start-func
+ tinybookmark-:comment-end-func
+ tinybookmark-:scan-filter-func
+ tinybookmark-:goto-func
+ tinybookmark-:insert-strict
+ tinybookmark-:re-default-chars)))
+
+;;}}}
+
+;;; ########################################################## ¯os ###
+
+;;{{{ Macros
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinybookmark-regexp-read-from-buffer ()
+ "Return buffer's book mark regexp.
+If the local value where the regexp is stored is nil, the rescan buffer.
+
+References:
+ `tinybookmark-:bookmark-regexp'"
+ (or tinybookmark-:bookmark-regexp ;changing mode kill local vars
+ (setq tinybookmark-:bookmark-regexp
+ (tinybookmark-search-bm-re))))
+
+;;; ----------------------------------------------------------------------
+;;; Default book mark syntax that is used if file does not contain
+;;; it's own definition of book mark syntax.
+;;;
+(defsubst tinybookmark-regexp-default ()
+ "Return default book mark regexp.
+References:
+ `tinybookmark-:re-default-chars'"
+ (concat
+ tinybookmark-:re-default-chars
+ tinybookmark-:re-default-chars "+"
+ " &+\\([^ \t]+\\) "
+ tinybookmark-:re-default-chars "+"))
+
+;;}}}
+
+;;; ########################################################### &Funcs ###
+
+;;{{{ movement functions
+
+;;; ........................................................ &movement ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinybookmark-search-regexp ()
+ "Return book mark search regexp."
+ (concat "^[ \t]*" (or comment-start "") "+ *"
+ (tinybookmark-regexp-read-from-buffer)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinybookmark-backward ()
+ "Search book mark line backward."
+ (interactive)
+ (re-search-backward (tinybookmark-search-regexp) nil t))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinybookmark-forward (&optional back)
+ "Search book mark line forward or optionally BACK."
+ (interactive)
+ (re-search-forward (tinybookmark-search-regexp) nil t))
+
+;;}}}
+
+;;{{{ miscellaneous functions
+
+;;; ............................................................ &misc ...
+
+;;; ----------------------------------------------------------------------
+;;; LISP column
+;;; - I can hear you saying: "Why 74? why not 70 or 75 ?..."
+;;; - Well, I usually add book mark section to my elisp code and while
+;;; I did them by hand I added ';;; ' comment at the beginning of
+;;; line and fed 70 continuous characters with ESC 70 '-'after
+;;; comment --> totals 4 + 70 chars :-/
+;;;
+;;; - The idea of this calculation is that when you hit separator,
+;;; like this: COMMENT-SPACE-70_CHAR_SEPARATOR, this will calculate
+;;; the column so, that when tinybookmark-insert is called, the last
+;;; char lines up with yours.
+;;;
+;;; E.g. in shell mode:
+;;;
+;;; # ---------------, 70 chars long sep, last col is 2 + 70
+;;; # ..............., tinybookmark-insert lines up to col 72
+;;;
+;;; But in lisp
+;;;
+;;; ;;; -------------, again 70 chars long sep, 4 + 70
+;;; ;;; ............., tinybookmark-insert lines up to col 74
+;;;
+;;; Now you can hit 70 line separator in any mode and to be sure the
+;;; tinybookmark-insert lines up with you.
+;;;
+(defun tinybookmark-calc-max-col ()
+ "Calculates column for mode."
+ (let* ((mode (symbol-name major-mode))
+ (cs (or comment-start ""))
+ (def-len 70)) ; like "# " + 70 chars
+ (cond
+ ((string-match "lisp" mode)
+ 74)
+ (t
+ (if (string-match "[ \t]+" cs) ;does it already have space "# "
+ (+ def-len (length cs)) ;no it does not "#", add room for it.
+ (1+ (+ def-len (length cs))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinybookmark-goto (point)
+ "Go to the selected POINT."
+ (let* ((re ".*{{{"))
+ (cond
+ ((and (featurep 'folding)
+ (symbol-value 'folding-mode))
+ (goto-char point)
+ (save-excursion
+ (beginning-of-line)
+ (if (looking-at re)
+ (folding-show-current-entry))))
+ (t
+ (goto-char point)))))
+
+;;; ----------------------------------------------------------------------
+;;; - include all lines
+;;;
+(defun tinybookmark-scan-filter (full-line pos id)
+ "Return always t, so all matched lines are cached.
+Ignore FULL-LINE POS ID."
+ t)
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinybookmark-comment-end ()
+ "Return appropriate comment end, according to mode."
+ (let* ((str (or comment-end "")))
+ (unless (equal "" str)
+ (setq str (ti::string-add-space str)))
+ str))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinybookmark-comment-start ()
+ "Return appropriate comment, according to mode."
+ (let* ((str (or comment-start ""))) ;comment
+ ;; Lisp is special, due to it's comment usage
+
+ (when (memq major-mode '(lisp-mode emacs-lisp-mode lisp-interaction-mode))
+ (if (bolp)
+ (setq str ";;;")
+ (setq str ";;")))
+ (unless (equal "" str)
+ (setq str (ti::string-add-space str t)))
+ str))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinybookmark-cache-update ()
+ "Determines when and how to update cache.
+References: `tinybookmark-cache-update'"
+ (let* ((mode tinybookmark-:cache-update)
+ (end (marker-position (point-max-marker)))
+ (cache-end (or tinybookmark-:cache-char-count end))
+ (limit tinybookmark-:cache-threshold-val)
+ diff)
+ (cond
+ ((eq mode nil)
+ nil) ;manual
+
+ ((eq mode 'always)
+ (tinybookmark-parse))
+
+ ((eq mode 'threshold)
+ (setq diff (abs (- end cache-end)))
+;;; (ti::d! diff limit end cache-end )
+ (if (< diff limit) nil
+ ;; Hmm, should we print a message "threshold exceeded, reparsing..?"
+ ;; Let's be transparent this time: no messages.
+;;; (ti::d! "reparsing..")
+ (tinybookmark-parse))))))
+
+;;}}}
+;;{{{ book mark line insert
+
+;;; ##################################################### &bookmarkAdd ###
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinybookmark-repeat (str count &optional col strict)
+ "Repeats character or string sequence STR COUNT times.
+
+COUNT can be:
+
+ 0 repeat until position 79 or COL , or if the STR is not single
+ character, until fits below COL
+ \"\" interactive insert, as long as user presses RET or SPACE.
+
+STRICT has effect only if COL is given:
+
+ nil insert as long as STR fits below COL
+ t insert strictly up till COL and cut away portion
+ of STR if necessary"
+
+ (interactive "sString:\nsCount[0=eol]: ")
+
+ (let* ((swide (or col 79)) ;screen width
+ (i 0)
+ (ok t)
+ ch
+ c
+ len
+ p)
+
+ (if (or (not (stringp str)) ;it's not string
+ (eq 0 (length str))) ;string is empty
+ (throw 'done nil))
+
+ (cond
+ ((stringp count)
+ (if (equal "" count)
+ (setq c -1) ;interactive
+ (setq c (string-to-int count))))
+ ((numberp count)
+ (setq c count))
+ (t
+ (error "Invalid count arg" count)))
+
+;;; (ti::d! "c-val" c)
+
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... ... ... ... ...
+ (cond
+ ((eq c -1) ;ask confirmation every time...
+ (while ok
+ (message "insert? <spc,enter> ") (setq ch (read-char))
+ (cond
+ ((or (char= ch ?\C-m ) (char= ch ?\ ))
+ (insert str))
+ (t (setq ok nil))))
+ (message ""))
+
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... ... ... ... ...
+
+ ((eq c 0)
+
+ (setq len (length str)
+ p (current-column))
+
+ ;; we have to remove tabs from this line to get count right
+
+ (untabify (line-beginning-position) (line-end-position))
+ (move-to-column p) ;restore position
+
+ ;; the added str must not move point further than COL
+
+ (while (<= (+ len (current-column)) swide)
+ (insert str))
+
+;;; (ti::d! "c-val 0" (current-column) swide)
+
+ ;; Check if it was multicharacter and we didn't get to last position
+ ;; Insert the last string and cut after COL
+
+ (if (null strict) nil
+ (if (= (current-column) swide) nil
+ (insert str)
+ (ti::buffer-move-to-col swide)
+ (delete-region (point) (progn (end-of-line) (point))))))
+
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... ... ... ... ...
+ (t ;straight number !
+ (while (< i c)
+ (insert str) (setq i (1+ i)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinybookmark-insert (txt sep &optional strict)
+ "Add book mark until the end of line.
+Normally line is filled as long as the pattern fits below max column,
+but if the optional argument is given, it will be filled in _full_ ,
+truncating if necessary. To see an example, try with some _long_
+pattern.
+
+Input:
+
+ TXT book mark name
+ SEP separator string that is repeated.
+ STRICT
+ 0 strict is nil in spite of `tinybookmark-:insert-strict'
+ 1 strict is t in spite of `tinybookmark-:insert-strict'
+ nil use default value in `tinybookmark-:insert-strict'
+
+References:
+
+ `tinybookmark-:insert-strict'"
+ (interactive "sBookmark: \nsSep: \nP")
+ (let* (
+ (strict-def tinybookmark-:insert-strict)
+ (cs-func tinybookmark-:comment-start-func)
+ (ce-func tinybookmark-:comment-end-func)
+ (line-col (eval tinybookmark-:max-col))
+ (trail-len tinybookmark-:trailer-space-len) ;how much to leave
+ (bolp (line-beginning-position))
+ (cur-col (current-column))
+ (orig-point (+ bolp cur-col))
+ col
+ cs
+ ce)
+
+ (cond
+ ((eq nil strict) ;use default
+ (setq strict strict-def))
+
+ ((eq 0 strict)
+ (setq strict nil))
+
+ ((eq 1 strict)
+ (setq strict t))) ;; cond end
+
+ (if (= 0 (length sep))
+ (error "No separator"))
+
+ ;; Add surrounding spaces if they are not included
+
+ (unless (equal "" txt)
+ (setq txt (ti::string-add-space txt)
+ txt (ti::string-add-space txt t)))
+
+ (setq cs (funcall cs-func) ;Set comments
+ ce (funcall ce-func))
+
+ ;; I tried to turn overwrite-mode on, but SUPRISE!
+ ;; - While it was on, and I tried to do 'insert',
+ ;; it didn't _overwrite_; emacs why can't you behave as expected ?
+ ;; - So I have to hack with delete-region instead.
+
+ ;; - skip lenght of comment start
+
+ (ti::buffer-move-to-col (+ cur-col (length cs)))
+
+ ;; We must clear the rest of line
+
+ (unless (looking-at "$")
+ (delete-region (point) (line-end-position)))
+
+ ;; - draw the line until max col
+
+ (setq col line-col) ;maximum repeat column
+
+ (tinybookmark-repeat sep 0 col strict) ;insert full separator
+
+ ;; - Now cut room for identifier
+
+ (backward-char (+ (length txt) trail-len)) ;leave trailer space
+ (delete-region (point) (+ (point) (length txt)))
+
+ ;; - write the identifier
+
+ (insert txt)
+ (end-of-line)
+ (insert ce) ;comment end
+
+ ;; - delete spaces at front and replace it with comment start
+
+ (goto-char orig-point)
+ (delete-region (point) (+ (point) (length cs)))
+ (insert cs)
+
+ (goto-char orig-point)))
+
+;;}}}
+;;{{{ Book Mark find, cacheing
+
+;;; #################################################### &bookmarkScan ###
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinybookmark-scan (re)
+ "Gather all book marks from current point forward using RE.
+Return list: (id . beginning-of-line-point).
+
+References:
+ `tinybookmark-:scan-filter-func'"
+ (let* ((func tinybookmark-:scan-filter-func) ;should we filter something ?
+ id
+ p
+ list)
+
+ (while (re-search-forward re nil t)
+;;; (ti::d! (match-string 1) (ti::read-current-line))
+ (when (setq id (match-string 1))
+ (setq p (line-beginning-position))
+ ;; Is this line allowed to add ?
+ (if (funcall func (ti::read-current-line) id p)
+ ;; Nothing magic in this expression, just build list
+ ;; '((id point) (id .point) ..)
+ (ti::nconc list (cons id p)))))
+ list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinybookmark-search-bm-re ()
+ "Search buffer for automatic book mark identifier 'BookMarkRegexp'.
+Returns regexp defined in it. if is doesn't exist returns default
+book mark regexp."
+ (let* ((id "BookMarkRegexp")
+ (re-default (tinybookmark-regexp-default))
+ id-val
+ fixed-val
+ ret)
+ (setq id-val (ti::vc-rcs-str-find-buffer id t))
+ ;; while reading from buffer the \ doubles, convert it back to \
+ (setq fixed-val (ti::string-plain-string-to-regexp id-val))
+
+ (if (or (null fixed-val)
+ ;; We must find the '' marks
+ (not (string-match "'\\(.+\\)'" fixed-val)))
+ (setq ret re-default)
+ (setq ret (match-string 1 fixed-val)))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinybookmark-parse ()
+ "Build book mark list and save it to cache.
+
+Return:
+
+ t cache was built.
+ nil book marks not found or error happened. Cache untouched."
+ (interactive)
+ (let* ((op (point)) ;user's original point
+ (beg (point-min-marker))
+ (end (point-max-marker))
+ (end-pos (marker-position (point-max-marker)))
+ (end-max (point-max))
+ end-wmax
+ re
+ ret
+ list)
+
+ (run-hooks 'tinybookmark-:parse-before-hook)
+ (setq tinybookmark-:cache-char-count end-pos) ;<< GLOBAL
+
+ (if (null (setq re (tinybookmark-regexp-read-from-buffer)))
+ (message "TinyBookmark: No book mark syntax Identifier found.")
+ (unwind-protect ;handle narrowed buffers too
+ (progn
+ (widen)
+ (setq end-wmax (point-max))
+ (ti::pmin)
+ (setq list (tinybookmark-scan re))
+ (if (null list)
+ (message "TinyBookmark: No book marks found.")
+ (setq ret t)
+ (setq tinybookmark-:cache list)))
+ (save-excursion
+ (set-buffer (marker-buffer beg))
+ ;; what about after widen ? Were we in narrow mode ?
+ (unless (= end-wmax end-max)
+ (narrow-to-region beg end)))))
+ ;; only reasonable way to return to current point
+ (goto-char op)
+ ret))
+
+;;}}}
+;;{{{ mouse
+
+;;; ################################################### &mouseHandling ###
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinybookmark-keyboard-parse ()
+ "Reparse book marks."
+ (tinybookmark-mouse-parse nil (interactive-p)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinybookmark-mouse-parse (&optional event verb)
+ "Reparse book mark list. This function is called from mouse binding.
+Called with mouse EVENT. VERB displays message."
+ (interactive "e")
+ (ti::verb)
+ (if (and verb (tinybookmark-parse))
+ (message "TinyBookmark: Book Marks cached.")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinybookmark-selection (event)
+ "Display cache menu. Called with mouse EVENT."
+ (interactive "e")
+ (let* ((go-func tinybookmark-:goto-func)
+ cache
+ data)
+
+ (tinybookmark-cache-update)
+ (setq cache tinybookmark-:cache)
+
+ (if (null cache)
+ (message "TinyBookmark: No book marks found.")
+ (cond
+ ((ti::compat-window-system)
+ (setq data (imenu--mouse-menu cache event)))
+ (t
+ (setq data (completing-read "Select: " cache))
+ (setq data (assoc data cache))))
+
+ (if data
+ (funcall go-func (cdr data))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinybookmark-cache-regenerate (&optional force)
+ "Regenerate cache if needed. Optional FORCE."
+ (let* ((cache-ok tinybookmark-:cache))
+ (when (or (null cache-ok)
+ force)
+ (message "TinyBookmark: building cache...")
+ (sleep-for 1)
+ (message "")
+ (tinybookmark-parse))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinybookmark-keyboard (bookmark &optional arg)
+ "Complete and jump to bookmarks.
+Optional ARG rebuilds cache."
+ (interactive
+ (progn
+ (if current-prefix-arg
+ (tinybookmark-cache-regenerate t))
+ (let* ((ans (completing-read "TinyBookmark: "
+ tinybookmark-:cache nil 'match)))
+ (list ans
+ current-prefix-arg))))
+ (unless (interactive-p)
+ (tinybookmark-cache-regenerate arg))
+ (let* ((elt (assoc bookmark tinybookmark-:cache)))
+ (if (not elt)
+ (message
+ (substitute-command-keys
+ (concat
+ "TinyBookmark: ERROR, rebuild with "
+ "\\[universal-argument] \\[tinybookmark-keyboard]")))
+ (goto-char (cdr elt)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinybookmark-mouse (event &optional arg)
+ "Display book mark pop up menu. Use mouse EVENT.
+Optional ARG rebuilds cache."
+ (interactive "e\nP")
+ (tinybookmark-cache-regenerate arg)
+ (tinybookmark-selection event))
+
+;;}}}
+
+(provide 'tinybookmark)
+(run-hooks 'tinybookmark-:load-hook)
+
+;;; tinybookmark.el ends here
--- /dev/null
+;;; tinybuffer.el --- Change buffers in current window.
+
+;; This file is not part of Emacs.
+
+;;{{{ Id
+
+;; Copyright (C) 1996-2007 Jari Aalto
+;; Keywords: extensions
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program, call M-x tinybuffer-version.
+;; Look at the code with folding.el
+
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;; ....................................................... &t-install ...
+;; Add following statement(s) to your ~/.emacs
+;;
+;; (require 'tinybuffer)
+;;
+;; or use autoload and your ~/.emacs starts lot faster. Preferred method.
+;;
+;; (autoload 'tinybuffer-iswitch-to-buffer "tinybuffer.el" "" t)
+;; (autoload 'tinybuffer-previous-buffer "tinybuffer.el" "" t)
+;; (autoload 'tinybuffer-next-buffer "tinybuffer.el" "" t)
+;; (autoload 'tinybuffer-sort-mode-toggle "tinybuffer.el" "" t)
+;;
+;; You don't need to copy these if you used the `require', but in order
+;; to trigger autoload you must insert these into your ~/.emacs. These
+;; are also the defaults bindings. If you use something other that these,
+;; reset the `tinybuffer-:load-hook' too.
+;;
+;; (defconst tinybuffer-:load-hook nil) ;; Don't load default bindings.
+;;
+;; ;; If you use Emacs with X window, these could be suitable keys.
+;;
+;; (global-set-key [(control <)] 'tinybuffer-previous-buffer)
+;; (global-set-key [(control >)] 'tinybuffer-next-buffer)
+;; (global-set-key [(control meta <)] 'tinybuffer-iswitch-to-buffer)
+;; (global-set-key [(alt <)] 'tinybuffer-sort-mode-toggle)
+;;
+;; ;; For non-windowed emacs; you want to program your own keys
+;; ;; Please check C-h l `view-lossage' for your keybindings, these
+;; ;; examples are from HP-UX numpad:
+;;
+;; (global-set-key "\eOq" 'tinybuffer-previous-buffer) ;; numpad 1
+;; (global-set-key "\eOr" 'tinybuffer-sort-mode-toggle) ;; numpad 2
+;; (global-set-key "\eOs" 'tinybuffer-next-buffer) ;; numpad 3
+;;
+;; ;; Here is code to switch between all visible windows
+;;
+;; (global-set-key [(f5)]
+;; (ti::definteractive ; in tinylibm.el
+;; (other-window 1 t)
+;; (raise-frame (window-frame
+;; (get-buffer-window
+;; (current-buffer))))))
+;;
+;; If you have any questions, use this function to contact author
+;;
+;; M-x tinybuffer-submit-bug-report
+
+;;}}}
+;;{{{ Documentation
+
+;; ..................................................... &t-commentary ...
+
+;;; Commentary:
+
+;;
+;; Preface, May 1996
+;;
+;; With this small package you can switch to next or previous buffer
+;; in a current window. If you only have small amount of buffers in
+;; `buffer-list', this may be the fastest way to select a working
+;; buffer. In the other hand, if you have more than 20 working
+;; buffers, I'd recommend that you use exellent substring buffer
+;; switching utility instead: *iswitchb.el* which is included in
+;; standard Emacs distribution
+;;
+;; If you have windowed environment and want to have hot list of your
+;; permanent buffers available, use *imenu.el* or *tinyhotlist.el* and
+;; you can select RMAIL; GNUS; VM; *scratch* buffers instantly.
+;;
+;; Description
+;;
+;; If you don't want default bindings, clear the installation with
+;; following command. This must be prior the 'require statement.
+;;
+;; (setq tinybuffer-:load-hook nil)
+;;
+;; To change buffers forward or backward, the default setup would install
+;; following key bindings:
+;;
+;; o Control-> Next buffer
+;; o Control-< Previous buffer
+;; o Alt-Control-< Iswitch mode, where you can scroll with < and >.
+;; Press RET to select or ESC/q to quit
+;; This may come handy if you have many buffers and just want to
+;; skip 2-5 buffers fast. E.g. if the buffers are font-lock
+;; controlled, switching to them with the C-, and C-, keys might
+;; be slow due to fontification which happens every time you
+;; switch over a buffer.
+;;
+;; In iswitch mode, the command prompt looks like following. The
+;; mode name is put last if buffer has and associated file name,
+;; so that filename gets as much display as possible.
+;;
+;; "TinyIswitch: my-lisp.el ~/elisp/my-lisp.el <Emacs lisp>"
+;; "TinyIswitch: test <dired> ~/tmp/test"
+;; "TinyIswitch: *Messages* <fundamental-mode>"
+;;
+;; Have a look at `tinybuffer-:ignore-regex' which you can configure
+;; to ignore some buffers permanently.
+;;
+;; Thanks
+;;
+;; Original idea for this package comes from *yic-buffer.el*
+;; by choo@cs.yale.edu (young-il choo) 1990-08-07.
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+;;; ......................................................... &require ...
+
+(require 'tinylibm)
+
+(eval-when-compile (ti::package-use-dynamic-compilation))
+
+(ti::package-defgroup-tiny TinyBuffer tinybuffer-: extensions
+ "Changing buffers in current window.
+ With this small package you can switch to next or previous buffer
+ in a current window. If you only have small amount of buffers
+ it may be the fastest way.")
+
+;;{{{ setup: -- variables
+
+;;; ........................................................ &v-public ...
+;;; User configurable
+
+(defcustom tinybuffer-:load-hook '(tinybuffer-install-default-bindings)
+ "*Hook run when file has been loaded.
+Default value contains function `tinybuffer-install-default-bindings'."
+ :type 'hook
+ :group 'TinyBuffer)
+
+(defcustom tinybuffer-:ignore-regexp
+ (concat
+ "^ " ;hidden buffers
+ "\\|completion\\|summary"
+ "\\|buffer list\\|help\\|ispell\\|abbrev"
+ "\\|temp\\|tmp\\|vc\\|compile-log\\|occur")
+ "*Buffers to ignore when changing to another."
+ :type 'regexp
+ :group 'TinyBuffer)
+
+(defcustom tinybuffer-:sort-flag nil
+ "*Non-nil means that buffers are switched in sorted order."
+ :type 'boolean
+ :group 'TinyBuffer)
+
+(defcustom tinybuffer-:iswitch-to-buffer-keys '(?< ?>)
+ "*Keys to scroll buffers backward and forward in iswitch mode.
+See \\[tinybuffer-iswitch-to-buffer]."
+ :type '(list
+ (character :tag "Backward")
+ (character :tag "Forward"))
+ :group 'TinyBuffer)
+
+(defcustom tinybuffer-:iswitch-show-directory-flag t
+ "*Non-nil means that directory name is shown in iswitch mode.
+See \\[tinybuffer-iswitch-to-buffer]."
+ :type 'boolean
+ :group 'TinyBuffer)
+
+;;; ....................................................... &v-private ...
+;;; Internal variables
+
+(defvar tinybuffer-:buffer-list nil
+ "Global buffer list for `tinybuffer-iswitch-to-buffer'.")
+
+;;; ....................................................... &v-version ...
+
+;;;###autoload (autoload 'tinybuffer-version "tinybuffer" "Display commentary." t)
+(eval-and-compile
+ (ti::macrof-version-bug-report
+ "tinybuffer.el"
+ "tinybuffer"
+ tinybuffer-:version-id
+ "$Id: tinybuffer.el,v 2.41 2007/05/01 17:20:42 jaalto Exp $"
+ '(tinybuffer-:version-id
+ tinybuffer-:load-hook
+ tinybuffer-:ignore-regexp
+ tinybuffer-:sort-flag
+ tinybuffer-:iswitch-to-buffer-keys
+ tinybuffer-:iswitch-show-directory-flag
+ tinybuffer-:buffer-list)))
+
+;;}}}
+;;{{{ code: functions
+
+;;; ########################################################### &Funcs ###
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinybuffer-install-default-bindings ()
+ "Define default global keys."
+ (interactive)
+ (global-set-key [(control <)] 'tinybuffer-previous-buffer)
+ (global-set-key [(control >)] 'tinybuffer-next-buffer)
+ (global-set-key [(control meta <)] 'tinybuffer-iswitch-to-buffer)
+ (global-set-key [(control meta >)] 'tinybuffer-sort-mode-toggle))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinybuffer-start-list (buffer-pointer list)
+ "Let BUFFER-POINTER be first and arrange LIST."
+ (let* ((start (memq buffer-pointer list))
+ (rev (reverse list))
+ before
+ ret)
+ ;; Basic idea is this, say pointer is at B
+ ;; list: A B C D
+ ;; start: B C D
+ ;; rev D C B A
+ ;; before B A --> take cdr --> A
+ ;;
+ ;; ret start + before = B C D A
+ ;;
+ (unless start
+ (error "No such elt in list %s" buffer-pointer))
+ (setq before (cdr-safe (memq buffer-pointer rev)))
+ (setq ret start)
+ (if before
+ (union (reverse start) before))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinybuffer-buffer-filter (&optional blist)
+ "Filter BLIST, which defaults to `buffer-list'.
+References:
+ `tinybuffer-:ignore-regexp'"
+ (let* (ret)
+ (dolist (elt (or blist (buffer-list)) )
+ (if (not (string-match tinybuffer-:ignore-regexp
+ (buffer-name elt)))
+ (push elt ret)))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinybuffer-sort-buffer-list-1 (&optional blist reverse)
+ "Sort BLIST, which defaults to `buffer-list'. Optionally REVERSE."
+ (let* ((list (or blist (buffer-list))))
+ (setq
+ list
+ (if reverse
+ (sort list
+ (function
+ (lambda (a b)
+ (string< (buffer-name b) (buffer-name a)))))
+ (sort list
+ (function
+ (lambda (a b)
+ (string< (buffer-name a) (buffer-name b)))))))
+ list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinybuffer-sort-buffer-list (&optional reverse blist)
+ "Sort buffer list, optionally REVERSE and use BLIST."
+ (let* (sorted
+ part
+ list)
+ (setq sorted (tinybuffer-sort-buffer-list-1 blist reverse))
+
+ ;; What is this? Okay, you see, when we sort the buffer list...
+ ;; A B C D E F G
+ ;; ^
+ ;; ############# 'sorted' holds all
+ ;; %%%%%%% 'part' contains only these
+ ;;
+ ;; We're currently in C, and next one must be D. But if we're
+ ;; at the end, we're in G, and no buffers follow.
+ ;;
+ ;; So, to get past G, we have to make list in following way:
+ ;;
+ ;; @@@@@@ = %%%%% ############
+ ;; list = 'part' + 'sorted
+ ;;
+ ;; Sure, there is redundancy, since the 'sorted' holds all elements,
+ ;; but since we actually ignore buffers in the moving loop, we need
+ ;; all buffers past G.
+
+ (when (setq part (memq (current-buffer) sorted))
+ (setq list (cdr part))
+ (ti::nconc list sorted))
+ sorted))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinybuffer-buffer-list-next (&optional reverse)
+ "Switch to next buffer in list, skipping unwanted ones. Optionally REVERSE.
+See variable `tinybuffer-:ignore-regexp'."
+ (let* ((re tinybuffer-:ignore-regexp)
+ list go)
+ (cond
+ (tinybuffer-:sort-flag
+ (setq list (tinybuffer-sort-buffer-list reverse)))
+ (reverse
+ (setq list (reverse (buffer-list))))
+ (t
+ (setq list (buffer-list))))
+
+ (setq list (delq (current-buffer) list))
+
+ (dolist (buffer list)
+ (unless (string-match re (buffer-name buffer))
+ (setq go buffer) ;Stop and select it
+ (return)))
+
+ (if (null go)
+ (message
+ "TinyBuffer: No buffers to circulate; see `tinybuffer-:ignore-regexp'"))
+
+ (if go
+ (switch-to-buffer go))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinybuffer-init-buffer-list ()
+ "Initialize global variable `tinybuffer-:buffer-list'."
+ (let* ((list (tinybuffer-buffer-filter)))
+ (if tinybuffer-:sort-flag
+ (setq list (tinybuffer-start-list
+ (current-buffer)
+ (tinybuffer-sort-buffer-list-1 list))))
+ (setq tinybuffer-:buffer-list list)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro tinybuffer-iswitch-next ()
+ "Return next buffer in list."
+ (`
+ (let* ((first (car tinybuffer-:buffer-list))
+ (rest (cdr tinybuffer-:buffer-list))
+ (ret (car rest)))
+ (setq list rest)
+ (ti::nconc list first) ;add to the end
+ (setq tinybuffer-:buffer-list list) ;update list
+ ret)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro tinybuffer-iswitch-previous ()
+ "Return previous buffer in list."
+ (`
+ (let* ((rev (reverse tinybuffer-:buffer-list))
+ (last (car rev))
+ (rest (reverse (cdr rev)))
+ (ret last))
+ (setq list rest)
+ (push last list) ;add to the end
+ (setq tinybuffer-:buffer-list list) ;update list
+ ret)))
+
+;;}}}
+;;{{{ code: interactive
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinybuffer-iswitch-to-buffer ()
+ "Switch to buffer when RETURN/SPACE/TAB pressed.
+Show buffer at echo area. ESC to cancel prompt.
+
+Note:
+
+ The startup time of calling this function may be high, because it has
+ to build list of choices and possibly filter out unwanted buffers.
+
+References:
+
+ `tinybuffer-:iswitch-to-buffer-keys' keys to scroll buffer list"
+ (interactive)
+ (let* ((keys tinybuffer-:iswitch-to-buffer-keys)
+ (show-dir tinybuffer-:iswitch-show-directory-flag)
+ (go-list '(?\C-m ?\t ?\ ?\e ?\q ?\Q))
+ (quit-list '(?\e ?\q ?\Q))
+ (key-back (nth 0 keys))
+ (key-fw (nth 1 keys))
+ (str (buffer-name))
+ (loop t)
+ dir
+ fmt
+ list
+ buffer
+ mode
+ ch)
+
+ (tinybuffer-init-buffer-list)
+
+ (while loop
+
+ (setq mode
+ (with-current-buffer (get-buffer str)
+ (cond
+ ((eq major-mode 'dired-mode)
+ (format "<dired> %s"
+ (symbol-value 'dired-directory)))
+ (t
+ (format "<%s>" (symbol-name major-mode))))))
+
+ (when show-dir
+ (setq dir (or (buffer-file-name (get-buffer str))
+ nil)))
+
+ ;; This formats the line so that it is visually more pleasant
+ ;; to read. If the file and dir are sticked together, it's
+ ;; hard to distinguish the words.
+ ;;
+ ;; FILE DIR
+
+ (setq fmt
+ (if (and str (< (+ (length str) (length dir)) 55))
+ "TinyIswich: %-20s %s %s"
+ "TinyIswich: %s %s %s"))
+
+ (unless dir
+ (setq dir mode
+ mode nil))
+
+ (setq ch (ti::read-char-safe-until
+ (format fmt str (or dir "") (or mode "" ))))
+
+;;; (ti::d! str buffer (char= ch key-back) (char= ch key-fw) go-list)
+
+ (cond
+ ((and ch (char= ch key-back))
+ (setq buffer (tinybuffer-iswitch-previous)))
+ ((and ch (char= ch key-fw))
+ (setq buffer (tinybuffer-iswitch-next)))
+ ((and ch (ti::char-in-list-case ch go-list))
+ (setq loop nil)))
+
+ (if buffer
+ (setq str (buffer-name buffer))))
+
+ (if (and ch
+ buffer
+ (not (ti::char-in-list-case ch quit-list)))
+ (switch-to-buffer buffer))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinybuffer-previous-buffer ()
+ "Switch to previous buffer in current window."
+ (interactive)
+ (tinybuffer-buffer-list-next 'reverse))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinybuffer-next-buffer ()
+ "Switch to the other buffer (2nd in list-buffer) in current window."
+ (interactive)
+ (bury-buffer (current-buffer))
+ (tinybuffer-buffer-list-next))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinybuffer-sort-mode-toggle ()
+ "Sort mode on/off."
+ (interactive)
+ (setq tinybuffer-:sort-flag (not tinybuffer-:sort-flag))
+ (message (concat "TinyBuffer: sort mode "
+ (if tinybuffer-:sort-flag
+ "on"
+ "off"))))
+
+;;}}}
+
+(provide 'tinybuffer)
+(run-hooks 'tinybuffer-:load-hook)
+
+;;; tinybuffer.el ends here
--- /dev/null
+;;; tinycache.el --- Maintain a cache of visited files [compile,dired]
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 1996-2007 Jari Aalto
+;; Keywords: extensions
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program, call M-x tinycache-version.
+;; Look at the code with folding.el
+
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;; Put this file on your Emacs-Lisp load path, add following into
+;; ~/.emacs startup file:
+;;
+;; (add-hook tinycache-:load-hook 'tinycache-install-msb)
+;; (require 'tinycache)
+;;
+;; Or use quicker autoload:
+;;
+;; (add-hook tinycache-:load-hook 'tinycache-install-msb)
+;; (eval-after-load "compile" '(progn (require 'tinycache)))
+;; (eval-after-load "dired" '(progn (require 'tinycache)))
+;;
+;; If you use *gnuserv.el*, be sure that to load the packages in order:
+;; gnuserv, tinycache.
+;;
+;; To disable this package:
+;;
+;; M-x tinycache-uninstall
+;;
+;; If you have any questions, use this function
+;;
+;; M-x tinycache-submit-bug-report
+
+;;}}}
+;;{{{ Documentation
+
+;;; Commentary:
+
+;; Preface, overview of features
+;;
+;; This package is meant to be used with `dired' and compilation
+;; buffers. When you load file from either one, the file is
+;; "remembered". This way you can browse bunch of files easily and
+;; when you have finished you can flush the cache and get rid of all
+;; vieved files.
+;;
+;; Dired description
+;;
+;; When you load a file from dired with `dired-view-file', the
+;; file is remembered. You can load several files for viewing and when you
+;; have finished, call `tinycache-flush' (Defaults to `C-c' `k' in
+;; dired) to remove all the remembered (cached) files from emacs.
+;;
+;; This way you don't end up having files that you're not interested
+;; in any more. Using the cache makes browsing bunch of files very
+;; easy. Each dired buffer has it's own cache. The cache is also
+;; flushed if you kill the dired buffer.
+;;
+;; Compilation cache description
+;;
+;; Maintain also a cache of buffers visiting files via the
+;; `next-error' and `compile-goto-error' commands; each compile/grep
+;; buffer has its own cache. To kill the cached buffers manually, use
+;; `C-c' `C-d' (compile-flush-cache) in the compile/grep buffer;
+;; deleting the compile/grep buffer automatically kills the cached
+;; buffers. To disable the cache, set `compilation-find-file-cache'
+;; to a non-list value (e.g. 'disable).
+;;
+;; After loading this file, every file that is loaded by calling some
+;; compile function, i.e. `compile-goto-error', is cached if it is not
+;; in emacs already. I.e. when you fix some small errors in other
+;; files, you may not want to keep those files in emacs after you've
+;; done; remember, those got loaded during the calls to
+;; compile-goto-error. The easiest way to get rid of these extra
+;; files, that were not originally in emacs, is to:
+;;
+;; A. kill compilation buffer, C-x k *compilation*
+;; B. Call M-x tinycache-flush directly
+;;
+;; See *igrep.el* also how you can browse (grep) files easily and when
+;; you've done, you can call this package top get rid of those browsed
+;; files.
+;;
+;; Cache minor mode indication -- Controlling the cache flag
+;;
+;; Mode line indication shows for loaded buffer
+;;
+;; "+C" if file is loaded as cached.
+;; "+c" If you have manually turned off the cache
+;;
+;; And for root buffer where the file were loaded, normally
+;; compilation or dired buffer, the mode line shows
+;;
+;; "+CN" where N is number of files currently in the cache
+;;
+;; Sometimes you want to keep some file that belongs to the cache
+;; and you don't want to loose it when you execute `M-x' `tinycache-flush'
+;; or when you kill the root buffer.
+;;
+;; For that purpose there is function `tinycache-mode' to turn
+;; off the cache for current buffer. When the cache mark says
+;; "+c" in the mode line, it tells you that the file will not be
+;; killed when you `tinycache-flush' is called.
+;;
+;; Note: the root buffer's xx count is not updated when you kill
+;; buffer that was cached. So if the count says 10, and you kill 3
+;; files that, the count will still still say 10. The count is
+;; updated only when you load some *new* file from the root buffer.
+;; At that time all the buffers cached are checked and the ones that
+;; do not exist any more are removed.
+;;
+;; Buffer list commands
+;;
+;; There are some additional commands added to buffer list which
+;; helps you to keep track of the cached files better. The "c"
+;; prefix is chosen for (c)ache related commands.
+;;
+;; C-c c m mark all cached files
+;; C-c c d mark as deleted
+;; C-c c u unmark cached files.
+;;
+;; Dired mode commands
+;;
+;; Similar to buffer list, there is some dired commands too
+;;
+;; C-c c k tinycache-flush, remove all cached files from this dired
+;; C-c c m tinycache-dired-mark
+;; C-c c u tinycache-dired-unmark
+;;
+;; Thanks
+;;
+;; Kevin Rodgers, his *igrep.el* gave me an idea for this. The
+;; original cache code from where this package evolved was
+;; written by Kevin under name *compile-cache.el*
+
+;;; Change Log:
+
+;;}}}
+;;{{{ setup: require, variables
+
+;;; Code:
+
+(eval-when-compile (require 'advice))
+(require 'tinylibm)
+
+(eval-and-compile
+ (autoload 'compilation-find-buffer "compile" "" t)
+ (autoload 'dired-view-file "dired" "" t)
+ (autoload 'dired-get-filename "dired")
+ (autoload 'dired-mark "dired" "" t)
+ (autoload 'dired-unmark "dired" "" t))
+
+(ti::package-defgroup-tiny TinyCache tinycache-: extensions
+ "Maintain a cache of visited files [compile, dired].
+ overview of features
+
+ This package is meant to be used with dired and compilation
+ buffers. When you load file from either one, the file is
+ cached. This way you can view files easily and when you
+ have finished you can flush the cache and get rid of all
+ viewed files.")
+
+;;; ............................................. &emacs-compatibility ...
+;;; We must install this for older emacs versions ( 19.30< )
+
+(unless (boundp 'kill-buffer-hook)
+ ;; gnuserv.el
+ ;; - We have to do this now, because if user loads files in this order:
+ ;;
+ ;; tinycache
+ ;; gnuserv
+ ;;
+ ;; The gnuserv won't see the real function, because tinycache
+ ;; put advice around the function. And using the adviced function
+ ;; as "real" causes infinite loop.
+ ;;
+ ;; If user doesn't use gnuserv, this just defines one extra function,
+ ;; which does no harm.
+ ;;
+ (or (fboundp 'server-real-kill-buffer)
+ (fset 'server-real-kill-buffer (symbol-function 'kill-buffer)))
+
+ (defvar kill-buffer-hook nil
+ "Defined in tinycache.el package. Hook run just before buffer
+ is killed.")
+
+ (defadvice kill-buffer (around tinycache act)
+ "Run kill-buffer-hook before buffer iss killed."
+ (run-hooks 'kill-buffer-hook)
+ ;; prevent accidents by setting this hook to nil
+ (let ((kill-buffer-hook nil))
+ ad-do-it)))
+
+;;; ........................................................ &v-public ...
+
+(defcustom tinycache-:mode-on-string " +C"
+ "*Cache property on indicator. File can be flushed."
+ :type 'string
+ :group 'TinyCache)
+
+(defcustom tinycache-:mode-off-string " +c"
+ "*Cache property off indicator. File will not be flushed."
+ :type 'string
+ :group 'TinyCache)
+
+(defcustom tinycache-:load-hook nil
+ "*Hook run when file has been loaded.
+Suggested function `tinycache-install-msb'."
+ :type 'hook
+ :group 'TinyCache)
+
+(defcustom tinycache-:find-file-buffer-hook 'tinycache-maybe-view-mode
+ "*Hook run inside buffer which is loaded from compile output."
+ :type 'hook
+ :group 'TinyCache)
+
+;;; ....................................................... &v-private ...
+
+(defvar tinycache-:mode-name tinycache-:mode-on-string
+ "String in the mode line to mark if that file is part the cache or not.
+This is changed by program and not a user variable.")
+
+(defvar tinycache-mode nil
+ "Mode on/off variable.")
+(make-variable-buffer-local 'tinycache-mode)
+(put 'tinycache-mode 'permanent-local t)
+
+(defvar tinycache-:info nil
+ "Variable to keep information about the cache.
+Contains the compile buffer pointer from where the file was loaded.")
+(make-variable-buffer-local 'tinycache-:info)
+(put 'tinycache-:info 'permanent-local t)
+
+(defvar tinycache-:mode-user-flag nil
+ "If non-nil, user has touched the `tinycache-mode' flag in this buffer.")
+(make-variable-buffer-local 'tinycache-:mode-user-flag)
+(put 'tinycache-:mode-user-flag 'permanent-local t)
+
+(defvar tinycache-:cache nil
+ "List of buffers created by `compilation-find-file'. Local to each buffer.
+Format: (BUFFER-POINTER BP ..)")
+
+;; If user starts new compilation in *grep* buffer, it wipes the results
+;; but the cache must remain there, since he may have loaded files from
+;; previous compilation.
+
+(put 'tinycache-:cache 'permanent-local t)
+
+;;; ....................................................... &v-version ...
+
+;;;###autoload (autoload 'tinycache-version "tinycache" "Display commentary." t)
+(eval-and-compile
+ (ti::macrof-version-bug-report
+ "tinycache.el"
+ "tinycache"
+ tinycache-:version-id
+ "$Id: tinycache.el,v 2.45 2007/05/06 23:15:19 jaalto Exp $"
+ '(tinycache-:version-id
+ tinycache-:mode-on-string
+ tinycache-:mode-off-string
+ tinycache-:load-hook
+ tinycache-:find-file-buffer-hook
+ tinycache-:mode-name
+ tinycache-mode
+ tinycache-:info
+ tinycache-:mode-user-flag
+ tinycache-:cache)))
+
+;;}}}
+;;{{{ code: misc functions
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycache-uninstall ()
+ "Deactivate package."
+ (tinycache-advice-control 'disable))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycache-advice-control (&optional disable)
+ "Turn advices on. Optionally DISABLE."
+ (interactive)
+ (ti::advice-control
+ '(compile-internal compilation-find-file) "^tinycache" disable 'verb))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycache-install-mode ()
+ "Install `tinycache-mode'."
+ ;; Make sure we can display string in mode line
+ (if (null (assq 'tinycache-mode minor-mode-alist))
+ (ti::keymap-add-minor-mode 'tinycache-mode
+ 'tinycache-:mode-name
+ ;; No key map
+ (make-sparse-keymap))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycache-install-msb ()
+ "Install new cache menu to msb.el if it is loaded."
+ (let* ((elt
+ '((and (boundp 'tinycache-mode)
+ tinycache-mode)
+ 1005
+ "Cached compile files (%d)"))
+ (sym 'msb-menu-cond)
+ menu)
+ (when (and (featurep 'msb)
+ ;; Install only once.
+ ;; symbol-value just silences byteComp
+ (setq menu (symbol-value sym))
+ (not (member menu elt)))
+ (push elt menu)
+ (set sym menu))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycache-define-default-keys ()
+ "Define keys to `compilation-minor-mode-map'."
+ (interactive)
+ (let* (map)
+ ;; Avoid byte compilation warnings this way....
+ ;;
+ (when (and (boundp 'compilation-minor-mode-map)
+ (setq map (symbol-value 'compilation-minor-mode-map))
+ (keymapp map))
+ (ti::use-prefix-key map "\C-cc")
+ (ti::define-key-if-free map "\C-cck" 'tinycache-flush))
+ (when (and (boundp 'compilation-minor-mode-map)
+ (setq map (symbol-value 'compilation-minor-mode-map))
+ (keymapp map))
+ (ti::use-prefix-key map "\C-cc")
+ (ti::define-key-if-free map "\C-cck" 'tinycache-flush))
+ (when (and (boundp 'dired-mode-map)
+ (setq map (symbol-value 'dired-mode-map))
+ (keymapp map))
+ (ti::use-prefix-key map "\C-cc")
+ (ti::define-key-if-free map "\C-cck" 'tinycache-flush)
+ (ti::define-key-if-free map "\C-ccm" 'tinycache-dired-mark)
+ (ti::define-key-if-free map "\C-ccu" 'tinycache-dired-unmark))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycache-buffer-list-bindings-on ()
+ "Add default bindings to buffer list, \\[list-buffers]."
+ ;; Choose "c" for cache commands
+ (ti::use-prefix-key Buffer-menu-mode-map "\C-cc")
+ ;; With these you can see the cachec files
+ (ti::define-key-if-free Buffer-menu-mode-map "\C-ccd"
+ 'tinycache-buffer-list-mark-deleted)
+ (ti::define-key-if-free Buffer-menu-mode-map "\C-ccm"
+ 'tinycache-buffer-list-mark)
+ (ti::define-key-if-free Buffer-menu-mode-map "\C-ccu"
+ 'tinycache-buffer-list-unmark)
+ (ti::define-key-if-free Buffer-menu-mode-map "\C-ccf"
+ 'tinycache-buffer-list-mark-cache-off)
+ ;; Bye, bye. No need to call us again. Installation already done.
+ (remove-hook 'buffer-menu-mode-hook 'tinycache-define-default-keys))
+
+;;; ----------------------------------------------------------------------
+;;; - The following says that "Load view-(minor)mode in Emacs 19.30, but
+;;; for other (X)Emacs load mview-mode if it exists."
+;;; - The view-mode is minor mode in new Emacs releases, older
+;;; versions are encouraged to get mview.el minor mode
+;;;
+;;; mview.el
+;;; Mike Williams
+;;;
+(defun tinycache-maybe-view-mode ()
+ "Turen on view (minor) mode if needed."
+ (interactive)
+ (let* ((zip-re ;; arc-mode's zip file prompt
+ ;; M Filemode Length Date Time File
+ ;; - ---------- -------- ----------- -------- ---------
+ ;; -rw-r--r-- 9695 10-Sep-1993 17:53:46 Makefile
+ ;; -rw-r--r-- 7441 8-Sep-1993 14:21:20 README
+ ;;
+ ".*Filemode[ \t]+Length[ \t]+Date[ \t]+Time[ \t]+File[ \t]*$")
+ func)
+ ;; Now; if you load from dired a .zip or .tar file; you don't
+ ;; want view mode on, check buffer file name.
+ (cond
+ ((and (not (ti::emacs-p "21"))
+ (ti::emacs-p)
+ (< emacs-minor-version 30)
+ (require 'mview nil 'noerr)
+ ;;
+ ;; Not loaded from dired-view-file, but from compile buffer?
+ ;;
+ (not (eq major-mode 'view-mode)))
+ (when (fboundp 'view-mode) ;Turn off this mode.
+ (ti::funcall 'view-mode 0)) ;in 19.28 won't work, but try anyway
+ ;; Use minor mode instead
+ (setq func 'mview-mode))
+ ((fboundp 'view-mode)
+ (setq func 'view-mode)))
+ (cond
+ ((save-excursion
+ (ti::pmin)
+ (and (looking-at zip-re)
+ (fboundp 'archive-mode)))
+ (ti::funcall 'archive-mode))
+ (func
+ (funcall func)))))
+
+;;}}}
+;;{{{ code: Buffer list control
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro tinycache-:mode-on-string-p ()
+ "Check if `tinycache-mode' is on."
+ (` (memq tinycache-mode '(t on))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinycache-map-over-buffers 'lisp-indent-function 1)
+(defmacro tinycache-map-over-buffers (off &rest body)
+ "Map over all cached buffers.
+If OFF is non-nil, maps over buffers whose `tinycache-:cache' is off
+and do BODY.
+
+In macro you can refer to these variables. The names are mangled
+so that they don't clash with the toplevel definitions.
+
+ 'BuffeR' as current buffer
+ 'NamE' buffers's name
+ 'LisT' current list of buffers to loop over.
+
+Setting 'list' to nil terminates this macro."
+ (`
+ (let* (NamE)
+ (dolist (BuffeR (tinycache-cached-file-list (, off)) )
+ (setq NamE (buffer-name BuffeR))
+ (if (null NamE)
+ (setq NamE nil)) ;NoOp, Silence ButeComp
+ (,@ body)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinycache-buffer-list-map-over-buffers 'lisp-indent-function 0)
+(defmacro tinycache-buffer-list-map-over-buffers (&rest body)
+ "Special Buffer list macro to execute BODY at found buffer line."
+ (`
+ (tinycache-map-over-buffers nil
+ (setq NamE (regexp-quote NamE))
+ (ti::pmin)
+ (when (re-search-forward NamE nil t)
+ (beginning-of-line)
+ (,@ body)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinycache-buffer-list-map-over-off-buffers 'lisp-indent-function 0)
+(defmacro tinycache-buffer-list-map-over-off-buffers (&rest body)
+ "Special Buffer list macro to execute BODY at found buffer line."
+ (`
+ (tinycache-map-over-buffers 'off
+ (setq NamE (regexp-quote NamE))
+ (ti::pmin)
+ (when (re-search-forward NamE nil t)
+ (beginning-of-line)
+ (,@ body)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinycache-buffer-list-mark ()
+ "Mark Cached files in buffer list."
+ (interactive)
+ (tinycache-buffer-list-map-over-buffers (Buffer-menu-mark)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinycache-buffer-list-unmark ()
+ "Mark Cached files in buffer list."
+ (interactive)
+ (tinycache-buffer-list-map-over-buffers (Buffer-menu-unmark)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinycache-buffer-list-mark-deleted ()
+ "Mark Cached files in buffer list."
+ (interactive)
+ (tinycache-buffer-list-map-over-buffers (Buffer-menu-delete)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinycache-buffer-list-mark-cache-off ()
+ "Mark files whose cache property has been turned off."
+ (interactive)
+ (tinycache-buffer-list-map-over-off-buffers (Buffer-menu-mark)))
+
+;;}}}
+;;{{{ Dired buffer
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycache-dired-mark (&optional unmark verb)
+ "Mark cached files. Optionally UNMARK. VERB."
+ (interactive)
+ (let* ((i 0)
+ file)
+ (ti::verb)
+ (ti::save-line-column-macro nil nil
+ (dolist (elt tinycache-:cache)
+ (setq file (buffer-name elt))
+ (ti::pmin)
+ (when (re-search-forward (format "%s$" file))
+ (cond
+ (unmark
+ (beginning-of-line)
+ (when (eq (following-char)
+ (symbol-value 'dired-marker-char))
+ (incf i)
+ (dired-unmark 1)))
+ (t
+ (incf i)
+ (dired-mark 1))))))
+ (if verb
+ (message "%d cached files %smarked" i
+ (if unmark "un" "") ))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycache-dired-unmark (&optional verb)
+ "Unmark cached files. VERB."
+ (interactive)
+ (ti::verb)
+ (tinycache-dired-mark 'unmark verb))
+
+;;}}}
+;;{{{ code: cache control
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycache-add-local-hook ()
+ "Make `kill-buffer-hook' local to this buffer. And add `tinycache-flush' to it.
+When you kill the dired buffer, cached buffers loaded from this
+buffer are also killed."
+ (let* (buffer)
+ ;; Make sure this hook does not contain tinycache-flush outside
+ ;; the compilation buffer
+ (remove-hook 'kill-buffer-hook 'tinycache-flush)
+ (save-excursion
+ ;; Select right buffer where to localize the hook
+ (cond
+ ((eq major-mode 'dired-mode))
+ ((and (boundp 'compilation-last-buffer)
+ (setq buffer (symbol-value 'compilation-last-buffer))
+ (buffer-live-p (get-buffer buffer)))
+ (set-buffer buffer))
+ (t
+ (error "improper use of tinycache-add-local-hook: no dired/compilation")))
+ ;; force the hook local to buffer
+ (make-local-hook 'kill-buffer-hook)
+ ;; Make sure there are no constants in the hook.
+ (setq kill-buffer-hook (delq nil (delq t kill-buffer-hook)))
+ (add-hook 'kill-buffer-hook 'tinycache-flush))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycache-activate (this-buffer buffer)
+ "THIS-BUFFER is the root buffer (dired,compile) and put BUFFER to cache."
+ (interactive)
+ (let (new-list)
+ ;; update cache list
+ (with-current-buffer this-buffer
+ (make-local-variable 'tinycache-:cache)
+ (dolist (elt tinycache-:cache) ;Remove buffers that do not exist
+ (if (buffer-live-p (get-buffer elt))
+ (push elt new-list)))
+ (setq tinycache-:cache new-list)
+ (if (not (memq buffer tinycache-:cache))
+ (push buffer tinycache-:cache))
+ (tinycache-mode-root-buffer))
+ ;; Turn on cache mode
+ (with-current-buffer buffer
+ (setq tinycache-:info this-buffer)
+ ;; - We don't touch the tinycache-mode if user has taken control
+ ;; - If the flag shows untouched buffer, mark the buffer
+ ;; to cache.
+ (unless tinycache-:mode-user-flag
+ (setq tinycache-mode 'on)
+ (setq tinycache-:mode-name tinycache-:mode-on-string)
+ (ti::compat-modeline-update))
+ (run-hooks 'tinycache-:find-file-buffer-hook))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycache-cached-file-list (&optional off)
+ "Return all cached files by looking at every compilation buffer.
+This excludes files that user has manually instructed not to be in
+cache (tinycache-mode is off for buffer)
+
+if optional OFF is non-nil, then return buffers whose `tinycache-:cache'
+has been turned manually off."
+ (let* ((modes '(compilation-mode compilation-minor-mode dired-mode))
+ buffers
+ blist2)
+ (dolist (elt (buffer-list))
+ (with-current-buffer elt
+ (when (and (memq major-mode modes)
+ tinycache-:cache)
+ ;; Read the value of cache and loop over it
+ (setq blist2 tinycache-:cache)
+ ;; Check the `tinycache-mode' for every cached file.
+ (dolist (elt2 blist2)
+ (with-current-buffer elt2
+ (cond
+ ((null off)
+ (if (tinycache-:mode-on-string-p)
+ (push elt2 buffers)))
+ (t
+ (if (null (tinycache-:mode-on-string-p))
+ (push elt2 buffers)))))) ))) ;; dolist1 - 2
+ buffers))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycache-mode-root-buffer (&optional remove)
+ "Update root buffer's `tinycache-mode' flag. Optionally REMOVE from cache.
+This is the buffer where `tinycache-:cache' resides."
+ (make-variable-buffer-local 'tinycache-:mode-name)
+ (cond
+ (remove
+ (setq tinycache-mode nil))
+ (t
+ (setq tinycache-mode 'on)
+ (setq tinycache-:mode-name
+ (format "%s%d" tinycache-:mode-on-string (length tinycache-:cache))))))
+;;; ----------------------------------------------------------------------
+;;; - This function must be called by user only!
+;;;
+;;;###autoload
+(defun tinycache-mode (&optional arg)
+ "Toggle cache flag for this buffer with ARG.
+If the file does not belong to compile cache, calling this function
+does nothing. If the file is in the cache, the mode line displays mode name.
+
+Removing the file from cache means that the file is not killed when
+the cache is flushed with \\[tinycache-flush]."
+ (interactive)
+ (unless tinycache-:info
+ (message "Can't find tinycache-:info, Buffer is not part of the cache?")
+ (sleep-for 1))
+ (if (null tinycache-mode)
+ (message "This buffer is not in cache controlled.")
+ (setq tinycache-:mode-user-flag t)
+ (cond
+ ((memq arg '(0 -1))
+ (setq tinycache-mode 'off))
+ ((eq arg nil)
+ (if (tinycache-:mode-on-string-p)
+ (setq tinycache-mode 'off)
+ (setq tinycache-mode 'on)))
+ (t
+ (setq tinycache-mode 'on)))
+ (message
+ (format "Buffer is %s in cache control"
+ (if (tinycache-:mode-on-string-p)
+ (progn
+ (setq tinycache-:mode-name tinycache-:mode-on-string)
+ "now")
+ (setq tinycache-:mode-name tinycache-:mode-off-string)
+ "no more")))
+ (ti::compat-modeline-update)))
+
+;;}}}
+;;{{{ code: flush
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinycache-flush-all-compilation (&optional verb)
+ "Kill all cached files by stepping through all compilation buffers. VERB."
+ (interactive)
+ (let* ((count 0)
+ (verb (or verb (interactive-p))))
+ (tinycache-map-over-buffers nil
+ (when (buffer-live-p (get-buffer BuffeR))
+ (kill-buffer BuffeR)
+ (incf count)))
+ (if verb
+ (message (format "Flushed %d buffers." count)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinycache-flush (&optional verb)
+ "Kill buffers listed in `tinycache-:cache'. VERB.
+You must be in the Compilation/Dired buffer to execute this command.
+
+If you're not in dired buffer, function tries to find compilation
+buffer and kill compilation cached files."
+ (interactive)
+ (let* ((cache-buffer (current-buffer))
+ count
+ do-it)
+ (ti::verb)
+ (unless (eq major-mode 'dired-mode)
+ ;; This calls error if no compile buffer found...
+ (setq cache-buffer (ignore-errors (compilation-find-buffer))))
+ (when cache-buffer ;if there is buffer for us
+ (with-current-buffer cache-buffer
+ (tinycache-mode-root-buffer 'remove)
+ ;; This variable is local to buffer
+ (setq count (length tinycache-:cache))
+ (dolist (buffer tinycache-:cache)
+ (setq do-it nil)
+ (if (not (buffer-live-p (get-buffer buffer)))
+ (setq do-it t)
+ (with-current-buffer buffer
+ ;; kill-buffer-hook is local to each buffer.
+ ;; prevent alias loop
+ (let ((kill-buffer-hook kill-buffer-hook))
+ (remove-hook 'kill-buffer-hook 'tinycache-flush)
+ (when (tinycache-:mode-on-string-p) ;it's allowed to kill
+ (kill-buffer buffer)
+ (setq do-it t)))))
+ (if do-it
+ (setq tinycache-:cache (delq buffer tinycache-:cache))))))
+ (if verb
+ (message (format "Cache flushed [%s] files. " count)))))
+
+;;}}}
+;;{{{ code: advice
+
+;;; ----------------------------------------------------------------------
+;;;
+(defadvice compilation-find-file (around tinycache activate)
+ "Cache newly visited files in `tinycache-:cache';
+use `\\[tinycache-flush]' in compilation buffer,
+to kill these loaded files."
+ (let ((this-buffer (current-buffer))
+ (file filename) ;ADVICE variable
+ buffer)
+ (tinycache-install-mode)
+ ;; Already in emacs ?
+ (setq buffer (get-file-buffer file))
+ (prog1
+ ad-do-it
+ (unless buffer ;Loaded new file
+ (if (setq buffer ad-return-value)
+ (tinycache-activate this-buffer buffer))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defadvice compile-internal (after tinycache activate)
+ "Automatically kill the buffers listed in `tinycache-:cache'.
+`kill-buffer-hook' when the `compile' buffer is killed."
+ (tinycache-add-local-hook))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defadvice dired-view-file (around tinycache act)
+ "Cache newly visited files in `tinycache-:cache';
+Kill the dired buffer to kill cached files."
+ (let ((this-buffer (current-buffer))
+ (file (dired-get-filename))
+ buffer)
+ (tinycache-install-mode)
+ (cond
+ ((file-directory-p file)
+ (setq buffer t)) ;skip this one
+ ((get-file-buffer file) ;Already in emacs ?
+ (setq buffer t))
+ (t
+ (setq buffer (get-file-buffer file))))
+ (prog1
+ ad-do-it
+ (when (and (null buffer) ;Loaded new file
+ (setq buffer (get-file-buffer file)))
+ (tinycache-activate this-buffer buffer)))))
+
+;;}}}
+
+;; delayed install
+
+(add-hook 'buffer-menu-mode-hook 'tinycache-buffer-list-bindings-on)
+(add-hook 'compilation-mode-hook 'tinycache-define-default-keys)
+(add-hook 'dired-mode-hook 'tinycache-add-local-hook)
+(add-hook 'dired-mode-hook 'tinycache-define-default-keys)
+
+(provide 'tinycache)
+(run-hooks 'tinycache-:load-hook)
+
+;; tinycache.el ends here
--- /dev/null
+;;; tinychist.el --- Command history save/restore utility
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 1996-2007 Jari Aalto
+;; Keywords: extensions
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program, call M-x tinychist-version.
+;; Look at the code with folding.el
+
+;; COPYRIGHT NOTICE
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;; ....................................................... &t-install ...
+;; Put this file on your Emacs-Lisp load path, add following into your
+;; ~/.emacs startup file.
+;;
+;; (require 'tinychist)
+;;
+;; This package also installs function `tinychist-command-history-load' in
+;; `kill-emacs-hook' or if no such hook exist, you will be warned that
+;; other means must be used. Now, whenever you start emacs, name it with
+;; this option.
+;;
+;; -name <TITLE> e.g. -name Mail
+;;
+;; and the history file associated with "Mail emacs" is loaded.
+;; If you have any questions, use this function
+;;
+;; M-x tinychist-submit-bug-report
+
+;;}}}
+;;{{{ Docs
+
+;; ..................................................... &t-commentary ...
+
+;;; Commentary:
+
+;; Preface, apr 1996
+;;
+;; In newsgroup post to gnu.emacs.help there was discussion about
+;; saving and restoring emacs command history between session. Fred G.
+;; Athearn <fga@maple.sover.net> sent a help message to a person
+;; asking for it describing how to print out command-history and
+;; saving it into a file with `C-x' `C-w'. This little package tries
+;; to automate everything, so that when you load it, it will
+;; automatically load command history for the right emacs and when you
+;; exit emacs, the command history is saved to disk.
+;;
+;; Overview of features
+;;
+;; o Save and restore emacs command history
+;; o Suport simultaneous emacs sessions, different history for
+;; each one. Eg. "-name Mail" is associated with "mail" emacs history,
+;; "-name News" is associated with "news" history. This trick works
+;; on non-windowed tty too, since the switch is evaluated and cached
+;; internally in those cases.
+;;
+;; Default save file from -name parameter
+;;
+;; The default save name of command history file is extracted from
+;; the frame parameter. It is quite customary that people have
+;; several emacs open in their X display, each one dedicated to
+;; specific task.
+;;
+;; The key here is, that you should make a habit of naming your
+;; emacs by task when you start it:
+;;
+;; % emacs -name Mail & # My mail emacs
+;; % emacs -name C++1 & # My C++ project 1
+;; % emacs -name News # for news reading
+;;
+;; This effectively sets the frame's name to "-name" parameter's
+;; value. But old emacs versions are a little picky about the order of
+;; command line options, please look at the info pages in which order
+;; you must specify additional arguments. (info pages, Node:Initial
+;; Options) For non-windowed environment, this trick doesn't quite
+;; work out of the box, because emacs doesn't accept the name option
+;; at all. Let's try to start fresh emacs to an xterm, not to separate
+;; frame and see what happens. Order of the options is important here.
+;;
+;; % emacs -nw -q -name Mail &
+;;
+;; What happens, is that you get two new buffers: "-name" and "Mail",
+;; and this is not what we intended. If we ask the frame name in this
+;; emacs, it says "terminal" or something similar. What we do instead,
+;; is ,that we install our own command line handler in non-windowed
+;; emacs and then we're able to intercept the "-name" option and it's
+;; parameter. When the emacs is killed, we then again look at the
+;; cached "-name" option to derive the save file postfix. If you're
+;; interested in adding your own command line option, see function
+;; ti::add-command-line-arg in tinylibm.el
+;;
+;; How it works
+;;
+;; Your emacs must support `kill-emacs-hook', so that the command
+;; history can be saved automatically when you exit emacs. If you have
+;; older than 19.xx, or other emacs that doesn't support the variable,
+;; there is alternative example which replaces you emacs exit. See at
+;; the end of file for examples. When emacs loads, the
+;; `tinychist-load' is runs (see installation) and correct
+;; `command-history' file is loaded.
+;;
+;; File saving/loading
+;;
+;; If you want to save/load the history session manually, you can call
+;; function
+;;
+;; M-x tinychist-command-history-save
+;;
+;; About using the frame name
+;;
+;; I know it's a bit risky to rely on the frame name's first word,
+;; that it designates the purpose of your emacs. After all you _can_
+;; change the frame name to whatever you want in side emacs. But in
+;; general, the name labels your emacs and gives visible clue in X
+;; where the particular emacs is used to. (in non-X you can't see the
+;; name parameter at all, but I don't think that's a problem.)
+;;
+;; See also
+;;
+;; See file *chistory.el* in your emacs distribution, how to configure
+;; some parameters. E.g.:
+;;
+;; M-x command-history-mode
+;; (setq list-command-history-max 50)
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+;;{{{ setup: require
+
+;; Require not needed
+;; (require 'chistory)
+
+(require 'tinylibm)
+
+(eval-when-compile (ti::package-use-dynamic-compilation))
+
+(ti::package-defgroup-tiny TinyChist tinychist-: extensions
+ "Automatic `command-history' save and restore utility.
+ Overview of features
+
+ o Saving and restoring emacs command history
+ o Supports simultaneous emacs sessions, different history for
+ each one. E.g. '-name Mail' is associated with 'mail' emacs history,
+ '-name News' is associated with 'news' history. This trick works
+ on non-windowed tty too, since the switch is evaluated and cached
+ internally in those cases.")
+
+;;}}}
+;;{{{ setup: variables
+
+;;; ......................................................... &v-hooks ...
+
+(defcustom tinychist-:load-hook '(tinychist-install)
+ "*Hook run when file is loaded."
+ :type 'hook
+ :group 'TinyChist)
+
+;;; ........................................................ &v-public ...
+;;; user configurable
+
+(defcustom tinychist-:file-prefix (ti::package-config-file-prefix "tinychist-")
+ "*File prefix for command history files."
+ :type 'file
+ :group 'TinyChist)
+
+(defcustom tinychist-:non-x-function 'tinychist-non-x-name
+ "*Function which return history file postfix in non-X Emacs."
+ :type 'function
+ :group 'TinyChist)
+
+;;; ....................................................... &v-private ...
+;;; do not touch this
+
+(defvar tinychist-:load-flag nil
+ "Non-nil means that flag is t when history has been loaded.")
+
+;;; ....................................................... &v-version ...
+
+;;;###autoload (autoload 'tinychist-version "tinychist" "Display commentary." t)
+(eval-and-compile
+ (ti::macrof-version-bug-report
+ "tinychist.el"
+ "tinychist"
+ tinychist-:version-id
+ "$Id: tinychist.el,v 2.44 2007/05/07 10:50:07 jaalto Exp $"
+ '(tinychist-:version-id
+ tinychist-:load-hook
+ tinychist-:load-flag
+ tinychist-:file-prefix
+ tinychist-:non-x-function)))
+
+;;}}}
+
+;;; ########################################################### &Funcs ###
+
+;;{{{ code: misc
+
+;;; ----------------------------------------------------------------------
+;;; - If you don't use -name in X, then the frame name looks like
+;;; EMACS-RUN-COMMAND@site.some.com
+;;;
+(defsubst tinychist-get-frame-name ()
+ "Return first word of frame. "
+ (let (ptr)
+ (or (and (boundp 'command-line-args)
+ (setq ptr (member "-name" command-line-args))
+ (nth 1 ptr))
+ (ti::string-match "^\\([^\t ]+\\)" 1
+ (frame-parameter (selected-frame) 'name)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinychist-get-command-line-cache ()
+ "Return option's -name ARG, if it was cached in non window env."
+ (let* (ret)
+ ;; (("-name" . ignore) ("TITLE" . ignore) ..)
+ (dolist (elt command-switch-alist)
+ (when (string= "-name" (car elt))
+ (setq ret (car elt))
+ (return)))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;; - This is just an sample, you propably want to modify this
+;;; to your env.
+;;;
+(defun tinychist-non-x-name ()
+ "Return command history filename postfix.
+Snoop what files are currently loaded into emacs. Eg. if RMAIL is found from
+emacs, it is supposed that this emacs handles \"mail\"."
+ (let* (elt)
+ ;; The order is important, because first one matched is used
+ (cond
+ ((setq elt (tinychist-get-command-line-cache))
+ ;; If this is non-window emacs, check if this option is "cached" by
+ ;; this package.
+ elt)
+ ((ti::dolist-buffer-list
+ (string-match "VM$\\|RMAIL$\\|MH$" (buffer-name)) 'temp-buffers)
+ "mail")
+ ((ti::dolist-buffer-list (string-match "gnus" (buffer-name)) 'temp-buffers)
+ "news")
+ (t
+ "def"))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinychist-get-file-name ()
+ "Return command history filename."
+ (let* ((pfx (expand-file-name tinychist-:file-prefix))
+ frame)
+ (if (ti::compat-window-system)
+ (setq frame (tinychist-get-frame-name))
+ (setq frame (funcall tinychist-:non-x-function)))
+ (concat pfx frame)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinychist-install (&optional uninstall)
+ "Install the package. optionally UNINSTALL."
+ (interactive)
+ (let* ()
+ (if uninstall
+ (remove-hook 'kill-emacs-hook 'tinychist-command-history-load)
+ (cond
+ ((boundp 'kill-emacs-hook)
+ (add-hook 'kill-emacs-hook 'tinychist-command-history-load))
+
+ ;; Too bad; this emacs does not have kill-emacs-hook,
+ ;; Check if the default exit function is bound to default key
+ ;; and notify user that he should add custom exit function there.
+
+ ((memq (lookup-key global-map "\C-x\C-c")
+ '(save-buffers-kill-emacs))
+
+ (read-from-minibuffer
+ (concat
+ "Cannot auto-install. Use manual key binding C-xC-c installation."
+ " See source code of `tinychist-install'."))))
+
+ ;; load only once, prevent command-history wipe out
+ ;; if package is loaded multiple times
+
+ (if (null tinychist-:load-flag)
+ (tinychist-load) ;Autoload the command history
+ (setq tinychist-:load-flag t)))))
+
+;;}}}
+;;{{{ code: main
+
+;;; ............................................................ &main ...
+
+;;; ----------------------------------------------------------------------
+;;; - I admit, this is a bit tricky thing to do, but it also demonstrates
+;;; how you'd add new command line options
+;;;
+;;; 1. Install extra argument
+;;; 2. read the argument content and put it into list too
+;;;
+(defun tinychist-load ()
+ "Load appropriate `command-history' file by looking at command line option.
+The `-name' option is used. This function runs when package is loaded."
+ (let* ((elt1 (member "-name" command-line-args))
+ (elt2 (car-safe (cdr elt1)))
+ (pfx (expand-file-name tinychist-:file-prefix))
+ (debug-on-error t) ;trigger errors
+ file)
+ (cond
+ ((not elt1) ;no option given
+ (setq file (tinychist-get-file-name))) ;guess which file to load.
+ (t
+ ;; We know what user wants to load...
+ ;; Prevent using this argument as buffer name. The "-name"
+ ;; option is valid only in X
+ (unless (ti::compat-window-system)
+ (ti::add-command-line-arg elt2) ;; this is put after
+ (ti::add-command-line-arg (car elt1))) ;; this is put before
+ (setq file (concat pfx elt2))))
+ (if (and file (file-exists-p file))
+ (load file))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinychist-command-history-load ()
+ "Load the saved `command-history' file."
+ (if command-history ;something to save ?
+ (tinychist-command-history-save (tinychist-get-file-name))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinychist-command-history-save (file &optional load)
+ "Save history to FILE or optionally LOAD (prefix arg) command history."
+ (interactive "FFile: \nP")
+ (let* ((buffer "*Command History*") ;see chistory.el
+ (debug-on-error t) ;trigger errors
+
+ ;; XEmacs and Emacs don't agree with key commands,
+ ;; so we leave them out from history
+ ;; (global-set-key
+ ;; (quote [#<keypress-event control-C> #<keypress-event 1>]) ...
+
+ (re-incompatible "([^ ]+-key\\(-[^ ]+\\)* "))
+
+ (cond
+ (load
+ (load-file file))
+ (t
+ (list-command-history)
+ (with-current-buffer buffer
+ (setq buffer-read-only nil)
+ ;; Format it
+ (ti::pmin)
+ (flush-lines re-incompatible)
+ (ti::pmin)
+ (insert
+ (concat
+ ";;\n"
+ ";; File: Emacs command history file\n"
+ ";; Desc: Load this with M-x load-file to reset the history to "
+ "these values\n"
+ ;; This is for tinymy.el -- RCS compatible times tamp
+ ;;
+ ";; $\Docid: $\n"
+ "\n"))
+ (insert "(defconst command-history\n'(\n")
+ (ti::pmax)
+ (insert
+ (concat
+ "))\n\n"
+ ";;; " (file-name-nondirectory file) " ends here"))
+ (lisp-mode)
+ (indent-region (point-min) (point-max) nil)
+ ;; Update the times tamp [if function exist] and save the configuration
+ ;; See tinymy.el
+ (when (fboundp 'tinymy-file-stamp)
+ (ti::funcall 'tinymy-file-stamp))
+ (write-region (point-min) (point-max) file))
+
+ (ti::kill-buffer-safe buffer)))))
+
+;;}}}
+;;{{{ code: examples
+
+;;; ......................................................... &example ...
+;;; Draw region and extract code with tinylib.el / ti::package-rip-magic
+;;; This is Manual C-xC-x installation
+;;;
+;;; - If your Emacs doesn't have `kill-emacs-hook' then you
+;;; need this manual installation example.
+;; - Copy this into your emacs BEFORE the (require 'tinychist)
+
+;;* _
+;;* (global-set-key "\C-x\C-c" 'my-kill-emacs)
+;;* _
+;;* ;; This works for 18.57 and 19.xx, whereas the
+;;* ;; kill-emacs-query-functions doesn't, and this suffices for personal
+;;* ;; needs.
+;;* _
+;;* (defun my-kill-emacs (&optional arg)
+;;* "Prevent accidental emacs kill. Calls save-buffers-kill-emacs"
+;;* (interactive "P")
+;;* (let* ((chist (tinychist-get-file-name))
+;;* ch)
+;;* (setq ch (ti::read-char-safe-until "Exit emacs y/[n]"))
+;;* (when (char= ch ?y)
+;;* (tinychist-command-history-save chist)
+;;* (save-buffers-kill-emacs arg))))
+
+;;}}}
+;;{{{ code: install
+
+;;; .................................................... &auto-install ...
+
+(provide 'tinychist)
+(run-hooks 'tinychist-:load-hook)
+
+;;}}}
+
+;;; tinychist.el ends here
--- /dev/null
+;;; tinycomment.el --- Smart comment setting utility
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 1994-2007 Jari Aalto
+;; Keywords: extensions
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program use ident(1) or call M-x
+;; tinycomment-version Look at the code with folding.el
+
+;; COPYRIGHT NOTICE
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Installation
+
+;; ........................................................ &t-install ...
+;; - Put this file on your Emacs-Lisp load path, add following into your
+;; ~/.emacs startup file
+;;
+;; (require 'tinycomment)
+;; (global-set-key "\M-;" 'tinycomment-indent-for-comment)
+;; (setq-default comment-column 48)
+;;
+;; Or use autoload and your .emacs starts quicker
+;;
+;; (global-set-key "\M-;" 'tinycomment-indent-for-comment)
+;; (autoload 'tinycomment-indent-for-comment "tinycomment" "" t)
+;;
+;; If you have any questions, use this function to contact author
+;;
+;; M-x tinycomment-submit-bug-report
+
+;;}}}
+;;{{{ Commentary
+
+;;; Commentary:
+
+;;}}}
+;;{{{ Documentation
+
+;; Preface, Sep 1994
+;;
+
+;; In 1994-10-18 Era Eriksson wrote in gnu.emacs.help that he didn't
+;; like 'modes' because they redefined his tab key strangely. What he
+;; wanted was tab 8 in _every possible case_. He wrote: "..if mode
+;; messes with tab key, I don't want it". He also wanted his comments
+;; always to be positioned at column 56 (tab #7). The problem was that
+;; how he could he add comments with tab key, when the mode occied it
+;; already. He also always used to program using `fundamental-mode';
+;; what a cool dude. As a result this package was born. The
+;; original lisp file sent to Era was posted under name
+;; general-comment.el.
+;;
+;; What's this all about, short introduction
+;;
+;; Let's see...You're in C/C++ mode, and want to switch to better mode
+;; before starting to adjust comments. But wait, the new mode doesn't
+;; know about C++-comments! Or if you're editing ~/.Xdefauls, there is
+;; no mode for it (at the time of writing), no-one to know the comment
+;; syntax. Boom. Now it's time to give this packet a run. It hooks
+;; itself directly to `\M-;' replacing any previous function. The
+;; packages defines comment syntax and position on the fly when it can
+;; identify the file name. If the file isn't known then it passes
+;; control to mode to handle the commenting. This is handy in
+;; temporary buffers that do not have filename: e.g. *scratch* buffer.
+;; Repetitive calls to `M-;' shift between comment *classes*: comment
+;; is adjusted according to previous one, or move it on the line.
+;;
+;; Overview of features
+;;
+;; o Replaces `M-;' comment key. Suitable for any major mode.
+;; o Determine comment variables on the fly, no matter where you
+;; are or what mode you are using.
+;; o There is no-list that tells not to touch this mode's commenting.
+;; This is for modes that has `comment-end' which aren't supported.
+;; o Repetitive `M-;' converts single comment into *bigger* *classes*.
+;; o Position new comment on empty line by looking at previous
+;; comment.
+;; o It is possible to define column position for those comments
+;; that are not allowed to move This handy for long lines
+;; or special comments.
+;; o If there are multiple so called comments, like $#var # comment
+;; in `perl-mode', the last # char is treated as a comment.
+;;
+;; Limitations
+;;
+;; This isn't designed for modes that have `comment-end', you get
+;; only '/* */' string e.g. in C-mode and no comment class shifting.
+;;
+;; Examples
+;;
+;; At the end of file there is simple general editing mode, which can
+;; be used for perl, shells, awk, C++ [sometimes]
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+;;{{{ setup: require
+
+;;; ......................................................... &require ...
+
+(require 'tinylibm)
+
+(eval-when-compile
+ (ti::package-use-dynamic-compilation))
+
+(ti::package-defgroup-tiny TinyComment tinycomment-: extensions
+ "Smart comment setting utility
+ Overview of features:
+
+ o Replaces M-; commenting key. Suitable for any major-mode
+ o Determines comment variables on the fly, no matter where you
+ are or what mode you are.
+ o There is no-list that tells not to touch this mode's commenting.
+ This is for modes that has comment-end. TIC can't handle those.
+ o Repetitive M-; converts single comments into 'bigger classes'
+ o Positions new comment on empty line by looking at previous
+ comment.
+ o You can define column position for those comments that are not
+ allowed to move This handy for long lines or special comments.
+ o If there are multiple 'comments' , like $#var # comment
+ in perl-mode, TIC picks the last # char and treats
+ it as a comment. Emacs commention cope similar situations.")
+
+;;}}}
+;;{{{ setup:
+
+;;; ......................................................... &v-hooks ...
+
+(defcustom tinycomment-:load-hook nil
+ "*Hook run when package has been loaded."
+ :type 'hook
+ :group 'TinyComment)
+
+;;; ........................................................ &v-public ...
+;;; User configurable
+
+(defcustom tinycomment-:not-comment-re ".*[$]\\(#\\)[a-zA-Z]"
+ "*Reject comment position according to subexpression 1.
+When searching for comment position, the position found will be
+rejected, if comment subexpression 1 match's position is the same as
+initially found comment position. The test will be done with `looking-at' at
+the beginnning of line.
+
+ $#variable_in_csh
+0123456789 123456789 12345 ;columns
+ * ;found comment pos, reject it.")
+
+(defcustom tinycomment-:tab-call-no-alist
+ '(fundamental-mode
+ text-mode)
+ "*List of modes which enable using TIC's own indent-for-code algorithm.
+
+Most programming modes supply function that knows how to indent the
+statement. But in some cases mode does not supply it's own indent
+function placed on variable `indent-line-function', which is called by
+tab key."
+ :type '(repeat (function :tag "Mode function"))
+ :group 'TinyComment)
+
+(defcustom tinycomment-:adj-no-alist
+ '(lisp-interaction-mode
+ lisp-mode
+ emacs-lisp-mode
+ c-mode ;; we use use // in c++, not /* */
+ pascal-mode)
+ "*List of modes which disable converting comment class.
+
+The function `tinycomment-adjust-comment' isn't suitable for all possible
+modes. Eg. Lisp has it's own idea about placing comments according
+to comment used.
+ ; --> comment column
+ ;; --> right to code level
+ ;;;+ --> left margin.
+
+This defines list of mode names where `tinycomment-adjust-comment' is suppressed
+and the normal `indent-for-comment' is used."
+ :type '(repeat (function :tag "Mode function"))
+ :group 'TinyComment)
+
+(defcustom tinycomment-:comment-notify nil
+ "*If non-nil allow printing notify messages.
+When the comment syntax wasn't found according to file name.
+The message is _not_ displayed when `buffer-name' contains '*'.
+
+You may want to set this to 't for awhile, so that you can add all
+those files that are missing from the list. When you're satisfied,
+you can turn off the warning."
+ :type 'boolean
+ :group 'TinyComment)
+
+(defcustom tinycomment-:def-com-pos 'code
+ "*Default comment position for empty lines.
+Possible choices are:
+
+ 'code code level indent [usually as previous code line]
+ 'cpos normal `comment-column'
+
+Note that 'cpos doesn't always put comment where you would expect, because
+it looks back until it finds code. In spite of that, it normally works
+well _inside_ functions"
+ :type '(choice
+ (const code)
+ (const cpos))
+ :group 'TinyComment)
+
+(defcustom tinycomment-:comment-extra-arg 1
+ "*See documentation of `tinycomment-:comment-extra'."
+ :type 'integer
+ :group 'TinyComment)
+
+(defcustom tinycomment-:comment-extra-stop 63 ;TAB position 64
+ "*See documentation of `tinycomment-:comment-extra'.
+The comment movement is not done if `current-column' > this variable."
+ :type 'integer
+ :group 'TinyComment)
+
+(defcustom tinycomment-:comment-extra 'tab
+ "*This affects function `tinycomment-set-com'. Let's see an example:
+
+ abcd abcd abcd abcd abcd abcd[x] abcd abcd # COMMENT
+
+You have line, where line exeeds the comment column[x] and your
+comment is at the end. This variable determines how such
+line is handled when you now hit M-;
+
+Current choices are:
+ 'tab Insert tab between code and comment, so that they get
+ separated. Any previous whitespace is deleted.
+ 'spc Same, but insert space instead. The number or spaces inserted
+ is told in variable `tinycomment-:comment-extra-arg'
+
+None of these actions are carried out if the comment was placed in
+column `tinycomment-:comment-extra-stop' +1 or further. Such comment is
+left untouched, because adjusting may push it out of the window edge."
+ :type '(choice
+ (const tab)
+ (const spc))
+ :group 'TinyComment)
+
+;;}}}
+;;{{{ setup: -- version notice
+
+;;; ....................................................... &v-version ...
+
+;;;###autoload (autoload 'tinycomment-version "tinycomment" "Display commentary." t)
+(eval-and-compile
+ (ti::macrof-version-bug-report
+ "tinycomment.el"
+ "tinycomment"
+ tinycomment-:version-id
+ "$Id: tinycomment.el,v 2.38 2007/05/01 17:20:42 jaalto Exp $"
+ '(tinycomment-:version-id
+ tinycomment-:not-comment-re
+ tinycomment-:tab-call-no-alist
+ tinycomment-:adj-no-alist
+ tinycomment-:comment-notify
+ tinycomment-:def-com-pos
+ tinycomment-:comment-extra-arg
+ tinycomment-:comment-extra-stop
+ tinycomment-:comment-extra)))
+
+;;}}}
+
+;;; ########################################################### &Funcs ###
+
+;;{{{ code: misc
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycomment-find-prev-com-col (com-start &optional not-this-col CF)
+ "Look upward to find previous comment column.
+
+Input:
+
+ COM-START comment start string.
+ NOT-THIS-COL if given, scan backward until different column
+ is found.
+ CF tell that comment searched must reside further in
+ in the line than this column.
+
+Return:
+
+ nil unable to find previous comment
+ col"
+ (let* ((re com-start)
+ (loop t)
+ ret
+ found)
+ (save-excursion
+ (while loop
+ (beginning-of-line)
+ (setq ret nil found nil)
+ (if (setq found (re-search-backward re nil t))
+ (setq ret (current-column)))
+ (setq loop nil) ;default
+ (if (or (null found)
+ (null not-this-col))
+ nil
+ (if (not (= ret not-this-col))
+ (setq loop nil) ;this will do !
+ (setq loop t found nil))) ;keep searching
+
+ (if (or (null found)
+ (null CF))
+ nil
+ (if (> ret CF) ;this IS suitable !
+ (setq loop nil)
+ (setq loop t found nil))))) ;keep going
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycomment-find-com-col ()
+ "Look current line to find `comment-start'.
+
+Return:
+
+ nil
+ nbr column."
+ (let ((no-com (or tinycomment-:not-comment-re "dummy"))
+ (max (save-excursion (end-of-line) (point)))
+ (clen (length comment-start))
+ (re comment-start)
+ ret found
+ not-pos
+ cp)
+ (save-excursion
+ (beginning-of-line)
+ ;; is there restrictions ?
+ (setq not-pos (if (and (looking-at no-com)
+ (match-beginning 1))
+ (match-beginning 1)
+ nil))
+ (while (re-search-forward re max t) ; find last comment
+ (setq found t))
+ (if (null found)
+ nil
+ (backward-char clen)
+ (setq cp (point))
+ (if (eq cp not-pos)
+ nil ;cannot use this
+ (setq ret (current-column))))
+ ret)))
+
+;;}}}
+;;{{{ positions
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycomment-check-line (mode &optional arg)
+ "Few commands to use to determine line data according to MODE and ARG.
+
+Return:
+
+ Depends heavily on the MODE"
+ (let* (ret
+ re
+ re2
+ bp
+ p
+ p2)
+ (if (null (symbolp mode)) nil ;handle literals
+ (cond
+
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... ... ... ...
+ ((and (eq 'code-last-col mode) comment-start)
+ (setq re comment-start)
+ (save-excursion
+ (beginning-of-line)
+ (setq bp (point))
+
+ (if (null (re-search-backward comment-start bp t))
+ nil ;not moved anywhere
+ (goto-char (match-beginning 0)))
+ (skip-syntax-backward " " bp)
+ (setq ret (current-column))))
+
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... ... ... ...
+ ;; find *last* comment start pos
+ ;; like '// i = 1000; // temporarily commented out'
+
+ ((and (eq 'com-last-col mode) comment-start)
+ ;; the '.*' always matches up till last one
+ (setq re (concat ".*\\(" comment-start "\\)" ))
+ (save-excursion
+ (beginning-of-line)
+ (if (not (looking-at re))
+ nil
+ (goto-char (match-beginning 1))
+ (setq ret (current-column)))))
+
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... ... ... ...
+ ;; whole line is 'alone' comment, so that there is no
+ ;; double comments, return it's starting position
+ ;; Double comment is like the previous cond-case
+
+ ((and (eq 'com-alone-col mode) comment-start)
+ (setq re (concat "[ \t]*\\(" comment-start "\\)" ))
+
+ ;; notice COM + SPC in re2
+ ;; - user may write '// this is separator /////////////////////'
+ ;; But that's one comment
+ ;; - '// i = MaxPos; // commented'. There is SPC in second
+ ;; comment, so it has to be Double Commented line.
+
+ (setq re2 (concat ".*\\(" comment-start " \\)" ))
+
+ (save-excursion
+ (beginning-of-line)
+ (if (not (looking-at re))
+ nil
+ (setq p (match-beginning 1))
+ (if (not (looking-at re2))
+ (progn ;only single comment
+ (goto-char p)
+ (setq ret (current-column)))
+ (setq p2 (match-beginning 1))
+ (if (not (eq p p2)) ;Double Commented
+ nil
+ (goto-char p) ;same comment hit twice
+ (setq ret (current-column)))))))
+
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... ... ... ...
+ ((eq 'eolpos mode)
+ (save-excursion (end-of-line) (setq ret (point))))
+
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... ... ... ...
+ ((eq 'bolpos mode)
+ (save-excursion (beginning-of-line) (setq ret (point))))
+
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... ... ... ...
+ ((eq 'emptyEol mode)
+ ;; If the rest of line empty ?
+ (setq ret (looking-at "[ \t]*")))))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycomment-find-comment-col (com-start)
+ "Look upward to find possible COM-START position."
+ (save-excursion
+ (if (re-search-backward (regexp-quote com-start) nil t)
+ (current-column))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycomment-find-code-col (com-start)
+ "Look upward to find possible code indent column. Use COM-START.
+Eg.
+
+ echo something
+ # ridiculous comment
+ <now press ESC ;> # inserts comment here
+
+The problem is that the first comment is considered as indent
+for code by normal Lisp functions, when it should be the 'echo' line.
+We look upward till there is code line that isn't full comment line.
+
+NOTE:
+
+ This doesn't work on C/C++, or any mode that has `comment-end',
+ because we can't keep track of multiline comments.
+
+Return:
+
+ nbr found code, proposed column returned.
+ nil unable to find proper code indent"
+ (let* ((re-com (concat
+ "^[ \t]*" (regexp-quote com-start)
+ "\\|^[ \t]*$")) ;skip empty lines.
+ (move t)
+ p ;point mark
+ ret)
+ (save-excursion
+ (while (and move (eq ret nil)) ;while RET is not set
+ (re-search-backward "[^ \t]+" nil t)
+ (if (save-excursion
+ (beginning-of-line)
+ (looking-at re-com)) ;ignore full comment lines.
+ (if (eq (point) p) ;have we moved since?
+ (setq move nil)) ;we're stucked .. :-C
+ ;; Maybe this real code line?
+
+ (setq ret (1+ (current-column)))) ;1+ due to re-search
+ (setq p (point))))
+ ret))
+
+;;}}}
+
+;;; ######################################################### &comment ###
+;;; The real engine parts to do the job
+
+;;{{{ tinycomment-set-com
+
+;;; ----------------------------------------------------------------------
+;;; See simple.el (funcall comment-indent-function)
+;;; - Funny thing is that you just can't set comment-column to NBR
+;;; and expect it to be comment place, because the indent-for-comment
+;;; might decide to move the position to another place!
+;;; - This function instead, will always put comment there where
+;;; user want's it.
+;;;
+(defun tinycomment-set-com (&optional new)
+ "Lighter version of function `indent-for-comment'.
+Moves current comment tocomment-position. Doesn't signal any errors.
+
+Features:
+
+- if there is multiple comments on the line, like in shell or
+ perl code '#', the last one is considered as comment, *unless*
+ optional artgument NEW is given. In that case, nothing is considered
+ as old comments.
+- If line is too long for comment column it inserts additional SPC or TAB
+ between the code and comment. See variable `tinycomment-:comment-extra'
+
+Return:
+
+ t position changed OR new comment added
+ nil position not allowed"
+ (let* (
+ (xtra tinycomment-:comment-extra)
+ (x-spc (make-string tinycomment-:comment-extra-arg ?\ ))
+ (x-spc (if (eq 'tab xtra) "\t" x-spc)) ; what's the insert type ?
+ (stop-col tinycomment-:comment-extra-stop)
+ (ep (save-excursion (end-of-line) (point)))
+ (skip (or comment-start-skip comment-start))
+
+ found
+ bp ;BEG of line point
+ com-c code-c com-p
+ ret)
+ (beginning-of-line)
+ (setq bp (point))
+
+ (if (null new) ;did user say new vomment ?
+ (while (re-search-forward skip ep t) ;last comment
+ (setq found t)))
+
+;;; (d! skip new found (match-beginning 0))
+ (if (null found)
+ (progn
+ (end-of-line)
+ (indent-to comment-column)
+ (insert comment-start)
+ (setq ret t))
+
+ ;; first set comment position
+ (goto-char (match-beginning 0))
+ (setq com-p (point))
+ (setq com-c (current-column)) ;comment column
+
+ ;; Now where is the code position
+ ;; Give argument "nil" (no limit) for skip syntax function is line
+ ;; is first line in buffer.
+ ;;
+ (backward-char 1)
+ (skip-syntax-backward " " (if (eq 1 bp)
+ nil
+ (1- bp)))
+ (setq code-c (current-column))
+
+ (goto-char com-p)
+;;; (d! "#set" (current-column) comment-column com-c)
+
+ (if (= comment-column com-c)
+ nil ;nothing to do
+ (setq ret t)
+ (if (< code-c comment-column)
+ (progn ;we can indent ok
+ (delete-horizontal-space)
+;;; (d! "deleted")
+ (indent-to comment-column))
+ ;; line is too long to get position to comment-col
+;;; (d! "Too long line..." (point) com-c stop-col)
+ (if (> com-c stop-col) nil ;do not touch this
+ (delete-horizontal-space)
+;;; (d! "del ok" )
+ (insert x-spc)))))
+;;; (d! "#set end" ret (current-column))
+ ret))
+
+;;}}}
+;;{{{ tinycomment-adj-com
+
+;;; ----------------------------------------------------------------------
+;;; Original idea in asm-mode.el by :
+;;; Martin Neitzel, Techn. Univ. Braunschweig, W.Germany
+;;; BITNET/EARN: neitzel@dbsinf6.bitnet (mail via bitnet preferred)
+;;
+;;; - Thank you Martin! I'm Afraid the code isn't like yours any more,
+;;; but the same principle 'converting to bigger class'
+;;; is preserved.
+;;; - This is self standing function.
+;;;
+;;; - I really should write this again some day, divide into more smaller
+;;; blocks of funcs...
+;;;
+(defun tinycomment-adjust-comment ()
+ "Introduce a comment or convert an already existing comment to next class.
+These are the known comment classes:
+
+ 1-- Left margin ;; omitted if there is CODE on the line
+ 2-- indented like code
+ 3-- on comment column
+
+Suggested usage: while writing your code, trigger this command repeatedly
+until you are satisfied with the comment.
+
+Comment on it's own line note:
+
+- Following lines has two comment chars '#', I call it double commented line.
+ # comment text # more text
+ # set myVariable = 100; # temporarily commented
+ Because It's hard to know if the line is 'full comment' as in case 1, or
+ has 'code temporarily commented out' as line 2, we always consider
+ line as 'full comment' if line starts with `comment-start'.
+- In this case whole line moves when converting to classes.
+
+Code note:
+
+- `tinycomment-set-com' is used instead of standard `indent-for-comment'.
+- Considered adding 4th choice: indent like previous comment,
+ but I decided 4th choice or 4 taps was too much...3 seemed ideal,
+ so I left it out from 'full comment line'."
+ (let* (
+ (def-place tinycomment-:def-com-pos)
+ (tab-alist tinycomment-:tab-call-no-alist)
+ (ci (current-indentation))
+ (cc (current-column))
+ (com comment-start)
+ (col comment-column)
+ (clen (length comment-start))
+
+ ;; handle ONLY lines that have only comment, no code.
+ (re-com (concat "^[ \t]*\\(" (regexp-quote com) "+\\)"))
+ (re-com2 (concat ".*" (regexp-quote com)))
+
+ cur-code-c
+ prev-cc cur-cc ;various com-col points
+ code-col
+ class
+ prev-code-ind
+ cont
+ tmp)
+
+ (catch 'done
+ (if (or (not (integerp col)) (not (stringp com)))
+ (error "comment-[column/start] not set"))
+
+ (when (string-match "^[ \t]*$" com) ;empty comment?
+ (if (tinycomment-check-line 'emptyEol)
+ (indent-to col)
+ (message "tinycomment-adj: no comment-start defined.")
+ (throw 'done t)))
+
+ (setq cur-code-c (tinycomment-check-line 'code-last-col))
+ (setq prev-cc (tinycomment-find-prev-com-col com col cur-code-c)) ;previous c col
+ (setq cur-cc (tinycomment-find-com-col)) ;current comment column
+
+ ;; - If we do NOT already have a comment, indent for a new one.
+ (beginning-of-line)
+
+ (unless (looking-at re-com) ;comment on it's own line ?
+;;; (d! (looking-at re-com2) re-com2)
+ ;; .............................................................
+ (cond
+ ;; no comment at all or not suitable comment ?
+ ((or (null (setq tmp (looking-at re-com2)))
+ (and tmp
+ (null (tinycomment-find-com-col)))) ;it isn't suitable
+ (if (not (looking-at "[ \t]*$")) ; CODE + no COM
+ (progn
+;;; (d! "new")
+ (tinycomment-set-com 'new) ;Normal column, but it'll be changed
+ (setq cur-cc (tinycomment-find-com-col))
+ (setq class 3)) ;indent like prev line by DEF
+ ;; empty line
+ (insert com) ;see cont, it passes thru
+;;; (d! "Insert 1")
+
+ ;; User propably want CODE level indent on empty line by DEF
+ (if (eq def-place 'code )
+ (setq cont t))))
+
+ ;; There is existing comment
+ ((and cur-cc (= cur-cc col)) ;change class if possible
+ (setq class 3))
+
+ ((and cur-cc prev-cc ;make sure these are set
+ (or (null prev-cc) (= cur-cc prev-cc)))
+ ;; possibly change class to standard column
+;;; (d! "set com")
+ (tinycomment-set-com)) ; no prev comment or position was same
+
+ (t
+ ;; add New comment
+;;; (d! "new--")
+ (tinycomment-set-com)))
+
+;;; (d! "CLASS " class cur-cc col)
+ ;; Determine how CODE + COM line is handled
+ (when (eq class 3)
+
+ (save-excursion
+ (forward-line -1) (end-of-line)
+ (setq prev-code-ind (tinycomment-find-comment-col com)))
+
+;;; (d! "#1 prev" (point) "col" cur-code-c col
+;;; "cc" prev-cc cur-cc "ind" prev-code-ind )
+
+ (if (or (null prev-code-ind) ;No code found
+ (>= cur-code-c col) ;cannot put to comment-col
+ (null prev-cc) ;cannot convert to class, isn't set
+ (>= cur-code-c prev-cc) ;cannot use prev com class
+ (not (= cur-cc col))) ;convert to com-col CLASS
+ (progn
+;;; (d! "#1.1 com-col" col)
+ (tinycomment-set-com))
+
+ ;; Convert to previous comment column class then
+;;; (d! "#2 prev" prev-cc "cur" cur-cc "code" code-c)
+ (setq comment-column prev-cc) ; change temporarily
+ (tinycomment-set-com)
+ ;; restore value
+ (setq comment-column col)))
+
+;;; (d! "cont" cont)
+ (if cont
+ nil ;do we continue forward ?
+ (if (not (eolp))
+ (forward-char (length comment-start)))
+
+ (throw 'done t)))
+
+;;; (d! "Comment ok")
+
+ ;; --``-- --``-- --``-- --``-- --``-- --``-- --``-- --``-- --``--
+ ;; There is a comment, convert it between classes.
+ ;; Also correct the search position due to S-FWD command
+
+ (beginning-of-line)
+ (if (re-search-forward comment-start (tinycomment-check-line 'eolpos))
+ (goto-char (match-beginning 0)))
+
+ (setq cc (current-column)) ;at front of comment
+ (setq code-col (tinycomment-find-code-col com))
+
+ ;; First select where to convert?
+ (cond
+ ((= cc 0) ;BEG of line ?
+ (setq class 1))
+
+ ((or (eq code-col cc)
+ (eq cc col)) ; in Comment column ?
+ (setq class 0))
+
+ ((and (not (eq ci 0)) ; prallel to code ?
+ (not (eq cc col))) ; this is rough guess...
+ (setq class 2)))
+
+;;; (d! "cc" cc ci col class)
+
+ ;; --``-- --``-- --``-- --``-- --``-- --``-- --``-- --``-- --``--
+;;; (d! "TIC-ADJ" (point) (bolp) cc col class)
+
+ (cond ;Now the converting procedure
+ ((eq class 0) ;BEG of line
+ (delete-horizontal-space))
+
+ ((eq class 1) ;code level
+ (beginning-of-line) (delete-horizontal-space)
+
+ ;; Are we allowed to indent this by ourself ?
+ (if (null (memq major-mode tab-alist))
+ (indent-according-to-mode) ;let mode place the statement
+
+ (if (null code-col) ;no code
+ (indent-to comment-column)
+ (if (and (= cc 0) (= col 0)) ;if suggested POS is same
+ (indent-relative))
+ (indent-to col))))
+
+ ((eq class 2) ;column level
+ (indent-to col)))
+ (forward-char clen)) ;after class change
+
+ ;; do we need to restore the point ? [experimental]
+ ;; (if save-excur (goto-char op))
+ nil)) ;
+
+;;}}}
+;;{{{ code: main
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycomment-status ()
+ "Displays comment info."
+ (interactive)
+ (message
+ (concat
+ "cc=" (prin1-to-string comment-column) " "
+ "cs=" (prin1-to-string comment-start) " "
+ "ce=" (prin1-to-string comment-end) " "
+ "css=" (prin1-to-string comment-start-skip) " ")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycomment-set-c-vars-maybe (&optional cs ce cc css)
+ "Set comment variables CS CE CC and CSS.
+The names are `comment-start' `comment-end' etc. If some
+comment variable is nil, it will be set to some harmless value."
+ (if (null cs) (setq comment-start ""))
+ (if (null ce) (setq comment-end ""))
+ (if (not (integerp cc)) (setq comment-column 48))
+ (if (null css) (setq comment-start-skip "")))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinycomment-indent-for-comment ()
+ "Alternative to standard `indent-for-comment'.
+Relies on file extension
+and doesn't need specific mode to be turned on. Temporary buffers
+that has no file name cannot be identified by this function, so
+it passes control directly to mode. There is a chance you might not
+even notice that this function is working on the background.
+
+Verbose warnings are enabled by `tinycomment-:comment-notify'
+Special cases are handled by tinycomment-:comment-extra* variables
+Version info is on \\[tinycomment-version]."
+ (interactive)
+ (let* ((warn tinycomment-:comment-notify) ;; shorter name
+ (no-list tinycomment-:adj-no-alist)
+ (com-col 48) ;default comment column if not set
+ elt
+ (mode-desc (or (ti::id-info nil 'variable-lookup)
+ (concat
+ "code-"
+ (replace-regexp-in-string
+ "-mode" "" (symbol-name major-mode))))))
+
+ (if mode-desc
+ (setq elt (ti::id-cnv-txt2comment mode-desc)))
+
+ (if warn
+ (setq warn warn)) ;XE 19.14 ByteComp silencer
+
+ (tinycomment-set-c-vars-maybe
+ comment-start comment-end comment-column comment-start-skip)
+
+ (cond
+ ;; ........................................ mode's own commenting ...
+ ((or (memq major-mode no-list)
+ (null mode-desc))
+ ;; let mode handle comment classes, only IF NOT SET
+ ;; but let's correct some user mistakes first...
+ (indent-for-comment)) ;mode call...)
+
+ (t
+ ;; ............................................... real engine ...
+
+ (if (ti::nil-p comment-start) ;they are not defined.
+ (if elt ;we have comment info?
+ (setq comment-start (car elt) comment-end (or (cdr elt) ""))))
+
+ (tinycomment-set-c-vars-maybe
+ comment-start comment-end comment-column comment-start-skip)
+
+ ;; if the position is NOT set use default comment position
+ ;;
+ (if (not (integerp comment-column))
+ (setq comment-column com-col))
+
+ ;; - The indent-for-comment WON'T work if this is nill
+ ;; See simple.el for function def.
+ ;; - We don't set _right_ value, just sufficent replacement.
+ ;;
+ (setq comment-start-skip (concat comment-start "+"))
+ (tinycomment-adjust-comment)
+
+ (if (and warn (ti::nil-p comment-start))
+ (message
+ "TIC: unknown file, no comment syntax available")) ))))
+
+;;}}}
+
+;;{{{ example setup
+
+;;; ......................................................... &example ...
+;;; - Copy this, and use M-% to remove comment prefixes ';;* '
+;;; - Code can also be extracted with function tinylib.el/ti::package-rip-magic
+
+;;* (autoload 'turn-on-tinytab-mode "tinytab" "" t)
+;;_
+;;* (defun my-fundamental-mode ()
+;;* "my fundamental-mode"
+;;* (interactive)
+;;* (fundamental-mode)
+;;* (turn-on-tinytab-mode)
+;;* (setq tinytab-tt-mode nil)
+;;* (if (fboundp 'folding-mode)
+;;* (ti::funcall 'folding-mode))
+;;* (recenter) ;Show visible notification
+;;* ;; delete possible comment settings
+;;* (setq comment-start nil
+;;* comment-end nil
+;;* comment-column nil
+;;* ;; very important to restore this !! See simple.el
+;;* comment-indent-hook '(lambda () comment-column)))
+;;* _
+;;* (add-hook 'c++-mode-hook 'my-c++-mode-hook)
+;;* _
+;;* (defun my-c++-mode-hook ()
+;;* (setq comment-column nil ;; When set to nil, tinycomment.el takes over.
+;;* comment-start nil
+;;* comment-end nil))
+
+;;}}}
+
+(provide 'tinycomment)
+(run-hooks 'tinycomment-:load-hook)
+
+;;; tinycomment.el ends here
--- /dev/null
+;;; tinycompile.el --- Compile buffer extras. Minor mode.
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 1996-2007 Jari Aalto
+;; Keywords: extensions
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program, call M-x tinycompile-version
+;; Look at the code with folding.el
+
+;; COPYRIGHT NOTICE
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;; ....................................................... &t-install ...
+;; Put this file on your Emacs-Lisp load path, add following into your
+;; ~/.emacs startup file.
+;;
+;; ;; You could also call M-x tinycompile-install / tinycompile-uninstall
+;; (add-hook tinycompile-:load-hook 'tinycompile-install)
+;; (require 'tinycompile)
+;;
+;; or use this autoload; your ~/.emacs loads quicker
+;;
+;; (autoload 'tinycompile-mode "tinycompile" "" t)
+;; (autoload 'turn-on-tinycompile-mode "tinycompile" "" t)
+;; (add-hook 'compilation-mode-hook 'turn-on-tinycompile-mode 'append)
+;;
+;; If you find any incorrect behavior, please immediately
+;;
+;; o Turn on debug with `M-x' `tinycompile-debug-toggle'
+;; o Repeat the task
+;; o Send bug report with included debug buffer contents.
+
+;;}}}
+
+;;{{{ Documentation
+
+;; ..................................................... &t-commentary ...
+
+;;; Commentary:
+
+;; Preface, mar 1997
+;;
+;; When I was doing grepping over multiple files with igrep.el the
+;; results that were inserted into buffer were too long: There were
+;; 2-6 directory paths which occupied 40 characters and the actual
+;; grep hits were continued with \ character to the right. That was
+;; awfull to read. I couldn't get clear look at the grep results. I
+;; decided that there must be a way to clarify the results somehow, so
+;; I started writing this package.
+;;
+;; Overview of features
+;;
+;; o Shorten long directory paths (to the right hand)
+;; o Kill non-interesting files from the buffer
+;; o Hide selected lines from display
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+;;{{{ setup: misc
+
+;;; ......................................................... &require ...
+
+(require 'tinylibm)
+
+(eval-when-compile
+ (defvar mode-line-mode-menu)
+ (defvar tinyurl-mode)
+ (ti::package-use-dynamic-compilation))
+
+(ti::package-defgroup-tiny TinyCompile tinycompile-: tools
+ "Compile buffers additions.
+ Overview of features
+
+ o Shorten long directory paths (to the right hand)
+ o Kill non-interesting files from the buffer
+ o Hide selected lines from display")
+
+;;; .......................................................... &v-menu ...
+
+(defcustom tinycompile-:menu-use-flag t
+ "*Non-nil means to use echo-area menu."
+ :type 'boolean
+ :group 'TinyCompile)
+
+(defvar tinycompile-:menu-main
+ (list
+ '(format
+ "%sTinyCompile: k)ill files s)horten SPC)hide rRU)egexp RET)parse x)mode off"
+ (if current-prefix-arg
+ (format "%s " (prin1-to-string current-prefix-arg)) "" ))
+ '((?\177 . ( (tinycompile-kill-all-file-lines)))
+ (?\b . ( (tinycompile-kill-all-file-lines)))
+ (?k . ( (tinycompile-kill-all-file-lines)))
+ (?s . ( (tinycompile-shorten-lines)))
+ (?\ . ( (tinycompile-show-hide-toggle)))
+ (?r . ( (call-interactively 'tinycompile-hide-by-regexp-whole-line)))
+ (?R . ( (call-interactively 'tinycompile-hide-by-regexp)))
+ (?U . ( (call-interactively 'tinycompile-unhide)))
+ (?\C-m . ( (tinycompile-parse-line-goto)))
+ (?x . ( (turn-off-tinycompile-mode)))))
+ "*TinyCompile echo menu.
+
+k Kill/Delete all lines that referer to current file
+s If possible, shorten long path names in display
+SPC Toggle hiding lines on/off
+r Hide whole line matching regexp
+R Hide (partial) text matching regexp
+U Unhide all
+RET Goto current file and line
+x Turn mode off.")
+
+;;; ............................................................ &mode ...
+
+;;;###autoload (autoload 'tinycompile-version "tinycompile" "Display commentary." t)
+(ti::macrof-version-bug-report
+ "tinycompile.el"
+ "tinycompile"
+ tinycompile-:version-id
+ "$Id: tinycompile.el,v 2.52 2007/08/04 10:09:46 jaalto Exp $"
+ '(tinycompile-:version-id
+ tinycompile-:debug
+ tinycompile-:menu-use-flag
+ tinycompile-:menu-main
+ tinycompile-:load-hook
+ tinycompile-:table-hide)
+ '(tinycompile-:debug-buffer))
+
+;;;### (autoload 'tinycompile-debug-toggle "tinycompile" "" t)
+;;;### (autoload 'tinycompile-debug-show "tinycompile" "" t)
+
+(eval-and-compile (ti::macrof-debug-standard "tinycompile" "-:"))
+
+;;;###autoload (autoload 'turn-on-tinycompile-mode "tinycompile" "" t)
+;;;###autoload (autoload 'turn-off-tinycompile-mode "tinycompile" "" t)
+;;;###autoload (autoload 'tinycompile-mode "tinycompile" "" t)
+;;;###autoload (autoload 'tinycompile-commentary "tinycompile" "" t)
+
+(eval-and-compile
+ (ti::macrof-minor-mode-wizard
+ "tinycompile-" " Tco" "\C-c:" "Tco" 'TinyCompile "tinycompile-:" ;1-6
+
+ "Additional commands to Compile buffer. You can kill lines or
+shorten the file names and hide comments.
+
+Defined keys:
+
+Prefix key to access the minor mode is defined in
+`tinycompile-:mode-prefix-key'
+
+\\{tinycompile-:mode-map}
+\\{tinycompile-:mode-prefix-map}"
+
+ "TinyCompile"
+ (progn
+ (if (and tinycompile-mode verb
+ (not (string-match "compil" (symbol-name major-mode))))
+ (message "TinyCompile: Are you sure this is compile buffer?")))
+ "Compile buffer extras."
+ (list
+ tinycompile-:mode-easymenu-name
+ ["Kill all matching file lines at point" tinycompile-kill-all-file-lines t]
+ ["Shorten directory names" tinycompile-shorten-lines t]
+ ["Goto file at point" tinycompile-parse-line-goto t]
+ "----"
+ ["Show or hide comments (toggle)" tinycompile-show-hide-toggle t]
+ ["Hide by regexp - partial" tinycompile-hide-by-regexp t]
+ ["Hide by regexp - whole line" tinycompile-hide-by-regexp-whole-line t]
+ ["Unhide all" tinycompile-unhide t]
+ "----"
+ ["Keyboard menu" tinycompile-menu-main t]
+ ["Package version" tinycompile-version t]
+ ["Package commentary" tinycompile-commentary t]
+ ["Mode help" tinycompile-mode-help t]
+ ["Mode off" tinycompile-mode t])
+
+ (progn
+ (if (ti::xemacs-p)
+ (define-key root-map [(button2)] 'tinycompile-parse-line-goto)
+ (define-key root-map [mouse-2] 'tinycompile-parse-line-goto))
+ (cond
+ (tinycompile-:menu-use-flag
+ ;; Using menu to remeber commands is easier if you don't use
+ ;; menu bar at all.
+ (define-key root-map p 'tinycompile-menu-main))
+ (t
+ (define-key map "k" 'tinycompile-kill-all-file-lines)
+ (define-key map "s" 'tinycompile-shorten-lines)
+ (define-key map " " 'tinycompile-show-hide-toggle)
+ (define-key map "r" 'tinycompile-hide-by-regexp-whole-line)
+ (define-key map "R" 'tinycompile-hide-by-regexp)
+ (define-key map "U" 'tinycompile-unhide)
+ (define-key map "x" 'turn-off-tinycompile-mode)
+ (define-key map "?" 'tinycompile-mode-help)
+ (define-key map "Hm" 'tinycompile-mode-help)
+ (define-key map "Hc" 'tinycompile-commentary)
+ (define-key map "Hv" 'tinycompile-version)
+ ;; Overwrite {compilation-minor-mode|grep-mode} definition
+ (define-key root-map "\C-m" 'tinycompile-parse-line-goto))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycompile-menu-main (&optional arg)
+ "Show echo area menu and pass ARG to `ti::menu-menu'."
+ (interactive "P")
+ (ti::menu-menu 'tinycompile-:menu-main arg))
+
+;;; ......................................................... &v-hooks ...
+
+(defcustom tinycompile-:load-hook nil
+ "*Hook that is run when package is loaded."
+ :type 'hook
+ :group 'TinyCompile)
+
+;;}}}
+;;{{{ setup: public
+
+;;; ........................................................ &v-public ...
+;;; User configurable
+
+(defcustom tinycompile-:table-hide
+ '(("^.*\\.el:" ;lisp
+ "^.*:[ \t]*[;\"'].*")
+ ("^.*\\.\\([cC][cC]?\\|[hH][hH]?\\):" ;C/C++
+ ":[ \t]*/[/*].*"))
+ "*List of FILENAME and HIDE regexps.
+If filename in the beginning of line matches elt1 then
+show/hide all lines matching elt2.
+
+Format:
+ '((FILENAME-REGEXP HIDE-REGEXP)
+ (FILENAME-REGEXP HIDE-REGEXP)
+ ...)"
+ :type '(repeat
+ (string :tag "File Regexp")
+ (string :tag "Hide Regexp"))
+ :group 'TinyCompile)
+
+;;}}}
+
+;;{{{ code: macros
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinycompile-get-files (&optional max-point)
+ "Return all filenames in compile buffer, optionally until MAX-POINT."
+ (beginning-of-line)
+ (tinycompile-get-error-lines max-point 'car))
+
+;;}}}
+;;{{{ code: support functions
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycompile-install (&optional uninstall)
+ "Install or optinally UNINSTALL package with prefix arg."
+ (interactive "p")
+ (cond
+ (uninstall
+ (if (boundp 'grep-mode-hook)
+ (add-hook 'grep-mode-hook 'turn-on-tinycompile-mode 'append))
+ (add-hook 'compilation-mode-hook 'turn-on-tinycompile-mode 'append))
+ (t
+ (if (boundp 'grep-mode-hook)
+ (remove-hook 'grep-mode-hook 'turn-on-tinycompile-mode))
+ (remove-hook 'compilation-mode-hook 'turn-on-tinycompile-mode))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycompile-uninstall ()
+ "Uninstall package."
+ (interactive)
+ (tinycompile-install 'remove))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycompile-cd-directory ()
+ "Return the CD directory."
+ ;; Emacs 22 uses line like:
+ ;; -*- mode: grep; default-directory: "~/elisp" -*-
+ (save-excursion
+ (goto-char (point-min))
+ (or (ti::buffer-match "^-[*]- mode: grep.*\"\\([^\"]+\\)" 1)
+ (ti::buffer-match "^cd +\\(.*\\)" 1))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycompile-shorten-lines ()
+ "Shorten the filenames in compile buffer.
+
+Line format must be
+ FILE:LINE: results"
+ (interactive)
+ (let* ( ;; About 1000 lines, with 70 characters
+ (treshold (* 70 1000))
+ (indicator (and (> (- (point-max)
+ (point-min))
+ treshold)
+ t))
+ count
+ prev-point
+ dir
+ cd
+ path
+ prev
+ file)
+ (buffer-enable-undo)
+ (save-excursion
+ (ti::pmin)
+ (setq cd (tinycompile-cd-directory))
+ (while (re-search-forward "^\\([/.][^:]+\\):" nil t)
+ (setq path (match-string 1))
+ (when (and indicator
+ ;; count percentages only after 1000 chars.
+ (> (point) (+ prev-point 1000)))
+ (setq count (/ (* 100 (point)) (point-max)))
+ (message "Tinycompile: Wait, processing %d %%" count))
+ ;; ./pie-mail/hypb.el --> {cd}/pie-mail/hypb.el
+ (if (char= (aref path 0) ?.)
+ (setq path (concat cd (substring path 2))))
+ (when path
+ (setq file (file-name-nondirectory path))
+ (setq path (file-name-directory path))
+ (ti::replace-match 1 file)
+ (when
+ (or (null prev)
+ (null dir)
+ (string= dir prev))
+ (setq dir path))
+ (unless
+ (string= dir prev)
+ (setq prev dir dir path)
+ (beginning-of-line)
+ (insert "\ncd " dir "\n\n")))
+ (if indicator
+ (message "Tinycompile: Wait, processing done."))
+ (end-of-line)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycompile-parse-line-goto ()
+ "Go to line under cursor.
+The found file is loaded to emacs and cursor put to line. This works
+like `compile-goto-error'.
+
+Note:
+
+ If TinyUrl package is present and current point holds TinyUrl overlay,
+ then it is called to handle the line."
+ (interactive)
+ ;; If TinyUrl is present, try it to resolve the line.
+ ;; If it marks anything, raise flag `tinyurl'
+ (let* ((fid "tinycompile-parse-line-goto:")
+ (elt (ti::buffer-parse-line-main))
+ (file (and elt (car elt)))
+ (absolute-p (and file (string-match "^[/\\~]" file)))
+ tinyurl
+ buffer
+ win)
+ (unless fid ;; XEmacs byte compiler silencer
+ (setq fid nil))
+ (when (and absolute-p
+ (file-exists-p file)
+ (ti::overlay-supported-p)
+ (boundp 'tinyurl-mode)
+ tinyurl-mode)
+ (when (tinyurl-overlay-get) ;line already marked
+ (setq tinyurl t))
+ (tinycompile-debug fid 'TinyUrl tinyurl (ti::read-current-line)))
+ (cond
+ (tinyurl ;Let this handle url first
+ (tinyurl-dispatcher "\C-m" 'key)
+ nil)
+ (elt
+ (multiple-value-bind (file line)
+ elt
+ (setq file (ti::file-name-for-correct-system file 'emacs))
+ (setq buffer (or (find-buffer-visiting file)
+ (get-buffer file)
+ ;; We may have mistakenly grabbed 'cd' command and
+ ;; stucked it with buffers name.
+ ;; /users/foo/*scratch* --> *scratch*
+ (get-buffer (file-name-nondirectory file))))
+ ;; If buffer exists and is diplayed in another frame, use it.
+ (if buffer
+ (setq win (get-buffer-window buffer t)))
+ (tinycompile-debug fid "interactive" buffer 'file file)
+ (cond
+ ((and buffer win)
+ (select-window win)
+ (raise-frame (window-frame win)))
+ (t
+ (ti::select-frame-non-dedicated)
+ (if (and buffer
+ (not (file-exists-p file)))
+ (switch-to-buffer-other-window buffer)
+ (switch-to-buffer-other-window
+ (if (file-exists-p file)
+ (find-file-noselect file)
+ (error "TinyCompile: file not found `%s'" file))))))
+ (when line
+ (goto-line line))))
+ (t
+ (message "TinyCompile: Can't read file/line information.")
+ ;; We don't know how to handle this line, Let the mode
+ ;; below us handle it
+ (let (tinycompile-mode
+ func)
+ (setq func (lookup-key (current-local-map) "\C-m"))
+ (message "TinyCompile: Passing control to underlying \C-m key: %s"
+ (symbol-name func))
+ (when (fboundp func)
+ (funcall func)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycompile-get-error-lines (&optional max-point list-func)
+ "Get error lines in compile buffer from current point forward.
+Input:
+
+ MAX-POINT max search point, defaults to `point-max'
+ LIST-FUNC if given apply it to extract data member.
+ Eg 'car, gives you only list of filenames
+
+Return:
+
+ '((\"filename\" . NBR) ...)
+ or whatever format LIST-FUNC says."
+ (let* ((max-point (or max-point (point-max)))
+ table
+ elt)
+ (save-excursion
+ (while (and (re-search-forward "^\\([^:]+\\):[0-9]+:" nil t)
+ (< (point) max-point))
+ (setq elt (ti::buffer-parse-line-main))
+ (if list-func
+ (setq elt (funcall list-func elt)))
+ (if (null (member elt table))
+ (push elt table)))
+ (nreverse table))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycompile-kill-all-file-lines ()
+ "Kill all lines associated with the file on the current line."
+ (interactive)
+ (let* ((fid 'tinycompile-kill-all-file-lines)
+ (elt (ti::buffer-parse-line-main))
+ (cd (save-excursion
+ (goto-char (point-min))
+ (when (looking-at "^cd \\(.+\\)")
+ (match-string 1))))
+ file
+ file2
+ re
+ point)
+ (unless fid ;; XEmacs byte compiler silencer
+ (setq fid nil))
+ (if (null elt)
+ (message "TinyCompile: Can't find file name in this line.")
+ (beginning-of-line)
+ (setq file (car elt)
+ file2 (when (and cd
+ (string-match
+ (concat (regexp-quote cd) "\\(.+\\)")
+ file))
+ (match-string 1 file))
+ re (format "^%s:\\|^%s:\\|^%s:\\|^%s:"
+ (file-name-nondirectory file)
+ (regexp-quote file)
+ (file-name-nondirectory file)
+ (if file2
+ file2
+ "#cannot-match-anything")))
+ (tinycompile-debug fid 'file file 'RE re 'elt)
+ ;; Search previous line that is not the same as the line we want
+ ;; to kill
+ (while (re-search-backward re nil t))
+ (setq point (point))
+ (buffer-enable-undo)
+ (ti::pmin)
+ (delete-matching-lines re)
+ (if (< point (point-max))
+ (goto-char point)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycompile-show-hide-toggle (&optional regexp)
+ "Hide or show comment lines matching REGEXP.
+References:
+ `tinycompile-:table-hide'"
+ (interactive)
+ (let* ((list tinycompile-:table-hide)
+ search
+ show)
+ (save-excursion
+ (unless regexp ;Find right value
+ (setq show (y-or-n-p "Y = show, N = hide "))
+ (dolist (elt list)
+ (setq search (car elt))
+ (if (ti::re-search-check search)
+ (setq list nil
+ regexp (nth 1 elt)))))
+ (ti::pmin)
+ (cond
+ (show
+ (set-text-properties (point-min) (point-max) nil)
+ ;; Won't update well otherwise
+ (redraw-display))
+ (t
+ (if (null regexp)
+ (message
+ "TinyCompile: No matching regexp in tinycompile-:table-hide")
+ (ti::text-re-search
+ regexp nil nil nil
+ (if show
+ 'null
+ '(owner tinycompile invisible t)))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycompile-hide-by-regexp (regexp)
+ "Hide lines matching REGEXP."
+ (interactive "s[TinyCompile] Hide strings matching: ")
+ (tinycompile-show-hide-toggle regexp))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycompile-hide-by-regexp-whole-line (regexp)
+ "If REGEXP is found, hide whole line."
+ (interactive "s[TinyCompile] Hide lines matching: ")
+ (tinycompile-show-hide-toggle
+ (format "^.*\\(%s\\).*[\r\n]+" regexp)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycompile-unhide ()
+ "UNhide all hidden text or lines.
+See `tinycompile-hide-by-regexp' and `tinycompile-hide-by-regexp-whole-line'."
+ (interactive)
+ (set-text-properties (point-min) (point-max) nil))
+
+;;}}}
+
+;; NOTE: In some cases `tinycompile-mode' gets set globally
+;; to value `t'. Reset this, because it would take out mouse-2.
+;; Make sure that the global value is nil
+
+(if (default-value 'tinycompile-mode)
+ (setq-default tinycompile-mode nil))
+
+(add-hook 'tinycompile-:mode-define-keys-hook 'tinycompile-mode-define-keys)
+
+(provide 'tinycompile)
+(run-hooks 'tinycompile-:load-hook)
+
+;;; tinycompile.el ends here
--- /dev/null
+;;; tinycygwin.el --- Cygwin utilities (bug reports, administrative tasks).
+
+;;{{{ Id
+
+;; Copyright (C) 2004-2007 Jari Aalto
+;; Keywords: extensions
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; Look at the code with folding.el
+
+;; COPYRIGHT NOTICE
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;; ........................................................ &t-install ...
+;; Put this file on your Emacs-Lisp load path, add following into your
+;; $HOME/.emacs startup file
+;;
+;; (add-hook 'tinycygwin-:load-hook 'tinycygwin-install)
+;; (autoload 'tinycygwin-reportbug "tinycygwin" nil t)
+;; (autoload 'tinycygwin-package-info-port-maintainer-list "tinycygwin" nil t)
+;;
+;; To get extra cygwin bindings in `message-mode', add this
+;;
+;; (add-hook 'tinycygwin-:load-hook 'tinycygwin-install-message-mode)
+
+;;}}}
+;;{{{ Documentation
+
+;; ..................................................... &t-commentary ...
+
+;;; Commentary:
+
+;; Overview of features
+;;
+;; This package contains utilities for the Cygwin System.
+;; It will help users to submit bug reports from Emacs.
+;; Learn more about Cygwin at http://www.cygwin.org/
+;;
+;; To report bug against Cygwin package:
+;;
+;; M-x tinycygwin-reportbug
+;;
+;; When reporting bugs, one pseudo package is available which
+;; does not actually exist. If you select package "bug-generic"
+;; a standard bug template is generated. It can be used to report e.g.
+;; a configuration problem or to send a patch proposal to a 3rd party.
+;; The template provides additional environemtn information on your
+;; current syste,
+;;
+;; A bug report's Subject is set to a time based id tag to thelp
+;; tracking and monitoring the messages.
+;;
+;; To display list of all packages and their maintainers:
+;;
+;; M-x tinycygwin-package-info-port-maintainer-list
+;;
+;; To include e.g. cygcheck results to Email buffer, call
+;;
+;; M-x tinycygwin-sysinfo-insert-os-cygwin
+;;
+;; Further reading:
+;;
+;; http://cygwin.com/problems.html
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+;;{{{ setup: libraries
+
+(eval-when-compile
+ (require 'cl))
+
+(eval-and-compile
+ ;; Forward declarations
+ (autoload 'executable-find "executable")
+ (autoload 'mail-setup "sendmail")
+ (autoload 'message-mode "message")
+ (autoload 'message-disassociate-draft "message")
+ (autoload 'message-fetch-field "message")
+ (autoload 'message-goto-cc "message")
+ (autoload 'ti::menu-menu "tinylibmenu")
+ (autoload 'mml-attach-file "mml")
+ (autoload 'mml-minibuffer-read-type "mml")
+ (autoload 'base64-decode-string "base64")
+ ;; Byte compiler silencer. Defined in separate file
+ (defvar debug-ignored-errors)
+ (defvar font-lock-defaults)
+ (defvar font-lock-keyword-face)
+ (defvar font-lock-keywords)
+ (defvar font-lock-mode)
+ (defvar global-font-lock-mode)
+ (defvar gnus-agent-send-mail-function)
+ (defvar mail-header-separator)
+ (defvar message-font-lock-keywords)
+ (defvar message-mode-map)
+ (defvar message-send-actions)
+ (defvar message-user-mail-address)
+ (defvar smtpmail-debug-info)
+ (defvar smtpmail-local-domain)
+ (defvar stack-trace-on-error)
+ (defvar tinycygwin-:command-switch-email)
+ (defvar tinycygwin-:command-switch-expert)
+ (defvar tinycygwin-:command-switch-files)
+ (defvar tinycygwin-:command-switch-package)
+ (defvar tinycygwin-:command-switch-type)
+ (defvar user-mail-address)
+ (defvar window-system))
+
+(defgroup dired nil
+ "Cygwin System administrator's grabbag of utilities."
+ :group 'TinyCygwin)
+
+;;}}}
+;;{{{ setup: hooks
+
+;;; ......................................................... &v-hooks ...
+
+(defcustom tinycygwin-:load-hook nil
+ "*Hook run when file has been loaded."
+ :type 'hook
+ :group 'TinyCygwin)
+
+(defcustom tinycygwin-:bug-report-mail-hook nil
+ "*Hook run after `tinycygwin-bug-report-mail-compose-interactive'."
+ :type 'hook
+ :group 'TinyCygwin)
+
+;;}}}
+;;{{{ setup: user config
+
+;;; ................................................... &v-user-config ...
+
+(defcustom tinycygwin-:dummy nil
+ "*"
+ :type 'string
+ :group 'TinyCygwin)
+
+(defface tinycygwin-:warn-face
+ '((((class color) (background light))
+ (:background "green"))
+ (((class color) (background dark))
+ (:background "sea green"))
+ (((class grayscale monochrome)
+ (background light))
+ (:background "black"))
+ (((class grayscale monochrome)
+ (background dark))
+ (:background "white")))
+ "Face used for warnings."
+ :group 'TinyCygwin)
+
+(defface tinycygwin-:item-face
+ '((((class color) (background light))
+ (:foreground "green4"))
+ (((class color) (background dark))
+ (:foreground "green3")))
+ "Face used for noticing important items."
+ :group 'TinyCygwin)
+
+(defcustom tinycygwin-:expert-flag nil
+ "*If non-nin, ask minimum of question in expert mode.
+All fancy features or Emacs settings are also disabled."
+ :type 'boolean)
+
+(defcustom tinycygwin-:debug nil
+ "*Print extra message when debug iqs non-nil."
+ :type 'boolean)
+
+;;}}}
+;;{{{ setup: -- private
+
+;;; ....................................................... &v-private ...
+
+(defvar tinycygwin-:os-type
+ (cond
+ ;; Win32 and Cygwin are considered equal here
+ ((or (memq system-type '(ms-dos windows-nt))
+ (file-directory-p "c:/"))
+ 'cygwin)
+ ((or (memq system-type '(gnu/linux))
+ (string-match "linux" (emacs-version))
+ (file-directory-p "/boot/vmlinuz")
+ (file-directory-p "/vmlinuz"))
+ 'linux)
+ ((or (memq system-type '(darwin))
+ (string-match "darwin" (emacs-version))) ;; Mac OS
+ 'darwin))
+ "Recognized system type: cygwin, linux, darwin,")
+
+(defvar tinycygwin-:original-font-lock-keywords nil
+ "This value holds copy of `font-lock-keywords'. Do not touch.
+Variable is made buffer local in `message-mode'.")
+
+(defvar tinycygwin-:external-call-flag nil
+ "Set to non-nil while bug interface is called form external shell script.
+Do not in any circumstances set this variable.")
+
+(defvar tinycygwin-:external-call-flag-value nil
+ "Set to non-nil while bug interface is called form external shell script.
+This is buffer local version of dynamically bound
+`tinycygwin-:external-call-flag'.")
+
+(defvar tinycygwin-:external-email-address nil
+ "Set to non-nil when bug interface is called form external shell script.
+Do not in any circumstances set this variable, but
+set `user-mail-address' to correct value.")
+
+(defvar tinycygwin-:email-cygwin-users-list
+ "user list <cygwin@cygwin.com>"
+ "Email address of Cygwiin mailing list.")
+
+(defvar tinycygwin-:email-cygwin-apps-list
+ "devel list (subscriber only) <cygwin-apps@cygwin.com>"
+ "Email address of Cygwin mailing list.")
+
+(defvar tinycygwin-:email-cygwin-xfree-list
+ "xfree devel list <cygwin-apps@cygwin.com>"
+ "Email address of Cygwiin mailing list.")
+
+(defvar tinycygwin-:email-cygbug-maintainer
+ (lambda ()
+ (concat
+ "cygbug/tinycygwin.el maintainer - "
+ (base64-decode-string "amFyaS5hYWx0b0Bwb2JveGVzLmNvbQ==")))
+ "Email address of mainteiner. String or function.
+The function should return email address.")
+
+(defvar tinycygwin-:root-dir "/"
+ "Location of Cygwin root directory.")
+
+(defvar tinycygwin-:file-install-db
+ (concat (file-name-as-directory tinycygwin-:root-dir)
+ "etc/setup/installed.db")
+ "Location of `installed.db'.
+Notice that this is the official Cygwin nstallation file that
+reports packages that have been installed using Cygwin netinstaller.
+This does not report any 3rd party local installation.")
+
+(defvar tinycygwin-:path-doc-root-list
+ (list (concat (file-name-as-directory tinycygwin-:root-dir)
+ "usr/share/doc")
+ (concat (file-name-as-directory tinycygwin-:root-dir)
+ "usr/doc")) ;; Old location
+ "Location of documentation.")
+
+(defvar tinycygwin-:path-doc-cygwin-list
+ (list (concat (file-name-as-directory tinycygwin-:root-dir)
+ "usr/share/doc/Cygwin")
+ (concat (file-name-as-directory tinycygwin-:root-dir)
+ "usr/doc/Cygwin")) ;; Old location
+ "List of directories of Cygwin package documentation.")
+
+(defvar tinycygwin-:bin-cygcheck (executable-find "cygcheck")
+ "Location of `cygcheck' binary.")
+
+(defvar tinycygwin-:file-cygcheck
+ (concat (file-name-as-directory tinycygwin-:root-dir)
+ "tmp/cygcheck-report.txt")
+ "Cached result of cygcheck -c -s -d")
+
+(defvar tinycygwin-:buffer-maintainer-list "*Cygwin maintainer summary*"
+ "List of Cygwin packages and their maintainers.
+See \\[tinycygwin-package-info-port-maintainer-list\\]")
+
+(defvar tinycygwin-:buffer-cygcheck "*Cygwin cygcheck*"
+ "Cygcheck systeinfo buffer")
+
+(defvar tinycygwin-:history-ask-program nil
+ "History of quesions.
+See function `tinycygwin-message-mode-attach-program-version'.")
+
+(defvar tinycygwin-:history-ask-version nil
+ "History of quesions.
+See function `tinycygwin-message-mode-attach-program-version'.")
+
+(defconst tinycygwin-:sysinfo-program-list
+ '((devel-tools ("gcc" "make" "libtool" "automake"))
+ (lang ("perl" "python" "ruby")))
+ "List of system information bundles.
+Format:
+
+ '((BUNDLE-SYMBOL (\"program\" \"program\" ...))
+ ..)")
+
+(defconst tinycygwin-:sysinfo-environment-list
+ '("CYGWIN")
+ "List of environment variables to include to bug report.")
+
+(defvar tinycygwin-:package-maintainer-email-include nil
+ "Should the Cygwin Net package maintainer's email addres be offered.
+Nil is the default value. If you set this to `t' be sure that
+you know what you're doing. The default policy is not to send any personal
+mail, but direct bug messages to the mailing lists.
+
+Only if you're a package developer and know some of the maintainers
+personally, setting this variable to t provide concatct help.")
+
+(defvar tinycygwin-:package-upstream-email-include t
+ "Should the Upstream author's email address be offered.
+That, the author who is developing the package. Most likely he knows
+nothing about Cygwin, so tthe Cygwin mailing lists should be the
+first contact points. If you have found real bug, then it would
+be good to contact the Author.")
+
+;; Same as in Debian
+(defconst tinycygwin-:severity-list
+ '(("critical"
+ "Makes unrelated software on the system (or the whole system) break,
+or causes serious data loss, or introduces a security hole on systems where
+you install the package.")
+ ("grave"
+ "Makes the package in question unuseable or mostly so, or causes data
+loss, or introduces a security hole allowing access to the accounts of users
+who use the package.")
+ ("serious"
+ "Severe violation of policy (that is, it violates a
+\"must\" or \"required\" directive), or, in the package maintainer's
+opinion, makes the package unsuitable for release.")
+ ("important"
+ "A bug which has a major effect on the usability of a package,
+without rendering it completely unusable to everyone.")
+ ("normal"
+ "The default value, applicable to most bugs.")
+ ("minor"
+ "A problem which doesn't affect the package's usefulness, and is
+presumably trivial to fix.")
+ ("wishlist"
+ "For any feature request, and also for any bugs that are very
+difficult to fix due to major design considerations.")
+ ("fixed"
+ "For bugs that are fixed but should not yet be closed. This is an
+exception for bugs fixed by non-maintainer uploads. Note: the "fixed"
+tag should be used instead."))
+ "The bug system may record a severity level with each bug report.
+This is set to normal by default, but can be overridden either by supplying a Severity line in the pseudo-header when the bug is submitted Severity or error.")
+
+(defvar tinycygwin-:menu-severity-selected nil
+ "Functions `tinycygwin-severity-select-*' set this to user selection.")
+
+(defvar tinycygwin-:menu-bug-classification-selected nil
+ "Functions `tinycygwin-type-select-*' set this to user selection.")
+
+(defconst tinycygwin-:menu-bug-classification
+ '("\
+Type of bug: q)uit ?)help RET)standard u)pdate U)pstream"
+ ;; NOTE: These function are automatically created, you don't find
+ ;; See `tinycygwin-install-bug-classification-functions'.
+ ((?\C-m . ( (setq tinycygwin-:menu-bug-classification-selected
+ "standard")))
+ (?u . ( (setq tinycygwin-:menu-bug-classification-selected
+ "update")))
+ (?U . ( (setq tinycygwin-:menu-bug-classification-selected
+ "upstream")))))
+ "Bug classification menu.
+
+standard
+ Report standard package bug. The packaging is erroneous, files are
+ in incorrect places, configuration files have problems, default setup
+ does not work etc.
+
+ Please do not report program's behavious problems. The package
+ maintainer does not know how the program is supposed to work. He has
+ only put it available in Cygwin Net Release form, so he is not the
+ correct person where to report problems in the program itself (see
+ bug type 'upstream' below).
+
+update
+ Request package update. Package included in Cygwin is out of date
+ and there is newer one available at upstream sources. You want the
+ package maintainer to be informed.
+
+upstream
+ Report problems to upstream. You are seing erratic behavior of the
+ program or you think some new feature would be nice. Contact maintainer
+ or author of the program.")
+
+(defconst tinycygwin-:menu-severity
+ '("\
+Severity: q?)help c)rit g)rave s)erious i)import RET-n)orm m)inor w)ish f)ixed"
+ ;; NOTE: These function are automatically created, you don't find
+ ;; them with C-h f or from this file with C-s.
+ ;; See `tinycygwin-install-severity-functions'
+ ((?c . ( (call-interactively 'tinycygwin-severity-select-critical)))
+ (?g . ( (call-interactively 'tinycygwin-severity-select-grave)))
+ (?s . ( (call-interactively 'tinycygwin-severity-select-serious)))
+ (?i . ( (call-interactively 'tinycygwin-severity-select-important)))
+ (?n . ( (call-interactively 'tinycygwin-severity-select-normal)))
+ (?\C-m . ( (call-interactively 'tinycygwin-severity-select-normal)))
+ (?m . ( (call-interactively 'tinycygwin-severity-select-minor)))
+ (?w . ( (call-interactively 'tinycygwin-severity-select-wishlist)))
+ (?f . ( (call-interactively 'tinycygwin-severity-select-fixed)))))
+ "Severity menu.
+
+The bug system records a severity level with each bug report. This is set
+to normal by default, but can be overridden either by supplying a Severity
+line in the pseudo-header when the bug is submitted (see the instructions
+for reporting bugs), or by using the severity command with the control
+request server.
+
+critical
+ Makes unrelated software on the system (or the whole system) break, or
+ causes serious data loss, or introduces a security hole on systems where
+ you install the package.
+
+grave
+ Makes the package in question unuseable or mostly so, or causes data loss,
+ or introduces a security hole allowing access to the accounts of users who
+ use the package.
+
+serious
+ Is a severe violation of policy (that is, it violates a \"must\" or
+ \"required\" directive), or, in the package maintainer's opinion, makes the
+ package unsuitable for release.
+
+important
+ A bug which has a major effect on the usability of a package, without
+ rendering it completely unusable to everyone.
+
+normal
+ The default value, applicable to most bugs.
+
+minor
+ A problem which doesn't affect the package's usefulness, and is presumably
+ trivial to fix.
+
+wishlist
+ For any feature request, and also for any bugs that are very difficult to
+ fix due to major design considerations.
+
+fixed
+ For bugs that are fixed but should not yet be closed. This is an exception
+ for bugs fixed by non-maintainer uploads. Note: the \"fixed\" tag should be
+ used instead. Certain severities are considered release-critical, meaning
+ the bug will have an impact on releasing the package with the stable
+ release. Currently, these are critical, grave and serious.")
+
+(defvar tinycygwin-:tags-list
+ '(("patch"
+ "A patch or some other easy procedure for fixing the bug is included
+in the bug logs. If there's a patch, but it doesn't resolve the bug
+adequately or causes some other problems, this tag should not be used.")
+ ("wontfix"
+ "This bug won't be fixed. Possibly because this is a choice between
+two arbitrary ways of doing things and the maintainer and submitter prefer
+different ways of doing things, possibly because changing the behaviour
+will cause other, worse, problems for others, or possibly for other reasons.")
+ ("moreinfo"
+ "This bug can't be addressed until more information is provided by
+the submitter. The bug will be closed if the submitter doesn't provide
+more information in a reasonable (few months) timeframe. This is for
+bugs like "It doesn't work". What doesn't work?.")
+ ("unreproducible"
+ "This bug can't be reproduced on the maintainer's system.
+Assistance from third parties is needed in diagnosing the cause of the problem.")
+ ("help"
+ "The maintainer is requesting help with dealing with this bug.")
+ ("pending"
+ "The problem described in the bug is being actively worked on,
+i.e. a solution is pending.")
+ ("fixed"
+ "This bug is fixed or worked around (by a non-maintainer upload,
+for example), but there's still an issue that needs to be resolved.
+This tag replaces the old \"fixed\" severity.")
+ ("security"
+ "This bug describes a security problem in a package (e.g., bad
+permissions allowing access to data that shouldn't be accessible;
+buffer overruns allowing people to control a system in ways they
+shouldn't be able to; denial of service attacks that should be fixed, etc).
+Most security bugs should also be set at critical or grave severity.")
+ ("upstream"
+ "This bug applies to the upstream part of the package."))
+ "Each bug can have zero or more of a set of given tags.
+These tags are displayed in the list of bugs when you look at a
+package's page, and when you look at the full bug log.")
+
+(defvar tinycygwin-:wnpp-buffer "*TinyCygwin WNPP*"
+ "WNPP question buffer.")
+
+(defvar tinycygwin-:menu-wnpp-selected nil
+ "Placeholder of selection from `tinycygwin-:menu-wnpp'.")
+
+(defconst tinycygwin-:menu-wnpp
+ (list
+ '(format
+ "\
+WNPP:%s q?)help 1i)itp 2o)rphan 3a)dopt 4n)ew suggested package"
+ (if tinycygwin-:menu-wnpp-selected
+ (format "%s; " (symbol-name tinycygwin-:menu-wnpp-selected))
+ ""))
+ (list
+ '(?1 . ( (setq tinycygwin-:menu-wnpp-selected 'package)))
+ '(?i . ( (setq tinycygwin-:menu-wnpp-selected 'package)))
+ '(?I . ( (setq tinycygwin-:menu-wnpp-selected 'package)))
+ '(?p . ( (setq tinycygwin-:menu-wnpp-selected 'package)))
+ '(?P . ( (setq tinycygwin-:menu-wnpp-selected 'package)))
+ '(?2 . ( (setq tinycygwin-:menu-wnpp-selected 'orphan)))
+ '(?o . ( (setq tinycygwin-:menu-wnpp-selected 'orphan)))
+ '(?O . ( (setq tinycygwin-:menu-wnpp-selected 'orphan)))
+ '(?3 . ( (setq tinycygwin-:menu-wnpp-selected 'adopt)))
+ '(?a . ( (setq tinycygwin-:menu-wnpp-selected 'adopt)))
+ '(?A . ( (setq tinycygwin-:menu-wnpp-selected 'adopt)))
+ '(?4 . ( (setq tinycygwin-:menu-wnpp-selected 'new)))
+ '(?n . ( (setq tinycygwin-:menu-wnpp-selected 'new)))
+ '(?N . ( (setq tinycygwin-:menu-wnpp-selected 'new)))))
+ ;; This message is straight from reportbug(1)
+ ;; 'apt-get install reportbug'
+ "What request type? If none of these things mean anything to you you
+should report normal bug to existing package instead.
+
+1 i ITP, `Intent To Package'. You want to be maintainer
+ of this package. Please submit a package description
+ along with copyright and URL in such a report.
+
+2 o The package has been `Orphaned'. Nobody is maintaining it.
+ It needs a new maintainer as soon as possible.
+
+3 a RFA, this is a `Request for Adoption'. Due to lack of time, resources,
+ interest or something similar, the current maintainer is asking for
+ someone else to maintain this package. He/she will maintain it in the
+ meantime, but perhaps not in the best possible way. In short: the
+ package needs a new maintainer.
+
+4 n RFP, this is a `Request For Package'. You have found an interesting
+ piece of software and would like SOMEONE ELSE to package and
+ maintain it. Please submit a package description along with
+ copyright and URL in such a report.
+
+q Quit menu.
+
+See http://www.debian.org/devel/wnpp for more information
+")
+
+;; Emacs includes so good message.el colors, that it does not need
+;; these. Do not modify.
+
+(defvar tinycygwin-:message-mode-font-lock-keywords-window-system
+ (list
+ (list
+ "^-- +[A-Z][^ \t\r\n]+ +.*"
+ (list 0 'font-lock-builtin-face t))
+ (list
+ "^Severity:[ \t]+\\(critical\\|grave\\|serious\\)"
+ (list 1 'font-lock-warning-face t))
+ (list
+ "^Severity:[ \t]+\\(wishlist\\)"
+ (list 1 'font-lock-string-face t))
+ (list
+ "^[A-Z][^ \t\r\n]+:"
+ (list 0 'font-lock-doc-string-face))
+ (list
+ "^\\[ATTACHMENT.*"
+ (list 0 'font-lock-constant-face t)))
+ "Additional `message-mode' `font-lock-keywords'.
+This is for XEmacs. Activated only if `tinycygwin-:expert-flag' is nil.")
+
+;;; (list
+;;; "^\\([Tt]o:\\)\\(.*\\)"
+;;; (list 1 'message-header-name-face)
+;;; (list 2 'message-header-to-face nil t))
+;;; (list
+;;; "^\\([Cc]C\\|Reply-[Tt]o:\\)\\(.*\\)"
+;;; (list 1 'message-header-name-face)
+;;; (list 2 'message-header-cc-face nil t))
+;;; (list
+;;; "^\\(Subject:\\)\\(.*\\)"
+;;; (list 1 'message-header-name-face)
+;;; (list 2 'message-header-subject-face nil t))
+
+(defvar tinycygwin-:message-mode-font-lock-keywords-non-window-system
+ ;; In XEmacs 21.4, Cygwin, there are only two faces available.
+ (list
+ (list
+ "^[A-Z][^ \t\r\n]+:"
+ (list 0 'font-lock-type-face))
+ (list
+ "^-- +[A-Z][^ \t\r\n]+ +.*"
+ (list 0 'font-lock-function-name-face t))
+ (list
+ "^Severity:[ \t]+\\(critical\\|grave\\|serious\\)"
+ (list 1 'font-lock-warning-face t))
+ (list
+ "^Severity:[ \t]+\\(wishlist\\)"
+ (list 1 'font-lock-comment-face t))
+ (list
+ "^\\[ATTACHMENT.*"
+ (list 0 'message-header-other-face t)))
+ "Additional `message-mode' `font-lock-keywords'.
+This is for XEmacs. Activated only if `tinycygwin-:expert-flag' is nil.")
+
+(defvar tinycygwin-:email-address-correct-list
+ '((" A *T " "@")
+ (" do?t " "."))
+ "List of regexp to correct email addresses.
+Format:
+ '((SEARCH-REGEXP REPLACE-STRING)
+ (SEARCH-8REGEXP REPLACE-STRING)
+ ...)")
+
+;;}}}
+;;{{{ XEmacs support
+
+;;; ----------------------------------------------------------------------
+;;;
+;;; (put 'tinycygwin-defalias 'lisp-indent-function 0)
+(defmacro tinycygwin-defalias (this that)
+ "If there is no THIS then use THAT. Signal error if cannot make `defalias'."
+ `(if (not (fboundp ,this))
+ (if (fboundp ,that)
+ (defalias ,this ,that)
+ (error "[ERROR] function is not supported by this X/Emacs: %s"
+ (symbol-name ,this)))))
+
+(unless (fboundp 'replace-regexp-in-string)
+ (defun replace-regexp-in-string (re str string)
+ "TinyCygwin XEmacs support.
+This is a cheap implementaion of an Emacs function and it DOES NOT
+support all the capabilities. You code will break if it relies on this
+to exist."
+ (with-temp-buffer
+ (insert string)
+ (goto-char (point-min))
+ (while (re-search-forward re nil t)
+ (replace-match str))
+ (buffer-string))))
+
+(defun tinycygwin-window-system ()
+ "XEmacs and Emacs Compatibility, Mimic Emacs `window-system' variable.
+In XEmacs the `cosole-type' returns 'tty on terminal, but this function
+return nil to be in par with Emacs behavior. An 'tty is not a windowed
+environment."
+ (let ((func 'console-type))
+ (cond
+ ((fboundp func)
+ (let ((val (funcall func)))
+ (unless (eq 'tty val)
+ val)))
+ ((boundp 'window-system)
+ (symbol-value 'window-system)))))
+
+(tinycygwin-defalias 'insert-file-literally 'insert-file-contents-literally)
+(tinycygwin-defalias 'insert-file-literally 'insert-file)
+(tinycygwin-defalias 'line-beginning-position 'point-at-bol)
+(tinycygwin-defalias 'line-end-position 'point-at-eol)
+
+;;}}}
+;;{{{ General
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinycygwin-file-binary-p (file)
+ "Check if FILE name looks like binary file (.gz etc.)."
+ (string-match "\\.\\(g?z\\|bz2\\|zip\\|tar\\)" file))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-insert-file (file)
+ "INsert FILE literally at point."
+ (tinycygwin-clean-system-with
+ (insert-file-literally file)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinycygwin-mail-attachment-tag (string)
+ "Return attachment tag for STRING."
+ (format "[ATTACHMENT: %s]"
+ (if (string-match "[\\/]" string)
+ (file-name-nondirectory string)
+ string)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinycygwin-maintainer ()
+ "Return maintainer."
+ (let ((val tinycygwin-:email-cygbug-maintainer))
+ (cond
+ ((functionp val)
+ (funcall val))
+ ((stringp val)
+ val)
+ ((listp val)
+ (eval val)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-variable-documentation (variable-sym)
+ "Return documentation of VARIABLE-SYM."
+ (let ((str (documentation-property
+ (if (boundp variable-sym)
+ variable-sym)
+ 'variable-documentation)))
+ (when (stringp str)
+ (replace-regexp-in-string
+ "\r" ;; Remove possible extra line endings
+ ""
+ str))))
+
+;;}}}
+;;{{{ Install: bindings
+
+;;; ........................................................ &bindings ...
+
+(defun tinycygwin-tab-to-tab-stop-4-spaces (map)
+ "Define TAB key to run 4 spaces."
+ ;; Status: `tab-stop-list' is core Emacs variable
+ ;; Info: (Info-goto-node "(emacs)Tab Stops")
+ ;;
+ ;; Make TAB key advance at 4 positions at the time. The code
+ ;; will set the tab-stop-list to value '(4 8 12 16 20 ...)
+ (make-local-variable 'tab-stop-list)
+ (setq tab-stop-list
+ (let ((i 4) list)
+ (while (< i 80)
+ (setq list (cons i list))
+ (setq i (+ i 4)))
+ (reverse list)))
+ (define-key map "\t" 'tab-to-tab-stop))
+
+;; #todo:
+(defun tinycygwin-bug-report-default-bindings ()
+ "Define default key bindings to `tinycygwin-mode-map'.")
+
+;;}}}
+;;{{{ Install: generate severity function etc.
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinycygwin-install-menu-function-macro 'lisp-indent-function 0)
+(defmacro tinycygwin-install-menu-function-macro (template value variable)
+ "Generate ti::menu TEMPLATE, VALUE using VARIABLE."
+ (let* ((sym (intern (format template value))))
+ `(defun ,sym ()
+ (interactive)
+ (setq ,variable , value))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro tinycygwin-menu-call-with (menu-symbol variable)
+ "Call MENU-SYMBOL and return content of VARIABLE."
+ ` (progn
+ (setq ,variable nil)
+ (ti::menu-menu ,menu-symbol)
+ ,variable))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-install-menu-function-list (variable-sym)
+ "Get list of menu functions from VARIABLE-SYM.
+The menu item is left flushed, lowercase word that is immediately
+followed by indented two space explanation. An example:
+
+ item
+ The item is ..."
+ (let* ((string (tinycygwin-variable-documentation variable-sym))
+ case-fold-search
+ list)
+ (when string
+ (with-temp-buffer
+ (insert string)
+ (goto-char (point-min))
+ (while (re-search-forward "^\\([a-z]+\\)[ \t]*\n[ \t]+[A-Z]" nil t)
+ (push (match-string 1) list))))
+ list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-install-severity-functions ()
+ "Generate `tinycygwin-severity-select-*' user functions."
+ ;; Generate functions at run-time.
+ (mapcar
+ (lambda (x)
+ (eval
+ `(tinycygwin-install-menu-function-macro
+ "tinycygwin-severity-select-%s"
+ ,x
+ tinycygwin-:menu-severity-selected)))
+ (tinycygwin-install-menu-function-list
+ 'tinycygwin-:menu-severity)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-install-bug-classification-functions ()
+ "Generate `tinycygwin-severity-select-*' user functions."
+ ;; Generate functions at run-time.
+ (mapcar
+ (lambda (x)
+ (eval
+ `(tinycygwin-install-menu-function-macro
+ "tinycygwin-type-select-%s"
+ ,x
+ tinycygwin-:menu-bug-classification-selected)))
+ (tinycygwin-install-menu-function-list
+ 'tinycygwin-:menu-bug-classification)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-find-file-hooks ()
+ "Install `font-lock-keywords' for log files."
+ (tinycygwin-font-lock-keywords))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-install-font-lock-keywords (&optional uninstall)
+ "Install colors to all current buffers."
+ (dolist (buffer (buffer-list))
+ (with-current-buffer buffer
+ (tinycygwin-font-lock-keywords uninstall))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-message-mode-help ()
+ "Return quick help of additional commands."
+ (substitute-command-keys
+ (concat
+ "Insert (file) "
+ "\\[tinycygwin-insert-attach-file-as-is] "
+ "(Env. var) "
+ "\\[tinycygwin-insert-environment-variable-content] "
+ "(cygcheck) "
+ "\\[tinycygwin-message-mode-attach-cygcheck]")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-message-mode-help-simple ()
+ "Return quick help of additional commands."
+ (concat
+ "Additional Cygwin related commands at C-c C-p C-h"))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-message-mode-faces ()
+ "Use custom faces."
+ ;; The defaults are not readable in Cygwin white/black rxvt
+ (set-face-foreground
+ 'message-header-name-face
+ (face-foreground 'font-lock-string-face))
+ (set-face-foreground
+ 'message-header-cc-face
+ (face-foreground 'font-lock-constant-face))
+ (set-face-foreground
+ 'message-header-to-face
+ (face-foreground 'font-lock-builtin-face)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-message-mode-hook ()
+ "Install extra Cygwin specific keybindings to `message-mode'."
+ (when (boundp 'message-mode-map)
+ (tinycygwin-tab-to-tab-stop-4-spaces message-mode-map)
+ (define-key message-mode-map "\C-C\C-pa"
+ 'tinycygwin-insert-attach-file-as-is)
+ (define-key message-mode-map "\C-C\C-pc"
+ 'tinycygwin-message-mode-attach-cygcheck)
+ (define-key message-mode-map "\C-C\C-pe"
+ 'tinycygwin-insert-environment-variable-content)
+ (define-key message-mode-map "\C-C\C-p-"
+ 'font-lock-mode)
+ (define-key message-mode-map "\C-C\C-p\C-r"
+ 'rename-uniquely)
+ (define-key message-mode-map "\C-C\C-pv"
+ 'tinycygwin-message-mode-attach-program-version)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-install-message-mode (&optional uninstall)
+ "Install extra Cygwin specific keybindings to `message-mode'."
+ (if uninstall
+ (remove-hook 'message-mode-hook 'tinycygwin-message-mode-hook)
+ (add-hook 'message-mode-hook 'tinycygwin-message-mode-hook)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinycygwin-install (&optional uninstall)
+ "Install or optionally UNINSTALL (i.e. inactivate) this lisp package."
+ (interactive "P")
+ (when nil
+ (cond
+ (uninstall
+ (tinycygwin-install-font-lock-keywords 'uninstall)
+ (remove-hook 'find-file-hooks 'tinycygwin-find-file-hooks)
+ nil)
+ (t
+ (tinycygwin-install-font-lock-keywords)
+ (add-hook 'find-file-hooks 'tinycygwin-find-file-hooks)
+ nil))))
+
+;;}}}
+;;{{{ Email functions
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-insert-attach-file-as-is (file)
+ "Insert FILE attachment \"as is\" to the end of buffer.
+This is different than a regular MIME attachment that is
+inserted in `message-mode' with \\[mml-attach-file]."
+ (interactive "FAttach file as is: ")
+ (save-current-buffer
+ (goto-char (point-max))
+ (tinycygwin-bug-report-mail-attach-file file)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-insert-environment-variable-content (var)
+ "Inser content of environment variable VAR at point."
+ (interactive
+ (list
+ (completing-read
+ "Iinsert environment variable: "
+ (mapcar
+ (lambda (x)
+ (if (string-match "^\\(.+\\)=\\(.*\\)" x)
+ (cons (match-string 1 x)
+ (match-string 2 x))
+ (cons "__NOT_FOUND__" . 1)))
+ process-environment)
+ nil
+ 'match)))
+ (when var
+ (let ((value (getenv var)))
+ (insert (format "%s=%s" var (or (getenv var) ""))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-message-mode-attach-cygcheck ()
+ "Insert cygcheck retults to the end of buffer as a MIME attachement."
+ (interactive)
+ (let* ((file (make-temp-file "emacs-tinycygwin-cygcheck"))
+ point
+ status)
+ (save-current-buffer
+ (goto-char (point-max))
+ (message "Wait, calling cygcheck [may take a while]... ")
+ (with-temp-buffer
+ (tinycygwin-sysinfo-insert-os-cygwin)
+ (write-region (point-min) (point-max) file))
+ (message "Wait, calling cygcheck [may take a while]... Done.")
+ (tinycygwin-bug-report-mail-insert-files (list file) 'mime))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-program-parse-version ()
+ "Parse version information from program's version output."
+ (let* ((list '(("[0-9]+\\.[0-9]+\\([0-9.]+\\)?" 0)))
+ version)
+ (dolist (elt list)
+ (goto-char (point-min))
+ (multiple-value-bind (regexp subexp) elt
+ (when (and (re-search-forward regexp nil t)
+ (setq version (match-string subexp)))
+ (return))))
+ version))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-message-mode-attach-program-version
+ (program &optional opt mode)
+ "Insert version information of PROGRAM calling with optional OPT.
+
+Possible values for variable MODE
+
+ 'end Insert to the end of buffer.
+ 'ask Ask user what to do.
+ nil Insert at point."
+ (interactive
+ (list
+ (read-string "Progam name: "
+ nil 'tinycygwin-:history-ask-program)
+ (read-string "Version option [--version by default]: "
+ nil tinycygwin-:history-ask-version)
+ 'ask))
+ (let* ((file (make-temp-file
+ (format
+ "emacs-tinycygwin-program-version-%s" program)))
+ (try-opt (if (or (null opt)
+ (and (stringp opt)
+ (string= opt "")))
+ '("--version" "-V" "-v")
+ (list opt)))
+ (bin (if (not (string-match "[\\/]" program))
+ (executable-find program)
+ program))
+ point
+ status
+ version)
+ (unless bin
+ (error "TinyCygwin: [ERROR] %s not found in PATH" program))
+ (save-current-buffer
+ (dolist (option try-opt)
+ (message "Wait, calling %s %s ... "
+ program option)
+ (with-temp-buffer
+ (call-process bin
+ nil ;infile
+ (current-buffer) ;buffer
+ nil ;display
+ option)
+ (when (setq version (tinycygwin-program-parse-version))
+ (write-region (point-min) (point-max) file)
+ (setq opt option)
+ (return))))
+ (cond
+ ((null version)
+ (message "Couldn't read version information. Please insert manually."))
+ (t
+ (let ((action (if (eq mode 'ask)
+ (if (y-or-n-p
+ "Insert at point or to the end of buffer? ")
+ nil
+ 'end)
+ mode)))
+ (cond
+ ((eq action 'end)
+ (goto-char (point-max))
+ (tinycygwin-bug-report-mail-attach-file file))
+ (t
+ (insert-file-contents-literally file)))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-user-mail-address-valid-p (email)
+ "Check if EMAIL address look valid."
+ (and (stringp email)
+ ;; foo@this.net
+ ;; || || | |
+ ;; 12 34 5 6
+ ;;
+ ;; 1. start with non-whitespace
+ ;; 2. followed by anything until @
+ ;; 3. continue non-whitespace
+ ;; 4. followed by anything until
+ ;; 5. Must have period "."
+ ;; 6. continue non-whitespace
+ (string-match
+ (concat
+ "^"
+ "[ \t]*"
+ "[^ \t\r\n]+.*@[^ \t\r\n]+.*\\.[^ \t\r\n]+"
+ "[ \t]*"
+ "$")
+ email)
+ email))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-user-full-name-valid-p (str)
+ "Check if STR includes valid 'Firstname Lastname'."
+ (and (stringp str)
+ (let (case-fold-search)
+ (string-match "^[^ \t\r\n]+ +[^ \t\r\n]" str))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-user-mail-address-value (&optional email)
+ "Check `user-mail-address' and read environment variable EMAIL.
+Return correct email address or nil."
+ (dolist (try (list
+ email
+ tinycygwin-:external-email-address
+ (and (boundp 'message-user-mail-address)
+ message-user-mail-address)
+ (and (boundp 'user-mail-address)
+ user-mail-address)
+ (getenv "EMAIL")))
+ (if (and (stringp try)
+ (tinycygwin-user-mail-address-valid-p try))
+ (return try))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-user-mail-address-set ()
+ "Set `user-mail-address' from possible addresses; the one that is valid.
+If `user-mail-address' is already valid, do nothing. If cannot set,
+call `error'."
+ (unless (tinycygwin-user-mail-address-valid-p user-mail-address)
+ (let ((value (tinycygwin-user-mail-address-value)))
+ (unless value
+ (error (concat "** [ERROR] Can't determine `user-mail-address'."
+ "Please define environemnt variable EMAIL.")))
+ (setq user-mail-address value))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-user-full-name-set ()
+ "Set `user-full-name' from environment.
+The varaibles NAME and DEBFULLNAME are examine if `user-full-name'
+does not contain space separated Firstname Lastname."
+ (unless (tinycygwin-user-full-name-valid-p user-full-name)
+ (let ((name (or (getenv "NAME")
+ (getenv "DEBFULLNAME"))))
+ (unless name
+ (error "TinyCygwin: [ERROR] Can't set `user-full-name'. %s"
+ "Please define environment variable NAME."))
+ (setq user-full-name name))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-user-mail-address-fix-angles ()
+ "Add <> around email in current buffer."
+ (goto-char (point-min))
+ (when (re-search-forward "@" nil t)
+ (skip-chars-backward "^ ")
+ (insert "<")
+ (skip-chars-forward "^ ")
+ (insert ">")
+ (buffer-string)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-user-mail-address-correct (str)
+ "Correct words like 'A T' as @ etc."
+ (with-temp-buffer
+ (insert str)
+ (dolist (elt tinycygwin-:email-address-correct-list)
+ (goto-char (point-min))
+ (while (re-search-forward (car elt) nil t)
+ (replace-match (nth 1 elt))))
+ (buffer-string)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-user-mail-address-fix (list)
+ "Add missing <> around LIST of email addresses like '(me@example.com)."
+ (when list
+ (with-temp-buffer
+ (let (ret)
+ (dolist (str list)
+ (when (and (stringp str)
+ (setq str (tinycygwin-user-mail-address-correct str))
+ (string-match "@" str))
+ (unless (string-match "[<>]" str)
+ (erase-buffer)
+ (insert str)
+ (setq str
+ (tinycygwin-user-mail-address-fix-angles)))
+ (push str ret)))
+ (reverse ret)))))
+
+;;}}}
+;;{{{ Utility functions
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinycygwin-debug 'edebug-form-spec '(body))
+(put 'tinycygwin-debug 'lisp-indent-function 0)
+(defmacro tinycygwin-clean-system-with (&rest body)
+ "Disable almost all auto-features and run BODY."
+ `(let (auto-mode-alist
+ find-file-hooks
+ interpreter-mode-alist)
+ ,@body))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinycygwin-debug 'edebug-form-spec '(body))
+(put 'tinycygwin-debug 'lisp-indent-function 0)
+(defmacro tinycygwin-debug (&rest body)
+ "Run BODY when tinycygwin-:debug is non-nil."
+ `(when tinycygwin-:debug
+ ,@body))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinycygwin-external-with 'edebug-form-spec '(body))
+(put 'tinycygwin-external-with 'lisp-indent-function 0)
+(defmacro tinycygwin-external-with (&rest body)
+ "Run BODY if this is external call.
+References:
+ `tinycygwin-:external-call-flag'
+ `tinycygwin-:external-call-flag-value'"
+ `(when (or tinycygwin-:external-call-flag
+ tinycygwin-:external-call-flag-value)
+ ,@body))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinycygwin-expert-with 'edebug-form-spec '(body))
+(put 'tinycygwin-expert-with 'lisp-indent-function 0)
+(defmacro tinycygwin-expert-with (&rest body)
+ "Run BODY if `tinycygwin-:expert-flag' is no-nil."
+ `(when tinycygwin-:expert-flag
+ ,@body))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinycygwin-non-expert-with 'edebug-form-spec '(body))
+(put 'tinycygwin-non-expert-with 'lisp-indent-function 0)
+(defmacro tinycygwin-non-expert-with (&rest body)
+ "Run BODY if `tinycygwin-:expert-flag' is nil."
+ `(unless tinycygwin-:expert-flag
+ ,@body))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinycygwin-not-modified-with 'edebug-form-spec '(body))
+(put 'tinycygwin-not-modified-with 'lisp-indent-function 0)
+(defmacro tinycygwin-not-modified-with (&rest body)
+ "Mark buffer as not modified after BODY."
+ `(progn
+ ,@body
+ (set-buffer-modified-p nil)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-email-choice-list (&optional package)
+ "Return list of Email choices for for user with `completing-read'."
+ (let ((list
+ (list
+ tinycygwin-:email-cygwin-users-list
+ tinycygwin-:email-cygwin-apps-list
+ (if (and package
+ (not (string-match "^x" package)))
+ nil
+ tinycygwin-:email-cygwin-xfree-list)
+ (unless package
+ (tinycygwin-maintainer)))))
+ (delq nil list)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinycygwin-bug-report-email-prefix (&optional type)
+ "Return Subejct's bug prefix string 'Cygwin-TYPE#YYYYMMDDTHHMM'
+The time is in UTC and similar to 'date ----iso-8601=minutes'
+The TYPE is 'bug' by default, but can also be other type, like
+rfa, rfp, itp, orphan, update. See `tinycygwin-:menu-wnpp'."
+ (format
+ ;; Cygwin-bug#NNNN Linux-Bug#NNNN
+ (concat (if tinycygwin-:os-type
+ (format "%s-" (capitalize (symbol-name tinycygwin-:os-type)))
+ "")
+ "%s#%s")
+ (or type
+ "bug")
+ ;; XEmacs does not support argument UTC
+ (if (featurep 'xemacs)
+ (format-time-string "%Y%m%dT%H%M")
+ (format-time-string "%Y%m%dT%H%M" nil 'utc))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinycygwin-bug-report-email-buffer-name (package &optional type)
+ "Compose *mail* buffer name string using PACKAGE.
+Optional TYPE is by deault \"bug\"."
+ (format "*mail* Cygwin %s%s"
+ (or type
+ "bug")
+ (if (and package
+ (not (string= "" package)))
+ (format " (%s)" package)
+ "")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinycygwin-string-trim (string)
+ "Delete leading and trailing spaces."
+ (when string
+ (replace-regexp-in-string "^[ \t]+" "" string)
+ (replace-regexp-in-string "[ \t]+$" "" string)
+ string))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinycygwin-bug-report-include-buffer-name-p (str)
+ "Check buffer name STR is Bug report include file."
+ (string-match "tinycygwin include" (or str "")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinycygwin-bug-report-include-buffer-name (str)
+ "Convert string into buffer name that would be included in Bug report."
+ (unless (tinycygwin-bug-report-include-buffer-name-p str)
+ (format "*tinycygwin include %s*" (buffer-name))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinycygwin-bug-report-include-buffer-list ()
+ "Return list of Bug report include buffers."
+ (let (list)
+ (dolist (buffer (buffer-list))
+ (with-current-buffer buffer
+ (when (and (buffer-file-name)
+ (tinycygwin-bug-report-include-buffer-name-p
+ (buffer-name)))
+ (push buffer list))))
+ list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinycygwin-msg-exit-emacs ()
+ "Return string to say how to exit Emacs."
+ (substitute-command-keys
+ "Exit Emacs \\[save-buffers-kill-emacs]"))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinycygwin-goto-mail-header-separator ()
+ "Goto start of body after `mail-header-separator'.
+If not found, goto `point-max'."
+ (goto-char (point-min))
+ (or (and (boundp 'mail-header-separator)
+ (re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "\n")
+ nil t))
+ (re-search-forward "^--text.*\n" nil t)
+ (goto-char (point-max))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinycygwin-goto-body-start ()
+ "Go to start of body, skipping all headers."
+ (goto-char (point-min))
+ (or (re-search-forward "\n\n" nil t)
+ (re-search-forward "^[ \t]*$" nil t)
+ (goto-char (point-max))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinycygwin-pop-to-buffer (buffer)
+ "Show buffer in full window."
+ (pop-to-buffer buffer)
+ (delete-other-windows))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinycygwin-bug-report-mail-mode-prepare ()
+ "Prepare current buffer for bug email."
+ (message "tinycygwin-bug-report-mail-mode-prepare: external %s"
+ tinycygwin-:external-call-flag)
+ (tinycygwin-external-with
+ (message "tinycygwin-bug-report-mail-mode-prepare: buffer %s"
+ (buffer-name))
+ (make-local-variable 'tinycygwin-:external-call-flag-value)
+ ;; Save the current state permanently to this buffer
+ (setq tinycygwin-:external-call-flag-value
+ tinycygwin-:external-call-flag)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinycygwin-bug-report-mail-mode-buffer (name)
+ "Return emty buffer with NAME and prepare it."
+ (tinycygwin-user-mail-address-set)
+ (tinycygwin-user-full-name-set)
+ (let ((buffer (get-buffer-create name)))
+ (with-current-buffer buffer
+ (tinycygwin-bug-report-mail-mode-prepare))
+ buffer))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-bug-report-mail-mode-finish-message ()
+ "Show message until user starts doing something."
+ (let* ((msg1 (tinycygwin-message-mode-help-simple))
+ (msg2 (substitute-command-keys
+ (concat
+ "Write description and send with "
+ "\\[message-send-and-exit] "
+ "("
+ "Help \\[describe-mode] "
+ (tinycygwin-external-with
+ (tinycygwin-msg-exit-emacs))
+ ")")))
+ (list (list msg1
+ msg2)))
+ (while (and (sit-for 0.2)
+ (not (input-pending-p))
+ (message (car list))
+ ;; Rotate list of messages
+ (let ((tmp (pop list)))
+ (setq list (append list (list tmp))))
+ (sit-for 5)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-bug-report-mail-mode-finish ()
+ "Finish mail buffer preparations."
+ (tinycygwin-bug-report-mail-mode-subject-fix)
+ (set-buffer-modified-p nil)
+ ;; (setq buffer-auto-save-file-name nil)
+ (tinycygwin-goto-body-start)
+ (tinycygwin-non-expert-with
+ (tinycygwin-bug-report-mail-mode-finish-message)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-update-file-autoloads (dir)
+ "Generate autoloads in DIR."
+ (let* ((default-directory dir)
+ (generated-autoload-file
+ (concat (file-name-as-directory dir)
+ "tinycygwin-autoloads.el")))
+ (unless (file-exists-p generated-autoload-file)
+ (message "TinyCygwin: [WARN] %s does not exist. Creating it."
+ generated-autoload-file)
+ (with-temp-buffer
+ (insert (format ";; Emacs autoload file. File was generated %s\n\n"
+ (format-time-string
+ "%Y-%m-%d %H:%M UTC" nil 'utc)))
+ (write-region (point-min) (point-max) generated-autoload-file)))
+ (dolist (file (directory-files dir nil "\\.el$" 'abs))
+ (unless (string-match "loaddefs\\|autoload\\|[#~]" file)
+ (update-file-autoloads file)))
+ (let ((buffer (get-file-buffer generated-autoload-file)))
+ (when buffer
+ (with-current-buffer buffer
+ (save-buffer))
+ (kill-buffer buffer)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinycygwin-update-file-autoloads-batch (&optional dir force)
+ "Update autoloads in batch mode. Argument in command line is DIR. FORCE."
+ (interactive "DAutoload dir to update: ")
+ (unless dir
+ (setq dir (pop command-line-args-left))
+ (setq force t))
+ (unless dir
+ ;; Self generate error for command line ...
+ (message "TinyCygwin: From what directory to generate autoloads?")
+ (error 'tinycygwin-update-file-autoloads-batch))
+ (message "TinyCygwin: Generating all autoloads in %s" dir)
+ (tinycygwin-update-file-autoloads dir))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-smtp-available-p (&optional force)
+ "Open smtå to see if mail is available. The value is cached unless FORCE."
+ (when (file-directory-p "/cygdrive/c") ;; Try only in Windows
+ (let ((checked (get 'tinycygwin-smtp-available-p 'checked))
+ (status (get 'tinycygwin-smtp-available-p 'status))
+ proc)
+ (when (or force
+ (null checked))
+ (message "Tinycygwin: Checking SMTP server... ")
+ (setq status
+ (condition-case error
+ (setq proc
+ (open-network-stream
+ "tinycygwin-smtp"
+ "*process-tinycygwin-smtp*"
+ "localhost"
+ 25))
+ (error
+ nil)
+ (t
+ (delete-process proc)
+ t))))
+ (message "Tinycygwin: Checking SMTP server... Done.")
+ (put 'tinycygwin-smtp-available-p 'checked t)
+ (put 'tinycygwin-smtp-available-p 'status status))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-smtp-setup-error ()
+ "Check that Emacs can in theory send mail.
+Call `error' if there are problems."
+ (unless (or (getenv "SMTPSERVER")
+ (tinycygwin-smtp-available-p))
+ (read-string
+ "TinyCygwin: [ERROR] No SMTPSERVER defined <press return> ")
+ (pop-to-buffer (get-buffer-create "*tinycygwin.el help*"))
+ (erase-buffer)
+ (insert "\
+\[Email configuration error]
+
+To activate Emacs email support for ISP's mailserver, following
+lines are needed in personal startup file ~/.emacs
+
+\(setenv \"SMTPSERVER\" \"your.isp.example.net\")
+\(setq smtpmail-debug-info t)
+\(setq smtpmail-local-domain nil)
+\(setq send-mail-function 'smtpmail-send-it)
+\(setq message-send-mail-function 'smtpmail-send-it)
+\(setq gnus-agent-send-mail-function 'smtpmail-send-it)
+
+After you have done these changes, the setings are active next time Emacs
+is started. Here are few inportant Eamcs commands to help you:
+
+ C-x C-c Quit
+ C-g Abort current (active) operation, like prompt input
+
+ C-x o Go to (o)ther visible window
+ C-x C-f Open file for editing
+ C-x C-s Save current file
+ C-x C-b Show buffer list (C-x o to it and press RET to select)
+
+ C-k Kill line (at the same time copies it)
+ C-y Yank, paste
+")
+ (when (y-or-n-p "Open ~/.emacs for editing? ")
+ (pop-to-buffer (find-file-noselect "~/.emacs")))
+ (message
+ "Unable continue before before working email. %s"
+ (tinycygwin-msg-exit-emacs))
+ 'error))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinycygwin-buffer-name-temp (name)
+ "Return temporary buffer for NAME"
+ (format "*tinycygwin %s*" name))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-file-buffer (file)
+ "Return buffer for FILE."
+ (when file
+ (let* ((name (tinycygwin-buffer-name-temp
+ (file-name-nondirectory file)))
+ (buffer (get-buffer name)))
+ (unless buffer
+ (with-current-buffer (setq buffer (get-buffer-create name))
+ (insert-file-literally file)
+ (setq buffer-read-only t)))
+ buffer)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinycygwin-first-directory (list)
+ "Return Cygwin package documentation root directory"
+ (dolist (dir list)
+ (when (file-directory-p dir)
+ (return dir))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-path-to-cygwin (path)
+ "Chnage Win32 path to Cygwin path."
+ (let* ((root tinycygwin-:root-dir))
+ (when (and path
+ (stringp path))
+ (replace-regexp-in-string root "" path))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-path (path)
+ "Convert Cygwin PATH, like /, to OS absolute patch like C:/cygwin.
+ Trailing slash is stripped."
+ (when path
+ (let* ((root tinycygwin-:root-dir)
+ ret)
+ (setq ret
+ (cond
+ ((string= root "/")
+ path) ;; Native Cygwin Emacs
+ ((string-match "^/cygdrive" path)
+ path)
+ ((string-match "^/\\(.*\\)" path)
+ (format
+ "%s%s"
+ (file-name-as-directory root)
+ (match-string 1 path)))
+ (t
+ path)))
+ ;; Delete trailing slash.
+ (if (string-match "^\\(.+\\)/$" ret)
+ (match-string 1 ret)
+ ret))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-path-doc-cygwin ()
+ "Return Cygwin package documentation root directory"
+ (tinycygwin-path
+ (tinycygwin-first-directory tinycygwin-:path-doc-cygwin-list)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-path-doc-root ()
+ "Return Cygwin package documentation root directory"
+ (tinycygwin-path
+ (tinycygwin-first-directory tinycygwin-:path-doc-root-list)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinycygwin-string-delete-newlines (string)
+ "Delete newlines from STRING."
+ (replace-regexp-in-string "[\r\n]" "" string))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinycygwin-turn-on-emacs-debug ()
+ "Activate Emacs debug."
+ (interactive)
+ (setq debug-on-error t)
+ (if (boundp 'stack-trace-on-error) ;; XEmacs
+ (setq stack-trace-on-error t))
+ (if (boundp 'debug-ignored-errors)
+ (setq debug-ignored-errors nil)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-font-lock-keywords (&optional uninstall)
+ "Add color support to various log files by setting
+`font-lock-keywords'."
+ (let* ((today "xxx") ;; (ti::date-standard-rfc-regexp "mon-date"))
+ ;; (cs (or comment-start-skip "[ \t]+"))
+ (file "")
+ keywords)
+
+ (when (stringp buffer-file-name)
+ (setq file (or buffer-file-name "no-name?")))
+
+ (setq
+ keywords
+ (cond
+
+ ;; ............................................. Linux log files ...
+ ;; /var/log/
+
+ ((string-match "/log/messages$" file)
+ ;; font-lock-constant-face
+ (make-local-variable 'font-lock-defaults)
+ (setq font-lock-keywords
+ (list
+ (list (concat today " +[0-9]+:+[0-9]+:+[0-9]+")
+ 0 'font-lock-function-name-face)
+ (list
+ (concat
+ "^... +[0-9]+ +[0-9]+:+[0-9]+:+[0-9]+")
+ 0 'font-lock-reference-face)
+ (list
+ (concat "restarted\\|started"
+ "\\|ignoring"
+ "\\|Linux version.*")
+ 0 'font-lock-comment-face))))
+
+ ((string-match "mail\\.log\\|mail\\.info" file)
+ ;; font-lock-constant-face
+ (make-local-variable 'font-lock-defaults)
+ (setq font-lock-keywords
+ (list
+ (list (concat today " +[0-9]+:+[0-9]+:+[0-9]+")
+ 0 'font-lock-function-name-face)
+ (list
+ (concat
+ "^... +[0-9]+ ++[0-9]+:+[0-9]+:+[0-9]+")
+ 0 'font-lock-reference-face)
+ '("timed out\\|did not.*"
+ 0 tinycygwin-:warn-face)
+ (list
+ (concat "\\(from\\|to\\)=\\([^ ,\t\r\n]+\\)")
+ 2 'font-lock-comment-face))))
+
+ ((string-match "daemon\\.log" file)
+ ;; font-lock-constant-face
+ (make-local-variable 'font-lock-defaults)
+ (setq font-lock-keywords
+ (list
+ (list
+ (concat
+ "^... +[0-9]+ +[0-9]+:+[0-9]+:+[0-9]+")
+ 0 'font-lock-reference-face)
+ (list
+ (concat "connection attempt" ;); See "iplogger" package
+ 0 'tinycygwin-:warn-face)
+ (list
+ (concat "signal +[0-9]+\\|no such user"
+ "\\|connect from .*")
+ 0 'font-lock-comment-face)))))
+
+ ((string-match "auth\\.log" file)
+ ;; font-lock-constant-face
+ (make-local-variable 'font-lock-defaults)
+ (setq font-lock-keywords
+ (list
+ (list (concat today " +[0-9]+:+[0-9]+:+[0-9]+")
+ 0 'font-lock-function-name-face)
+ (list
+ (concat
+ "^... +[0-9]+ +[0-9]+:+[0-9]+:+[0-9]+")
+ 0 'font-lock-reference-face)
+ (list
+ (concat "opened +for +[^ \t\r\n]+")
+ 0 'tinycygwin-:warn-face)
+ '( "for user \\(root\\)"
+ 1 font-lock-string-face)
+ '( "from \\([^ \t\r\n]+\\)"
+ 1 font-lock-type-face)
+ '( "for +\\([^ \t\r\n]+\\) +from"
+ 1 font-lock-comment-face)
+ '( "for user +\\([^ \t\r\n]+\\)"
+ 1 font-lock-comment-face))))
+
+ ((string-match "syslog" file)
+ ;; font-lock-constant-face
+ (make-local-variable 'font-lock-defaults)
+ (setq font-lock-keywords
+ (list
+ (list (concat today " +[0-9]+:+[0-9]+:+[0-9]+")
+ 0 'font-lock-function-name-face)
+ (list
+ (concat
+ "^... +[0-9]+ +[0-9]+:+[0-9]+:+[0-9]+")
+ 0 'font-lock-reference-face)
+ (list
+ (concat "Invalid.*"
+ ;; portmap[135]: cannot bind udp: Address already in use
+ "\\|cannot"
+ "\\|Connection timed out"
+ ;; See iplogger(1)
+ "\\|connection attempt"
+ ;; See portsentry(1)
+ "\\|attackalert:.* +to +.*port.*"
+ ;; apm -s failed
+ "\\| failed"
+ "\\|did not .*")
+ 0 'tinycygwin-:warn-face)
+ '("to=\\([^ \t\r\n]+\\)"
+ 1 font-lock-comment-face)
+ '("(\\([^ )\t\r\n]+\\)) CMD "
+ 1 font-lock-comment-face)
+ '("CMD .*"
+ 0 font-lock-constant-face)
+ '("inetd"2
+ 0 font-lock-type-face)
+ (list
+ (concat
+ "program exit.*\\|.*started.*"
+ ;; btpd daemon
+ "\\|synchronisation lost")
+ 0 font-lock-keyword-face))))))
+ (when keywords
+ (cond
+ (uninstall
+ (setq font-lock-keywords nil))
+ ((or font-lock-mode
+ (and (boundp 'global-font-lock-mode)
+ global-font-lock-mode)
+ (font-lock-mode 1))
+ (setq font-lock-keywords keywords))))))
+
+;;}}}
+;;{{{ WNPP
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinycygwin-list-match (regexp list)
+ "Check if REGEXP matched LIST of strings."
+ (dolist (str list)
+ (when (string-match regexp str)
+ (return str))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinycygwin-file-setup-hint-p (list)
+ "Check if setup.hint is included in LIST of files."
+ (tinycygwin-list-match (regexp-quote "setup.hint") list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-call-process (binary buffer arg-list)
+ "Call BINARY with list of ARGS and print output to current buffer or BUFFER."
+ (apply 'call-process
+ binary
+ nil
+ (or buffer (current-buffer))
+ nil
+ arg-list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-package-wnpp-main-interactive ()
+ "Ask the type of request for WNPP package.
+References:
+ `tinycygwin-:menu-wnpp'
+ `tinycygwin-:menu-wnpp-selected'"
+ (tinycygwin-menu-call-with
+ 'tinycygwin-:menu-wnpp
+ tinycygwin-:menu-wnpp-selected))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-bug-report-mail-compose (to-list subject)
+ "Compose new mail using TO-LIST and SUBJECT."
+ ;; mail-setup: (to subject in-reply-to cc replybuffer actions)
+ (mail-setup (or (pop to-list) "")
+ (or subject "")
+ nil nil nil nil)
+ (when to-list ;; More recipients
+ (unless (message-fetch-field "CC")
+ ;; This creates field as well
+ (message-goto-cc))
+ (let (newline
+ address)
+ (while to-list
+ (setq newline (if (cdr to-list)
+ ",\n "
+ "")
+ address (pop to-list))
+ (when (stringp address)
+ (insert address newline)))))
+ (tinycygwin-bug-report-mail-mode))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-package-wnpp-mail-generic
+ (&optional prefix description info file-list)
+ "Compose ITP message with optional subject PREFIX and DESCRIPTION.
+If there is package information, it is in INFO."
+ (interactive)
+ (let* ((subject (tinycygwin-bug-report-mail-subject-compose
+ description prefix "wnpp" ))
+ (name (tinycygwin-bug-report-email-buffer-name nil prefix))
+ (buffer (tinycygwin-bug-report-mail-mode-buffer name)))
+ (tinycygwin-debug
+ (message
+ (concat
+ "TinyCygwin: WNPP generic prefix [%s] description [%s] info: %s "
+ "expert: %s")
+ prefix description info tinycygwin-:expert-flag))
+ (tinycygwin-not-modified-with
+ (tinycygwin-pop-to-buffer buffer)
+ (erase-buffer)
+ (tinycygwin-bug-report-mail-compose
+ (list tinycygwin-:email-cygwin-apps-list)
+ subject)
+ (when info
+ (tinycygwin-bug-report-mail-insert-details-package
+ info))
+ (tinycygwin-bug-report-mail-insert-files
+ file-list
+ (tinycygwin-expert-with
+ 'as-is))
+ (tinycygwin-bug-report-mail-mode-finish))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-package-wnpp-main
+ (request-type &optional package desc info file-list)
+ "Submit REQUEST-TYPE against WNPP pseudo package.
+WNPP is used for requesting to be a new maintainer and
+for taking maintenance of other packages.
+
+REQUEST-TYPE can be symbol:
+
+ 'package 'orphan 'adopt or 'new.
+
+Optional PACKAGE in question, DESC string and package INFO.
+
+References:
+ `tinycygwin-:menu-wnpp'."
+ (interactive (list (tinycygwin-package-wnpp-main-interactive)))
+ (let ((type (if (symbolp request-type)
+ (symbol-name request-type)
+ request-type)))
+ (tinycygwin-debug
+ (message
+ (concat
+ "TinyCygwin: WNPP main type [%s] package [%s] desc [%s] info: %s"
+ " files: %s")
+ type package desc info file-list))
+ (cond
+ ((not (stringp type)))
+ ((string= type "package")
+ (or desc
+ (tinycygwin-non-expert-with
+ (setq desc (read-string "[ITP] Package name -- description: "))))
+ (unless (tinycygwin-file-setup-hint-p file-list)
+ (let ((file (read-file-name
+ "[ITP] setup.hint file to include: "
+ nil
+ nil
+ 'match)))
+ (cond
+ ((string-match "setup\\.hint" file))
+ ;; Ok.
+ ((or (string= "" file)
+ (file-directory-p file)) ;; User pressed return. No file.
+ (if (y-or-n-p (format "Include file %s. Are you sure? "
+ (file-name-nondirectory file))))
+ (push file file-list)))))
+ (tinycygwin-package-wnpp-mail-generic "ITP" desc nil file-list))
+ ((string= type "new")
+ (let ((desc (read-string "[RFP] Package name -- description: ")))
+ ;; Check status database
+ (tinycygwin-package-wnpp-mail-generic "RFP" desc)))
+ ((string= type "orphan")
+ (or package
+ (setq package
+ (tinycygwin-package-read-name
+ "[ORPHAN] package: ")))
+ (or info
+ (setq info (tinycygwin-package-info-main package)))
+ (tinycygwin-package-wnpp-mail-generic "ORPHAN" package info))
+ ((string= type "adopt\\|rfa")
+ (or package
+ (setq package
+ (tinycygwin-package-read-name
+ "[ADOPT/RFA] package: ")))
+ (or info
+ (setq info (tinycygwin-package-info-main package)))
+ (tinycygwin-package-wnpp-mail-generic "RFA" package info))
+ (t
+ ;; Nothing to do
+ nil))))
+
+;;}}}
+;;{{{ Cygcheck
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-sysinfo-insert-os-linux ()
+ "Insert result of uname -a to buffer."
+ (call-process "uname"
+ nil ;infile
+ (current-buffer) ;buffer
+ nil ;display
+ "-a"))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-sysinfo-insert-os-cygwin ()
+ "Insert result of cygcheck -s -v -r to buffer."
+ (let ((cmd tinycygwin-:bin-cygcheck))
+ (when cmd
+ (call-process cmd
+ nil ;infile
+ (current-buffer) ;buffer
+ nil ;display
+ "-s"
+ "-v"
+ "-r"))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-sysinfo-buffer (&optional force)
+ "Load `tinycygwin-:file-cygcheck' or FORCE (re)generating it."
+ (let* ((file tinycygwin-:file-cygcheck)
+ (bin tinycygwin-:bin-cygcheck)
+ (name tinycygwin-:buffer-cygcheck)
+ (buffer (or (get-buffer name)
+ (get-file-buffer file))))
+ (cond
+ ((and (null force)
+ buffer)
+ buffer)
+ ((and (null force)
+ (file-exists-p file))
+ (with-current-buffer (get-buffer-create name)
+ (tinycygwin-not-modified-with
+ (insert-file-contents-literally file))
+ (setq buffer-read-only t)
+ (current-buffer)))
+ (t
+ (when tinycygwin-:bin-cygcheck
+ (message "Please wait, reading sysinfo (cygcheck)... ")
+ (with-current-buffer (get-buffer-create name)
+ (tinycygwin-not-modified-with
+ (tinycygwin-call-process
+ bin
+ (current-buffer)
+ (split-string "-s -v -r"))
+ (write-region (point-min) (point-max) file)
+ (setq buffer-read-only t)
+ (setq buffer (current-buffer))))
+ (message "Please wait, reading sysinfo (cygcheck)... Done.")
+ buffer)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinycygwin-sysinfo-with 'lisp-indent-function 0)
+(defmacro tinycygwin-sysinfo-with (&rest body)
+ "Run BODY at sysinfo buffer."
+ `(let* ((buffer (tinycygwin-sysinfo-buffer)))
+ (when buffer
+ (with-current-buffer buffer
+ ,@body))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-sysinfo-version-cygcheck (program)
+ "Search PROGRAM and it's version number from cygcheck listing."
+ (when program
+ (tinycygwin-sysinfo-with
+ (goto-char (point-min))
+ (if (not (re-search-forward
+ "Cygwin Package Information" nil t))
+ (tinycygwin-debug
+ (message
+ "TinyCygwin: [ERROR] tinycygwin-sysinfo-program; %s"
+ "no start tag found"))
+ (let (version)
+ ;; Cygwin Package Information
+ ;; Last downloaded files to: D:\ftp\cygwin\install\cygwin-install
+ ;; Last downloaded files from: http://mirrors.sunsite.dk/cygwin
+ ;;
+ ;; Package Version
+ ;;
+ ;; _update-info-dir 00227-1
+
+ (when (re-search-forward
+ (format "^%s[^ \t\r\n]*[ \t]+\\([0-9][^ \t\r\n]+\\)"
+ program)
+ nil t)
+ (match-string 1)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-sysinfo-version-syscall-parse ()
+ "Parse version number from currnt buffer."
+ (let* (ret)
+ (goto-char (point-min))
+ (when (re-search-forward "\\([0-9]\\.[0-9.]*[0-9]\\)" nil t)
+ (match-string 1))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-executable-find (program)
+ "Search for PROGRAM exactly from `exec-path'."
+ (let ((regexp (format "^%s$" program))
+ list
+ ret)
+ (dolist (path exec-path)
+ (setq list (directory-files path 'full regexp))
+ (when (and list (eq 1 (length list)))
+ (setq ret (car list))
+ (return)))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-sysinfo-version-syscall-call (program &optional version-arg)
+ "Search PROGRAM and its version number by calling shell.
+Optional VERSION-ARG defaults to --version."
+ (when program
+ (with-temp-buffer
+ (let* ((bin (executable-find program))
+ (args (list (or version-arg "--version"))))
+ (unless bin
+ ;; This was not a .exe program, but a shell script or something
+ ;; like that. E.g. 'automake' is in /usr/bin/automake
+ (let* ((found (tinycygwin-executable-find program))
+ shell)
+ (when (and found
+ (setq shell (executable-find "sh")))
+ (setq bin shell
+ args (list
+ "-c"
+ (format "%s %s"
+ (tinycygwin-path-to-cygwin found)
+ (or version-arg "--version")))))))
+ (when bin
+ (tinycygwin-call-process
+ bin
+ (current-buffer)
+ args)
+ (tinycygwin-sysinfo-version-syscall-parse))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-sysinfo-bundle-item (item &optional call-shell)
+ "Return version information of ITEM in `tinycygwin-:sysinfo-program-list'.
+If optional CALL-SHELL is non-nil, then query the information from
+shell (more reliable, but slower).
+
+Return:
+ '((PROGRAM VERSION)
+ ...)."
+ (let (ver
+ list)
+ (dolist (bin (cadr (assq item tinycygwin-:sysinfo-program-list)))
+ (when (setq ver
+ (if call-shell
+ (tinycygwin-sysinfo-version-syscall-call bin)
+ (tinycygwin-sysinfo-version-cygcheck bin)))
+ (push (list bin ver) list)))
+ ;; Preserve order
+ (reverse list)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-sysinfo-os-kernel-version ()
+ "Return OS details."
+ (with-temp-buffer
+ (tinycygwin-sysinfo-insert-os-linux)
+ (goto-char (point-min))
+ (when (re-search-forward "[0-9][.0-9]+-[-.0-9]+" nil t)
+ ;; Linux host 2.6.18-1-686 #1 SMP Sat Oct 21 17:21:28 UTC 2006 i686 GNU/Linux
+ (match-string 0))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-sysinfo-os-linux-arch ()
+ "Return OS details."
+ (with-temp-buffer
+ (insert (tinycygwin-sysinfo-os-kernel-version))
+ (goto-char (point-min))
+ ;; 2.6.18-1-686
+ (when (re-search-forward "[0-9]+$" nil t)
+ (match-string 0))))
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-sysinfo-os-windows ()
+ "Return Windows OS details."
+ ;; This is the first line in there
+ ;; Windows 2000 Professional Ver 5.0 Build 2195 Service Pack 4
+ (tinycygwin-sysinfo-with
+ (goto-char (point-min))
+ (when (re-search-forward "^Windows.*[^\r\n]" nil t)
+ (match-string 0))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-sysinfo-os-cygwin-dll-all ()
+ "Return cygwin1.dll details."
+ ;;Cygwin DLL version info:
+ ;; DLL version: 1.5.7
+ ;; DLL epoch: 19
+ ;; DLL bad signal mask: 19005
+ ;; DLL old termios: 5
+ ;; DLL malloc env: 28
+ ;; API major: 0
+ ;; API minor: 109
+ ;; Shared data: 3
+ ;; DLL identifier: cygwin1
+ ;; Mount registry: 2
+ ;; Cygnus registry name: Cygnus Solutions
+ ;; Cygwin registry name: Cygwin
+ ;; Program options name: Program Options
+ ;; Cygwin mount registry name: mounts v2
+ ;; Cygdrive flags: cygdrive flags
+ ;; Cygdrive prefix: cygdrive prefix
+ ;; Cygdrive default prefix:
+ ;; Build date: Fri Jan 30 19:32:04 EST 2004
+ ;; CVS tag: cr-0x9e
+ ;; Shared id: cygwin1S3
+ (tinycygwin-sysinfo-with
+ (goto-char (point-min))
+ (when (re-search-forward "^[ \t]*Cygwin DLL.*info:" nil t)
+ (let ((beg (line-beginning-position)))
+ (when (re-search-forward "^[ \t]*$" nil t)
+ (buffer-substring beg (line-beginning-position)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-sysinfo-os-cygwin-dll-info ()
+ "Return DLL information.
+
+Return:
+
+'((version \"1.5.7\")
+ (api \"0.109\") ;; Major.Minor
+ (cvs-tag \"cr-0x9e\"))"
+ (let* ((str (tinycygwin-sysinfo-os-cygwin-dll-all)))
+ (when str
+ (let (ret)
+ (when (string-match "CVS tag:[ \t]*\\(.*[^ \t\r\n]\\)" str)
+ (push (list 'cvs-tag (match-string 1 str)) ret))
+ (when (string-match "DLL version:[ \t]*\\(.*[^ \t\r\n]\\)" str)
+ (push (list 'version (match-string 1 str)) ret))
+ (when (string-match "API major:[ \t]*\\(.*[^ \t\r\n]\\)" str)
+ (let ((major (match-string 1 str)))
+ (when (string-match "API minor:[ \t]*\\(.*[^ \t\r\n]\\)" str)
+ (push (list 'api (format "%s.%s"
+ major
+ (match-string 1 str)))
+ ret))))
+ ret))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-sysinfo-os-cygwin-dll-version-string ()
+ "Make DLL version information string."
+ (let* ((info (tinycygwin-sysinfo-os-cygwin-dll-info)))
+ (when info
+ (let* ((ver (nth 1 (assq 'version info)))
+ (api (nth 1 (assq 'api info)))
+ (cvs (nth 1 (assq 'cvs-tag info))))
+ (concat
+ (if ver
+ ver
+ "")
+ (if api
+ (concat " api " api)
+ "")
+ (if cvs
+ (concat " cvs " cvs))
+ " (cygwin1.dll)")))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinycygwin-sysinfo-os-cygwin ()
+ "Return Cygwin OS information."
+ (tinycygwin-sysinfo-os-cygwin-dll-version-string))
+
+;;}}}
+;;{{{ Cygwin Packages
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-package-buffer (package &optional load)
+ "Return buffer for PACKAGE. Optionally LOAD to Emacs if no buffer found."
+ (tinycygwin-file-buffer
+ (tinycygwin-package-info-path-doc-cygwin-package package)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinycygwin-package-buffer-with 'edebug-form-spec '(body))
+(put 'tinycygwin-package-buffer-with 'lisp-indent-function 1)
+(defmacro tinycygwin-package-buffer-with (package &rest body)
+ "In Cygwin documentation buffer for PACKAGE, run BODY."
+ `(let* ((buffer (tinycygwin-package-buffer package)))
+ (when buffer
+ (with-current-buffer buffer
+ ,@body))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinycygwin-package-buffer-search 'lisp-indent-function 2)
+(defmacro tinycygwin-package-buffer-search (package regexp &optional subexp)
+ "Search Cywin PACKAGE documentation for REGEXP and return SUBEXP or 0."
+ `(progn
+ (tinycygwin-package-buffer-with package
+ (goto-char (point-min))
+ (when (re-search-forward ,regexp nil t)
+ (match-string (or ,subexp 0))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinycygwin-package-wnpp-p (package)
+ "Chekc if PACKAGE is the wnpp presude package."
+ (and (stringp package)
+ (string-match "^wnpp" package)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinycygwin-package-pseudo-p (package)
+ "Chekc if PACKAGE is the generic bug package."
+ (and (stringp package)
+ (string-match "^bug-generic" package)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinycygwin-package-itp-p (package)
+ "Chekc if PACKAGE is ITP, intent to package."
+ (and (stringp package)
+ (string-match "^wnpp" package)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinycygwin-package-special-p (package)
+ "Chekc if PACKAGE is special. I.e. does not exist, but has other meaning."
+ (and (stringp package)
+ (or (tinycygwin-package-pseudo-p package)
+ (tinycygwin-package-wnpp-p package))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinycygwin-package-info-field-1 (field info &optional string-p)
+ "Return FIELD from INFO, optionally as empty STRING-P."
+ (if string-p
+ (or (nth 1 (assoc field info)) "")
+ (nth 1 (assoc field info))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinycygwin-package-info-field-cdr (field info)
+ "Return cdr FIELD from INFO."
+ (cdr-safe (assoc field info)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinycygwin-package-info-field-ignore (info)
+ "Return the \"Ignore-errors\' field content."
+ (tinycygwin-package-info-field-1 "Ignore-errors" info))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinycygwin-package-info-field-status (info)
+ "Return the \"Status\' field content."
+ (tinycygwin-package-info-field-1 "Status" info))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinycygwin-package-info-field-package (info)
+ "Return the \"Package\' field content."
+ (tinycygwin-package-info-field-1 "Package" info))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinycygwin-package-info-field-version (info)
+ "Return the \"Package\' field content."
+ (tinycygwin-package-info-field-1 "Version" info))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinycygwin-package-info-field-release (info)
+ "Return the \"Package\' field content."
+ (tinycygwin-package-info-field-1 "Release" info))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinycygwin-package-info-field-name-ok-p (string)
+ "Return non-nil if STRING is valid package field name."
+ (not (string-match "^ignore" string)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-readme-package-file-list (&optional regexp)
+ "Return ist of absolute paths to <package>.README or REGEXP files."
+ (let ((dir (tinycygwin-path-doc-cygwin))
+ ret)
+ (when (and dir
+ (file-directory-p dir))
+ (directory-files
+ dir
+ 'absolute
+ regexp))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-readme-package-name-list (&optional add-list)
+ "Return list of all installed packages in `tinycygwin-path-doc-cygwin'.
+Optinally add ADD-LIST to the returned list."
+ (let (name
+ ret)
+ (dolist (file (tinycygwin-readme-package-file-list "\\.README"))
+ (setq name (replace-regexp-in-string
+ ;; Not all package have version number
+ ;; => cygserver.README
+ "\\(-[0-9].*\\)\\|\\.README.*"
+ ""
+ (file-name-nondirectory file)))
+ (push name ret))
+ (if add-list
+ (setq ret (append add-list ret)))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-install-database-buffer ()
+ "Return `tinycygwin-:file-install-db' buffer."
+ (tinycygwin-file-buffer tinycygwin-:file-install-db))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinycygwin-install-database-buffer-with 'lisp-indent-function 0)
+(defmacro tinycygwin-install-database-buffer-with (&rest body)
+ "Run BODY in `tinycygwin-:file-install-db' buffer."
+ `(let ((buffer (tinycygwin-install-database-buffer)))
+ (when buffer
+ (with-current-buffer buffer
+ ,@body))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-database-buffer-insert ()
+ "Insert `tinycygwin-:file-install-db'."
+ (let* ((file (tinycygwin-path tinycygwin-:file-install-db)))
+ (if (file-exists-p file)
+ (insert-file-contents file)
+ (message "TinyCygwin: Not found %s" file))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-database-buffer-package-info (package)
+ "Return PACKAGE install.db information."
+ (tinycygwin-install-database-buffer-with
+ (let* ((case-fold-search t)
+ (regexp (format "^%s +.+" package)))
+ (goto-char (point-min))
+ (when (re-search-forward regexp nil t)
+ (match-string 0)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-database-buffer-package-list ()
+ "Return list of installed packages"
+ (tinycygwin-install-database-buffer-with
+ (let (list)
+ (goto-char (point-min))
+ (search-forward "INSTALLED.DB" nil t) ;; Skip this
+ (while (re-search-forward "^[^ \t\r\n]+" nil t)
+ (push (match-string 0) list))
+ list)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-package-info-string-split (string)
+ "Return package, version, release from STRING like foo-1.2.0-1.tar.bz2."
+ (when (or (string-match
+ ;; foo-1.2.0-1.tar.bz2
+ "^\\([a-z-]+[0-9]?\\)-\\([0-9]+[0-9.-]*[0-9]\\)-\\(.+\\)"
+ string)
+ (string-match
+ ;; libxxx1-1.3-2
+ "^\\([a-z-]+[0-9]?\\)-\\([0-9]+[0-9.-]*[0-9]\\)\\(.*\\)"
+ string)
+ ;; a2ps-4.13
+ (string-match
+ "^\\([a-z0-9]+[0-9]?\\)-\\([0-9]+[0-9.-]*[0-9]\\)\\(.*\\)"
+ string))
+ (let* ((name (match-string 1 string))
+ (ver (match-string 2 string))
+ rel)
+ (setq string (match-string 3 string)) ;; The rest
+ ;; Release cannot be more than 2 numbers.
+ (when (string-match "^\\([0-9][0-9]?\\)\\([^0-9]+\\|$\\)" string)
+ (setq rel (match-string 1 string)))
+ (list name ver rel))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-package-info-string-package (string)
+ "Return version from STRING."
+ (nth 0 (tinycygwin-package-info-string-split string)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-package-info-string-version (string)
+ "Return version from STRING."
+ (nth 1 (tinycygwin-package-info-string-split string)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-package-info-string-release (string)
+ "Return release number from STRING."
+ (nth 2 (tinycygwin-package-info-string-split string)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-package-info-path-doc-cygwin (string)
+ "Return Cygwin documentation file path for STRING like foo-1.2.0-1.tar.bz2."
+ (multiple-value-bind (package version release)
+ (tinycygwin-package-info-string-split string)
+ (if (not version)
+ (message "TinyCygwin: Can't parse doc dir from %s" string)
+ (setq release release) ;; Byte compiler silencer
+ (let ((dir (tinycygwin-path-doc-root)))
+ (format "%s/Cygwin/%s-%s.README" dir package version)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-package-info-path-doc-cygwin-package (package)
+ "Return Cygwin documentation file path for PACKAGE like 'foo'."
+ (let ((dir (tinycygwin-path-doc-cygwin)))
+ (when (and dir
+ (file-directory-p dir))
+ (let ((list (directory-files
+ dir
+ 'absolute
+ (format "^%s-.*README" package))))
+ (when (eq (length list) 1)
+ (car list))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-package-info-name (package)
+ "Return PACKAGE name from `tinycygwin-:path-doc-cygwin-list'.
+This is ismilar function to `tinycygwin-database-buffer-package-info'."
+ (let* ((file (tinycygwin-package-info-path-doc-cygwin-package package)))
+ (when file
+ (replace-regexp-in-string
+ "\\.README"
+ ""
+ (file-name-nondirectory file)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-package-info-port-maintainer-1 ()
+ "Search current buffer for maintainer."
+ (goto-char (point-min))
+ (or (and (re-search-forward
+ "Cygwin port.*maintained.*:[ \t]*\\(.+[^ \t\r\n]\\)" nil t)
+ (match-string 1))
+ (progn
+ (goto-char (point-max))
+ (when (search-backward "@" nil t)
+ (cond
+ ((search-backward ":" (line-beginning-position) t)
+ ;; Maintainer: ...
+ (re-search-forward "[: \t]+" nil t)
+ (buffer-substring (point) (line-end-position)))
+ (t
+ (goto-char (line-beginning-position))
+ (if (looking-at "[ \t]*\\(.+@.+[^ \t\r\n]\\)")
+ (match-string 1))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-package-info-port-maintainer (package)
+ "Return Cygwin port maintainer for PACKAGE."
+ (tinycygwin-package-buffer-with package
+ (tinycygwin-package-info-port-maintainer-1)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-package-info-bug-report (package)
+ "Return bug report address for PACKAGE"
+ (let* ((upstream-info
+ (tinycygwin-package-info-upstream-contacts package))
+ (str (if upstream-info
+ (nth 1 (assq 'bugs upstream-info)))))
+ str))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-package-info-maintainer (package)
+ "Return author or maintainer of the PACKAGE."
+ (let* ((upstream-info
+ (tinycygwin-package-info-upstream-contacts package))
+ (str (if upstream-info
+ (nth 1 (or (assq 'maintainer upstream-info)
+ (assq 'author upstream-info))))))
+ str))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinycygwin-package-info-macro 'lisp-indent-function 2)
+(defmacro tinycygwin-package-info-macro (package check-variable &rest body)
+ "PACKAGE. If CHECK-VARIABLE is set, then allow running BODY."
+ `(let ((special (tinycygwin-package-special-p package)))
+ (when (and
+ (not special)
+ ,check-variable)
+ ,@body)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-package-info-port-maintainer-maybe (package)
+ "Only in certain conditions return package mailtainer's email aadress.
+PACKAGE is not special and
+`tinycygwin-:package-maintainer-email-include' is set."
+ (tinycygwin-package-info-macro
+ package tinycygwin-:package-maintainer-email-include
+ (tinycygwin-package-info-port-maintainer package)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-package-info-maintainer-maybe (package)
+ "Only in certain conditions return package mailtainer's email aadress.
+PACKAGE is not special and
+`tinycygwin-:package-maintainer-email-include' is set."
+ (tinycygwin-package-info-macro
+ package tinycygwin-:package-upstream-email-include
+ (tinycygwin-package-info-port-maintainer package)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinycygwin-package-info-port-maintainer-list (&optional display)
+ "Generate list of all packages and their maintainers. Optionally DISPLAY."
+ (interactive (list t))
+ (let* ((buffer (get-buffer-create
+ tinycygwin-:buffer-maintainer-list))
+ (dir (tinycygwin-path-doc-cygwin))
+ package
+ maintainer)
+ (with-current-buffer buffer
+ (erase-buffer))
+ (with-temp-buffer
+ (dolist (file (directory-files dir 'abs "\\.README$"))
+ (erase-buffer)
+ (insert-file-contents-literally file)
+ (setq maintainer
+ (or (tinycygwin-package-info-port-maintainer-1)
+ "ERROR, not found; file syntax unknown"))
+ (with-current-buffer buffer
+ (goto-char (point-max))
+ (insert (format "%-30s %s\n"
+ (replace-regexp-in-string
+ "\\.README"
+ ""
+ (file-name-nondirectory file))
+ maintainer)))))
+ (if display
+ (pop-to-buffer buffer))
+ buffer))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-package-info-homepage (package)
+ "Return homepage of PACKAGE."
+ (tinycygwin-package-buffer-search
+ package
+ ".*homepage:[ \t\r\n]*\\(.+[^ \t\r\n]\\)"
+ 1))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinycygwin-package-info-heading-block (package heading)
+ "Return Heading: block for Cygwin PACKAGE documentation."
+ (tinycygwin-package-buffer-search
+ package
+ ;; Grab all indented lines after HEADING
+ (format "%s.*\\(\r?\n[ \t]+.*\\)+" heading)
+ 0))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-package-info-heading-value
+ (package heading header &optional subexp)
+ "Read PACKAGE and position to HEADING regexp and read HEADER SUBEXP
+Like if HEADER were 'Upstream contact' and HEADING were
+'Author: +\(.+\)' from text:
+
+ Upstream contact:
+ Author: Foo Bar <foo@example.com>
+ Bugs: Foo Bar <foo@example.com>"
+ (let ((str (tinycygwin-package-info-heading-block
+ package
+ heading)))
+ (when str
+ (with-temp-buffer
+ (insert str)
+ (goto-char (point-min))
+ (goto-char (line-end-position)) ;; Past heading
+ (when (re-search-forward header nil t)
+ (match-string (or subexp 0)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-package-info-first-email (package)
+ "Return first email address from PACKAGE."
+ (tinycygwin-package-buffer-search
+ package
+ "[^: \t\r\n][^:@\r\n]+@.+[^ \t\r\n]"
+ 0))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-package-info-upstream-contacts (package)
+ "Return upstream contact addresses.
+
+Return:
+
+ '((author address)
+ (bugs address))
+
+Notice that the values may be missing if no such fields were found."
+ (let ((fields
+ '((bugs "Bugs:[ \t]*\\(.+\\)")
+ (maintainer "Maintainer:[ \t]*\\(.+\\)")
+ (author "Author:[ \t]*\\(.+\\)")))
+ ret
+ val)
+ (dolist (elt fields)
+ (multiple-value-bind (tag regexp) elt
+ (when (setq val
+ (tinycygwin-package-info-heading-value
+ package
+ "^upstream"
+ regexp
+ 1))
+ (push (list tag val) ret))))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-package-status-cygwin (package)
+ "Return Cygwin PACKAGE details.
+'((\"Package\" \"foo\")
+ (\"Status\" \"installed\")
+ (\"Version\" \"1.13\")
+ (\"Release\" \"1\")
+ ...)"
+ (let* ((db (tinycygwin-database-buffer-package-info package))
+ (cygdoc (unless db
+ (tinycygwin-package-info-name package)))
+ version
+ release
+ ret)
+ (flet ((push-ret (tag value function)
+ (when (and value
+ (setq value (funcall function value)))
+ (push (list tag value) ret))))
+ (cond
+ ((not (or db cygdoc))
+ (setq ret
+ (list
+ (list "Package" package)
+ (list "Status" "not-installed"))))
+ (db
+ ;; keychain keychain-1.9-1.tar.bz2 0
+ (multiple-value-bind (name package dummy)
+ (split-string db)
+ (setq ret
+ (list (list "Package" name)
+ (list "Name" package)
+ (list "Status" "installed")))
+ (push-ret "Version"
+ package
+ 'tinycygwin-package-info-string-version)
+ (push-ret "Release"
+ package
+ 'tinycygwin-package-info-string-release)))
+ (cygdoc
+ (setq ret
+ (list
+ (list "Package" (replace-regexp-in-string
+ "-[0-9].*"
+ ""
+ package))
+ (list "Name" cygdoc)
+ (list "Status" "installed-3rd-party")))
+ (push-ret "Version"
+ cygdoc
+ 'tinycygwin-package-info-string-version)
+ (push-ret "Release"
+ cygdoc
+ 'tinycygwin-package-info-string-release)))
+ (tinycygwin-debug
+ (message "TinyCygwin: [DEBUG] pkg-status-cygwin '%s'"
+ (prin1-to-string ret)))
+ ret)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinycygwin-package-status-bug-generic ()
+ "Return Generic bug package status values."
+ '(("Package" "")
+ ("Status" "")
+ ("Ignore-errors" "files email")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinycygwin-package-status-wnpp ()
+ "Return WNPP package status values."
+ '(("Package" "wnpp")
+ ("Ignore-errors" "files email")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-package-status-main (package)
+ "Return PACKAGE details.
+
+One PACKAGE name is special: \"bug-generic\".
+
+This package does not exist, but informas, that you want to fill in a
+genereic bug report concerning issues in Cygwin. If you're porting
+software to Cygwin, but can't get it cmpiled, you may want to talk
+o the author of the code. Creating a generic bug report, help you and the
+author to keep track of discussion."
+ (cond
+ ((tinycygwin-package-pseudo-p package)
+ (tinycygwin-package-status-bug-generic))
+ ((tinycygwin-package-wnpp-p package)
+ (tinycygwin-package-status-wnpp))
+ (t
+ (tinycygwin-package-status-cygwin package))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-package-read-name (&optional prompt list add-list)
+ "Read installed package name with optional PROMPT.
+The optional LIST is full ask lisk. ADD-LIST is added to the default
+package ask list."
+ (message "Wait, building package list...")
+ (completing-read
+ (or prompt
+ "Cygwin package name (TAB to complete): ")
+ (mapcar (lambda (x)
+ (cons x 'dummy))
+ (or list
+ ;; tinycygwin-database-buffer-package-list
+ (tinycygwin-readme-package-name-list add-list)))
+ nil
+ 'match))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinycygwin-package-readme-find-file (package)
+ "Open PACKAGE*.README."
+ (interactive
+ (list (tinycygwin-package-read-name
+ "Find File (Cygwin package README): ")))
+ (when package
+ (let ((file (tinycygwin-package-info-path-doc-cygwin-package
+ package)))
+ (unless file
+ (error "TinyCygwin: [ERROR] Cannot find %s*.README"
+ package))
+ (find-file file))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-package-info-main (package)
+ "Get PACKAGE information. See`tinycygwin-package-status'."
+ (when (stringp package)
+ (tinycygwin-string-trim package)
+ (when (string-match "[^ \t\r\n]" package)
+ (tinycygwin-package-status-main package))))
+
+;;}}}
+;;{{{ Bug reporting interface
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinycygwin-bug-type-standard-p (type)
+ "Check if bug TYPE is standard bug."
+ (or (null type)
+ (and (stringp type)
+ (string= "standard" type))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-bug-system-info-os-architecture ()
+ "Read architecture."
+ (cond
+ ((eq tinycygwin-:os-type 'cygwin)
+ (tinycygwin-sysinfo-os-cygwin))
+ ((eq tinycygwin-:os-type 'linux)
+ (tinycygwin-sysinfo-os-linux-arch))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-bug-system-info-os-version ()
+ "Read Cygwin version number."
+ (cond
+ ((eq tinycygwin-:os-type 'cygwin)
+ (tinycygwin-sysinfo-os-windows))
+ ((eq tinycygwin-:os-type 'linux)
+ (tinycygwin-sysinfo-os-kernel-version))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-bug-system-info-locale ()
+ "Get locale information."
+ (let* ((list
+ '("LC_ALL"
+ "LC_CTYPE"))
+ val
+ ret)
+ (dolist (var list)
+ (when (setq val (getenv var))
+ (setq val (format "%s=%s" var val))
+ (setq ret (if (null ret)
+ val
+ (concat ret ", " val)))))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-bug-system-info-os-main ()
+ "Return OS information. Something like below.
+Release: 1.5.7
+Architecture: i386
+Kernel:
+Locale: LANG=en_US, LC_CTYPE=en_US."
+ (let ((kernel (tinycygwin-bug-system-info-os-architecture))
+ (release (tinycygwin-bug-system-info-os-version))
+ (locale (tinycygwin-bug-system-info-locale)))
+ (format "\
+Release: %s
+Kernel: %s
+Locale: %s
+"
+ (or release "")
+ (or kernel "")
+ (or locale ""))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-bug-severity ()
+ "Select bug severity."
+ (setq tinycygwin-:menu-severity-selected nil)
+ (while (null tinycygwin-:menu-severity-selected)
+ (ti::menu-menu 'tinycygwin-:menu-severity)
+ (unless tinycygwin-:menu-severity-selected
+ (message "TinyCygwin: Please select severity.")
+ (sit-for 1)))
+ tinycygwin-:menu-severity-selected)
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-bug-report-exit ()
+ "Ask to exit Emacs unless `tinycygwin-:expert-flag' is non-nil."
+ (tinycygwin-non-expert-with
+ (tinycygwin-external-with
+ (when (y-or-n-p "Exit Emacs now? ")
+ (kill-emacs)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-bug-report-mail-attach-file (file)
+ "Attach file \"as is\" to current point."
+ (unless (bolp)
+ (beginning-of-line))
+ (unless (looking-at "^[ \t]*$")
+ (insert "\n"))
+ (insert (format "\n%s\n" (tinycygwin-mail-attachment-tag file)))
+ (tinycygwin-not-modified-with
+ (insert-file-contents-literally file)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-bug-report-mail-insert-files (list &optional type)
+ "Attach LIST of file to the end of current buffer.
+
+Optional TYPE
+
+ 'as-is Add as plain text.
+ 'mime Add as a mime attachment.
+ nil Ask user wat to do with files that are not binaries."
+ (when list
+ (unless (eq major-mode 'message-mode)
+ (error
+ "TinyCygwin: Can't add attachments. Not in `message-mode'"))
+ (let (mml-type
+ description)
+ (goto-char (point-max))
+ (tinycygwin-not-modified-with
+ (insert "\n"))
+ (dolist (file list)
+ (goto-char (point-max))
+ (cond
+ ((not (file-exists-p file))
+ (let ((msg (format "[ERROR] Not exists. Can't attach file %s "
+ file)))
+ (message msg)
+ (tinycygwin-non-expert-with
+ (sit-for 2))))
+ ((tinycygwin-file-binary-p file)
+ (mml-attach-file file type description))
+ ((or (eq type 'mime)
+ (and (null type)
+ (y-or-n-p
+ (format "Insert as a MIME attachment/as is [%s]? "
+ (file-name-nondirectory file)))))
+ (tinycygwin-expert-with
+ (setq mml-type (mml-minibuffer-read-type file)))
+ (mml-attach-file file mml-type description))
+ (t
+ (tinycygwin-bug-report-mail-attach-file file)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-bug-report-mail-insert-details-bundle ()
+ "Include `tinycygwin-sysinfo-bundle-item' details."
+ (let (done
+ info)
+ (dolist (bundle '(devel-tools lang))
+ (when (setq info
+ (mapconcat (lambda (x)
+ (multiple-value-bind (bin ver) x
+ (format "%s %s" bin ver)))
+ (tinycygwin-sysinfo-bundle-item
+ bundle (not (eq tinycygwin-:os-type 'cygwin)))
+ ", "))
+ (unless done
+ (insert "\n-- Other package information\n")
+ (setq done t))
+ (insert (format "Info-Pkg-%s: %s\n"
+ (symbol-name bundle)
+ info))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-bug-report-mail-insert-environment ()
+ "Insert details from `tinycygwin-:sysinfo-environment-list'"
+ (let (done
+ info)
+ (dolist (var tinycygwin-:sysinfo-environment-list)
+ (unless done
+ (insert "\n-- Environment information\n")
+ (setq done t))
+ (when (setq info (getenv var))
+ (insert (format "%s: %s\n" var info))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-bug-report-mail-insert-details-upstream (package)
+ "Insert PACKAGE upstream information at point."
+ (when package
+ (let ((upstream-info
+ (tinycygwin-package-info-upstream-contacts package)))
+ (dolist (info upstream-info)
+ (multiple-value-bind (type email) info
+ (insert (format "Upstream-%s: %s"
+ (symbol-name type)
+ email)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-bug-report-mail-insert-details-sysinfo ()
+ "Insert system information at point."
+ (insert "\n\n-- System Information\n"
+ (tinycygwin-bug-system-info-os-main))
+ (tinycygwin-bug-report-mail-insert-details-bundle))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-bug-report-mail-insert-details-package
+ (info &optional severity)
+ "Insert package INFO details with optional bug SEVERITY level."
+ (goto-char (point-min))
+ (tinycygwin-goto-mail-header-separator)
+ (let* ((status (tinycygwin-package-info-field-status info))
+ (package (tinycygwin-package-info-field-package info))
+ (version (tinycygwin-package-info-field-version info))
+ (release (tinycygwin-package-info-field-release info)))
+ (dolist (elt (list
+ (list "Package" package)
+ (list "Version" (concat
+ version
+ (if release
+ (concat "-" release)
+ "")))
+ (list "Status" status)
+ (list "Severity" (or severity "normal"))))
+ (multiple-value-bind (field value) elt
+ (insert (format "%s: %s\n" field (or value "")))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-bug-report-mail-insert-details-main
+ (info &optional severity)
+ "Insert Details for package INFO with optional bug SEVERITY level."
+ (tinycygwin-bug-report-mail-insert-details-package info severity)
+ (tinycygwin-bug-report-mail-insert-details-sysinfo)
+ (tinycygwin-bug-report-mail-insert-environment)
+ (tinycygwin-bug-report-mail-insert-details-upstream
+ (cadr (assoc "Package" info))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinycygwin-bug-report-message-mark-external ()
+ "Define `tinycygwin-:external-call-flag' local to buffer."
+ (when tinycygwin-:external-call-flag
+ (set (make-local-variable 'tinycygwin-:external-call-flag)
+ tinycygwin-:external-call-flag)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-bug-report-message-send-actions ()
+ "Arrange `message-send-actions'."
+ ;; Will be buffer local. See message.el
+ (when (boundp 'message-send-actions)
+ (push '(progn
+ (message "Bug report sent. %s"
+ (or (tinycygwin-external-with
+ (tinycygwin-msg-exit-emacs))
+ "")))
+ message-send-actions)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-message-mode-font-lock-keywords ()
+ "Return correct `font-lock-keywords'."
+ (if (tinycygwin-window-system)
+ tinycygwin-:message-mode-font-lock-keywords-window-system
+ tinycygwin-:message-mode-font-lock-keywords-non-window-system))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-bug-report-mail-mode-font-lock ()
+ "Activate `font-lock-mode' with custom settings."
+ (let ((keys (tinycygwin-message-mode-font-lock-keywords)))
+ (when (fboundp 'font-lock-mode)
+ (when (and (boundp 'message-font-lock-keywords)
+ (null (get 'message-mode
+ 'tinycygwin-font-lock-keywords)))
+ (require 'font-lock) ;; force to define variables
+ (tinycygwin-message-mode-faces)
+ (unless tinycygwin-:original-font-lock-keywords
+ (set (make-local-variable 'tinycygwin-:original-font-lock-keywords)
+ font-lock-keywords))
+ (make-local-variable 'message-font-lock-keywords)
+ (setq message-font-lock-keywords
+ (append message-font-lock-keywords keys))
+ ;; Delete "Catch all" header regexp whic overrides all other
+ ;; faces.
+ ;; ("^\\([A-Z][^: \n ]+:\\)..."
+ ;; (1 'message-header-name-face)
+ ;; (2 'message-header-other-face nil t))
+ (setq
+ message-font-lock-keywords
+ (delete-if (lambda (x)
+ (let* ((str (prin1-to-string x))
+ (status
+ (string-match
+ "other-face\\|cited-text" str)))
+ status))
+ message-font-lock-keywords))
+ ;; (put 'message-mode
+ ;; 'font-lock-defaults
+ ;; '(message-font-lock-keywords t))
+ (put 'message-mode
+ 'tinycygwin-font-lock-keywords
+ keys))
+ (font-lock-mode 1))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-bug-report-mail-mode ()
+ "Turn on mail mode for current buffer."
+ (set (make-local-variable 'message-cite-prefix-regexp)
+ "^\\([|>] *\\)+")
+ (message-mode)
+ (tinycygwin-non-expert-with
+ (tinycygwin-bug-report-mail-mode-font-lock))
+ (tinycygwin-external-with
+ (tinycygwin-bug-report-message-send-actions))
+ (auto-save-mode -1)
+ (when buffer-file-name
+ ;; Under windows, file #*message*# is invalid, change it.
+ (setq buffer-file-name
+ (replace-regexp-in-string "[*]" "" buffer-file-name))
+ ;; Check for working Emacs/Gnus, if not, then cancel save file name
+ (let ((dir (file-name-directory buffer-file-name)))
+ (unless (file-directory-p dir)
+ (message-disassociate-draft)
+ (setq buffer-file-name nil)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-bug-report-mail-body-header-value (header)
+ "Return HEADER value from body of email."
+ (save-current-buffer
+ (tinycygwin-goto-mail-header-separator)
+ (when (re-search-forward
+ (format
+ "^%s:[ \t]*\\([^ \t\r\n]+\\)" header)
+ nil t)
+ (match-string 1))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinycygwin-bug-high-priority-p (severity)
+ "Check SEVERITY is high priority (Severity > important)."
+ (and (stringp severity)
+ (string-match "critical\\|grave\\|serious" severity)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinycygwin-bug-mail-attached-patch-p ()
+ "Check if Patch has been attached."
+ (save-current-buffer
+ (tinycygwin-goto-mail-header-separator)
+ (re-search-forward
+ "\\(attachment:\\|filename=\\).*.\\(diff\\|patch\\)"
+ nil t)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-bug-report-mail-mode-subject-tags ()
+ "Add subject tags [patch] etc. if needed"
+ (let* (value
+ tag)
+ (save-current-buffer
+ (when (and (setq value (tinycygwin-bug-report-mail-body-header-value
+ "Severity"))
+ (tinycygwin-bug-high-priority-p value))
+ (setq tag (format "[%s]" value)))
+ (when (tinycygwin-bug-mail-attached-patch-p)
+ (setq tag (concat (or tag "") "[patch]"))))
+ tag))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-bug-report-mail-mode-subject-split (str)
+ "Split subject STR on ':' or if it does not exist return BUG ID."
+ (when (stringp str)
+ (let* (prefix
+ rest
+ list)
+ (cond
+ ((and (string-match ":" str)
+ (setq list (split-string str ":")))
+ (setq prefix (pop list)
+ rest (mapconcat 'identity list " ")))
+ ((string-match "^\\([^#\r\n]+#[0-9T]+\\)\\(.*\\)" str)
+ (setq prefix (match-string 1 str)
+ rest (match-string 2 str))))
+ (if rest
+ (list prefix rest)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-bug-report-mail-mode-set-header (header value)
+ "Replace HEADER with value."
+ (save-current-buffer
+ (goto-char (point-min))
+ (let ((end "\n"))
+ (when (re-search-forward
+ (concat "^" header ":")
+ nil t)
+ (delete-region (line-beginning-position) (line-end-position))
+ (setq end ""))
+ (insert (format "%s: %s%s" header value end)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-bug-report-mail-mode-subject-fix ()
+ "Add tags to subject."
+ (let ((tag (tinycygwin-bug-report-mail-mode-subject-tags)))
+ (when tag
+ ;; message-field-value
+ (let ((subject (message-fetch-field "Subject")))
+ (when subject
+ (multiple-value-bind (prefix rest)
+ (tinycygwin-bug-report-mail-mode-subject-split subject)
+ (when (and rest
+ ;; Does not have tags already?
+ (not (string-match "\\[" rest)))
+ (tinycygwin-bug-report-mail-mode-set-header
+ "Subject"
+ (format "%s: %s%s" prefix tag rest)))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-bug-report-mail-subject-compose
+ (&optional subject package type)
+ "Compose bug SUBJECT and optionally include PACKAGE name with tYPE."
+ (format (if package
+ "%s%s%s"
+ "%s%s%s")
+ (tinycygwin-bug-report-email-prefix type)
+ (if (and (stringp package)
+ (not (string= "" package)))
+ (format " %s: " package)
+ ": ")
+ (or subject "")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-bug-report-mail-subject-interactive (&optional package)
+ "Compose Bug subject. Optional argument PACKAGE is added to Subject."
+ (let ((subject (or (tinycygwin-non-expert-with
+ (read-string "Cygwin bug subject: "))
+ "")))
+ (tinycygwin-bug-report-mail-subject-compose subject package)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-bug-report-mail-compose-email (&optional address-list)
+ "Compose list of email addresses with optional ADDRESS-LIST."
+ (let* ((choices (append
+ (tinycygwin-email-choice-list)
+ address-list))
+ (choice-alist (mapcar (lambda (x)
+ (cons x "dummy"))
+ choices))
+ list
+ email)
+ (while (string-match
+ "@"
+ (setq email
+ (completing-read
+ (format
+ "[%d]Bug email (TAB choices; empty to quit): "
+ (length list))
+ choice-alist)))
+ (pushnew email list :test 'string=))
+ (reverse list)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-bug-report-mail-compose-interactive
+ (buffer to-list package-name info &optional file-list)
+ "Compose bug report interactively and display BUFFER.
+Send mail to TO-LIST with PACKAGE-NAME INFO.
+Attach FILE-LIST."
+ (tinycygwin-pop-to-buffer buffer)
+ ;; For inspection in `tinycygwin-bug-report-message-send-actions'.
+ (tinycygwin-bug-report-message-mark-external)
+ (erase-buffer)
+ (let ((subject (tinycygwin-bug-report-mail-subject-interactive
+ package-name)))
+ (tinycygwin-not-modified-with
+ (tinycygwin-bug-report-mail-compose
+ to-list
+ subject)
+;;; (when info
+ (message "Please wait, reading sysinfo...")
+ (goto-char (point-max))
+ (tinycygwin-bug-report-mail-insert-details-main
+ info
+ (tinycygwin-non-expert-with
+ (tinycygwin-bug-severity)))
+ (message "Please wait, reading sysinfo... Done.")
+;;; )
+ (tinycygwin-bug-report-mail-insert-files file-list)
+ (tinycygwin-bug-report-mail-mode-finish)))
+ (run-hooks 'tinycygwin-:bug-report-mail-hook))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-bug-report-mail-main-new-bug
+ (buffer package info &optional email-list file-list)
+ "Generate new bug report for PACKAGE and with INFO.
+Optionally to EMAIL-LIST."
+ (let ((ignore (tinycygwin-package-info-field-ignore info)))
+ (setq email-list
+ (cond
+ (tinycygwin-:expert-flag
+ (append email-list
+ (tinycygwin-email-choice-list package)))
+ ((null ignore)
+ (tinycygwin-bug-report-mail-compose-email
+ email-list))))
+ (tinycygwin-bug-report-mail-compose-interactive
+ buffer
+ email-list
+ package
+ info
+ file-list)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-bug-report-mail-main-2 (info &optional file-list)
+ "See `tinycygwin-bug-report-mail-main' for INFO FILE-LIST."
+ (let* ((status (tinycygwin-package-info-field-status info))
+ (ignore (tinycygwin-package-info-field-ignore info))
+ (package (tinycygwin-package-info-field-package info))
+ (special (tinycygwin-package-special-p package))
+ (maintainer (tinycygwin-package-info-port-maintainer-maybe
+ package))
+ (author (tinycygwin-package-info-maintainer package))
+ (name (tinycygwin-bug-report-email-buffer-name
+ package))
+ email-list)
+ (tinycygwin-debug
+ (message "TinyCygwin: [DEBUG] bug-1 pkg %s maintainer %s maint %s"
+ package maintainer author))
+ ;; ............................................. no maintainer ...
+ (when (and package
+ tinycygwin-:package-maintainer-email-include
+ (not special)
+ (not maintainer))
+ (read-string
+ (format
+ (concat
+ "No maintainer email in %s*.README. "
+ "Consider reporting this bug as well <RET to continue>.")
+ package)))
+ (cond
+ ;; ...................................... previous bug report ...
+ ((and (get-buffer name)
+ (null (y-or-n-p
+ "Delete previously composed bug report? ")))
+ (tinycygwin-pop-to-buffer (get-buffer name)))
+ ;; ........................................... new bug report ...
+ (t
+ (when author
+ (push (format
+ "maintainer of the package %s - %s"
+ (or package "")
+ (car (tinycygwin-user-mail-address-fix
+ (list author))))
+ email-list))
+ (when maintainer
+ (push (format
+ "Cygwin port maintainer %s - %s"
+ (or package "")
+ (car (tinycygwin-user-mail-address-fix
+ (list maintainer))))
+ email-list))
+ (tinycygwin-bug-report-mail-main-new-bug
+ (tinycygwin-bug-report-mail-mode-buffer name)
+ package
+ info
+ email-list
+ file-list)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-bug-report-mail-type-standard (info &optional file-list)
+ "INFO is alist of package's attributes.
+Optional TYPE is bug type.
+FILE-LIST are files to attach.
+
+An example bug report would look something like:
+
+ To: <Cygwin package maintainer>
+ Subject: Cygwin-bug#20040121T1030 foo: <subject of the bug>
+ --text follows this line--
+ Package: foo
+ Version: 0.35-10
+ Status: installed-3rd-party
+ Severity: wishlist
+
+ <bug report body described here>
+
+ -- System Information
+ Release: 1.5.7 api 0.109 cvs cr-0x9e
+ Kernel: Windows 2000 Professional Ver 5.0 Build 2195 Sp4
+ Locale: LC_ALL=en_US
+
+ -- Other package information
+ Info-Pkg-devel-tools: gcc 3.3.1-3, make 3.80-1, libtool 1.5b-1
+ Info-Pkg-lang: perl 5.8.2-1, python 2.3.3-1, ruby 1.8.1-1
+
+ -- Environment information
+ CYGWIN: tty ntsec binmode smbntsec
+
+For lisp calls, The INFO variables is like:
+
+ '((\"Status\" ...)
+ (\"Package\" ...)
+ ...)."
+ (let* ((status (tinycygwin-package-info-field-status info))
+ (package (tinycygwin-package-info-field-package info))
+ (special (tinycygwin-package-special-p package)))
+ (tinycygwin-debug
+ (message "TinyCygwin: [DEBUG] bug-1 info %s\n"
+ (prin1-to-string info))
+ (message "TinyCygwin: [DEBUG] bug-1 package '%s'"
+ (prin1-to-string package))
+ (message "TinyCygwin: [DEBUG] bug-1 file-list '%s'"
+ (prin1-to-string file-list)))
+ (cond
+ ((null info)
+ (message
+ (format "No package INFO available to send a bug report. %s"
+ (if (tinycygwin-external-with
+ (tinycygwin-msg-exit-emacs))
+ ""))))
+ ((and (not special)
+ (string-match "not-installed" (or status "")))
+ (cond
+ ((y-or-n-p
+ (format "Packege [%s] is not installed. Select other package? "
+ (or package "")))
+ (let ((package (tinycygwin-package-read-name)))
+ (when (string-match "[^ \t\r\n]" (or package ""))
+ ;; Phew, this is recursive call to back to us.
+ (tinycygwin-bug-report-mail-package package file-list))))
+ (t
+ (or (tinycygwin-bug-report-exit)
+ (tinycygwin-external-with
+ (message (tinycygwin-msg-exit-emacs)))))))
+ (t
+ (tinycygwin-bug-report-mail-main-2 info file-list)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-bug-report-mail-type-update-xxx-todo (info)
+ "Request update of package whose INFO is old."
+ (let* ((status (assoc "Status" info)))
+ (when status
+ (setq info (delete status info)))
+ (push '("Status" "old") info)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-bug-report-mail-type-wnpp (type &optional info file-list)
+ "WNPP type request with INFO and FILE-LIST."
+ (tinycygwin-package-wnpp-main
+ type
+ nil
+ nil
+ nil
+ file-list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-bug-report-mail-type-upstream (info &optional file-list)
+ "Send message to upstream maintainer with package INFO and FILE-LIST."
+ (let* ((package (tinycygwin-package-info-field-package info))
+ (name (tinycygwin-bug-report-email-buffer-name package))
+ (buffer (tinycygwin-bug-report-mail-mode-buffer name)))
+ (message "Sending mail to UPSTREAM has not been implemented yet.")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-bug-report-mail-type-update (info &optional file-list)
+ "Update request."
+ (let* ((package (tinycygwin-package-info-field-package info))
+ (name (tinycygwin-bug-report-email-buffer-name package))
+ (buffer (tinycygwin-bug-report-mail-mode-buffer name)))
+ (if buffer
+ (pop-to-buffer buffer)
+ (tinycygwin-pop-to-buffer (get-buffer-create name))
+ (let ((subject (tinycygwin-bug-report-mail-subject-compose
+ "[UPDATE] Newer package available" package))
+ (to-list (list
+ tinycygwin-:email-cygwin-apps-list
+ (tinycygwin-package-info-port-maintainer-maybe
+ package))))
+ (tinycygwin-not-modified-with
+ (tinycygwin-bug-report-mail-compose
+ to-list
+ subject)
+ (tinycygwin-bug-report-mail-insert-files file-list)
+ (tinycygwin-bug-report-mail-mode-finish)))
+ (run-hooks 'tinycygwin-:bug-report-mail-hook))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-bug-report-mail-type (&optional type info file-list)
+ "Determine correct TYPE of message and act accordingly. This the main bug
+report handling semaphore, which delegates the task to correct
+function. INFO is alist of package's attributes. FILE-LIST contains
+files to attach."
+ (let* ((package (tinycygwin-package-info-field-package info)))
+ (tinycygwin-debug
+ (message "TinyCygwin: Mail-type type [%s] info: %s files: %s"
+ type info file-list))
+ (cond
+ ((and (stringp package)
+ (string= package "wnpp"))
+ (tinycygwin-bug-report-mail-type-wnpp type info file-list))
+ ((and info
+ (tinycygwin-bug-type-standard-p type))
+ (tinycygwin-bug-report-mail-type-standard info file-list))
+ ((and info
+ (stringp type)
+ (string= type "update"))
+ (tinycygwin-bug-report-mail-type-update info file-list))
+ ((and info
+ (stringp type)
+ (string= type "upstream"))
+ (tinycygwin-bug-report-mail-type-upstream info file-list))
+ (t
+ (error
+ (concat "TinyCygwin: [ERROR] Insufficient information [%s, %s, %s, %s] "
+ "Perhaps you meant `wnpp'?")
+ type package info file-list)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-bug-report-ask-type ()
+ "Ask type of bug.
+References:
+ `tinycygwin-:menu-bug-classification'
+ `tinycygwin-:menu-bug-classification-selected'"
+ (tinycygwin-menu-call-with
+ 'tinycygwin-:menu-bug-classification
+ tinycygwin-:menu-bug-classification-selected))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-bug-report-ask-package (&optional add-list)
+ "Return package infor by asking and completing name with ADD-LIST."
+ (let ((package (tinycygwin-package-read-name
+ "[TinyCygwin] Report bug to package: "
+ nil
+ add-list)))
+ (if (or (not (stringp package))
+ (string= "" package))
+ (setq package "bug-generic"))
+ (tinycygwin-package-info-main package)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-bug-report-mail-main (&optional info type file-list)
+ "Report bug interactive by mail. TYPE is bug type.
+INFO is alist of package's attributes. FILE-LIST are files to attach."
+ (interactive
+ (if (tinycygwin-smtp-setup-error)
+ (list nil)
+ (let ((info (tinycygwin-bug-report-ask-package
+ '("bug-generic" "wnpp"))))
+ (list
+ info
+ (if (tinycygwin-package-wnpp-p
+ (tinycygwin-package-info-field-package info))
+ (tinycygwin-package-wnpp-main-interactive)
+ (tinycygwin-bug-report-ask-type))))))
+ (tinycygwin-debug
+ (message "TinyCygwin: mail-mail info %s" (prin1-to-string info)))
+ (let ((error (unless (interactive-p)
+ (tinycygwin-smtp-setup-error))))
+ (unless error
+ (tinycygwin-debug
+ (message "TinyCygwin: mail-main %s" (prin1-to-string info)))
+ (tinycygwin-bug-report-mail-type type info file-list))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinycygwin-reportbug ()
+ "Fully interactive Cygwin bug reporting entrance.
+See function `tinycygwin-bug-report-mail-main' which contains more
+detailled description."
+ (interactive)
+ (call-interactively 'tinycygwin-bug-report-mail-main))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-bug-report-mail-package (package &optional type file-list)
+ "Interface to `tinycygwin-bug-report-mail-main' when PACKAGE is known.
+Optional TYPE of bug and possibly attach FILE-LIST."
+ (tinycygwin-bug-report-mail-main
+ (tinycygwin-package-status-main package)
+ type
+ file-list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-bug-report-batch-include-tag-buffers ()
+ "Tag all Emacs files as include files to bug report
+This function must not be called by any other than function
+`tinycygwin-bug-report-mail-batch'."
+ (dolist (buffer (buffer-list))
+ (with-current-buffer buffer
+ (let ((file (buffer-file-name))
+ (name (buffer-name)))
+ (when file
+ (unless (tinycygwin-bug-report-include-buffer-name-p name)
+ (setq buffer-read-only t)
+ (rename-buffer
+ (tinycygwin-bug-report-include-buffer-name name))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-bug-report-batch-setup-general ()
+ "Define Emacs settings for batch bug reporting.
+This function is not called if `tinycygwin-:expert-flag' is non-nil.
+the setting include e.g.
+
+ (setq sentence-end-double-space nil)
+ (setq colon-double-space nil)
+ (setq mouse-yank-at-point t)
+ (setq use-dialog-box nil)
+ (setq-default fill-column 75)
+ (setq isearch-lazy-highlight t)
+ (setq query-replace-highlight t)
+ (setq search-highlight t)
+ (setq track-eol t)
+ (setq resize-minibuffer-mode t)
+ ..."
+ (modify-syntax-entry ?- "w") ; part of word
+ (modify-syntax-entry ?\t " ") ; Treat TABs as spaces.
+ (setq sentence-end-double-space nil)
+ (setq colon-double-space nil)
+ (setq smtpmail-debug-info t)
+ (setq mouse-yank-at-point t)
+ (setq use-dialog-box nil)
+ (setq-default fill-column 75)
+ (setq isearch-lazy-highlight t)
+ (setq query-replace-highlight t)
+ (setq search-highlight t)
+ (setq track-eol t)
+ (setq resize-minibuffer-mode t)
+ (setq-default indent-tabs-mode nil) ;; Always spaces, more secure in email
+ (add-hook 'debugger-mode-hook 'toggle-truncate-lines)
+ (when (fboundp 'minibuffer-electric-default-mode)
+ (minibuffer-electric-default-mode 1)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinycygwin-bug-report-batch-setup-smtp ()
+ "If SMTPSERVER is set, arrange `smtpmail-send-it' to send mail."
+ (let ((server (getenv "SMTPSERVER")))
+ (when server
+ (setq smtpmail-debug-info t)
+ (setq smtpmail-local-domain nil)
+ (setq send-mail-function 'smtpmail-send-it)
+ (setq message-send-mail-function 'smtpmail-send-it)
+ (setq gnus-agent-send-mail-function 'smtpmail-send-it))))
+
+;;; ----------------------------------------------------------------------
+;;; This function is called from external program 'cygbug' which see.
+;;;
+;;;###autoload
+(defun tinycygwin-bug-report-batch (&optional package)
+ "This function is called from external script. DO NOT USE.
+Do not call this from lisp in any circumstances or it will cause
+Emacs to exit."
+ (let ((tinycygwin-:external-call-flag t)
+ (tinycygwin-:debug tinycygwin-:debug) ;; Make local copy
+ (tinycygwin-:expert-flag
+ (if (boundp 'tinycygwin-:command-switch-expert)
+ tinycygwin-:command-switch-expert))
+ (tinycygwin-:external-email-address
+ (if (boundp 'tinycygwin-:command-switch-email)
+ tinycygwin-:command-switch-email))
+ (file-list
+ (if (boundp 'tinycygwin-:command-switch-files)
+ tinycygwin-:command-switch-files))
+ (type
+ (if (boundp 'tinycygwin-:command-switch-type)
+ tinycygwin-:command-switch-type)))
+ ;; Enable these commands
+ (put 'narrow-to-region 'disabled nil)
+ (put 'eval-expression 'disabled nil)
+ (put 'downcase-region 'disabled nil)
+ (put 'upcase-region 'disabled nil)
+ ;; Make answering questions easier, like "Really exit
+ ;; "Emacs" when message is being composed still.
+ (defalias 'yes-or-no-p 'y-or-n-p)
+ (or package
+ (setq package
+ (when (boundp 'tinycygwin-:command-switch-package)
+ ;; Because this is called from external script,
+ ;; be cautious and activate debug to pinpoint
+ ;; possible errors.
+ (setq tinycygwin-:debug t)
+ tinycygwin-:command-switch-package)))
+ (unless package
+ (error "** [ERROR] Need Cygwin PACKAGE name in order to report bug."))
+ (when (and (null type)
+ (tinycygwin-package-wnpp-p package))
+ (let ((loop t)
+ selection)
+ (while loop
+ (cond
+ ((setq type (tinycygwin-package-wnpp-main-interactive))
+ (setq loop nil))
+ ((when (y-or-n-p
+ "Select other package bug/WNPP again (C-g to abort)? ")
+ (setq selection
+ (tinycygwin-package-read-name
+ "[TinyCygwin] Report bug to package: "
+ nil
+ '("bug-generic")))
+ (cond
+ ((string-match "^[ \t\r\n]*$" selection)
+ (message "Hm, nothing selected. Trying agian...")
+ (sit-for 1))
+ (t
+ (setq package selection
+ loop nil)))))))))
+ (tinycygwin-bug-report-batch-setup-smtp)
+ (tinycygwin-non-expert-with
+ (tinycygwin-bug-report-batch-setup-general)
+ (when nil ;; disabled for now
+ ;; Print clear message to Emacs novices.
+ (message
+ (substitute-command-keys
+ (concat
+ "[INFO] Exit \\[save-buffers-kill-emacs] "
+ "Abort \\[keyboard-quit] "
+ "")))
+ (sit-for 1.9)))
+ (tinycygwin-bug-report-batch-include-tag-buffers)
+ (tinycygwin-bug-report-mail-package package type file-list)))
+
+;;}}}
+
+;; Auto-created functions
+(tinycygwin-install-severity-functions)
+(tinycygwin-install-bug-classification-functions)
+(tinycygwin-install-message-mode)
+
+(provide 'tinycygwin)
+(run-hooks 'tinycygwin-:load-hook)
+
+;;; tinycygwin.el ends here
--- /dev/null
+;;; tinydebian.el --- Debian utilities.
+
+;;{{{ Id
+
+;; Copyright (C) 2001-2007 Jari Aalto
+;; Keywords: extensions
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program, call M-x tinydebian-version.
+;; Look at the code with folding.el
+
+;; COPYRIGHT NOTICE
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;; ........................................................ &t-install ...
+;; Put this file on your Emacs-Lisp load path, add following into your
+;; $HOME/.emacs startup file
+;;
+;; (add-hook 'tinydebian-:load-hook 'tinydebian-install)
+;; (require 'tinydebian)
+;;
+;; If you have any about this Emacs package:
+;;
+;; M-x tinydebian-submit-bug-report send question, feedback, bugs
+;;
+;; To read the documentation after file has been loaded, call
+;;
+;; M-x tinydebian-version
+
+;;}}}
+;;{{{ Documentation
+
+;; ..................................................... &t-commentary ...
+
+;;; Commentary:
+
+;; Overview of features
+;;
+;; This package contains utilities for the Debian System Administarator,
+;; to help administring Debian in daily tasks and submitting bug
+;; reports from Emacs. Learn more about debian at
+;; http://www.debian.org/
+;;
+;; o colorize /var/log files like messages, syslog etc.
+;; o Report Debian bug with M-x ... #todo
+;;
+;; Quick start:
+;;
+;; To report bug to Debian package, like command line reportbug(1):
+;;
+;; M-x tinydebian-reportbug
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+;;{{{ setup: libraries
+
+(require 'tinylibm)
+
+(eval-when-compile (ti::package-use-dynamic-compilation))
+
+(eval-and-compile
+ ;; Forward declarations to quiet byte compiler.
+ (defvar gnus-newsgroup-name)
+ (defvar font-lock-mode)
+ (defvar font-lock-keyword-face)
+ (defvar global-font-lock-mode)
+ (defvar font-lock-keywords)
+ (defvar font-lock-defaults)
+ (autoload 'gnus-summary-article-number "gnus-sum")
+ (autoload 'gnus-summary-display-article "gnus-sum")
+ (defvar gnus-article-buffer))
+
+(ti::package-defgroup-tiny TinyDebian tinydebian-: extensions
+ "Debian System administrator's grabbag of utilities.")
+
+;;}}}
+;;{{{ setup: hooks
+
+;;; ......................................................... &v-hooks ...
+
+(defcustom tinydebian-:load-hook nil
+ "*Hook run when file has been loaded."
+ :type 'hook
+ :group 'TinyDebian)
+
+(defcustom tinydebian-:find-bug-nbr-hook '(tinydebian-bug-nbr-any)
+ "*Functions to return Debian bug tracking number as string.
+Default value is '(tinydebian-bug-nbr-any)."
+ :type 'function
+ :group 'TinyDebian)
+
+(defcustom tinydebian-:find-email-hook '(tinydebian-email-any)
+ "*Functions to return Email address as string.
+Default value is '(tinydebian-email-any)."
+ :type 'function
+ :group 'TinyDebian)
+
+(defcustom tinydebian-:load-hook nil
+ "*Hook run when file has been loaded."
+ :type 'hook
+ :group 'TinyDebian)
+
+(defcustom tinydebian-:browse-url-function
+ (function tinydebian-browse-url-browse-url)
+ "*Function to run for HTTP URLs. Default is `browse-url'.
+To use text mode buffer inside Emacs, set value to
+`tinydebian-browse-url-lynx-dump' if lynx(1) is available.
+
+See also `browse-url-browser-function'."
+ :type 'function
+ :group 'TinyDebian)
+
+;;}}}
+;;{{{ setup: user config
+
+;;; ................................................... &v-user-config ...
+
+(defcustom tinydebian-:install-buffer-file-name-regexp
+ "/debian/\\(changelog\\|.*README\\)"
+ "*Activate `tinydebian-bts-mode' on buffers whose file name match regexp.
+This variable is used when function `tinydebian-install' is called."
+ :type 'regexp
+ :group 'TinyDebian)
+
+(defcustom tinydebian-:buffer-tiger "*Tinydebian tiger*"
+ "*Buffer name where to generate tiger(1) mail report chmod fixes.
+See function `tinydebian-command-audit-report-tiger'."
+ :type 'string
+ :group 'TinyDebian)
+
+(defcustom tinydebian-:buffer-wnpp-alert "*Tinydebian wnpp-alert*"
+ "*Buffer name where to generate wnpp-alert(1) report.
+See function `tinydebian-command-wnpp-alert'."
+ :type 'string
+ :group 'TinyDebian)
+
+(defcustom tinydebian-:buffer-www "*Tinydebian WWW*"
+ "*Buffer name where to put WWW call results.
+See `tinydebian-:browse-url-function'."
+ :type 'string
+ :group 'TinyDebian)
+
+(defcustom tinydebian-:buffer-bug-format "*Tinydebian bug#%s*"
+ "*A `format' string for buffer, where %s is substituted with bug number.
+See `tinydebian-buffer-url-bug'."
+ :type 'string
+ :group 'TinyDebian)
+
+(defcustom tinydebian-:install-gnus-newsgroup-name-regexp
+ "debian"
+ "*Newsgroup name regexp to match to activate `tinydebian-bts-mode'."
+ :type 'string
+ :group 'TinyDebian)
+
+(defface tinydebian-:warn-face
+ '((((class color) (background light))
+ (:background "green"))
+ (((class color) (background dark))
+ (:background "sea green"))
+ (((class grayscale monochrome)
+ (background light))
+ (:background "black"))
+ (((class grayscale monochrome)
+ (background dark))
+ (:background "white")))
+ "Face used for warnings."
+ :group 'TinyDebian)
+
+;;; Color loading section This is messy *Blech!*
+;;
+(defface tinydebian-:item-face
+ '((((class color) (background light))
+ (:foreground "green4"))
+ (((class color) (background dark))
+ (:foreground "green3")))
+ "Face used for noticing important items."
+ :group 'TinyDebian)
+
+(defcustom tinydebian-:font-lock-mode t
+ "If non-nil, allow turning on `font-lock-mode'.")
+
+;;}}}
+;;{{{ setup: -- private
+
+;;; ....................................................... &v-private ...
+
+(defvar tinydebian-:font-lock-keywords-adaptive-date t
+ "Flag to signal that current time is used to display today's log.
+For exmple in /etc/syslog today's log log entries are highlighted
+differently that previous days. However this must be changed in
+next day, because the day changes.
+
+This flags says, that adaptive-date regexps are be used.")
+
+(make-variable-buffer-local 'tinydebian-:font-lock-keywords-adaptive-date)
+
+(defvar tinydebian-:font-lock-keywords-bugs-rc ;; &font
+ ;; Package: [59]bookmarks (optional; [60]Tobias Toedter) [bookmarks/1.4 ; =] [[61]
+ ;; add/edit comment]
+ ;; [62]401275 [P N ] Remove two sites which force the user to enter a 24 mo
+ ;; nth contract
+ (list
+ (list
+ "Package: *\\[[0-9]+\\] *\\([a-z0-9.-]+\\)"
+ 1 'font-lock-builtin-face)
+ (list
+ (concat
+ "^\\[[0-9]+\\][[0-9]+ *\\(\\[[^]\r\n]+\\]\\) +"
+ "\\(.+"
+ ;; Continue to second line
+ "\\(?:\n *[A-Za-z<>'()].*\\)?"
+ "\\)")
+ '(1 'font-lock-type-face)
+ '(2 'font-lock-keyword-face)))
+ "Font lock keywords to set after calling `tinydebian-url-list-bugs-by-rc'.
+Only used if `tinydebian-:browse-url-function'is set to
+`tinydebian-browse-url-lynx-dump'.")
+
+(defvar tinydebian-:font-lock-package-bugs
+ (list
+ (list
+ "Package: *\\[[0-9]+\\] *\\([a-z0-9.-]+\\)"
+ 1 'font-lock-builtin-face))
+ "Font lock keywords to set after calling `tinydebian-url-list-bugs-by-rc'.
+Only used if `tinydebian-:browse-url-function'is set to
+`tinydebian-browse-url-lynx-dump'.")
+
+(defconst tinydebian-:bin-dpkg (executable-find "dpkg")
+ "Location of `dpkg' binary.")
+
+(defconst tinydebian-:bin-grep-available (executable-find "grep-available")
+ "Location of `grep-available' binary.")
+
+(defvar tinydebian-:grep-find-devel-docdir-list
+ '("/usr/share/doc/debian-policy"
+ "/usr/share/doc/debian-reference-en"
+ "/usr/share/doc/debian-reference-en"
+ "/usr/share/doc/developers-reference")
+ "*List of directororied to search for Debian development policy etc.")
+
+(defvar tinydebian-:severity-list
+ '(("critical"
+ "Makes unrelated software on the system (or the whole system) break,
+or causes serious data loss, or introduces a security hole on systems where
+you install the package.")
+ ("grave"
+ "Makes the package in question unuseable or mostly so, or causes data
+loss, or introduces a security hole allowing access to the accounts of users
+who use the package.")
+ ("serious"
+ "Severe violation of Debian policy (that is, it violates a
+\"must\" or \"required\" directive), or, in the package maintainer's
+opinion, makes the package unsuitable for release.")
+ ("important"
+ "A bug which has a major effect on the usability of a package,
+without rendering it completely unusable to everyone.")
+ ("normal"
+ "The default value, applicable to most bugs.")
+ ("minor"
+ "A problem which doesn't affect the package's usefulness, and is
+presumably trivial to fix.")
+ ("wishlist"
+ "For any feature request, and also for any bugs that are very
+difficult to fix due to major design considerations.")
+ ("fixed"
+ "For bugs that are fixed but should not yet be closed. This is an
+exception for bugs fixed by non-maintainer uploads. Note: the "fixed"
+tag should be used instead."))
+ "The bug system records a severity level with each bug report.
+This is set to normal by default, but can be overridden either by supplying a Severity line in the pseudo-header when the bug is submitted Severity or error.
+http://www.debian.org/Bugs/Developer#severities")
+
+(defvar tinydebian-:severity-selected nil
+ "Function `tinydebian-severity-select-*' sets this to user selection.")
+
+(defconst tinydebian-:menu-severity
+ '("\
+Severity: ?h)elp c)rit g)rave s)erious i)import RET-n)orm m)inor w)ish f)ixed"
+ ;; NOTE: These function are automatically created, you don't find
+ ;; then with C-s. See `tinydebian-install-severity-functions'
+ ((?c . ( (call-interactively 'tinydebian-severity-select-critical)))
+ (?g . ( (call-interactively 'tinydebian-severity-select-grave)))
+ (?s . ( (call-interactively 'tinydebian-severity-select-serious)))
+ (?i . ( (call-interactively 'tinydebian-severity-select-important)))
+ (?n . ( (call-interactively 'tinydebian-severity-select-normal)))
+ (?\C-m . ( (call-interactively 'tinydebian-severity-select-normal)))
+ (?m . ( (call-interactively 'tinydebian-severity-select-minor)))
+ (?w . ( (call-interactively 'tinydebian-severity-select-wishlist)))
+ (?f . ( (call-interactively 'tinydebian-severity-select-fixed)))))
+ "Severity menu.
+
+The bug system records a severity level with each bug report. This is set
+to normal by default, but can be overridden either by supplying a Severity
+line in the pseudo-header when the bug is submitted (see the instructions
+for reporting bugs), or by using the severity command with the control
+request server.
+
+critical
+ makes unrelated software on the system (or the whole system)
+ break, or causes serious data loss, or introduces a security hole
+ on systems where you install the package.
+
+grave
+ makes the package in question unuseable or mostly so, or causes
+ data loss, or introduces a security hole allowing access to the
+ accounts of users who use the package.
+
+serious
+ is a severe violation of Debian policy (that is, it violates a
+ \"must\" or \"required\" directive), or, in the package
+ maintainer's opinion, makes the package unsuitable for release.
+
+important
+ a bug which has a major effect on the usability of a package,
+ without rendering it completely unusable to everyone.
+
+normal
+ the default value, applicable to most bugs.
+
+minor
+ a problem which doesn't affect the package's usefulness, and is
+ presumably trivial to fix.
+
+wishlist
+ for any feature request, and also for any bugs that are very
+ difficult to fix due to major design considerations.
+
+fixed
+ for bugs that are fixed but should not yet be closed. This is an
+ exception for bugs fixed by non-maintainer uploads. Note: the
+ \"fixed\" tag should be used instead. Certain severities are
+ considered release-critical, meaning the bug will have an impact
+ on releasing the package with the stable release of Debian.
+ Currently, these are critical, grave and serious.")
+
+(defvar tinydebian-:tags-list
+ '(("already-in-ubuntu"
+ "Package is in Ubuntu but not yet in Debian. This is a notice to a wishlist
+See <http://utnubu.alioth.debian.org/>.xm")
+ ("patch"
+ "A patch or some other easy procedure for fixing the bug is included
+in the bug logs. If there's a patch, but it doesn't resolve the bug
+adequately or causes some other problems, this tag should not be used.")
+ ("wontfix"
+ "This bug won't be fixed. Possibly because this is a choice between
+two arbitrary ways of doing things and the maintainer and submitter prefer
+different ways of doing things, possibly because changing the behaviour
+will cause other, worse, problems for others, or possibly for other reasons.")
+ ("moreinfo"
+ "This bug can't be addressed until more information is provided by
+the submitter. The bug will be closed if the submitter doesn't provide
+more information in a reasonable (few months) timeframe. This is for
+bugs like "It doesn't work". What doesn't work?.")
+ ("unreproducible"
+ "This bug can't be reproduced on the maintainer's system.
+Assistance from third parties is needed in diagnosing the cause of the problem.")
+ ("help"
+ "The maintainer is requesting help with dealing with this bug.")
+ ("pending"
+ "The problem described in the bug is being actively worked on,
+i.e. a solution is pending.")
+ ("fixed"
+ "This bug is fixed or worked around (by a non-maintainer upload,
+for example), but there's still an issue that needs to be resolved.
+This tag replaces the old \"fixed\" severity.")
+ ("security"
+ "This bug describes a security problem in a package (e.g., bad
+permissions allowing access to data that shouldn't be accessible;
+buffer overruns allowing people to control a system in ways they
+shouldn't be able to; denial of service attacks that should be fixed, etc).
+Most security bugs should also be set at critical or grave severity.")
+ ("upstream"
+ "This bug applies to the upstream part of the package.")
+ ("confirmed"
+ "The maintainer has looked at, understands, and basically agrees
+with the bug, but has yet to fix it. (Use of this tag is optional; it is
+intended mostly for maintainers who need to manage large numbers of open bugs.")
+ ("fixed-upstream"
+ "The bug has been fixed by the upstream maintainer, but not yet
+in the package (for whatever reason: perhaps it is too complicated to
+backport the change or too minor to be worth bothering).")
+ ("ipv6"
+ "This bug affects support for Internet Protocol version 6.")
+ ("lfs"
+ "This bug affects support for large files (over 2 gigabytes).")
+ ("l10n"
+ "This bug is relevant to the localisation of the package.")
+ ("woody"
+ "This bug particularly applies to the (unreleased) woody distribution.")
+ ("sarge"
+ "This bug particularly applies to the sarge distribution.")
+ ("etch"
+ "This bug particularly applies to the etch distribution.")
+ ("sid"
+ "This bug particularly applies to an architecture that is
+currently unreleased (that is, in the sid distribution).")
+ ("experimental"
+ "This bug particularly applies to the experimental distribution."))
+ "Each bug can have zero or more of a set of given tags.
+These tags are displayed in the list of bugs when you look at a
+package's page, and when you look at the full bug log.
+See <http://www.debian.org/Bugs/Developer#tags>.")
+
+(defvar tinydebian-:wnpp-buffer "*TinyDebian WNPP*"
+ "WNPP question buffer.")
+
+(defvar tinydebian-:menu-wnpp-selected nil
+ "Placeholder of selection from `tinydebian-:menu-wnpp'.")
+
+(defconst tinydebian-:menu-wnpp
+ (list
+ '(format
+ "TinyDebian:WNPP%s 1i)tp 2o)rphan 3a)dopt 4n)ew package ?)help q)uit"
+ (if tinydebian-:menu-wnpp-selected
+ (format ";%s " (symbol-name tinydebian-:menu-wnpp-selected))
+ ""))
+ (list
+ '(?1 . ( (setq tinydebian-:menu-wnpp-selected 'package)))
+ '(?i . ( (setq tinydebian-:menu-wnpp-selected 'package)))
+ '(?I . ( (setq tinydebian-:menu-wnpp-selected 'package)))
+ '(?p . ( (setq tinydebian-:menu-wnpp-selected 'package)))
+ '(?P . ( (setq tinydebian-:menu-wnpp-selected 'package)))
+ '(?2 . ( (setq tinydebian-:menu-wnpp-selected 'oprhan)))
+ '(?o . ( (setq tinydebian-:menu-wnpp-selected 'oprhan)))
+ '(?O . ( (setq tinydebian-:menu-wnpp-selected 'oprhan)))
+ '(?3 . ( (setq tinydebian-:menu-wnpp-selected 'adopt)))
+ '(?a . ( (setq tinydebian-:menu-wnpp-selected 'adopt)))
+ '(?A . ( (setq tinydebian-:menu-wnpp-selected 'adopt)))
+ '(?4 . ( (setq tinydebian-:menu-wnpp-selected 'new)))
+ '(?n . ( (setq tinydebian-:menu-wnpp-selected 'new)))
+ '(?N . ( (setq tinydebian-:menu-wnpp-selected 'new)))))
+ ;; This message is straight from reportbug(1)
+ ;; 'apt-get install reportbug'
+ "What request type? If none of these things mean anything to you, or
+you are trying to report a bug in an existing package)
+
+1 p ITP, `Intent To Package'. Please submit a package description
+ along with copyright and URL in such a report.
+
+2 o The package has been `Orphaned'. It needs a new maintainer as soon as
+ possible.
+
+3 a RFA, this is a `Request for Adoption'. Due to lack of time, resources,
+ interest or something similar, the current maintainer is asking for
+ someone else to maintain this package. He/she will maintain it in the
+ meantime, but perhaps not in the best possible way. In short: the
+ package needs a new maintainer.
+
+4 n RFP, this is a `Request For Package'. You have found an interesting piece of
+ software and would like someone else to maintain it for Debian. Please
+ submit a package description along with copyright and URL in such a
+ report.
+
+q Quit menu.
+")
+
+(defconst tinydebian-:rfp-template "\
+Package: wnpp
+Severity: wishlist
+
+* Package name : <package>
+ Version : x.y.z
+ Upstream Author : Name <somebody@example.org>
+* URL : <homepage: http://www.example.org/>
+* License : <license: GPL, LGPL, BSD, MIT/X, etc.>
+ Programming Lang: <C, C++, C#, Perl, Python, etc.>
+ Description : <short desc>
+
+\(Include the long description here.)
+"
+ "Wnpp RFP/ITP template.
+NOTE: The <TAG:> constructs must be retained.")
+
+(defvar tinydebian-:rfp-hook nil
+ "Hook run after function `tinydebian-bts-mail-type-rfp'.
+See also `tinydebian-:rfp-template'")
+
+(defconst tinydebian-:wnpp-template-licenses-alist
+ '("Artistic"
+ "BSD"
+ "GPL"
+ "GPL-2"
+ "LGPL"
+ "LGPL-2"
+ "MIT/X11")
+ "List of licenses as recorded in Debian /usr/share/common-licenses/
+See also <http://www.debian.org/legal/licenses/> and
+<http://people.debian.org/~bap/dfsg-faq.html>.")
+
+(defconst tinydebian-:rfs-template "\
+
+I'm looking for sponsor:
+
+ Package name : <package>
+ Version : x.y.z
+ ITA/ITP URL : <ita: http://bugs.debian.org/BugNbr>
+* Package bugs URL: <bugs: http://bugs.debian.org/Package>
+ URL : <mentors: http://mentors.debian.net/debian/pool/main/p/package/*.dsc>
+ License : <license: GPL, LGPL, BSD, MIT/X, Artistic, etc.>
+ Programming Lang: <C, C++, C#, Perl, Python, etc.>
+
+\(* = remove if package is not in Debian.)
+Description:
+
+debian/changelog:
+
+Other notes:
+"
+ "RFS message to debian.devel.mentor mailinf list.
+NOTE: The <TAG:> constructs must be retained.
+See also `tinydebian-:rfs-hook'.")
+
+(defvar tinydebian-:rfs-hook nil
+ "Hook run after function `tinydebian-bts-mail-type-rfs'.
+See also `tinydebian-:rfs-template'")
+
+(defvar tinydebian-:bts-email-address "bugs.debian.org"
+ "Email address or Debian Bug Tracking System.")
+
+;; https://help.launchpad.net/UsingMaloneEmail
+(defvar tinydebian-:launchpad-email-address "bugs.launchpad.net"
+ "Email address or Debian Bug Tracking System.")
+
+(defvar tinydebian-:list-email-address "lists.debian.org"
+ "Email address or Debian mailing lists.")
+
+(defvar tinydebian-:url-http-package-search
+ ;; http://packages.debian.net/search?keywords=chbg&searchon=names
+ "http://packages.debian.net/search?"
+ "The packages Debian control URL without parameter, up to '?' token.")
+
+(defconst tinydebian-:url-http-package-bugs
+ "http://bugs.debian.org"
+ "The bugs Debian control URL without parameter, up to '/' token.")
+
+(defvar tinydebian-:url-http-debian-www
+ "http://www.debian.org"
+ "The main WWW page of Debian.")
+
+(defvar tinydebian-:url-http-wnpp-page-main
+ "http://www.debian.org/devel/wnpp"
+ "The WNPP main page URL address. No trailing slash.")
+
+(defconst tinydebian-:url-http-wnpp-page-alist
+ '(("RFA" . "rfa_bypackage")
+ ("O" . "orphaned")
+ ("RFH" . "help_request")
+ ("RFP" . "requested")
+ ("ITP" . "being_packaged"))
+ "List of mapping to pages under `tinydebian-:url-http-wnpp-page-main'.")
+
+(defconst tinydebian-:url-debian-page-alist
+ (list
+ '(bts-control
+ "http://www.debian.org/Bugs/server-control")
+ ;; 2006-11-06 unofficial
+ (list 'bugs-rc
+ "http://bts.turmzimmer.net/details.php"
+ tinydebian-:font-lock-keywords-bugs-rc)
+ '(qa-developer-status
+ "http://qa.debian.org/developer.php?")
+ '(qa-developer-bugs
+ "http://bugs.debian.org/cgi-bin/pkgreport.cgi?")
+ '(dfsg-license-faq
+ "http://people.debian.org/~bap/dfsg-faq.html")
+ '(base-files-faq
+ "http://ftp.debian.org/doc/base-files/FAQ")
+ '(debcheck-package
+ "http://qa.debian.org/debcheck.php?dist=%s&package=%s")
+ '(mentors
+ "http://mentors.debian.net")
+ '(mentors-pkg-pool
+ "http://mentors.debian.net/debian/pool")
+ '(pkg-search-files
+ "http://packages.debian.org/cgi-bin/search_contents.pl?searchmode=searchfiles&case=insensitive")
+ '(developers-reference
+ "http://www.debian.org/doc/packaging-manuals/developers-reference/")
+ ;; apt-get install debian-reference-common debian-reference-en
+ '(developers-reference-text
+ "/usr/share/doc/Debian/reference/reference.en.txt.gz")
+ '(policy
+ "http://www.debian.org/doc/debian-policy/index.html")
+ '(policy-text
+ "/usr/share/doc/debian-policy/policy.txt.gz")
+ '(newmaint-guide
+ "http://www.debian.org/doc/maint-guide/")
+ '(best-practises
+ "http://www.debian.org/doc/packaging-manuals/developers-reference/ch-best-pkging-practices.en.html"))
+ "List of Debian site pages.
+Format:
+ '((PAGE-TYPE URL [FONT-LOCK-KEYWORDS])
+ ...)
+
+The FONT-LOCK-KEYWORDS is only used if the results appear in `tinydebian-:buffer-www'.
+See `tinydebian-:browse-url-function'.")
+
+;;}}}
+;;{{{ setup: -- version
+
+;;; ....................................................... &v-version ...
+
+;;;###autoload (autoload 'tinydebian-version "tinydebian" "Display commentary." t)
+(eval-and-compile
+ (ti::macrof-version-bug-report
+ "tinydebian.el"
+ "tinydebian"
+ tinydebian-:version-id
+ "$Id: tinydebian.el,v 1.97 2007/08/04 10:09:46 jaalto Exp $"
+ '(tinydebian-version-id
+ tinydebian-:load-hook
+ tinydebian-:font-lock-keywords-adaptive-date
+ tinydebian-:bin-dpkg
+ tinydebian-:severity-list
+ tinydebian-:severity-selected
+ tinydebian-:tags-list)))
+
+(defvar tinydebian-:bts-extra-headers
+ (format "X-Bug-User-Agent: Emacs %s and tinydebian.el %s\n"
+ emacs-version
+ (substring tinydebian-:version-id 21 25))
+ "Header to add to BTS control mails.")
+
+;;}}}
+;;{{{ Install: bindings
+
+;;; ........................................................ &bindings ...
+
+;; #todo:
+(defun tinydebian-default-bindings ()
+ "Define default key bindings to `tinydebian-mode-map'.")
+
+(eval-and-compile
+
+;;;###autoload (autoload 'tinydebian-bts-mode "tinydebian" "" t)
+;;;###autoload (autoload 'turn-on-tinydebian-bts-mode "tinydebian" "" t)
+;;;###autoload (autoload 'turn-off-tinydebian-bts-mode "tinydebian" "" t)
+;;;###autoload (defvar tinydebian-:bts-mode-prefix-key "\C-c-")
+ (ti::macrof-minor-mode-wizard
+ "tinydebian-bts-" " Tdeb" "\C-c-" "Tdeb" 'TinyDebian "tinydebian-:bts-" ;1-6
+
+ "Debian Bug Tracking System (BTS) Minor mode. With this mode you can
+jump to a bug report at or near current point (using browser), send
+control messages, like turning RFS into ITP, send new RFS, send new
+ITP etc.
+
+Prefix key is:
+
+ tinydebian-:bts-mode-prefix-key
+
+Mode description:
+
+\\{tinydebian-:bts-mode-prefix-map}"
+
+ "TinyDebian BTS"
+ nil
+ "TinyDebian BTS minor mode menu."
+ (list
+ tinydebian-:bts-mode-easymenu-name
+ ["Reply to bug" tinydebian-bts-mail-type-reply t]
+ ["Report bug by mail" tinydebian-bug-report-mail t]
+ ["Goto URL by bug number" tinydebian-bug-browse-url-by-bug t]
+ ["Goto URL by package bugs" tinydebian-bug-browse-url-by-package-bugs t]
+ ["Goto URL by package name" tinydebian-bug-browse-url-by-package-name t]
+
+ "----"
+
+ (list
+ "BTS WNPP messages"
+ ["Send BTS ITA: intent to adopt" tinydebian-bts-mail-type-ita t]
+ ["Send BTS ITP: reponse to RFP" tinydebian-bts-mail-type-itp t]
+ ["Send BTS RFA: request for adopt" tinydebian-bts-mail-type-rfa t]
+ ["Send BTS RFH: request for help" tinydebian-bts-mail-type-rfh t]
+ ["Send BTS RFP: request for packege" tinydebian-bts-mail-type-rfp t]
+ ["Send BTS RFS: request for sponsor" tinydebian-bts-mail-type-rfs t]
+ ["Send BTS O: orphan" tinydebian-bts-mail-type-orphan t]
+ ["WNPP control menu" tinydebian-package-wnpp-main t])
+
+ (list
+ "BTS Control messages"
+ ["Send BTS Ctrl close" tinydebian-bts-mail-ctrl-close t]
+ ["Send BTS Ctrl severity" tinydebian-bts-mail-ctrl-severity t]
+ ["Send BTS Ctrl tags" tinydebian-bts-mail-ctrl-tags t]
+ ["Send BTS Ctrl usertag" tinydebian-bts-mail-ctrl-usertag t]
+ ["Send BTS Ctrl forward" tinydebian-bts-mail-ctrl-forward-main t]
+ ["Send BTS Ctrl reassign" tinydebian-bts-mail-ctrl-reassign t]
+ ["Send BTS Ctrl retitle" tinydebian-bts-mail-ctrl-retitle t]
+ ["Send BTS Ctrl reopen" tinydebian-bts-mail-ctrl-reopen t])
+
+ (list
+ "Query information"
+ ["List of WNPP RFP" tinydebian-url-list-wnpp-rfp t]
+ ["List of WNPP RFH" tinydebian-url-list-wnpp-rfh t]
+ ["List of WNPP RFA" tinydebian-url-list-wnpp-rfa t]
+ ["List of WNPP Orphaned" tinydebian-url-list-wnpp-orphaned t]
+ ["List of WNPP ITP" tinydebian-url-list-wnpp-itp t]
+ ["List of RC bugs" tinydebian-url-list-bugs-by-rc t]
+ ["List of items by usertag" tinydebian-url-list-bugs-by-usertag t]
+ ["Installed pkg problems" tinydebian-command-show-wnpp-alert t]
+ ["Grep devel documentation" tinydebian-grep-find-debian-devel t]
+
+ "----"
+
+ ["QA Developer status" tinydebian-url-list-qa-developer-status t]
+ ["QA Developer bugs" tinydebian-url-list-qa-developer-bugs t]
+ ["Package debcheck" tinydebian-url-list-package-debcheck t]
+ ["Package search by name" tinydebian-url-list-package-by-package-name t]
+ ["Package search by filename" tinydebian-url-list-package-by-filename t]
+
+ "----"
+
+ ["FAQ DFSG and licenses" tinydebian-url-list-dsfg-license-faq t]
+ ["FAQ base files" tinydebian-url-list-base-files-faq t])
+
+ (list
+ "Debian manuals"
+ ["URL BTS Ctrl page" tinydebian-url-bts-ctrl-page t]
+ ["URL Policy manual" tinydebian-url-policy-manual t]
+ ["URL Newmaint guide" tinydebian-url-policy-new-maintainer-guide t]
+ ["URL Developer's reference" tinydebian-url-policy-developers-reference t]
+ ["URL Best practises" tinydebian-url-policy-best-practises t]))
+
+ (progn
+
+ (define-key map "b" 'tinydebian-bug-browse-url-by-bug)
+ (define-key map "B" 'tinydebian-bug-browse-url-by-package-bugs)
+ (define-key map "M" 'tinydebian-bug-report-mail)
+ (define-key map "p" 'tinydebian-bug-browse-url-by-package-name)
+ (define-key map "r" 'tinydebian-bug-reply)
+ (define-key map "w" 'tinydebian-package-wnpp-main)
+
+ (define-key map "-a" 'tinydebian-bts-mail-type-ita)
+ (define-key map "-A" 'tinydebian-bts-mail-type-rfa)
+ (define-key map "-h" 'tinydebian-bts-mail-type-rfh)
+ (define-key map "-P" 'tinydebian-bts-mail-type-itp)
+ (define-key map "-p" 'tinydebian-bts-mail-type-rfp)
+ (define-key map "-r" 'tinydebian-bts-mail-type-reply)
+ (define-key map "-s" 'tinydebian-bts-mail-type-rfs)
+ (define-key map "-o" 'tinydebian-bts-mail-type-orphan)
+ (define-key map "mi" 'tinydebian-bts-mail-message-info)
+
+ ;; (i)nfo (i)nstalled
+ (define-key map "ii" 'tinydebian-command-show-wnpp-alert)
+
+ ;; (i)nfo (g)rep
+ (define-key map "ig" 'tinydebian-grep-find-debian-devel)
+
+ ;; (L)ist Url commands
+ ;; (b)ugs
+ (define-key map "lbr" 'tinydebian-url-list-bugs-by-rc)
+ (define-key map "lbu" 'tinydebian-url-list-bugs-by-usertag)
+ ;; (d)eveloper
+ (define-key map "ldb" 'tinydebian-url-list-qa-developer-bugs)
+ (define-key map "lds" 'tinydebian-url-list-qa-developer-status)
+ ;; (f)aq
+ (define-key map "lfl" 'tinydebian-url-list-dsfg-license-faq)
+ (define-key map "lfb" 'tinydebian-url-list-base-files-faq)
+ ;; (p)ackage
+ (define-key map "lpf" 'tinydebian-url-list-package-by-filename)
+ (define-key map "lpp" 'tinydebian-url-list-package-by-package-name)
+ (define-key map "lpc" 'tinydebian-url-list-package-debcheck)
+ ;; (w)npp
+ (define-key map "lwa" 'tinydebian-url-list-wnpp-rfa)
+ (define-key map "lwh" 'tinydebian-url-list-wnpp-rfh)
+ (define-key map "lwo" 'tinydebian-url-list-wnpp-orphaned)
+ (define-key map "lwp" 'tinydebian-url-list-wnpp-rfp)
+ (define-key map "lwP" 'tinydebian-url-list-wnpp-itp)
+
+ ;; (C)ontrol commands
+ (define-key map "cc" 'tinydebian-bts-mail-ctrl-close)
+ (define-key map "cs" 'tinydebian-bts-mail-ctrl-severity)
+ (define-key map "ct" 'tinydebian-bts-mail-ctrl-tags)
+ (define-key map "cT" 'tinydebian-bts-mail-ctrl-usertag)
+ (define-key map "cf" 'tinydebian-bts-mail-ctrl-forward-main)
+ (define-key map "cr" 'tinydebian-bts-mail-ctrl-reassign)
+ (define-key map "cR" 'tinydebian-bts-mail-ctrl-retitle)
+ (define-key map "co" 'tinydebian-bts-mail-ctrl-reopen)
+
+ ;; URLs
+ (define-key map "ub" 'tinydebian-url-bts-ctrl-page)
+ (define-key map "ud" 'tinydebian-url-policy-developers-reference)
+ (define-key map "un" 'tinydebian-url-policy-new-maintainer-guide)
+ (define-key map "up" 'tinydebian-url-policy-manual)
+ (define-key map "uP" 'tinydebian-url-policy-best-practises))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-bts-mode-gnus-summary-maybe-turn-on ()
+ "Activate tinydebian-bts-mode if group name contains word 'Debian'"
+ (when (and (boundp 'gnus-newsgroup-name)
+ (stringp gnus-newsgroup-name)
+ (string-match "debian" gnus-newsgroup-name))
+ (turn-on-tinydebian-bts-mode)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-bts-mode-maybe-turn-on ()
+ "Activate tinydebian-bts-mode if buffer contains word 'Debian'"
+ (when (save-excursion
+ (goto-char (point-min))
+ (re-search-forward "debian" nil t))
+ (turn-on-tinydebian-bts-mode)))
+
+;;}}}
+;;{{{ Install: generate severity function etc.
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-install-severity-functions ()
+ "Generate `tinydebian-severity-select-*' user functions."
+ ;; Generate functions on run-time.
+ (mapcar
+ (function
+ (lambda (x)
+ (let ((sym (intern (format "tinydebian-severity-select-%s" x)))
+ def)
+ (setq def
+ (` (defun (, sym) ()
+ "Set Severity level `tinydebian-:severity-selected'."
+ (interactive)
+ (setq tinydebian-:severity-selected (, x)))))
+ (eval def))))
+ '("critical"
+ "grave"
+ "serious"
+ "important"
+ "normal"
+ "minor"
+ "wishlist"
+ "fixed")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-find-file-hooks ()
+ "Run `tinydebian-bts-mode-maybe-turn-on'.
+Install `font-lock-keywords' for log files."
+ (tinydebian-bts-mode-maybe-turn-on)
+ (tinydebian-font-lock-keywords))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-install-font-lock-keywords (&optional uninstall)
+ "Install colors to all current buffers."
+ (dolist (buffer (buffer-list))
+ (with-current-buffer buffer
+ (tinydebian-font-lock-keywords uninstall))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinydebian-install-in-buffers (&optional uninstall)
+ "Install or UNINSTALL `tinydebiab-bts-mode' in existing buffers.
+Activate on Gnus summary and article modes if there is word 'Debian'.
+Activate on files whose path matches
+`tinydebian-:install-buffer-file-name-regexp'."
+ (flet ((search (regexp)
+ (save-excursion
+ (goto-char (point-min))
+ (re-search-forward regexp nil t))))
+ (dolist (buffer (buffer-list))
+ (let (doit)
+ (with-current-buffer buffer
+ (cond
+ ((and (stringp buffer-file-name)
+ (string-match tinydebian-:install-buffer-file-name-regexp
+ buffer-file-name))
+ (setq doit t))
+ ((and (eq major-mode 'gnus-summary-mode)
+ (boundp 'gnus-newsgroup-name)
+ (string-match
+ tinydebian-:install-gnus-newsgroup-name-regexp
+ gnus-newsgroup-name))
+ (setq doit t))
+ ((and (eq major-mode 'gnus-article-mode)
+ (search "debian"))
+ (setq doit t))
+ ((search (concat
+ "bug#[0-9][0-9][0-9][0-9][0-9][0-9]\\>"
+ "\\|Closes +#[0-9][0-9][0-9][0-9][0-9][0-9]"))
+ (setq doit t)))
+ (if uninstall
+ (turn-off-tinydebian-bts-mode)
+ (turn-on-tinydebian-bts-mode)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-install (&optional uninstall)
+ "Install or UNINSTALL package."
+ (interactive "P")
+ ;; This just hides from byte compiler function definition
+ ;; so that it does not remember how amny arguments it takes
+ ;;
+ ;; function tinydebian-bug-report-mail used to take 0+ arguments,
+ ;; now takes 1 function tinydebian-bug-report-mail defined multiple
+ ;; times in this file
+ ;;
+ (cond
+ (uninstall
+ ;;(remove-hook 'write-file-hooks 'tinydebian-auto-save)
+ (tinydebian-install-font-lock-keywords 'uninstall)
+ (remove-hook 'find-file-hooks 'tinydebian-find-file-hooks)
+ (remove-hook 'gnus-summary-prepare-hook
+ 'tinydebian-bts-mode-gnus-summary-maybe-turn-on)
+ (remove-hook 'gnus-article-prepare-hook
+ 'tinydebian-bts-mode-maybe-turn-on)
+ (tinydebian-install-in-buffers 'uninstall))
+ (t
+ ;; (add-hook 'write-file-hooks 'tinydebian-auto-save)
+ (tinydebian-install-font-lock-keywords)
+ (add-hook 'find-file-hooks 'tinydebian-find-file-hooks)
+ (add-hook 'gnus-summary-prepare-hook
+ 'tinydebian-bts-mode-gnus-summary-maybe-turn-on)
+ (add-hook 'gnus-article-prepare-hook
+ 'tinydebian-bts-mode-maybe-turn-on)
+ (tinydebian-install-in-buffers)))
+ nil)
+
+;;}}}
+;;{{{ Utility functions
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro tinydebian-launchpad-email-compose (address)
+ "Send message to Launchpad at ADDRESS."
+ `(format "%s@%s" ,address tinydebian-:launchpad-email-address))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinydebian-launchpad-email-new ()
+ (tinydebian-launchpad-email-compose "new"))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro tinydebian-list-email-compose (address)
+ "Send message to Debian mailing list at ADDRESS."
+ `(format "%s@%s" ,address tinydebian-:list-email-address))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro tinydebian-bts-email-compose (address)
+ "Send message to Debian BTS at ADDRESS."
+ `(format "%s@%s" ,address tinydebian-:bts-email-address))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinydebian-bts-email-submit ()
+ (tinydebian-bts-email-compose "submit"))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinydebian-bts-email-control ()
+ (tinydebian-bts-email-compose "control"))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro tinydebian-package-narrow-to-region (&rest body)
+ "Search dpkg -s result from current point forward and narrow around it.
+Point is put at the beginning of region.
+Variable `package' contains the package name."
+ (`
+ (let* (beg-narrow
+ package)
+ (when (re-search-forward "^Package: +\\([^ \t\r\n]+\\) *$" nil t)
+ (setq beg-narrow (line-beginning-position))
+ (setq package (match-string 1))
+ (when (re-search-forward "^[ \t]*$" nil t)
+ (ti::narrow-safe beg-narrow (point)
+ (ti::pmin)
+ (,@ body)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinydebian-with-buffer-macro 'edebug-form-spec '(body))
+(put 'tinydebian-with-buffer-macro 'lisp-indent-function 0)
+(defmacro tinydebian-with-buffer-macro (buffer &rest body)
+ "Create BUFFER, empty it and run BODY.
+Variable `buffer' is available in this macro."
+ `(let ((buffer (get-buffer-create ,buffer)))
+ (with-current-buffer buffer
+ (erase-buffer)
+ ,@body)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinydebian-string-p (str &optional error)
+ "Check that STR contains non-empty value.
+Signal optional ERROR message is STR was empty."
+ (or (and (stringp str)
+ (string-match "[^ \t\r\n]" str))
+ (and (stringp error)
+ (error "TinyDebian: %s" error))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinydebian-buffer-match-string (regexp &optional start)
+ "Search REGEX at optional START point and return submatch 1."
+ (save-excursion
+ (if start
+ (goto-char start))
+ (if (re-search-forward regexp nil t)
+ (match-string 1))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinydebian-call-process (prg &optional buffer &rest args)
+ "Call PRG with list of ARGS and print output to current buffer or BUFFER."
+ (apply 'call-process
+ prg
+ (not 'infile)
+ (or buffer (current-buffer))
+ (not 'real-time-display)
+ args))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinydebian-packages-browse-url-compose
+ (keyword &optional search-on distribution section)
+ "Return URL search string.
+Argument: KEYWORD
+Optional: SEARCH-ON DISTRIBUTION SECTION."
+ (format (concat tinydebian-:url-http-package-search
+ "keywords=%s&"
+ "searchon=%s&"
+ "subword=1&"
+ "version=%s&"
+ "release=%s")
+ keyword
+ (or search-on "names")
+ (or distribution "all")
+ (or section "all")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinydebian-string-delete-newlines (string)
+ "Delete newlines from STRING."
+ (ti::string-regexp-delete "[\r\n]" string))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinydebian-read-license (message)
+ "Ask license with MESSAGE.
+ See `tinydebian-:wnpp-template-licenses-alist'."
+ (completing-read
+ message
+ (mapcar (lambda (x)
+ (cons x 1))
+ tinydebian-:wnpp-template-licenses-alist)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-font-lock-keywords (&optional uninstall)
+ "Add color support to various log files by setting
+`font-lock-keywords'."
+ (interactive)
+ (let* ((today (ti::date-standard-rfc-regexp "mon-date"))
+ ;; (cs (or comment-start-skip "[ \t]+"))
+ (file "")
+ keywords)
+ (when (stringp buffer-file-name)
+ (setq file (or buffer-file-name "no-name?")))
+ (setq
+ keywords
+ (cond
+ ;; ............................................. Linux log files ...
+ ;; /var/log/
+ ((string-match "/log/messages$" file)
+ ;; font-lock-constant-face
+ (make-local-variable 'font-lock-defaults)
+ (setq font-lock-keywords
+ (list
+ (list (concat today " +[0-9]+:+[0-9]+:+[0-9]+")
+ 0 'font-lock-function-name-face)
+ (list
+ (concat
+ "^... +[0-9]+ +[0-9]+:+[0-9]+:+[0-9]+")
+ 0 'font-lock-reference-face)
+ (list
+ (concat "restarted\\|started"
+ "\\|ignoring"
+ "\\|Linux version.*")
+ 0 'font-lock-comment-face))))
+
+ ((string-match "mail\\.log\\|mail\\.info" file)
+ ;; font-lock-constant-face
+ (make-local-variable 'font-lock-defaults)
+ (setq font-lock-keywords
+ (list
+ (list (concat today " +[0-9]+:+[0-9]+:+[0-9]+")
+ 0 'font-lock-function-name-face)
+ (list
+ (concat
+ "^... +[0-9]+ ++[0-9]+:+[0-9]+:+[0-9]+")
+ 0 'font-lock-reference-face)
+ '("timed out\\|did not.*"
+ 0 tinydebian-:warn-face)
+ (list
+ (concat "\\(from\\|to\\)=\\([^ ,\t\r\n]+\\)")
+ 2 'font-lock-comment-face))))
+
+ ((string-match "daemon\\.log" file)
+ ;; font-lock-constant-face
+ (make-local-variable 'font-lock-defaults)
+ (setq font-lock-keywords
+ (list
+ (list
+ (concat
+ "^... +[0-9]+ +[0-9]+:+[0-9]+:+[0-9]+")
+ 0 'font-lock-reference-face)
+ (list
+ (concat "connection attempt" ;); See "iplogger" package
+ 0 'tinydebian-:warn-face)
+ (list
+ (concat "signal +[0-9]+\\|no such user"
+ "\\|connect from .*")
+ 0 'font-lock-comment-face)))))
+
+ ((string-match "auth\\.log" file)
+ ;; font-lock-constant-face
+ (make-local-variable 'font-lock-defaults)
+ (setq font-lock-keywords
+ (list
+ (list (concat today " +[0-9]+:+[0-9]+:+[0-9]+")
+ 0 'font-lock-function-name-face)
+ (list
+ (concat
+ "^... +[0-9]+ +[0-9]+:+[0-9]+:+[0-9]+")
+ 0 'font-lock-reference-face)
+ (list
+ (concat "opened +for +[^ \t\r\n]+")
+ 0 'tinydebian-:warn-face)
+ '( "for user \\(root\\)"
+ 1 font-lock-string-face)
+ '( "from \\([^ \t\r\n]+\\)"
+ 1 font-lock-type-face)
+ '( "for +\\([^ \t\r\n]+\\) +from"
+ 1 font-lock-comment-face)
+ '( "for user +\\([^ \t\r\n]+\\)"
+ 1 font-lock-comment-face))))
+
+ ((string-match "syslog" file)
+ ;; font-lock-constant-face
+ (make-local-variable 'font-lock-defaults)
+ (setq font-lock-keywords
+ (list
+ (list (concat today " +[0-9]+:+[0-9]+:+[0-9]+")
+ 0 'font-lock-function-name-face)
+ (list
+ (concat
+ "^... +[0-9]+ +[0-9]+:+[0-9]+:+[0-9]+")
+ 0 'font-lock-reference-face)
+ (list
+ (concat "Invalid.*"
+ ;; portmap[135]: cannot bind udp: Address already in use
+ "\\|cannot"
+ "\\|Connection timed out"
+ ;; See iplogger(1)
+ "\\|connection attempt"
+ ;; See portsentry(1)
+ "\\|attackalert:.* +to +.*port.*"
+ ;; apm -s failed
+ "\\| failed"
+ "\\|did not .*")
+ 0 'tinydebian-:warn-face)
+ '("to=\\([^ \t\r\n]+\\)"
+ 1 font-lock-comment-face)
+ '("(\\([^ )\t\r\n]+\\)) CMD "
+ 1 font-lock-comment-face)
+ '("CMD .*"
+ 0 font-lock-constant-face)
+ '("inetd"2
+ 0 font-lock-type-face)
+ (list
+ (concat
+ "program exit.*\\|.*started.*"
+ ;; btpd daemon
+ "\\|synchronisation lost")
+ 0 font-lock-keyword-face))))))
+ (when keywords
+ (cond
+ (uninstall
+ (setq font-lock-keywords nil))
+ ((or font-lock-mode
+ tinydebian-:font-lock-mode
+ global-font-lock-mode
+ (font-lock-mode-maybe 1))
+ (setq font-lock-keywords keywords))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-email-at-word (&optional string)
+ "Read email address if any at current point or from STRING."
+ (or string
+ (setq string (thing-at-point 'url)))
+ (when (and (stringp string)
+ (string-match "mailto:\\(.+\\)" string))
+ (match-string 1 string)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-email-at-line (&optional string)
+ "Read email address if any at current line or from STRING."
+ (or string
+ (setq string (thing-at-point 'line)))
+ (when (and (stringp string)
+ (string-match "[^ <\t\r\n]+@[^ \t\r\n>]+" string))
+ (match-string 0 string)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinydebian-email-gnus-summary-mode-macro 'edebug-form-spec '(body))
+(put 'tinydebian-email-gnus-summary-mode-macro 'lisp-indent-function 0)
+(defmacro tinydebian-email-gnus-summary-mode-macro (&rest body)
+ "At current poiint, examine article and run BODY."
+ `(when (eq major-mode 'gnus-summary-mode)
+ (let ((article (gnus-summary-article-number))
+ article-window)
+ (gnus-summary-display-article article)
+ (setq article-window (get-buffer-window gnus-article-buffer t))
+ (gnus-eval-in-buffer-window gnus-article-buffer
+ ,@body))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-email-gnus-summary-mode ()
+ "Read mail address if point is at Gnus summary buffer."
+ (tinydebian-email-gnus-summary-mode-macro
+ (tinydebian-email-field-from)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-email-field-from ()
+ "Read From: field and return email."
+ (let* ((str (mail-fetch-field "From")))
+ (or (and str
+ (tinydebian-email-at-line str)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-email-field-to ()
+ "Read To: field and return email."
+ (let* ((str (mail-fetch-field "To")))
+ (or (and str
+ (tinydebian-email-at-line str)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-email-any (&rest args)
+ "Try various methods to find email address. Ignore ARGS.
+At current point, current line, headers of the mail message."
+ (or (tinydebian-email-gnus-summary-mode)
+ (tinydebian-email-at-word)
+ (tinydebian-email-at-line)
+ (tinydebian-email-field-from)
+ (tinydebian-email-field-to)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinydebian-email-search ()
+ "Call hook `tinydebian-:find-email-hook' until value returned."
+ (run-hook-with-args-until-success 'tinydebian-:find-email-hook))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-bug-string-parse-wnpp-alert (str)
+ "Parse wnpp-alert(1) like line. Return '(bug package bug-type desc)
+ RFA 321654 debtags -- Enables support for package tags."
+ (let (case-fold-search)
+ (when (string-match
+ (concat
+ "\\<\\(RF.\\|IT.\\|O\\) +\\([0-9]+\\) +"
+ "\\([^ \t\r\n]+\\) +-- +\\(.+[^ \t\r\n]\\)")
+ str)
+ (list
+ (match-string 2 str)
+ (match-string 3 str)
+ (match-string 1 str)
+ (match-string 4 str)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-bug-nbr-string (str)
+ "Read bug nbr from STR."
+ (or (and (string-match "#\\([0-9]+\\)" str)
+ (match-string 1 str))
+ (multiple-value-bind (bug)
+ (tinydebian-bug-string-parse-wnpp-alert str)
+ bug)
+ ;; NNNN@bugs.debian.org
+ (and (string-match (concat "\\([0-9]+\\)\\(?:-[a-z]+\\)?@"
+ tinydebian-:bts-email-address)
+ str)
+ (match-string 1 str))
+ ;; BTS message lines: "owner NNNNNN"
+ (and (string-match (concat "\\<\\(?:owner\\|retitle\\) "
+ "\\([0-9][0-9][0-9][0-9][0-9][0-9]\\)\\>")
+ str)
+ (match-string 1 str))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-bug-nbr-at-current-point ()
+ "Read bug number with hash (#) mark from current point"
+ (let ((table (syntax-table))
+ word)
+ (with-syntax-table table
+ (modify-syntax-entry ?# "w" table)
+ (tinydebian-bug-nbr-string (current-word)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinydebian-bug-nbr-any-at-current-point ()
+ "Read bug number NNNNNN from current point"
+ (let ((str (current-word)))
+ (if (string-match
+ "\\([^0-9]\\|^\\)\\([0-9][0-9][0-9][0-9][0-9][0-9]\\)$"
+ str)
+ (match-string 2 str))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinydebian-bug-nbr-current-line ()
+ "Read bug number from current line"
+ (let* ((line (buffer-substring-no-properties
+ (line-beginning-position)
+ (line-end-position))))
+ (tinydebian-bug-nbr-string line)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinydebian-bug-nbr-forward (&optional regexp)
+ "Read bug#NNNN from current point forward.
+If optional REGEXP is sebt, it must take number in submatch 1."
+ (tinydebian-buffer-match-string (or regexp "Bug#\\([0-9]+\\)")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinydebian-bug-hash-forward ()
+ "Search #NNNN forward."
+ (tinydebian-bug-nbr-forward "#\\([0-9]+\\)"))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinydebian-bug-nbr-buffer (&optional regexp)
+ "Read bug#NNNN or REGEXP from buffer."
+ (save-excursion
+ (goto-char (point-min))
+ (tinydebian-bug-nbr-forward)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinydebian-bug-hash-buffer ()
+ "Search #NNNN from buffer."
+ (tinydebian-bug-nbr-buffer "#\\([0-9]+\\)"))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinydebian-email-cc-to-bug-nbr ()
+ "Read BTS number from CC or To"
+ (let* ((str (mail-fetch-field "To")))
+ (or (and str
+ (tinydebian-bug-nbr-string str))
+ (and (setq str (mail-fetch-field "Cc"))
+ (tinydebian-bug-nbr-string str)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinydebian-email-subject-bug-nbr ()
+ "Read BTS number from Subject"
+ (let* ((subject (mail-fetch-field "Subject")))
+ (and subject
+ (tinydebian-bug-nbr-string subject))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-bug-nbr-any (&rest args)
+ "Try various methods to find bug tracking number. Ignore ARGS.
+At current point, current line, headers of the mail message
+(CC, To, Subject), forward from point, whole buffer."
+ (or (tinydebian-bug-nbr-at-current-point)
+ (tinydebian-bug-nbr-current-line)
+ (tinydebian-email-cc-to-bug-nbr)
+ (tinydebian-email-subject-bug-nbr)
+ (tinydebian-bug-nbr-forward)
+ (tinydebian-bug-nbr-buffer)
+ (tinydebian-bug-hash-forward)
+ (tinydebian-bug-hash-buffer)
+ (tinydebian-bug-nbr-any-at-current-point)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinydebian-bug-nbr-search ()
+ "Call hook `tinydebian-:find-bug-nbr-hook' until value returned."
+ (run-hook-with-args-until-success 'tinydebian-:find-bug-nbr-hook))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-bug-package-name-header-pool ()
+ "Search Filename: pool/main/p/<package>."
+ (tinydebian-buffer-match-string
+ "^Filename: pool.*/\\([^/ \t\r\n]+\\)/"
+ (point-min)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-bug-package-name-header-package ()
+ "Search Package: <package>."
+ (tinydebian-buffer-match-string
+ "^Package: +\\([^/ \t\r\n]+\\)/"
+ (point-min)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-bts-parse-string-with-bug (str)
+ "Return '(bug type package description) for common matches."
+ (let (bug
+ type
+ package
+ desc
+ case-fold-search)
+ (cond
+ ((string-match "\\<\\([A-Z][A-Z][A-Z]\\|O\\): *\\(.*\\)" str)
+ (setq type (match-string 1 str)
+ desc (match-string 2 str)
+ bug (tinydebian-bug-nbr-string str))
+ (when (string-match "^\\([a-z].+\\) +--+ *\\(.*\\)" desc)
+ (setq package (match-string 1 desc)
+ desc (match-string 2 desc))))
+ ((string-match "Bug#\\([0-9]+\\): *\\(.*\\)" str)
+ (setq bug (match-string 1 str)
+ desc (match-string 2 str))))
+ (list bug type package desc)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-bts-parse-string-with-package (str)
+ "Return '(package description) for common matches."
+ (let (case-fold-search)
+ (cond
+ ((string-match
+ "[fF]ixed in\\(?: NMU of\\)? \\([a-z][^ \t\r\n]+\\) +\\(.*\\)" str)
+ (list (match-string 1 str)
+ str))
+ ((string-match "^\\([a-z][a-z0-9-]+\\): +\\(.*\\)" str)
+ (list (match-string 1 str)
+ (match-string 2 str))))))
+
+;;; ----------------------------------------------------------------------
+;;; (tinydebian-bts-parse-string-1 "Bug#353353: RFP: appweb -- very ...")
+;;; (tinydebian-bts-parse-string-1 "Bug#352429: marked as done (ITA: cdrdao -- records CDs in Disk-At-Once (DAO) mode)")
+;;; (tinydebian-bts-parse-string-1 "Bug#351502: fixed in nvu 1.0final-1")
+;;; (tinydebian-bts-parse-string-1 "Bug#352533: Fixed in NMU of sa-exim 4.2-3")
+;;; (tinydebian-bts-parse-string-1 "Bug#244582: UFO:AI is back")
+;;; (tinydebian-bts-parse-string-1 "")
+;;; (tinydebian-bts-parse-string-1 "")
+(defun tinydebian-bts-parse-string-1 (str)
+ "Parse STR and Return '(bug type package description)."
+ (when (stringp str)
+ ;; Treat long "folded" subject like:
+ ;;
+ ;; Subject: Bug#353588 acknowledged by developer (Re: Bug#353588: lintian:
+ ;; [add new rule] check debian/control::Description better ...
+ ;;
+ (setq str
+ (replace-regexp-in-string "[\r\n]+" " " str))
+ (multiple-value-bind (bug type package desc)
+ (tinydebian-bts-parse-string-with-bug str)
+ (when (and (not package)
+ desc)
+ (multiple-value-bind (ret-pkg ret-desc)
+ (tinydebian-bts-parse-string-with-package desc)
+ (setq package ret-pkg
+ desc ret-desc)))
+ (if (and (stringp desc)
+ (string= desc ""))
+ (setq desc nil))
+ (if (and bug desc)
+ (list bug type package desc)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinydebian-bts-parse-string-current-line ()
+ (let ((str (buffer-substring-no-properties
+ (line-beginning-position)
+ (line-end-position))))
+ (tinydebian-bts-parse-string-1 str)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinydebian-bts-parse-string-subject ()
+ (let ((str (mail-fetch-field "Subject")))
+ (when str
+ (tinydebian-bts-parse-string-1 str))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-bug-package-name-current-line ()
+ (let* ((line (buffer-substring-no-properties
+ (line-beginning-position)
+ (line-end-position))))
+ (when line
+ (multiple-value-bind (bug package)
+ (tinydebian-bug-string-parse-wnpp-alert line)
+ package))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun my-debian-bug-package-name-any ()
+ "Search package name."
+ (or (tinydebian-bug-package-name-current-line)
+ (tinydebian-bug-package-name-header-pool)
+ (tinydebian-bug-package-name-header-package)
+ (progn
+ (multiple-value-bind (bug type-orig package description)
+ (tinydebian-bts-parse-string-subject)
+ package))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-gnus-summary-subject ()
+ "In Gnus *Summary* buffer return current subject."
+ (tinydebian-email-gnus-summary-mode-macro
+ (mail-fetch-field "Subject")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun my-tinydebian-subject-any ()
+ "Try to find subject for mail message."
+ (or (tinydebian-gnus-summary-subject)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinydebian-email-subject-type-parse ()
+ "Read BTS Subject and return '(TYPE SUBJECT)"
+ (let* ((subject (mail-fetch-field "Subject")))
+ (when subject
+ ;; Bug#292579: marked as done (RFP: miwm -- MIcroscopic Window
+ (let (type subject bug)
+ (when (string-match "\\(?: (?\\)\\([a-z]+\\):\\(.*\\)" subject)
+ (setq type (match-string 1 subject)
+ subject (match-string 2 subject)))
+ (setq bug
+ (tinydebian-bug-nbr-string subject))
+ (list type subject bug)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-browse-url-browse-url (url &rest args)
+ "Call `browse-url' and ignore ARGS."
+ (browse-url url))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-browse-url-lisp-only (url &optional bug)
+ "Open HTTP connection to URL and read result.
+ If BUG is set, then read specific BUG page and create buffer for it.
+ If buffer already exists, do nothing."
+ (ti::process-http-request url (not 'port) (not 'timeout)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-browse-url-lynx-dump (url &optional mode)
+ "Run lynx(1) with option -dump using URL.
+ Optional MODE is hint to activate `tinydebian-bts-mode' on text buffer"
+ ;; For fast lookup, record the binary's full path
+ (unless (get 'tinydebian-browse-url-lynx-dump 'done)
+ (put 'tinydebian-browse-url-lynx-dump 'done t)
+ (put 'tinydebian-browse-url-lynx-dump 'program (executable-find "lynx")))
+ (let ((path (get 'tinydebian-browse-url-lynx-dump 'program)))
+ (if (not path)
+ (error "TinyDebian: [ERROR] `lynx' not found in PATH for %s" url)
+ (tinydebian-with-buffer-macro tinydebian-:buffer-www
+ (message "TinyDebian: Wait, accessing %s" url)
+ (tinydebian-call-process path nil "-dump" url)
+ (when mode
+ (turn-on-tinydebian-bts-mode)
+ (let ((font (tinydebian-url-page-font-lock-keywords mode)))
+ (when (and font
+ (or tinydebian-:font-lock-mode
+ global-font-lock-mode))
+ (setq font-lock-keywords font)
+ (font-lock-mode 1))))
+ (goto-char (point-min))
+ (display-buffer (current-buffer))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-browse-url-1 (url &optional mode)
+ "Call `tinydebian-:browse-url-function' with URL.
+ Optional MODE is hint to activate `tinydebian-bts-mode' on result buffer."
+ (if tinydebian-:browse-url-function
+ (funcall tinydebian-:browse-url-function url mode)
+ (tinydebian-browse-url-browse-url url)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-bug-browse-url-by-bug (bug &optional file)
+ "Browse by BUG number. Optionally save bug report to FILE.
+ A prefix argument in interactive mode prompts for FILE to save."
+ (interactive
+ (let* ((prev (get 'tinydebian-bug-browse-url-by-bug 'file))
+ (dir (if prev
+ (file-name-directory prev)))
+ (nbr (read-string "Browse URL by bug number: "
+ (tinydebian-bug-nbr-search)))
+ (name (if current-prefix-arg
+ (read-file-name
+ (format "Save bug %s to file: " nbr)
+ dir
+ nil
+ nil
+ (format "%s.txt" nbr)))))
+ (put 'tinydebian-bug-browse-url-by-bug 'file name)
+ (list nbr name)))
+ (when (or (not (stringp bug))
+ (not (string-match "^[0-9]+$" bug)))
+ (error "TinyDebian: Invalid bug number `%s'." bug))
+ (let ((tinydebian-:browse-url-function tinydebian-:browse-url-function))
+ (if file
+ (setq tinydebian-:browse-url-function
+ (function tinydebian-browse-url-lynx-dump)))
+ (tinydebian-browse-url-1
+ (format "http://bugs.debian.org/%s"
+ (if (numberp bug)
+ (int-to-string bug)
+ bug)))
+ (if file
+ (with-current-buffer (get-buffer tinydebian-:buffer-www)
+ (write-region (point-min) (point-max) file)
+ (if (interactive-p)
+ (message "Wrote %s" file))
+ file)
+ tinydebian-:buffer-www)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinydebian-bug-buffer-name (bug)
+ (or bug
+ (error "TinyDebian: BUG argument is empty"))
+ (format tinydebian-:buffer-bug-format bug))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinydebian-url-debian-bugs (string)
+ "Return bugs URL."
+ (format "%s/%s" tinydebian-:url-http-package-bugs string))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-bug-buffer-or-retrieve (bug)
+ "Return buffer for BUG or send HTTP request to read bug.
+ Return:
+ buffer name"
+ (or bug
+ (error "TinyDebian: BUG argument is empty"))
+ (let* ((name (tinydebian-bug-buffer-name bug))
+ (buffer (get-buffer name))
+ (url (tinydebian-url-debian-bugs bug)))
+ (if buffer
+ buffer
+ (setq buffer (get-buffer-create name))
+ (ti::process-http-request url (not 'port) (not 'timeout) buffer)
+ buffer)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-bug-browse-url-by-package-name (package)
+ "Jump to PACKAGE description."
+ (interactive
+ (list (read-string "Browse desription URL by package name: "
+ (my-debian-bug-package-name-any))))
+ (when (or (not (stringp package))
+ (not (string-match "[a-z]" package)))
+ (error "TinyDebian: Invalid package name `%s'." package))
+ (tinydebian-browse-url-1
+ (tinydebian-packages-browse-url-compose package)
+ package))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-bug-browse-url-by-package-bugs (package)
+ "Jump to PACKAGE description."
+ (interactive
+ (list (read-string "Browse bugs URL by package name: "
+ (my-debian-bug-package-name-any))))
+ (when (or (not (stringp package))
+ (not (string-match "[a-z]" package)))
+ (error "TinyDebian: Invalid package name `%s'." package))
+ (tinydebian-browse-url-1
+ (tinydebian-url-debian-bugs package)
+ package))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-command-show-wnpp-alert-format ()
+ "Convert lines to more readable format from current point.
+
+ Original:
+
+ RFH 354176 cvs -- Concurrent Versions System
+ O 367169 directvnc -- VNC client using the framebuffer as display
+
+ After formatting:
+
+ RFH 354176 cvs -- Concurrent Versions System
+ O 367169 directvnc -- VNC client using the framebuffer as display"
+ (let ((re (concat
+ "\\([a-z]+\\) +\\([0-9]+\\) +\\([^ \t\r\n]+\\)"
+ " +-- +\\(.*\\)")))
+ (while (re-search-forward re nil t)
+ (replace-match (format "%-3s %d %-12s -- %s"
+ (match-string 1)
+ (match-string 2)
+ (match-string 3)
+ (match-string 4))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-command-show-wnpp-alert ()
+ "Check for installed packages up for adoption or orphaned.
+ Requires that program wnpp-alert(1) has been installed."
+ (interactive)
+ (let* ((bin "wnpp-alert")
+ (path (executable-find bin)))
+ (cond
+ ((not bin)
+ (message "TinyDebian: [ERROR] program `%s' is not installed."
+ bin))
+ (t
+ (tinydebian-with-buffer-macro tinydebian-:buffer-wnpp-alert
+ (message "TinyDebian: wait, running %s..." path)
+ (tinydebian-call-process path)
+ (message "TinyDebian: wait, running %s... Done." path)
+ (goto-char (point-min))
+ (save-excursion
+ (tinydebian-command-show-wnpp-alert))
+ (turn-on-tinydebian-bts-mode)
+ (display-buffer buffer)
+ buffer)))))
+
+;;}}}
+;;{{{ BTS URL pages
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinydebian-with-url-page-type-macro 'edebug-form-spec '(body))
+(put 'tinydebian-with-url-page-type-macro 'lisp-indent-function 1)
+(defmacro tinydebian-with-url-page-type-macro (page-type &rest body)
+ "Retrieve PAGE-TYPE from `tinydebian-:url-debian-page-alist' and run BODY.
+ Variable `page'is bound to the retrieved value.
+ Signal error if PAGE-TYPE is not found."
+ `(let ((page (assoc ,page-type tinydebian-:url-debian-page-alist)))
+ (unless page
+ (error "TinyDebian: unknown page-typpe `%s'" ,page-type))
+ ,@body))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinydebian-url-page-compose (page-type)
+ "Return URL location of PAGE-TYPE."
+ (tinydebian-with-url-page-type-macro page-type (nth 1 page)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinydebian-url-page-font-lock-keywords (page-type)
+ "Return `font-lock-keywords' of PAGE-TYPE."
+ (tinydebian-with-url-page-type-macro page-type (nth 2 page)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinydebian-url-debian-mentors-url (package &optional section)
+ "Return PACKAGE URL to mentors.debian.net in optional SECTION (def. main)."
+ (let* ((first-char (substring package 0 1)))
+ (format "%s/%s/%s/%s"
+ (tinydebian-url-page-compose 'mentors-pkg-pool)
+ (or section "main")
+ first-char
+ package)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-url-debian-browse-url (page-type &optional mode)
+ "Browse Debian pages.
+ Optional MODE is hint to activate `tinydebian-bts-mode' on result buffer."
+ (let ((url (tinydebian-url-page-compose page-type)))
+ (unless url
+ (error "TinyDebian: Unknown URL request `%s'." page-type))
+ (cond
+ ((and (tinydebian-string-p url)
+ (string-match "^/" url))
+ (when (and (string-match "z$" url)
+ (null auto-compression-mode))
+ (auto-compression-mode 1))
+ (if (file-exists-p url)
+ (find-file-other-window url)
+ (error "TinyDebian: need 'apt-get install ...' (not found %s)"
+ url)))
+ ((string-match ":" url)
+ (tinydebian-browse-url-1 url mode)))
+ (t
+ (error "TinyDebian: browse internal error `%s' `%s' `%s'"
+ page-type mode url))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-url-bts-ctrl-page ()
+ "Browse BTS control page."
+ (interactive)
+ (tinydebian-url-debian-browse-url 'bts-control))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-url-policy-new-maintainer-guide ()
+ "Browse Debian New Maintainers' Guide."
+ (interactive)
+ (tinydebian-url-debian-browse-url 'newmaint-guide))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-url-policy-best-practises ()
+ "Browse Debian Developer's Reference Chapter 6 - Best Packaging Practices."
+ (interactive)
+ (tinydebian-url-debian-browse-url 'best-practices))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-url-policy-developers-reference (&optional text-file)
+ "Browse Debian Developer's Reference.
+ Optionally use TEXT-FILE from /usr/share/doc if found."
+ (interactive "P")
+ (tinydebian-url-debian-browse-url
+ (if text-file
+ 'developers-reference-text
+ 'developers-reference)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-url-policy-manual (&optional text-file)
+ "Browse policy manual page.
+ Optionally use TEXT-FILE from /usr/share/doc if found."
+ (interactive "P")
+ (tinydebian-url-debian-browse-url
+ (if text-file
+ 'policy-text
+ 'policy)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-url-policy-best-practises ()
+ "Browse policy manual page: best practises section."
+ (interactive)
+ (tinydebian-url-debian-browse-url 'best-practises))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-url-list-bugs-by-rc ()
+ "Browse release critical bugs."
+ (interactive)
+ (tinydebian-url-debian-browse-url 'bugs-rc 'bugs-rc))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-url-list-package-debcheck (package &optional distribution)
+ "Check package for debcheck problems.
+ Optionally from DISTRIBUTION which defaults to `testing'."
+ (interactive
+ (list
+ (read-string "Debcheck package: ")
+ (completing-read "Distribution: "
+ '(("stable" . 1)
+ ("testing" . 1)
+ ("unstable" . 1)
+ ("experimental" . 1))
+ (not 'predicate)
+ (not 'require-match))))
+ (when (and (stringp package)
+ (not (string= "" package)))
+ (tinydebian-url-debian-browse-url-1
+ (format (tinydebian-url-page-compose 'debcheck-package)
+ (or distribution "testing")
+ package))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-url-list-qa-developer-status (email)
+ "Browse QA developer status information by EMAIL address."
+ (interactive
+ (list (read-string "[QA status] developer's email address: "
+ (tinydebian-email-search))))
+ (tinydebian-string-p
+ email
+ (format "[ERROR] email is missing from input [%s]" email))
+ (tinydebian-browse-url-1
+ (format "%slogin=%s" (tinydebian-url-page-compose 'qa-developer-status) email)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-url-list-qa-developer-bugs (email)
+ "Browse QA developer bugs information by EMAIL address."
+ (interactive
+ (list (read-string "[QA bugs] developer's email address:"
+ (tinydebian-email-search))))
+ (tinydebian-string-p
+ email
+ (format "[ERROR] email is missing from input [%s]" email))
+ (tinydebian-browse-url-1
+ (format "%ssubmitter=%s" (tinydebian-url-page-compose 'qa-developer-bugs) email)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-url-list-dsfg-license-faq ()
+ "Browse DFSG FAQ about Licenses."
+ (interactive)
+ (tinydebian-browse-url-1 (tinydebian-url-page-compose 'dfsg-license-faq)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-url-list-base-files-faq ()
+ "Browse base-files FAQ."
+ (interactive)
+ (tinydebian-browse-url-1 (tinydebian-url-page-compose 'base-files-faq)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-url-list-package-by-filename (filename &optional arch)
+ "Package content search by FILENAME and optional ARCH."
+ (interactive
+ (let ((name (read-string "[Pkg search] filename: "))
+ (arch (read-string "[Pkg search] architecture [RET=all]: ")))
+ (list name arch)))
+ (tinydebian-string-p
+ filename
+ (format "[ERROR] filename is missing from input [%s]" filename))
+ ;; http://packages.debian.org/cgi-bin/search_contents.pl?word=svn_load_dirs&searchmode=searchfiles&case=insensitive&version=stable&arch=i386
+ (tinydebian-browse-url-1
+ (format "%s%s&word=%s"
+ (tinydebian-url-page-compose 'pkg-search-files)
+ (if (tinydebian-string-p arch)
+ (format "&arch=%s" arch)
+ "")
+ filename)))
+
+(defun tinydebian-grep-find-debian-devel (regexp grep-opt)
+ "Grep REGEXP from all ddevelopment text files (policy etc.)"
+ (interactive "sRegexp: \nsGrep opt (no single quotes): ")
+ (let ((path-list (mapconcat
+ 'concat
+ (delq nil
+ tinydebian-:grep-find-devel-docdir-list)
+ " "))
+ cmd)
+ (setq cmd
+ (format
+ (concat
+ "find %s -type f -name '*.txt.gz' -print0 "
+ "| xargs -0 -e zgrep -n %s '%s'")
+ path-list
+ grep-opt
+ regexp))
+ (grep-find cmd)))
+
+;;}}}
+;;{{{ WNPP URLs
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinydebian-url-wnpp-compose (page-type)
+ "Return URL to search"
+ (let ((page (assoc page-type tinydebian-:url-http-wnpp-page-alist)))
+ (unless page
+ (error "TinyDebian: unknow page-typpe `%s'" page-type))
+ (format "%s/%s" tinydebian-:url-http-wnpp-page-main (cdr page))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinydebian-url-usertag-compose (tag)
+ "Return URL to search"
+ (format "%s/usertag:%s" tinydebian-:url-http-debian-www tag))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinydebian-url-wnpp-browse-url (page-type)
+ "Browse WNPP PAGE-TYPE."
+ (tinydebian-browse-url-1 (tinydebian-url-wnpp-compose page-type)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-url-list-bugs-by-usertag (usertag)
+ "Browse by USERTAG."
+ (interactive "sUsertag to search: ")
+ (tinydebian-string-p
+ usertag
+ (format "[ERROR] usertag is missing from input [%s]" usertag))
+ (tinydebian-browse-url-1 (tinydebian-url-usertag-compose usertag)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-url-list-wnpp-itp ()
+ "Browse WNPP ITP page."
+ (interactive)
+ (tinydebian-url-wnpp-browse-url "ITP"))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-url-list-wnpp-rfp ()
+ "Browse WNPP RFP page."
+ (interactive)
+ (tinydebian-url-wnpp-browse-url "RFP"))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-url-list-wnpp-rfh ()
+ "Browse WNPP RFH page."
+ (interactive)
+ (tinydebian-url-wnpp-browse-url "RFH"))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-url-list-wnpp-rfa ()
+ "Browse WNPP RFA page."
+ (interactive)
+ (tinydebian-url-wnpp-browse-url "RFA"))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-url-list-wnpp-orphaned ()
+ "Browse WNPP orphaned page."
+ (interactive)
+ (tinydebian-url-wnpp-browse-url "O"))
+
+;;}}}
+;;{{{ BTS functions: Debian Developer interface to bug tracking system
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-bts-insert-headers ()
+ "Insert tinydebian-:bts-extra-headers' to mail buffer."
+ (let ((headers tinydebian-:bts-extra-headers))
+ (when (stringp headers)
+ (save-excursion
+ (goto-char (point-min))
+ (when (search-forward mail-header-separator nil t)
+ (forward-line 0)
+ (insert headers))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinydebian-bts-mail-compose-macro 'edebug-form-spec '(body))
+(put 'tinydebian-bts-mail-compose-macro 'lisp-indent-function 5)
+(defmacro tinydebian-bts-mail-compose-macro
+ (bug type package subject email &rest body)
+ "Compose mail with SUBJECT and run BODY."
+ (let ((name (gensym "name-")))
+ `(let ((,name (format "*Mail Debian BTS %s*"
+ (cond
+ ((and ,bug ,type ,package)
+ (format "%s %s %s"
+ ,type ,package ,bug))
+ ((and ,bug ,package)
+ (format "%s %s"
+ ,package ,bug))
+ (t
+ (or ,bug
+ ,subject
+ ""))))))
+ (pop-to-buffer (get-buffer-create ,name))
+ (erase-buffer)
+ (mail-setup
+ (if ,email
+ ,email
+ (tinydebian-bts-email-compose "control"))
+ ,subject
+ nil
+ nil
+ nil
+ nil)
+ (cond
+ ((or (featurep 'message)
+ (eq mail-user-agent 'message-user-agent))
+ (message-mode))
+ (t
+ (mail-mode)))
+ (tinydebian-bts-insert-headers)
+ ,@body)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinydebian-bts-mail-type-macro 'edebug-form-spec '(body))
+(put 'tinydebian-bts-mail-type-macro 'lisp-indent-function 4)
+(defmacro tinydebian-bts-mail-type-macro (type pkg email subject &rest body)
+ "Compose a TYPE request and run BODY.
+Variables available: bugnbr, type-orig, package, description; but these
+can all be nil."
+ (let ((subj (gensym "subject-")))
+ `(multiple-value-bind (bugnbr type-orig package description)
+ (or (tinydebian-bts-parse-string-current-line)
+ (tinydebian-bts-parse-string-subject))
+ (if (stringp ,pkg) ;; Use input argument
+ (setq package ,pkg))
+ (let ((,subj (or ,subject
+ (if ,type
+ (format "%s: %s%s"
+ ,type
+ (if package
+ (format "%s -- " package)
+ "")
+ (or description ""))
+ ""))))
+ (tinydebian-bts-mail-compose-macro
+ bugnbr
+ ,type
+ package
+ ,subj
+ ,email
+ (goto-char (point-max))
+ ,@body)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinydebian-bts-mail-ask-bug-number (&optional type)
+ "Ask bug number. Return as '(bug) suitable for interactive"
+ (read-string
+ (format "Debian BTS %sbug number: "
+ (if type
+ (concat type " ")
+ ""))
+ (tinydebian-bug-nbr-any)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-bts-mail-type-ita (bug)
+ "Send an ITA request."
+ (interactive (list (tinydebian-bts-mail-ask-bug-number "ITA")))
+ (tinydebian-bts-mail-type-macro "ITA" nil nil nil
+ (insert
+ (format "\
+ retitle %s %s
+ owner %s !
+ thanks
+ "
+ bug
+ (concat "ITA: "
+ (if package
+ (format "%s -- " package)
+ "")
+ (or description ""))
+ bug))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-bts-mail-type-itp (bug)
+ "Reposnd to RFP with an ITP request."
+ (interactive
+ (list (tinydebian-bts-mail-ask-bug-number "ITP response to RFP")))
+ (tinydebian-bts-mail-type-macro "ITP" nil nil nil
+ (insert
+ (format "\
+ retitle %s %s
+ owner %s !
+ thanks
+ "
+ bug
+ (concat "ITP: "
+ (if package
+ (format "%s -- " package)
+ "")
+ (or description ""))
+ bug))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-bts-mail-type-reply (bug)
+ "Reply to bug found at current point or line"
+ (interactive (list (tinydebian-bts-mail-ask-bug-number "Reply to bug")))
+ (let ((subject (my-tinydebian-subject-any)))
+ (tinydebian-bts-mail-compose-macro
+ bug
+ "reply"
+ "bug"
+ subject
+ (tinydebian-bts-email-compose bug)
+ (mail-position-on-field "CC")
+ (insert (tinydebian-bts-email-compose (format "%s-submitter" bug)))
+ (goto-char (point-max))
+ nil)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-bts-mail-type-orphan (package license homepage desc)
+ "Send an orphan request."
+ (interactive)
+ (message "tinydebian-bts-mail-type-orphan not yet implemented."))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-pkg-read-details-directory (directory)
+ "Assuming a simgle debian package is in DIRECTORY, extract details.
+ The directory should contain files:
+ -rw-r--r-- 1 jaalto jaalto 19885 2006-11-19 18:12 pkg_0.2.4-4.diff.gz
+ -rw-r--r-- 1 jaalto jaalto 605 2006-11-19 18:12 pkg_0.2.4-4.dsc
+ -rw-r--r-- 1 jaalto jaalto 1106 2006-11-19 18:12 pkg_0.2.4-4_i386.changes
+ -rw-r--r-- 1 jaalto jaalto 122188 2006-11-19 18:12 pkg_0.2.4-4_i386.deb
+ -rw-r--r-- 1 jaalto jaalto 339 2006-11-19 18:12 pkg_0.2.4-4_i386.upload
+ -rw-r--r-- 1 jaalto jaalto 942 2006-11-19 18:12 pkg_0.2.4-4_source.changes
+ -rw-r--r-- 1 jaalto jaalto 246864 2006-11-19 18:12 pkg_0.2.4.orig.tar.gz
+
+ RETURN:
+ ((pkg-name . \"pkg\")
+ (pkg-ver-major . \"0.2.4\")
+ (pkg-ver-minor . \"4\")
+ (dsc . \"pkg_0.2.4-4.dsc\")
+ (deb . \"pkg_0.2.4-4.dsc\")
+ "
+ (let* ()))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-bts-mail-type-rfs (package license bug desc)
+ "Send an RFS request: PACKAGE name, package LICENCE and BUG and DESC.
+ The DESC is short one line description string use in Subject."
+ (interactive
+ (let* ((name (read-string
+ "RFP package name [required; lowercase]: ")) ;
+ (license (tinydebian-read-license "License [required]: "))
+ (bug (read-string
+ "ITA/ITP bug number [required]: "))
+ (desc (read-string
+ "One line description [required]: ")))
+ (list name license bug desc)))
+ (flet ((replace (regexp str &optional point all)
+ (when (and (stringp str)
+ (not (string= "" str)))
+ (goto-char (or point
+ (point-min)))
+ (if all
+ (while (re-search-forward regexp nil t)
+ (replace-match str 'literal nil nil 1))
+ (if (re-search-forward regexp nil t)
+ (replace-match str 'literal nil nil 1))))))
+ (let* ((arg-pkg package) ;; Due to macro which reserves var `package'.
+ (mentors-url (tinydebian-url-debian-mentors-url package))
+ (ita-url (tinydebian-url-debian-bugs bug))
+ (pkg-url (tinydebian-url-debian-bugs package)))
+ (tinydebian-bts-mail-type-macro "RFS"
+ arg-pkg (tinydebian-list-email-compose "debian-mentors") nil
+ (insert tinydebian-:rfs-template)
+ (replace "\\(<package>.*\\)" package nil 'all)
+ (replace "\\(<bugs:.*\\)" pkg-url)
+ (replace "\\(<ita:.*\\)" ita-url)
+ (replace "\\(<mentors:.*\\)" mentors-url)
+ (replace "\\(<license:.*\\)" license)
+ (mail-position-on-field "Subject")
+ (beginning-of-line)
+ (replace ": \\(.*\\)"
+ (format "RFS: %s -- %s" package desc)
+ (point))
+ (goto-char (point-max))
+ (run-hooks 'tinydebian-:rfs-hook)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-bts-mail-type-rfp (package license homepage desc)
+ "Send an ITP request."
+ (interactive
+ (let* ((name (read-string
+ "RFP package name [required; lowercase]: "))
+ (desc (read-string
+ "Package description [required]: "))
+ (license (completing-read
+ "License [required]: "
+ (mapcar (lambda (x)
+ (cons x 1))
+ tinydebian-:wnpp-template-licenses-alist)))
+ (url (read-string
+ "Project homepage URL [required]: ")))
+ (list name license url desc)))
+ (flet ((replace (regexp str &optional point all)
+ (when (and (stringp str)
+ (not (string= "" str)))
+ (goto-char (or point
+ (point-min)))
+ (if all
+ (while (re-search-forward regexp nil t)
+ (replace-match str 'literal nil nil 1))
+ (if (re-search-forward regexp nil t)
+ (replace-match str 'literal nil nil 1))))))
+ (let ((arg-pkg package)) ;; Due to macro which reserves var `package'.
+ (tinydebian-bts-mail-type-macro "ITP"
+ arg-pkg (tinydebian-bts-email-submit) nil
+ (insert tinydebian-:rfp-template)
+ (replace "\\(<package>.*\\)" package nil 'all)
+ (replace "\\(<homepage:.*\\)" homepage)
+ (replace "\\(<license:.*\\)" license)
+ (replace "\\(<short desc>.*\\)" desc)
+ (mail-position-on-field "Subject")
+ (beginning-of-line)
+ (replace ": \\(.*\\)"
+ (format "RFP: %s -- %s" package desc)
+ (point))
+ (goto-char (point-max))
+ (run-hooks 'tinydebian-:rfp-hook)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-bts-mail-ctrl-severity (bug severity)
+ "Compose BTS control message to a BUG and chnage SEVERITY."
+ (interactive
+ (list (tinydebian-bts-mail-ask-bug-number)
+ (completing-read
+ "BTS severity: "
+ tinydebian-:severity-list
+ nil
+ 'match)))
+ (tinydebian-bts-mail-type-macro
+ nil nil nil
+ (format "Bug#%s Change of severity / %s" bug severity)
+ (insert
+ (format "\
+severity %s %s
+thanks
+
+"
+ bug
+ severity))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-bts-mail-ctrl-usertag (bug &optional tag-string)
+ "Compose BTS control message usertag to a BUG with TAG-STRING."
+ (interactive
+ (let ((bug (tinydebian-bts-mail-ask-bug-number)))))
+ (tinydebian-bts-mail-type-macro
+ nil nil nil
+ (format "Bug#%s change of usertag %s" bug (or tag-string ""))
+ (insert
+ (format "\
+usertag %s +
+thanks
+"
+ bug))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-bts-mail-ctrl-tags (bug tag-string)
+ "Compose BTS control message to a BUG with TAG-STRING."
+ (interactive
+ (let ((bug (tinydebian-bts-mail-ask-bug-number))
+ tag
+ list)
+ (while (or (null tag)
+ (not (string= "" tag)))
+ (setq tag (completing-read
+ "BTS tag [RET when done]: "
+ tinydebian-:tags-list
+ nil
+ 'match))
+ (unless (string= "" tag)
+ (push tag list)))
+ (list bug
+ (mapconcat 'concat list " "))))
+ (tinydebian-bts-mail-type-macro
+ nil nil nil
+ (format "Bug#%s change of tags / %s" bug tag-string)
+ (insert
+ (format "\
+tags %s + %s
+thanks
+
+"
+ bug
+ tag-string))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-bts-mail-ctrl-reassign (bug &optional package)
+ "Compose BTS control message to a BUG amd reassign PACKAGE."
+ (interactive
+ (list (tinydebian-bts-mail-ask-bug-number)
+ (read-string "Reassign to package: ")))
+ (tinydebian-bts-mail-type-macro
+ nil nil nil
+ (format "Bug#%s%s reassign " bug (if package
+ (format " to package %s"
+ package)
+ ""))
+ (insert
+ (format "\
+reassign %s %s
+thanks
+
+"
+ bug
+ (if (and package
+ (not (string= "" package)))
+ package
+ "<to-package>")))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-bts-mail-ctrl-retitle (bug title)
+ "Compose BTS control message to a BUG and change TITLE."
+ (interactive
+ (list (tinydebian-bts-mail-ask-bug-number)
+ (read-string "New title: ")))
+ (tinydebian-bts-mail-type-macro
+ nil nil nil
+ (format "Reassign Bug#%s" bug)
+ (insert
+ (format "\
+retitle %s %s
+thanks
+
+"
+ bug
+ title))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-bts-mail-ctrl-reopen (bug)
+ "Compose BTS control message a BUG and reopen it."
+ (interactive
+ (list (tinydebian-bts-mail-ask-bug-number)))
+ (tinydebian-bts-mail-type-macro
+ nil nil nil
+ (format "Reopen Bug#%s" bug)
+ (insert
+ (format "\
+reopen %s !
+thanks
+
+"
+ bug))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-bts-mail-ctrl-close (bug &optional package version)
+ "Compose BTS control message to close BUG.
+Optional PACAGE name and VERSION number can be supplied."
+ (interactive
+ (let ((bug (tinydebian-bts-mail-ask-bug-number))
+ (package (read-string "Package name [RET=ignore]: "))
+ version)
+ (if (tinydebian-string-p package)
+ (setq version (read-string "Version: "))
+ (setq package nil))
+ (list bug
+ package
+ (if (tinydebian-string-p version)
+ version
+ nil))))
+ (let* ((email (tinydebian-bts-email-compose (format "%s-done" bug)))
+ (pkg package))
+ (tinydebian-bts-mail-type-macro
+ nil
+ pkg
+ email
+ (format "Bug#%s Close" bug)
+ (insert
+ (if (not (stringp package))
+ ""
+ (format "\
+Package: %s
+Version: %s
+"
+ package
+ (or version "")))
+ "\nReason for close:\n"))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-bts-mail-ctrl-forward-upstream (bug)
+ "Compose BTS control message: forward BUG report to upstream."
+ (let* ((email-forward (tinydebian-bts-email-compose
+ (format "%s-forwarded" bug)))
+ (email-bug (tinydebian-bts-email-compose bug)))
+ (tinydebian-bts-mail-type-macro
+ nil nil "<upstream address>"
+ (format "Debian Bug#%s -- forwarded upstream" bug)
+ (mail-position-on-field "Cc")
+ (insert (format "%s, %s" email-forward email-bug))
+ (goto-char (point-max))
+ (insert
+ (format "\
+\[Please keep the CC]
+
+")))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-bts-mail-ctrl-forward-bts (bug)
+ "Compose BTS forwarded control message to BTS."
+ (tinydebian-bts-mail-type-macro
+ nil nil nil
+ (format "Debian Bug#%s -- forwarded upstream" bug)
+ (insert
+ (format "\
+forwarded %s <http://upstream.example.com/bug-tracking/nbr>
+thanks
+
+"
+ bug))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-bts-mail-ctrl-forward-main (bug &optional control-message)
+ "Compose BTS control message: forward BUG report to upstream.
+If optional CONTROL-MESSAGE is non-nil, then compose regular BTS control
+message which can be used to record upstream's bug tracking system URL."
+ (interactive
+ (list (tinydebian-bts-mail-ask-bug-number)
+ current-prefix-arg))
+ (if control-message
+ (tinydebian-bts-mail-ctrl-forward-bts bug)
+ (tinydebian-bts-mail-ctrl-forward-upstream bug)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-bts-mail-message-info (bug &optional quiet)
+ "Send more information to BUG, possibly with QUIET on.
+With QUIET, the email will only be archived, sent to package maintainer
+and not forwarded any Debian mailing lists."
+ (interactive
+ (list (tinydebian-bts-mail-ask-bug-number)
+ current-prefix-arg))
+ (let* ((email (tinydebian-bts-email-compose
+ (if quiet
+ (format "%s-maintonly" bug)
+ bug))))
+ (tinydebian-bts-mail-type-macro
+ nil nil email
+ (format "Debian Bug#%s " bug))))
+
+;;}}}
+;;{{{ Dpkg, apt functions
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-package-read-field-content-1 ()
+ "Read content. Point must be positionioned at Field:-!-."
+ (let* ((str (if (looking-at " +\\(.*\\)")
+ (match-string 1))))
+ (while (and (not (eobp))
+ (zerop (forward-line 1)) ;; Did it
+ (looking-at "^\\( +.*\\)"))
+ (setq str (concat (or str "") (match-string 1))))
+ str))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-package-read-field-content (&optional field)
+ "Read FIELD forward. FIELD ust be name like `Package'.
+Be sure to call `tinydebian-package-narrow-to-region' first."
+ (when (re-search-forward (format "^%s:" field) nil t)
+ (tinydebian-package-read-field-content-1)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-package-parse-info-all ()
+ "Parse all fields forward. Return '((field . info) (field . info) ..)."
+ (let* (field
+ alist)
+ (while (re-search-forward "^\\([^ \t\r\n]+\\):" nil t)
+ (setq field (match-string 1))
+ (push (cons field (tinydebian-package-read-field-content-1))
+ alist))
+ (nreverse alist)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-package-info-from-buffer (buffer)
+ "Parse dpkg -s from BUFFER. Buffer must contain nothing else."
+ (with-current-buffer buffer
+ (goto-char (point-min))
+ (tinydebian-package-parse-info-all)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-package-status-parse-depends-1 ()
+ "Parse `Depends' field content from current point forward.
+There must nothing else in the buffer."
+ (let* (name
+ op
+ ver
+ list)
+ (while (re-search-forward "\\([a-z][^ ,()\t\r\n]+\\)" nil t)
+ (setq name (ti::remove-properties (match-string 1))
+ op nil
+ ver nil)
+ (cond
+ ((looking-at " +(\\([=><]+\\) +\\([^ ,()\t\r\n]+\\))")
+ (setq op (ti::remove-properties (match-string 1))
+ ver (ti::remove-properties (match-string 2))))
+ ((looking-at " *,?")))
+ (goto-char (match-end 0))
+ (push (list name op ver) list))
+ (nreverse list)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-package-status-parse-depends (depends)
+ "Parse `Depends' field from DEPENDS string.
+Example of the DEPENDS string:
+
+ \"libc6 (>= 2.2.4-2), cron (>= 3.0pl1-42)\"
+
+Returned list is
+
+ '((\"libc6\" \">=\" \"2.2.4-2\")
+ (\"cron\" \">=\" \"3.0pl1-42\"))."
+ (with-temp-buffer
+ (insert depends)
+ (ti::pmin)
+ (tinydebian-package-status-parse-depends-1)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;; #todo:
+(defun tinydebian-package-status-apt-file (package)
+ "Use apt-file PACKAGE (must be installed separately) to find upstream."
+ (let* ((bin (executable-find "apt-file")))
+ (cond
+ ((null bin)
+ (message "TinyDebian: no `apt-fil' found along PATH (emacs `exec-path').")
+ (message "TinyDebian: Please run 'apt-get install apt-file'")
+ nil)
+ nil)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;; Package: autolog
+;;; Status: install ok installed
+;;; Priority: extra
+;;; Section: admin
+;;; Installed-Size: 45
+;;; Maintainer: Nicolás Lichtmaier <nick@debian.org>
+;;; Version: 0.35-10
+;;; Depends: libc6 (>= 2.2.4-2), cron (>= 3.0pl1-42)
+;;; Recommends: mail-transport-agent
+;;; Conffiles:
+;;; /etc/autolog.conf a3fcae584ed74543a4a943e722593ff6
+;;; /etc/cron.d/autolog 805d268ea44c645299defc1c14495282
+;;; Description: Terminates connections for idle users
+;;; Autolog terminates connections considered to be idle based on a large
+;;; variety of parameters.
+;;;
+(defun tinydebian-package-status-dpkg-s (package)
+ "Consult dpkg -s PACKAGE"
+ (let* ((dpkg tinydebian-:bin-dpkg))
+ (cond
+ ((not dpkg)
+ (message "TinyDebian: no `dpkg' found along PATH (emacs `exec-path').")
+ nil)
+ (t
+ (with-temp-buffer
+ (message "TinyDebian: Running ... dpkg -s %s" package)
+ (tinydebian-call-process dpkg nil "-s" package)
+ (ti::pmin)
+ (when (re-search-forward "^Use dpkg" nil t)
+ (message "TinyDebian: `dpkg`-s %s' returned error [%s]"
+ package
+ (buffer-string)))
+ (tinydebian-package-parse-info-all))))))
+
+;;; ----------------------------------------------------------------------
+;;; dpkg -S dh_make
+;;;
+;;; debhelper: /usr/bin/dh_makeshlibs
+;;; dh-make: /usr/share/debhelper/dh_make/debian/postrm.ex
+;;; dh-make: /usr/share/debhelper/dh_make/native
+;;; dh-make: /usr/share/debhelper/dh_make/debian/changelog
+;;; dh-make: /usr/share/debhelper/dh_make/debianl/shlibs.local.ex
+;;; dh-make: /usr/share/man/man1/dh_make.1.gz
+;;; dh-make: /usr/bin/dh_make
+;;; dh-make: /usr/share/debhelper/dh_make/debiank/README.Debian
+;;; dh-make: /usr/share/debhelper/dh_make/debianm/control
+;;; dh-make: /usr/share/debhelper/dh_make/debian/init.d.ex
+;;; dh-make: /usr/share/debhelper/dh_make/debian/cron.d.ex
+;;; dh-make: /usr/share/debhelper/dh_make/debianm/rules
+;;; dh-make: /usr/share/debhelper/dh_make/licenses/lgpl
+;;; dh-make: /usr/share/debhelper/dh_make/debiank/control
+;;; dh-make: /usr/share/debhelper/dh_make/debians/rules
+;;; dh-make: /usr/share/debhelper/dh_make/debianl/package1.dirs
+;;; dh-make: /usr/share/debhelper/dh_make/native/changelog
+;;; dh-make: /usr/share/debhelper/dh_make/licenses/bsd
+;;; dh-make: /usr/share/debhelper/dh_make/debianm/package-doc.files
+;;; dh-make: /usr/share/debhelper/dh_make/debians/watch.ex
+;;; dh-make: /usr/share/debhelper/dh_make/licenses/gpl
+;;; dh-make: /usr/share/debhelper/dh_make/licenses/blank
+;;;
+(defun tinydebian-package-status-dpkg-S-parse (package)
+ "Examine dpkg -S PACKAGE listing and return package name."
+ (ti::pmin)
+ (when (re-search-forward (concat "^\\([^: \t\r\n]+\\):.*/"
+ package
+ "[ \t]*$")
+ nil t)
+ (match-string 1)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-package-status-dpkg-S (file)
+ "Consult dpkg -S FILE
+In this case, the package is unknown."
+ (let* ((dpkg tinydebian-:bin-dpkg))
+ (cond
+ ((not dpkg)
+ (message "TinyDebian: no `dpkg' found along PATH (emacs `exec-path').")
+ nil)
+ (t
+ (with-temp-buffer
+ (message "TinyDebian: Running ... dpkg -S %s (takes a while)" file)
+ (apply 'tinydebian-call-process dpkg nil (list "-S" file))
+ (let ((pkg (tinydebian-package-status-dpkg-S-parse file)))
+ (cond
+ ((null pkg)
+ (message
+ "TinyDebian: dpkg -S doesn't know file `%s'" file)
+ nil)
+ (t
+ (tinydebian-package-status-dpkg-s pkg)))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;
+(defun tinydebian-package-status-apt-cache (package)
+ "Consult dpkg -S FILE
+In this case, the package is unknown."
+ (with-temp-buffer
+ (message "TinyDebian: Running ... apt-cache show %s (takes a while)"
+ package)
+ (apply 'tinydebian-call-process "apt-cache" nil (list "show" package))
+ (message "Done.")
+ (unless (eq (point-max) (point-min))
+ (goto-char (point-min))
+ (tinydebian-package-parse-info-all))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;
+(defun tinydebian-package-status-grep-available (package)
+ "Consult grep-available(1) for PACKAGE from 'Provides' field."
+ (let* ((bin tinydebian-:bin-grep-available)
+ (re (format ".*[ ,]+%s([, \t]|[ \t]*$)" package)))
+ (cond
+ ((not bin)
+ (message (concat "TinyDebian: no `grep-available' "
+ "found along PATH (emacs `exec-path')."))
+ nil)
+ (t
+ (with-temp-buffer
+ (message "TinyDebian: Running ... grep-available -e %s" package)
+ (apply 'tinydebian-call-process
+ bin
+ nil
+ (list "--field=Provides"
+ "--eregex"
+ re))
+ (let* ((info (tinydebian-package-info-from-buffer (current-buffer))))
+ (cond
+ ((null info)
+ (message
+ "TinyDebian: grep-available doesn't know package`%s'" package)
+ nil)
+ (t
+ info))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-package-wnpp-main-interactive ()
+ "Ask the type of request for WNPP package.
+References:
+ `tinydebian-:menu-wnpp'
+ `tinydebian-:menu-wnpp-selected'"
+ (setq tinydebian-:menu-wnpp-selected nil)
+ (ti::menu-menu 'tinydebian-:menu-wnpp)
+ tinydebian-:menu-wnpp-selected)
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-buffer-ask-input (message buffer &optional clear)
+ "Write MESSAGE to the buffer ans ask user to type input.
+The MESSAGE should contgain properly formatted text."
+ (let* ((buffer (ti::temp-buffer buffer clear)))))
+ ;; (switch-to-buffer buffer)
+ ;; #todo:
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-package-wnpp-main (request-type)
+ "Submit REQUEST-TYPE against WNPP pseudo package.
+WNPP is used for requesting to be a new Debian maintainer and
+for taking maintenance of other packages. Refer to
+http://www.debian.org/devel/wnpp and
+http://www.debian.org/doc/packaging-manuals/developers-reference/ch-pkgs.en.html
+and topic \"5.1 New Packages\"
+
+REQUEST-TYPE can be symbol:
+
+ 'package 'orphan 'adopt or 'new.
+ See http://www.debian.org/devel/wnpp for more information
+
+References:
+
+ `tinydebian-:menu-wnpp'."
+ (interactive (list (tinydebian-package-wnpp-main-interactive)))
+ (cond
+ ((eq request-type 'package)
+ (call-interactively 'tinydebian-bts-mail-type-itp))
+ ((eq request-type 'new)
+ (call-interactively 'tinydebian-bts-mail-type-rfp))
+ ((eq request-type 'orphan)
+ (call-interactively 'tinydebian-bts-mail-type-orphan))
+ ((eq request-type 'adopt)
+ (call-interactively 'tinydebian-bts-mail-type-ita))
+ (t
+ ;; Nothing to do
+ nil)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-package-status-main (package)
+ "Find out PACKAGE details."
+ (or (tinydebian-package-status-apt-cache package)
+ (tinydebian-package-status-dpkg-s package)
+ (tinydebian-package-status-grep-available package)
+ (tinydebian-package-status-dpkg-S package)
+ (tinydebian-package-status-apt-file package)
+ (if (string-match "^wnpp" package)
+ (error (concat "TinyDebian: package WNPP is special. "
+ "Use tinydebian-package-wnpp-main instead.")))
+ (error "Tinydebian: Can't find package information. `%s'" package)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-package-info (&optional package prompt)
+ "Get PACKAGE information. See`tinydebian-package-status'.
+If PACKAGE is nil and `tinydebian-:bin-dpkg' is not available,
+ask with PROMPT."
+ (let* ((dpkg tinydebian-:bin-dpkg))
+ (or package
+ (setq package (read-string
+ (or prompt
+ "[TinyDebian] Package name: "))))
+ (or (and dpkg
+ (tinydebian-package-status-main package)))))
+ ;; FIXME: todo
+
+;;}}}
+;;{{{ Bug reporting interface
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-bug-system-info-general ()
+ "Return relevant system information."
+ ;; FIXME: todo
+ (interactive))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-bug-system-info-depends (info &optional depend-key)
+ "Return additional Dependency INFO from item `Depends'.
+DEPEND-KEY can be \"Depends\" or \"Pre-Depends\".
+
+Example:
+
+ Versions of packages autolog depends on:
+ ii cron 3.0pl1-72 management of regular background p
+ ii libc6 2.2.5-3 GNU C Library: Shared libraries an."
+ (let* ((depends (cdr-safe (and info
+ (assoc
+ (or depend-key "Depends")
+ info))))
+ str)
+ (when depends
+ (setq str "")
+ (dolist (dep-info
+ (tinydebian-package-status-parse-depends depends))
+ (multiple-value-bind (package op version)
+ dep-info
+ ;; Not used yet, quiet byte compiler
+ (if op
+ (setq op op))
+ (if version
+ (setq version version))
+ (let* (info2
+ desc
+ ver)
+ (setq info2
+ (tinydebian-package-info
+ package
+ (format "\
+\[TinyDebian] Depend. Insert `dpkg -s %s' to *scratch* and press RET: "
+ package)))
+ (setq ver (cdr-safe (assoc "Version" info2)))
+ ;; cut first few characters
+ (when (setq desc (cdr-safe (assoc "Description" info2)))
+ (setq desc (ti::string-left desc 45)))
+ (setq str
+ (concat
+ str
+ (format "%-15s %-15s %s\n" package ver desc)))))))
+ str))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-bug-system-info-os-architecture ()
+ "Read architecture."
+ (if (not tinydebian-:bin-dpkg)
+ ""
+ (with-temp-buffer
+ (tinydebian-call-process
+ tinydebian-:bin-dpkg nil "--print-installation-architecture")
+ (tinydebian-string-delete-newlines
+ (buffer-string)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-bug-system-info-os-version ()
+ "Read Debian version number."
+ (let* ((file "/etc/debian_version")
+ (ret (format "%s not found or readable." file)))
+ (when (and (file-exists-p file)
+ (file-readable-p file))
+ (with-temp-buffer
+ (insert-file-contents-literally file)
+ (setq ret
+ (tinydebian-string-delete-newlines
+ (buffer-string)))))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-bug-system-info-locale ()
+ "Get locale information."
+ (let* ((list
+ '("LC_ALL"
+ "LC_CTYPE"))
+ val
+ ret)
+ (dolist (var list)
+ (when (setq val (getenv var))
+ (setq val (format "%s=%s" var val))
+ (setq ret (if (null ret)
+ val
+ (concat ret ", " val)))))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-bug-system-info-os ()
+ "Return OS information.
+Debian Release: 3.0
+Architecture: i386
+Kernel: Linux terra 2.4.17 #1 Fri Feb 8 21:32:43 EET 2002 i686
+Locale: LANG=en_US, LC_CTYPE=en_US."
+ (let* ((kernel (tinydebian-string-delete-newlines
+ (ti::process-uname)))
+ (architecture (tinydebian-bug-system-info-os-architecture))
+ (release (tinydebian-bug-system-info-os-version))
+ (locale (tinydebian-bug-system-info-locale)))
+ (format "\
+Debian Release: %s
+Architecture: %s
+Kernel: %s
+Locale: %s"
+ release
+ architecture
+ kernel
+ locale)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-bug-severity ()
+ "Select bug severity."
+ (setq tinydebian-:severity-selected nil)
+ (while (null tinydebian-:severity-selected)
+ (ti::menu-menu 'tinydebian-:menu-severity)
+ (unless tinydebian-:severity-selected
+ (message "TinyDebian: Please select severity.")
+ (sit-for 1)))
+ tinydebian-:severity-selected)
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-bug-report-mail-insert-details (info)
+ "Insert Details for apckage INFO into Mail."
+ (ti::mail-text-start 'move)
+ (insert "Package: " (cdr (assoc "Package" info)) "\n")
+ (insert "Version: " (cdr (assoc "Version" info)) "\n")
+ (insert "Severity: " (tinydebian-bug-severity) "\n\n")
+ (let* ((point (point))
+ (depends (tinydebian-bug-system-info-depends info "Depends"))
+ (pre-depends (tinydebian-bug-system-info-depends info "Pre-Depends"))
+ (package (or (and info
+ (cdr (assoc "Package" info)))
+ (error "No package information."))))
+ (insert "\n\n-- System Information\n"
+ (tinydebian-bug-system-info-os)
+ (format "\n\n-- Versions of packages `%s depends on'.\n"
+ package)
+ (if pre-depends
+ (concat "Pre-Depends:\n" pre-depends)
+ "")
+ (if depends
+ (concat "Depends:\n" depends)
+ ""))
+ (goto-char point)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinydebian-bug-report-mail (info)
+ "Submit Debian bug report. INFO is alist of attributes for package.
+An example ´reportbug(1)' looks like
+
+To: submit@bugs.debian.org
+Subject: autolog ....
+--text follows this line--
+Package: autolog
+Version: 0.35-10
+Severity: wishlist
+
+-- System Information
+Debian Release: 3.0
+Architecture: i386
+Kernel: Linux foo 2.4.17 #1 Fri Feb 8 21:32:43 EET 2002 i686
+Locale: LANG=en_US, LC_CTYPE=en_US
+
+Versions of packages autolog depends on:
+ii cron 3.0pl1-72 management of regular background p
+ii libc6 2.2.5-3 GNU C Library: Shared libraries an
+
+Subject: autolog based on DNS and IP names
+Package: autolog
+Version: 0.35-10
+Severity: wishlist
+
+-- System Information
+Debian Release: 3.0
+Architecture: i386
+Kernel: Linux terra 2.4.17 #1 Fri Feb 8 21:32:43 EET 2002 i686
+Locale: LANG=en_US, LC_CTYPE=en_US
+
+Versions of packages autolog depends on:
+ii cron 3.0pl1-72 management of regular background p
+ii libc6 2.2.5-3 GNU C Library: Shared libraries an."
+ (interactive
+ (progn
+ (if (y-or-n-p "[TinyDebian] Submit bug report? ")
+ (list (tinydebian-package-info))
+ nil)))
+ (let ((status (or (cdr-safe (assoc "Status" info)) ""))
+ (package (or (cdr-safe (assoc "Package" info)) "")))
+ (cond
+ ((null info)
+ (message "TinyDebian: no INFO available to send a bug report."))
+ ((string-match "not-installed" status)
+ (message "TinyDebian: bug report skipped. ´%s' status is [%s]"
+ package status))
+ (t
+ (let* ((name (format "*mail* Debian Bug %s" package))
+ buffer)
+ (cond
+ ((and (setq buffer (get-buffer name))
+ (null (y-or-n-p
+ "[TinyDebian] delete previous bug report? ")))
+ (pop-to-buffer buffer))
+ (t
+ (pop-to-buffer (get-buffer-create name))
+ (erase-buffer)
+ (let ((subject (read-string "[TinyDebian] bug Subject: ")))
+ (mail-setup
+ (tinydebian-bts-email-submit) subject nil nil nil nil))
+ (message-mode)
+ (tinydebian-bts-insert-headers)
+ (tinydebian-bug-report-mail-insert-details info))))))))
+
+;;}}}
+;;{{{ Admin functions: MAIL reports
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-command-audit-report-tiger-make-chmod (file line)
+ "Make suotable chmod command for FILE according to LINE report."
+ (let* ((operand "+")
+ group
+ group-cmd
+ type
+ type-cmd)
+ (when (string-match
+ "should .*+have +\\([^ \t\r\n]+\\) +\\([^ \t\r\n.]+\\)"
+ line)
+ (setq group (match-string 1 line)
+ type (match-string 2 line))
+ (if (string-match "should not" line)
+ (setq operand "-"))
+ (cond
+ ((string= group "group")
+ (setq group-cmd "g"))
+ ((string= group "world")
+ (setq group-cmd "o")))
+ (cond
+ ((string-match type "read")
+ (setq type-cmd "r"))
+ ((string-match type "write")
+ (setq type-cmd "w"))
+ ((string-match type "exec")
+ (setq type-cmd "x")))
+ (when (and operand type-cmd group-cmd)
+ (format "chmod %s%s%s %s;" group-cmd operand type-cmd file)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydebian-command-audit-report-tiger (beg end)
+ "Process tiger(1) mail system report on region BEG END.
+The body of mail looks like:
+
+ # Performing check of system file permissions...
+ OLD: --WARN-- [perm001w] /var/log/wtmp should not have group write.
+ OLD: --WARN-- [perm001w] /var/run/utmp should not have group write.
+ OLD: --WARN-- [perm001w] /var/log/XFree86.0.log should not have world read.
+
+For which a corresponding command to correct the error is generated.
+
+ chmod g-w /var/log/wtmp;
+ chmod g-w /var/run/utmp;
+ chmod o-r /var/log/XFree86.0.log;
+
+You can select region and these commands to shell `sh' with command
+`shell-command-on-region' which can be called with \\[shell-command-on-region]."
+ (interactive "r")
+ (let* ((buffer (get-buffer-create tinydebian-:buffer-tiger))
+ done
+ file
+ str)
+ (goto-char beg)
+ (while (re-search-forward
+ "--WARN-- +[^ \t\r\n]+ +\\(\\([^ \t\r\n]+\\).*\\)"
+ nil end)
+ (setq file (match-string 2)
+ str (match-string 1))
+ (unless done ;Draw one empty line between calls
+ (setq done t)
+ (ti::append-to-buffer buffer "\n"))
+ (when (setq str (tinydebian-command-audit-report-tiger-make-chmod
+ file str))
+ (ti::append-to-buffer buffer (concat str "\n"))))
+ (cond
+ ((ti::buffer-empty-p buffer)
+ (message
+ "TinyDebian: Hm, region did not have --WARN-- chmod candidates."))
+ (t
+ (display-buffer buffer)
+ (message
+ (substitute-command-keys
+ (concat
+ "TinyDebian: [tiger] "
+ "Select region and send commands to"
+ " `sh' with \\[shell-command-on-region]")))))))
+
+;;}}}
+
+(tinydebian-install-severity-functions) ;; Auto-created functions
+
+(add-hook 'tinydebian-:bts-mode-define-keys-hook
+ 'tinydebian-bts-mode-define-keys)
+
+(defalias 'tinydebian-reportbug 'tinydebian-bug-report-mail)
+
+(provide 'tinydebian)
+(run-hooks 'tinydebian-:load-hook)
+
+;;; tinydebian.el ends here
--- /dev/null
+;;; tinydesk.el --- Save and restore files between Emacs sessions
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 1995-2007 Jari Aalto
+;; Keywords: extensions
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program, call M-x tinydesk-version.
+;; Look at the code with folding.el
+
+;; COPYRIGHT NOTICE
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;; ........................................................ &t-install ...
+;; Put this file on your Emacs-Lisp load path, add following into your
+;; $HOME/.emacs startup file
+;;
+;; (add-hook 'tinydesk-:load-hook 'tinydesk-default-emacs-keybindings)
+;; (add-hook 'tinydesk-:load-hook 'tinydesk-recover-last-state)
+;; (require 'tinydesk)
+;;
+;; or use the autoload feature. Notice that the automatic "file
+;; state backup feature" gets enables only when this file is loaded.
+;; If you want that feature, then use require.
+;;
+;; (add-hook 'tinydesk-:load-hook 'tinydesk-default-emacs-keybindings)
+;; (add-hook 'tinydesk-:load-hook 'tinydesk-recover-last-state)
+;; (autoload 'tinydesk-mode "tinydesk" "" t)
+;; (autoload 'tinydesk-save-state "tinydesk" "" t)
+;; (autoload 'tinydesk-unload "tinydesk" "" t)
+;; (autoload 'tinydesk-recover-state "tinydesk" "" t)
+;; (autoload 'tinydesk-edit-state-file "tinydesk" "" t)
+;;
+;; Suggested keybindings. These are inlcuded in function
+;; `tinydesk-default-keybindings'.
+;;
+;; (define-key ctl-x-4-map "S" 'tinydesk-save-state)
+;; (define-key ctl-x-4-map "R" 'tinydesk-recover-state)
+;; (define-key ctl-x-4-map "E" 'tinydesk-edit-state-file)
+;; (define-key ctl-x-4-map "U" 'tinydesk-unload)
+;;
+;; If you have any questions, use this function:
+;;
+;; M-x tinydesk-submit-bug-report
+;;
+;; To read the documentation after file has been loaded, call
+;;
+;; M-x tinydesk-version
+
+;;}}}
+;;{{{ Documentation
+
+;; ..................................................... &t-commentary ...
+
+;;; Commentary:
+
+;; Preface, feb 1995
+;;
+;; At work working with windowed system, Emacs stays open from day to
+;; day. In fact people seldom even logout, so Emacs and the files
+;; just wait there nicely and there is seldom a need for a sophisticated
+;; session saver.
+;;
+;; But sometimes sometimes it may be necessary to visit lab next
+;; floor to see what's troubling a C++ program. There has to be a way
+;; to transfer the list of files that was being editing and bring
+;; them into lab where person can replicate the setup.
+;;
+;; These functions save Emacs configuration into file, which can later be
+;; opened again in Emacs somewhere else. Later Emacs versions
+;; introduced "~/.saves*" files that you may find disturbing occupying
+;; your home directory with many files. With this package all the
+;; files are grouped in only one "state" state file, which can be reused.
+;;
+;; Hopefully someone finds use for this also, although there exist
+;; much more better desktop savers, which save points, marks and
+;; modes.
+;;
+;; Overview of features
+;;
+;; o Simple desktop: only filenames and directories are read/saved.
+;; Unlike the other desktop savers, this one can also UNLOAD files
+;; from Emacs. You just tell it to remove 'these files listed in
+;; state file state.XXX', and those files will be removed from
+;; your Emacs buffers. You can collect 'projects' and switch
+;; between them easily: after project1, It can can be unload and
+;; load project3 instead.
+;;
+;; o Parse any file that includes filenames and comments
+;;
+;; o If there were any invalid entries in the state file,
+;; the state file contents is shown to user and the entries which
+;; had problems are marked.
+;;
+;; o State file editing (tinydesk-mode):
+;;
+;; -- load single file on the line
+;; -- clear face properties from buffer, so that they don't
+;; disturb your view.
+;; -- parse files for loading.
+;; -- Show files that cannot be loaded.
+;;
+;; o In regular intervals save the state of Emacs (files loaded)
+;; If Emacs crashes you can recover the previous session.
+;; See function `tinydesk-auto-save' for more. Similar functionality
+;; (".saves") is in new Emacs releases, but this package
+;; was originally written using 19.28
+;;
+;; o CRASH RECOVERY: If Emacs crashes, or you have to kill it
+;; with `-HUP' if it hangs, it leaves autosaved files around. When
+;; you boot up again, you need to reload the existing files AND
+;; recover any autosaved files. The best way to get your Emacs
+;; back where it was, is that you load the state file for editing:
+;; `M-x' `tinydesk-edit-state-file' And from the edit
+;; mode hit command `tinydesk-find-file-whole-buffer' which is
+;; bound to C-c b and `tinydesk-recover-file-whole-buffer' which
+;; is bound to C-c B. And you'll be up again with your latest
+;; files.
+;;
+;; Quick start
+;;
+;; If you're just eager to use the package, here are the basics.
+;; I suppose you have copied the installation setup as is.
+;;
+;; o You have Emacs session open with bunch of files. Now you
+;; believe that it's time to save this session. You do
+;; C-x 4 s and give some name "state.c" if you edited c project.
+;;
+;; Now, it all depends what you want to do after that. If you find more
+;; files to Emacs; or kill some unwanted buffers, you can re-execute
+;; C-x 4 s whenever you like. You can even edit the state file with
+;; C-x 4 e to remove some files that you don't want to include to
+;; that "project".
+;;
+;; o Next time you open Emacs you can load any state file with
+;; C-x 4 r "state.c"
+;;
+;; If you want to switch between projects; unload first the current
+;; project with C-x 4 u "state.c" and reload some other project
+;; with C-x 4 r, eg your current C++ project "state.cc"
+;;
+;; Automatic one time session saver
+;;
+;; Some people just want to save the session on exit and reopen it
+;; when Emacs starts again. I must say that this is not necessarily
+;; the best, because when you start Emacs for some quick job, you
+;; don't necessarily want it to load the saved session (loading all
+;; files take time considerably). Loading Emacs with -q is not the
+;; choice, if you still like to have your other Emacs goodies active.
+;;
+;; Here is semi-automatic save and restore, put all these lines near
+;; the end of your $HOME/.emacs. The setup saves the state when
+;; Emacs exists and asks if you want to return to saved session on
+;; Emacs startup. (You did also copy the installation lines too...)
+;;
+;; (defconst tinydesk-:directory-location "~/elisp/config")
+;;
+;; (defconst my-tinydesk-session
+;; (concat tinydesk-:directory-location "/state.last-session"))
+;;
+;; (add-hook 'kill-emacs-hook 'my-save-session)
+;;
+;; (defun my-save-session ()
+;; "Save loaded files to state file."
+;; ;; if you want to save dired buffers too.
+;; ;; use (tinydesk-save-state my-tinydesk-session '(4))
+;; (tinydesk-save-state my-tinydesk-session) nil)
+;;
+;; (if (and (file-exists-p my-tinydesk-session)
+;; (y-or-n-p "Recover session "))
+;; (tinydesk-recover-state my-tinydesk-session))
+;;
+;; Face setup
+;;
+;; This program uses some faces to catch your attention when you're
+;; working with the state files. I you restore state from a file and
+;; some file reference cannot be loaded, the state file will be shown
+;; to you and the problematic lines are highlighted. If you open the
+;; state file for editing, you can selectively load files. The mouse
+;; pointer will change and the text is again highlighted. To make the
+;; highlight work for you, you must set some colors like this
+;;
+;; (set-face-foreground 'italic "LightBlue")
+;;
+;; About saving the files
+;;
+;; While you may save your session files with any name, here is one
+;; convention that you could use. Name every filename so, that they
+;; have common prefix:
+;;
+;; M-x tinydesk-save-state ;; or any hotkey you have bound this to
+;; state.XXX
+;;
+;; The XXX describes the name of the state file you just saved. Later
+;; on it's easier to use Emacs file name completion capability to load
+;; the file you want. If you don't exactly remember what files you
+;; saved, or which sessions you have in dir, you just type
+;;
+;; state.[TAB]
+;;
+;; when `tinydesk-recover-state' ask for filename.
+;; Prefix arg to `tinydesk-save-state saves' says to load directories too.
+;;
+;; Automatic state file saving
+;;
+;; Emacs 19.29+ has feature that makes it possible to recover a session.
+;; See bunch of `auto-save-list-*' variables.
+;;
+;; Has it ever happened to you that Emacs crashed mystically when you
+;; were in the middle of your daily routines. You had several C++
+;; files open, perl code, text files, RMAIL, ... This package installs
+;; `tinydesk-auto-save' function to `write-file-hooks' and in regular
+;; intervals all your Emacs session files are stored into the state
+;; file. After a crash you can easily recover your session by reading
+;; the saved state file information with `tinydesk-recover-state'
+;; <FILE>. The name of the file of the latest saved state is in file
+;; "periodic"
+;;
+;; Development note
+;;
+;; There is no plan to duplicate *desktop.el* functionality to save points
+;; and modes and so on. This is for simple state restoring only.
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+(require 'tinylibm)
+
+(eval-when-compile (ti::package-use-dynamic-compilation))
+
+(ti::package-defgroup-tiny TinyDesk tinydesk-: extensions
+ "Simple desktop: only filenames and directories are read/saved.
+
+ Unlike the other desktop savers, this one can also UNLOAD files
+ from Emacs. You just tell it to remove 'these files listed in
+ state file state.XXX', and those files will be removed from
+ your Emacs buffers. You can collect 'projects' and switch
+ between them easily: after project1, It can can
+ be unload and load project3 instead.
+
+ Files that have been modified are not unloaded.
+ ")
+
+;;{{{ setup: hooks
+
+;;; ......................................................... &v-hooks ...
+
+(defcustom tinydesk-:mode-define-keys-hook
+ '(tinydesk-default-mode-bindings)
+ "*List of functions to run which define keys to `tinydesk-mode-map'."
+ :type 'hook
+ :group 'TinyDesk)
+
+(defcustom tinydesk-:load-hook nil
+ "*Hook run when file has been loaded."
+ :type 'hook
+ :group 'TinyDesk)
+
+(defcustom tinydesk-:save-before-hook nil
+ "*Hook run just before _writing_ files to STATE file.
+begins. This is your chance to do something to the buffers."
+ :type 'hook
+ :group 'TinyDesk)
+
+(defcustom tinydesk-:save-after-hook nil
+ "*Hook just before _saving_ of STATE file.
+The files are there, possibly in sorted order, and the title is there."
+ :type 'hook
+ :group 'TinyDesk)
+
+(defcustom tinydesk-:mode-hook nil
+ "*Hook run after the `tinydesk-mode' is turned on."
+ :type 'hook
+ :group 'TinyDesk)
+
+(defcustom tinydesk-:recover-before-hook nil
+ "*Hook run after recover file is loaded, just before processing start."
+ :type 'hook
+ :group 'TinyDesk)
+
+(defcustom tinydesk-:recover-after-hook nil
+ "*Hook run after recover file is _parsed_ AND no errors during load."
+ :type 'hook
+ :group 'TinyDesk)
+
+;;}}}
+;;{{{ setup: user config
+
+;;; ................................................... &v-user-config ...
+
+(defcustom tinydesk-:comment-characters ";#"
+ "*A string containing comment start characters in state file.
+The default value is ';#'."
+ :type 'string
+ :group 'TinyDesk)
+
+(defcustom tinydesk-:mode-name "TinyDesk"
+ "*Editing STATE files mode name."
+ :type 'string
+ :group 'TinyDesk)
+
+(defcustom tinydesk-:directory-location
+ (or
+ (file-name-as-directory
+ (file-name-directory (ti::package-config-file-prefix "tinydesk.el")))
+ (and (file-directory-p "~/tmp")
+ "~/tmp")
+ (error "\
+TinyDesk: Can't set default value for `tinydesk-:directory-location'"))
+ "*Default directory where to save and restore files."
+ :type 'directory
+ :group 'TinyDesk)
+
+(defcustom tinydesk-:directory-save-suggested 'default
+ "*How the state file's directory location is suggested.
+'last Offer last saved directory.
+'default Always offer the default directory `tinydesk-:directory-location'"
+ :type '(choice
+ (const last)
+ (const default))
+ :group 'TinyDesk)
+
+(defcustom tinydesk-:auto-save-interval 5
+ "*Interval between doing auto-save of Emacs state.
+If set to 5, after every 5th `write-file' the state is saved.
+
+The interval cannot be smaller than 5. It is reseted to 10 if
+it's smaller than 5.
+
+See variable `tinydesk-:auto-save-name-function' and
+function `tinydesk-auto-save' for more information."
+ :type '(integer :tag "Save interval")
+ :group 'TinyDesk)
+
+(defcustom tinydesk-:auto-save-name-function nil
+ "*Function to return a full path name for auto-save file.
+If this variable is nil, then default name is derived from frame's
+first element and it used in `tinydesk-:directory-location'
+
+For full documentation, see function `tinydesk-auto-save'"
+ :type 'function
+ :group 'TinyDesk)
+
+(defcustom tinydesk-:save-exclude-regexp
+ (concat
+
+ ;; Do save mail buffers; because you want to call M-x rmail
+ ;; instead.
+
+ "RMAIL\\|VM\\|MH"
+
+ ;; No ange ftp buffers
+
+ "\\(ftp\\|anonymous\\)@.*/"
+
+ ;; No files from these directories
+
+ "\\|^/tmp/\\|/junk/\\|/trash/\\|/[aA]utosaved?/")
+ "*Regexp of files that are not saved to state file.
+match is case sensitive. If you do want not case sensitive match, you
+have to do set this variable to nil and use your own line delete:
+
+ (setq tinydesk-:save-after-hook 'my-tinydesk-:save-after-hook)
+ (defun my-tinydesk-:save-after-hook ()
+ (flush-lines REGEXP))"
+
+ :type '(string :tag "Regexp")
+ :group 'TinyDesk)
+
+(defcustom tinydesk-:save-title
+ '(progn
+ (format
+ (concat
+ ";; Emacs tinydesk.el state file\n"
+ ";;\n"
+ ";;\n"
+ ";; M-x load-library RET tinydesk RET\n"
+ ";; M-x tinydesk-version RET <<to read manual>>\n"
+ ";; M-x tinydesk-recover-state RET %s RET"
+ "\n\n")
+ (ti::date-standard-date 'short)
+ (if (boundp 'file)
+ file ;; visible in function `tinydesk-save-state'
+ "")))
+ "*A lisp form to return a string to the beginning of state file."
+ :type 'sexp
+ :group 'TinyDesk)
+
+(defcustom tinydesk-:save-and-sort t
+ "*Non-nil to sort the file list in state file.
+nil to preserve `buffer-list' order."
+ :type 'boolean
+ :group 'TinyDesk)
+
+;; Set to nil if you don't want title.
+
+(defcustom tinydesk-:get-save-file-function 'tinydesk-get-save-files
+ "*Function to return list of filenames that are stored to state file.
+This function isn't run if `tinydesk-save-state' is explicitely
+run with parameter FILES.
+
+Arguments passed to function:
+ mode flag passed by `tinydesk-save-state'"
+
+ :type 'function
+ :group 'TinyDesk)
+
+(defcustom tinydesk-:face-table
+ '((file-pick . highlight)
+ (error . italic))
+ "*Alist of faces used for marking text.
+The default value is
+
+\(setq tinydesk-:face-table
+ '((file-pick . highlight)
+ (error . italic)))"
+ :type '(list
+ (cons
+ (const file-pick)
+ (symbol :tag "Face"))
+ (cons
+ (const error)
+ (symbol :tag "Face")))
+ :group 'TinyDesk)
+
+;;}}}
+;;{{{ setup: -- private
+
+;;; ....................................................... &v-private ...
+
+(defvar tinydesk-mode-map nil
+ "Local keymap for STATE files loaded by edit.")
+
+(defvar tinydesk-:directory-last nil
+ "Directory that was used for last save.")
+
+(defvar tinydesk-:tmp-buffer "*tmp*"
+ "The work buffer used, created and killed when needed.")
+
+(defvar tinydesk-:trash-tmp-buffer t
+ "If non-nil, the work buffer is always deleted.")
+
+(defvar tinydesk-:message-column 60
+ "Column where to put possible messages regarding file.")
+
+(defvar tinydesk-:auto-save-counter 0
+ "Counter incremented every every time `write-file' event happens.
+See. `tinydesk-auto-save'.")
+
+(defconst tinydesk-:loaded-file-list nil
+ "Overwritten when files are loaded. List.
+Contain files that were loaded by `tinydesk-find-file-whole-buffer'.
+Hooks may check the contents of this.")
+
+(defconst tinydesk-:rejected-file-list nil
+ "Overwritten when files are loaded. List.
+Contain files that were *not* loaded by
+`tinydesk-find-file-whole-buffer'. Reason may be anything: incorrect filename,
+path, garbage at line...Hooks may check the contents of this.")
+
+(defconst tinydesk-:comment-start-level 1
+ "Which sub expression is the comment start.")
+
+(defvar tinydesk-:last-state-file nil
+ "Last state file loaded is stored here.")
+
+;;}}}
+;;{{{ setup: -- version
+
+;;; ....................................................... &v-version ...
+
+;;;###autoload (autoload 'tinydesk-version "tinydesk" "Display commentary." t)
+(eval-and-compile
+ (ti::macrof-version-bug-report
+ "tinydesk.el"
+ "tinydesk"
+ tinydesk-:version-id
+ "$Id: tinydesk.el,v 2.52 2007/05/06 23:15:19 jaalto Exp $"
+ '(tinydesk-version-id
+ tinydesk-:mode-define-keys-hook
+ tinydesk-mode-map
+ tinydesk-:load-hook
+ tinydesk-:save-before-hook
+ tinydesk-:save-after-hook
+ tinydesk-:mode-hook
+ tinydesk-:recover-before-hook
+ tinydesk-:recover-after-hook
+ tinydesk-:directory-last
+ tinydesk-:tmp-buffer
+ tinydesk-:trash-tmp-buffer
+ tinydesk-:message-column
+ tinydesk-:loaded-file-list
+ tinydesk-:rejected-file-list
+ tinydesk-:comment-start-level
+ tinydesk-:mode-name
+ tinydesk-:directory-save-suggested
+ tinydesk-:save-exclude-regexp
+ tinydesk-:comment-characters
+ tinydesk-:save-title
+ tinydesk-:save-and-sort
+ tinydesk-:face-table)))
+
+;;}}}
+;;{{{ Install: bindings
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydesk-default-emacs-keybindings ()
+ "Install package under `ctl-x-4-map'
+\\{ctl-x-4-map}"
+ (interactive)
+ (define-key ctl-x-4-map "S" 'tinydesk-save-state) ;; free in Emacs
+ ;; This was find-file-read-only-other-window
+ (define-key ctl-x-4-map "R" 'tinydesk-recover-state) ;; Not free
+ (define-key ctl-x-4-map "E" 'tinydesk-edit-state-file) ;; free in Emacs
+ (define-key ctl-x-4-map "U" 'tinydesk-unload)) ;; free in Emacs
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydesk-default-mode-bindings ()
+ "Define default key bindings to `tinydesk-mode-map'."
+ (when (ti::emacs-p)
+ ;; - Don't want to use mouse-2 because it's for PASTE.
+ ;; - The others are put to mouse-2 because there is not
+ ;; not always 3 button mouse available.
+
+ (define-key tinydesk-mode-map [mouse-3] 'tinydesk-mouse-load-file)
+
+ ;; - When editing a file, those colors might be too annoyinng,
+ ;; so you can remove properties with this. Loading is disabled too
+ ;; - Remeber, Emacs is slow with this... wait some time.
+
+ (define-key tinydesk-mode-map [S-mouse-2]
+ 'tinydesk-clear-buffer-properties)
+
+ ;; To make buffer loadable by mouse again, run this
+
+ (define-key tinydesk-mode-map [C-mouse-2]
+ 'tinydesk-mark-buffer-loadable)
+
+ ;; To mark files that are not loadable, check for possibly typo in
+ ;; filename
+
+ (define-key tinydesk-mode-map [C-M-mouse-2]
+ 'tinydesk-set-face-non-files-buffer))
+
+ (when (ti::xemacs-p)
+
+ (define-key tinydesk-mode-map [(button3)]
+ 'tinydesk-mouse-load-file)
+
+ (define-key tinydesk-mode-map [(shift button2)]
+ 'tinydesk-clear-buffer-properties)
+
+ (define-key tinydesk-mode-map [(control button2)]
+ 'tinydesk-mark-buffer-loadable)
+
+ (define-key tinydesk-mode-map [(control alt button2)]
+ 'tinydesk-set-face-non-files-buffer))
+
+ ;; ............................................. users with no mouse ...
+
+ (define-key tinydesk-mode-map "\C-c\C-m" 'tinydesk-load-file)
+
+ (define-key tinydesk-mode-map "\C-cc" 'tinydesk-clear-buffer-properties)
+ (define-key tinydesk-mode-map "\C-cl" 'tinydesk-mark-buffer-loadable)
+ (define-key tinydesk-mode-map "\C-cn" 'tinydesk-set-face-non-files-buffer)
+ (define-key tinydesk-mode-map "\C-cu" 'tinydesk-unload-current-file)
+ (define-key tinydesk-mode-map "\C-cx" 'tinydesk-expunge-unloaded)
+ (define-key tinydesk-mode-map "\C-cr" 'tinydesk-remove-file-coments)
+ (define-key tinydesk-mode-map "\C-cb" 'tinydesk-find-file-whole-buffer)
+ (define-key tinydesk-mode-map "\C-cB" 'tinydesk-recover-file-whole-buffer))
+
+;;}}}
+;;{{{ code: misc
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinydesk-comment ()
+ "Return comment."
+ (make-string
+ 2
+ (string-to-char
+ (substring tinydesk-:comment-characters 0 1 ))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinydesk-comment-re ()
+ "Return comment regexp."
+ (concat "[^\n"
+ tinydesk-:comment-characters
+ "]*\\(["
+ tinydesk-:comment-characters
+ "].*\\)"))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinydesk-read-word ()
+ "Read filename word."
+ ;; Windows use spaces in file names
+ (ti::remove-properties
+ (ti::string-remove-whitespace
+ (ti::buffer-read-word "- a-zA-Z0-9_/.!@#%&{}[]+:;~`<>"))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinydesk-tmp-buffer (&optional clear)
+ "Return temp buffer. optionally CLEAR it."
+ (ti::temp-buffer tinydesk-:tmp-buffer clear))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinydesk-file-name-absolute (file)
+ "Add `default-directory' to FILE if it has no directory."
+ (if file
+ (if (not (string-match "/" (or file "")))
+ (setq file (concat default-directory file))))
+ file)
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinydesk-mode-map-activate ()
+ "Use local \\{tinydesk-mode-map} on this buffer."
+ (use-local-map tinydesk-mode-map))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydesk-get-save-dir ()
+ "Return suggested save directory."
+ (let* ((type tinydesk-:directory-save-suggested)
+ (last tinydesk-:directory-last)
+ (dir tinydesk-:directory-location)
+ (ret dir)) ;set default return value
+ (if (and (eq type 'last)
+ (stringp last)
+ (file-writable-p last))
+ (setq ret last))
+ (or ret
+ dir
+ "~/")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydesk-only-files-buffer ()
+ "Remove all comments and empty lines from buffer and leave 1st word."
+ (interactive)
+ (tinydesk-only-files-region (point-max) (point-min)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydesk-only-files-region (beg end)
+ "Remove comments BEG END and empty lines from region and leave 1st word.
+This way you can rip off all comments and leave filenames."
+ (interactive "r")
+ (let* ((sub-level tinydesk-:comment-start-level)
+ (comment-re (tinydesk-comment-re))
+ (empty-re "^[ \t]*$\\|$")
+ mark-end
+ p
+ maxp
+ word
+ tmp)
+ (if (> beg end)
+ (setq tmp beg beg end end tmp))
+ (save-excursion
+ (goto-char end)
+ ;; markers has to be used, beacuse we delete lines and points move
+ (setq mark-end (point-marker))
+ (goto-char beg)
+ (while (< (point) (marker-position mark-end))
+ (setq p (point) maxp nil)
+ (catch 'next
+ (if (null (looking-at empty-re))
+ nil
+ (ti::buffer-kill-line)
+ (throw 'next t))
+ (if (null (looking-at comment-re))
+ nil
+ (if (match-beginning sub-level)
+ (setq maxp (match-beginning sub-level))))
+ (if (and maxp (eq maxp p)) ;BEG of line comment
+ (progn
+ (ti::buffer-kill-line) (throw 'next t)))
+ (setq word (tinydesk-read-word))
+;;; (setq word (tinydesk-read-word p maxp))
+ (ti::buffer-kill-line)
+ ;; The \n make cursor forward
+ (if word
+ (insert word "\n")))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydesk-trash ()
+ "Kill temporary buffer if user has requested it.
+
+References:
+ `tinydesk-:tmp-buffer'
+ `tinydesk-:trash-tmp-buffer'"
+ (and tinydesk-:trash-tmp-buffer
+ (get-buffer tinydesk-:tmp-buffer)
+ (kill-buffer (get-buffer tinydesk-:tmp-buffer))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydesk-dired-table ()
+ "Return dired buffer table '((directory dired-buffer) ...)."
+ (interactive)
+ (let ((blist (buffer-list))
+ ;; ByteCompiler doesn't know that I do
+ ;; (eq major-mode 'dired-mode) test before I use this variable,
+ ;; so hide it from it.
+ ;;
+ ;; The variable is defined if it passed the eq test
+ (sym 'dired-directory)
+ list)
+ (dolist (elt blist)
+ (with-current-buffer elt
+ (if (eq major-mode 'dired-mode)
+ (push
+ (list (symbol-value sym)
+ (current-buffer))
+ list))))
+ list))
+
+;;}}}
+;;{{{ code: auto save
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydesk-auto-save-file-name ()
+ "Return state file name for auto save. See function `tinydesk-auto-save'.
+References:
+ `tinydesk-:directory-location'
+ `tinydesk-:auto-save-name-function'."
+ (let* ((func tinydesk-:auto-save-name-function)
+ (dir (or tinydesk-:directory-location "~" ))
+ (name (or (and (boundp 'command-line-args)
+ (nth 1 (member "-name" command-line-args)))
+ "periodic"))
+ (fn (concat
+ (file-name-as-directory dir)
+ "emacs-config-tinydesk-autosave-"
+ (or name "saved"))) ;; default
+ (save-to fn))
+ (if func
+ (setq save-to (funcall func)))
+ save-to))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydesk-auto-save (&optional force)
+ "This function is installed in `write-file-hooks'. Periodic auto save.
+
+Input:
+
+ FORCE Do autosave immediately
+
+Every Nth time the state of the Emacs (which files were loaded into Emacs)
+is saved, so that you can recover the same session if Emacs crashes.
+
+The default state name is derived in the following manner
+
+o use directory `tinydesk-:directory-location'
+o add string \"emacs-tinydesk-autosave-\"
+o get frame's first word, usually the one that gets set when
+ you use -name XXX switch in Emacs command line. If Emacs is being
+ run with -nw option, the frame name returns \"terminal\"
+o if there is no frame name, then use \"periodic\"
+
+ Possible yielding: ~/elisp/config/state.saved
+
+References:
+
+ `tinydesk-:auto-save-counter'
+ `tinydesk-:auto-save-interval' every Nth write"
+ (interactive "P")
+ (let* ((backup-inhibited t)
+ (save-to (tinydesk-auto-save-file-name)))
+ (when (stringp save-to)
+ ;; - Be extra careful, because we're in write file hook
+ ;; - Make sure we always succeed
+ (if (not (integerp tinydesk-:auto-save-counter)) ;; init if not int
+ (setq tinydesk-:auto-save-counter 0))
+ (if (not (integerp tinydesk-:auto-save-interval)) ;; user didn't set this?
+ (setq tinydesk-:auto-save-interval 10))
+ (if (< tinydesk-:auto-save-interval 5) ;; Must be more than 5
+ (setq tinydesk-:auto-save-interval 10))
+ (incf tinydesk-:auto-save-counter)
+ ;; time's up? Select name if it's string.
+ (cond
+ ((or force
+ (> tinydesk-:auto-save-counter tinydesk-:auto-save-interval))
+ ;; Actually tinydesk-save-state generates new call to this
+ ;; function but, it won't come in this COND, because the counter
+ ;; value is different.
+ (setq tinydesk-:auto-save-counter 0)
+ ;; Try chmod, if it fails, then signal error
+ (if (and (file-exists-p save-to)
+ (not (file-writable-p save-to)))
+ (set-file-modes
+ save-to
+ (ti::file-mode-make-writable (file-modes save-to))))
+ ;; Still no luck after chmod ?
+ (if (or (not (file-directory-p (file-name-directory save-to)))
+ (and (file-exists-p save-to)
+ (not (file-writable-p save-to))))
+ (error "\
+TinyDesk: Can't do state autosave: [%s] is not writable." save-to))
+
+ (save-window-excursion
+ (save-excursion
+ (message "TinyDesk: state backup in file %s" save-to)
+ (tinydesk-save-state save-to)))))
+ ;; `write-file-hook' function must return nil
+ nil)))
+
+;;}}}
+
+;;{{{ Code: faces
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydesk-face (face)
+ "Return FACE."
+ ;; This way the global variable does not float around the file
+ (cdr (assoc face tinydesk-:face-table)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydesk-clear-line-properties ()
+ "Remove properties from the line."
+ (set-text-properties (line-beginning-position) (line-end-position) nil)
+ (set-buffer-modified-p nil))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydesk-clear-buffer-properties ()
+ "Remove properties and EOL comments from buffer."
+ (interactive)
+ (let* ((c-chars tinydesk-:comment-characters)
+ (c-lev tinydesk-:comment-start-level)
+ (c-re (tinydesk-comment-re)))
+ (tinydesk-clear-region-properties (point-min) (point-max))
+ (save-excursion
+ (ti::pmin)
+ (while (not (eobp))
+
+ ;; Skip over BOL comments
+ (if (and (not (looking-at (concat "^[ \t]*[" c-chars "]+\\|$")))
+ (looking-at c-re)
+ (match-beginning c-lev))
+ (delete-region (match-beginning c-lev) (line-end-position)))
+ (forward-line 1)))
+ (set-buffer-modified-p nil)
+ (message "TinyDesk: *properties cleared from buffer")
+ ;; Little nasty, but Emacs does not update display always...
+ (redraw-display)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydesk-clear-region-properties (beg end)
+ "Remove properties from BEG END."
+ (set-text-properties beg end nil)
+ (set-buffer-modified-p nil))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydesk-line-property-set-error ()
+ "Set line face to signify error."
+ (let* (beg
+ end)
+ (save-excursion
+ (beginning-of-line) (setq beg (point))
+ (skip-chars-forward "^ \t\n") (setq end (point)))
+ ;; clear first full line
+ (put-text-property beg (line-end-position) 'face 'default)
+ (put-text-property beg end 'face (tinydesk-face 'error))
+ (set-buffer-modified-p nil)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydesk-handle-text-property (p text)
+ "Look property P and run command under TEXT."
+ (let* ((file (file-name-nondirectory text))
+ (loaded (get-buffer file)) ;in Emacs already ?
+ (comment (tinydesk-comment))
+ (err-col tinydesk-:message-column))
+ ;; We need the sleep-for, because moving the mouse
+ ;; clears the message and user may not notice it.
+ (cond
+ ((eq p (tinydesk-face 'file-pick))
+ (cond
+ ((null (file-exists-p text))
+ (message (concat "TinyDesk: File not exist, " text)) (sleep-for 0)
+ (tinydesk-clear-line-properties))
+ (loaded
+ (message "TinyDesk: File already loaded.") (sleep-for 0)
+ (tinydesk-clear-line-properties))
+ (t
+ (find-file-noselect text)
+ (message "TinyDesk: Loaded ok.") (sleep-for 0)
+ (tinydesk-clear-line-properties)
+ (move-to-column err-col t)
+ (if (not (looking-at "$\\|[ \t]*$"))
+ (end-of-line))
+ (insert comment " loaded")
+ (beginning-of-line)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydesk-mark-buffer-loadable (&optional verb)
+ "Parse whole buffer and make first _word_ loadable with mouse. VERB.
+Marking is only done if word is valid filename."
+ (interactive)
+ (save-excursion
+ (tinydesk-mark-region
+ (point-min) (point-max)
+ (tinydesk-comment-re)
+ tinydesk-:comment-start-level
+ (or (interactive-p)
+ verb))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydesk-set-face-non-files-buffer ()
+ "Change face to 'error in those lines whose first word is not valid file."
+ (interactive)
+ (tinydesk-set-face-non-files-region (point-min) (point-max))
+ (if (interactive-p)
+ (message "TinyDesk: marked non-lodable files")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydesk-set-face-non-files-region (beg end)
+ "Change face to 'error in those lines whose first word is not valid file.
+Also add comment marker for user that do not have highlight capability.
+Region is BEG END."
+ (interactive "r")
+ (let* ((empty-re "^[ \t]*$")
+ (sub-level tinydesk-:comment-start-level)
+ (c-chars tinydesk-:comment-characters)
+ (comment (tinydesk-comment))
+ (comment-re (tinydesk-comment-re))
+ (err-col tinydesk-:message-column)
+ word)
+ (save-excursion
+ (save-restriction
+ (narrow-to-region beg end)
+ (ti::pmin)
+ (while (not (eobp))
+ ;; - ignore empty lines and BEG of line comments.
+ (if (or (looking-at empty-re)
+ (and (looking-at comment-re)
+ (eq (match-beginning sub-level) (point))))
+ nil
+ (setq word (tinydesk-read-word))
+ (if (and word (file-exists-p word))
+ nil
+;;; (ti::d! word)
+ (tinydesk-line-property-set-error) ;put color on line
+ ;; Show to user that does not see the color
+ (move-to-column err-col t)
+ ;; Is the filename that long, that it goes past err-col ?
+ (cond
+ ((eq (point) (line-end-position))) ;do nothing
+ ((looking-at (concat "[ \t" c-chars "]"))
+ (kill-line)) ;delete other marks
+ (t ;no other choices. place is cccupied
+ (end-of-line)
+ (insert " "))) ;separate word
+ (insert (concat comment " invalid"))))
+ (forward-line 1))))))
+
+;;; ----------------------------------------------------------------------
+;;; - This function is not general.
+;;; #todo: rewrite it for this module only
+;;;
+(defun tinydesk-mark-region (beg end &optional com-re sub-level verb)
+ "Make all filenames in the buffer loadable by mouse.
+Supposes that the first _word_ on the line is filename.
+If the first word isn't loadable file, its face isn't changed.
+If there is no directory part, then `default-directory' is supposed.
+
+Input:
+
+ BEG END region
+
+ COM-RE the file can have comments, but comments can be only
+ _single span type_, that is, only shell like #, or C++
+ like //. Everything after and included COM-RE is discarded
+ from SUB-LEVEL.
+
+ SUB-LEVEL subexpression match; default is 0.
+
+ VERB verbose messages.
+
+Example:
+
+ Myfile.sh #comment
+
+ com-re = '.*\\\\(#\\\\)'
+ sub-level = 1 , because there is paren"
+ (let* ((err-col tinydesk-:message-column)
+ (file-face (tinydesk-face 'file-pick))
+ (sub-level (or sub-level 0))
+ (c-chars tinydesk-:comment-characters)
+ (comment (tinydesk-comment))
+ bp ep ;beg, end points
+ elp ;end line point
+ maxlp ;max line point
+ file)
+ (and verb ;this make take a while...
+ (message "TinyDesk: Marking files..."))
+ (save-restriction
+ (narrow-to-region beg end)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (if (looking-at "^[ \t]*$\\|$")
+ nil ;ignore empty lines
+ (setq elp (line-end-position))
+ (setq maxlp elp)
+ ;; Does there exist comment on the line ?
+ (save-excursion
+ (when (and (stringp com-re)
+ (looking-at com-re))
+ (setq maxlp (1- (match-beginning sub-level)))))
+ (if (< maxlp (1+ (point))) ;beg of line COMMENT exist
+ (progn
+;;; (ti::d! "skipped" (ti::read-current-line))
+ nil)
+ (skip-syntax-forward " " maxlp) ;ignore whitespace
+ (setq bp (point))
+
+ (skip-chars-forward "^ \t" maxlp) ;first space
+ (if (eq bp ep) ;not moved, maybe "one-word$" ?
+ (goto-char maxlp))
+ (setq ep (point))
+ (if (eq bp ep)
+ nil ;still not moved ?
+ ;; Mark the word only if the WORD is valid file
+ ;; - If the filename has ange-ftp @ char, then mark
+ ;; automatically. Calling file-exists-p for ange
+ ;; file would start ange-ftp... and we don't
+ ;; want that here.
+ (setq file (buffer-substring bp ep))
+ (setq file (tinydesk-file-name-absolute file))
+;;; (ti::d! bp ep (point) file )
+ (goto-char ep)
+ (if (looking-at "[ \t;]")
+ (delete-region (point) elp)) ;delete other marks
+ (cond
+ ((get-file-buffer file) ;already in Emacs ?
+ (move-to-column err-col t)
+ (if (not (looking-at (concat "$\\|[ \t" c-chars "]")))
+ (end-of-line)) ;no other choices, place is cccupied
+ (insert (concat comment " loaded")))
+ (t
+ ;; ............................... not loaded in Emacs ...
+ (if (or (string-match "@" file)
+ (file-exists-p file))
+ (put-text-property bp ep 'mouse-face file-face)))))))
+ (forward-line 1))
+ (set-buffer-modified-p nil)
+ (and verb ;this make take a while...
+ (message "TinyDesk: Marking files...ok")))))
+
+;;}}}
+;;{{{ code: mouse
+
+;;; ........................................................... &mouse ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydesk-mouse-load-file (event)
+ "Load file under mouse. Use mouse EVENT."
+ (interactive "e")
+ (mouse-set-point event) ;move point there
+ (tinydesk-load-file))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydesk-remove-file-coments ()
+ "Remove all comment at `tinydesk-:message-column'."
+ (interactive)
+ (ti::save-line-column-macro nil nil
+ (ti::pmin)
+ (while (re-search-forward (tinydesk-comment) nil t)
+ (if (eq (current-column) (+ 2 tinydesk-:message-column))
+ (delete-region (- (point) 2) (line-end-position))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydesk-expunge-unloaded ()
+ "Remove lines that have 'unloaded' flag."
+ (interactive)
+ (ti::save-line-column-macro nil nil
+ (ti::pmin)
+ (while (re-search-forward (format "%s unloaded$" (tinydesk-comment)) nil t)
+ (ti::buffer-kill-line))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydesk-unload-current-file ()
+ "Remove file on this line from Emacs."
+ (interactive)
+ (let* ((file (tinydesk-file-name-absolute
+ (tinydesk-read-word)))
+ buffer)
+ (when file
+ (if (setq buffer (find-buffer-visiting (expand-file-name file)))
+ (kill-buffer buffer)
+ (message "TinyDesk: No such buffer."))
+ (beginning-of-line)
+ (or (and (re-search-forward (tinydesk-comment) nil t)
+ (progn (delete-region (point) (line-end-position)) t))
+ (and (move-to-column tinydesk-:message-column t)
+ (insert ";;")))
+
+ (insert " unloaded")
+ (forward-line 1))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydesk-load-file ()
+ "Load file under point."
+ (interactive)
+ (let* (prop
+ word)
+ (setq prop (get-text-property (point) 'mouse-face))
+ (cond
+ (prop ;property found?
+ (setq word (tinydesk-file-name-absolute
+ (tinydesk-read-word))) ;read word under cursor
+ (cond
+ (word ;grabbed
+ (tinydesk-handle-text-property prop word))))
+ ((interactive-p)
+ (message
+ (substitute-command-keys
+ (concat
+ "TinyDesk: Can't find mouse face... Mark buffer first with "
+ "\\[tinydesk-mark-buffer-loadable]")))))))
+;;}}}
+;;{{{ code: edit, unload
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autolaod
+(defun tinydesk-unload (file &optional verb)
+ "Unload all files from Emacs that are in state file FILE.
+
+If VERB is non-nil offer verbose messages [for code calls]; interactive
+call always turns on verbose."
+
+ (interactive
+ (list
+ (let* ((save-dir (or (tinydesk-get-save-dir) "~/"))
+ (msg (concat "Unload from state file: ")))
+ (read-file-name msg save-dir))))
+ (let* ((b (tinydesk-tmp-buffer))
+ (dlist (tinydesk-dired-table))
+ (count 0)
+ (total 0)
+ buffer
+ elt
+ fn)
+ (ti::verb)
+ (with-current-buffer b
+ (erase-buffer)
+ (insert-file-contents file)
+ ;; - Now process every line. We don't care if we read commented
+ ;; line as "buffer" because the test inside loop return nil
+ ;; for such lines...
+ (ti::pmin)
+ (if (eobp)
+ (if verb
+ (message "TinyDesk: Empty state file."))
+ (while (not (eobp))
+ (beginning-of-line)
+ ;; - Expect Win32 or Unix absolute path name in line
+ ;; - find-buffer-visiting function can find files that
+ ;; may be symlinks.
+
+ (when (and (looking-at "[a-zA-Z]:/[^ \t\n\r]+\\|[~/][^ \t\n\r]+")
+ (setq fn (match-string 0))
+ (or (and (file-directory-p fn)
+ (setq elt (assoc (expand-file-name fn) dlist))
+ (setq buffer (nth 1 elt)))
+ (setq buffer (find-buffer-visiting fn))))
+ (with-current-buffer buffer
+ (cond
+ ((not (buffer-modified-p))
+ (kill-buffer (current-buffer))
+ (incf count))
+ (t
+ (message "Tinydesk: Buffer %s modified. Won't unload."
+ (buffer-name)))))
+ (incf total))
+ (forward-line))))
+ (when verb
+ (if (> count 0)
+ (message (format "TinyDesk: Removed %d/%d files. %s"
+ count
+ total
+ (if (equal count total)
+ ""
+ " Modified buffer not unloaded.")))
+ (message "TinyDesk: No files removed.")))
+ (tinydesk-trash)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autolaod
+(defun tinydesk-mode (&optional no-face verb)
+ "Mark and parse buffer's fist words as loada files.
+If NO-FACE is non-nil, the default mouse marking isn't performed. VERB.
+
+Comments in the right tell what is the files status:
+loaded = file inside Emacs already
+invalid = the path is invalid, no such file exists
+
+Mode description:
+
+\\{tinydesk-mode-map}"
+ (interactive "P")
+ (ti::verb)
+ ;; - If the file is already in buffer, remove extra marks, like
+ ;; non-loadable files.
+ (tinydesk-clear-region-properties (point-min) (point-max))
+ (tinydesk-remove-file-coments)
+ (if (null no-face)
+ (tinydesk-mark-buffer-loadable verb))
+ (tinydesk-mode-map-activate) ;turn on the map
+ (setq mode-name tinydesk-:mode-name)
+ (setq major-mode 'tinydesk-mode) ;; for C-h m
+ (when verb
+ (message
+ (substitute-command-keys
+ (concat
+ "load \\[tinydesk-load-file] "
+ "clear \\[tinydesk-clear-buffer-properties] "
+ "error \\[tinydesk-set-face-non-files-buffer] "
+ "mark \\[tinydesk-mark-buffer-loadable]")))
+ (sleep-for 1))
+ (run-hooks 'tinydesk-:mode-hook))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun turn-on-tinydesk-mode ()
+ "Turn on `tinydesk-mode'."
+ (interactive)
+ (tinydesk-mode))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun turn-on-tinydesk-mode-maybe ()
+ "Turn on `tinydesk-mode' if `tinydesk-:save-title' is found."
+ (interactive)
+ (let* ((string (substring
+ (or (eval tinydesk-:save-title)
+ "####No-string-available###")
+ 0 40)))
+ (save-excursion
+ (ti::pmin)
+ (when (re-search-forward
+ (concat "^" (regexp-quote string)) nil 'noerr)
+ (turn-on-tinydesk-mode)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun turn-off-tinydesk-mode ()
+ "Turn off `tinydesk-mode'."
+ (interactive)
+ (if (functionp default-major-mode)
+ (funcall default-major-mode)
+ (fundamental-mode)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autolaod
+(defun tinydesk-edit-state-file (file)
+ "Load state FILE into buffer for editing.
+You can add comments and remove/add files. Turns on `tinydesk-mode'.
+
+Following commands are available in `tinydesk-mode'.
+\\{tinydesk-mode-map}"
+ ;; I can't use interactive "f" , beacuse I want the completions
+ ;; to come from the save-directory. The "f" uses by default the
+ ;; variable default-directory...
+ (interactive
+ (list
+ (let* ((save-dir (tinydesk-get-save-dir))
+ (save-dir (if save-dir
+ save-dir
+ "./"))
+ (msg (concat "Edit state file: ")))
+ (read-file-name msg save-dir))))
+ ;; If file is already loaded, avoid creating duplicate window
+ (pop-to-buffer (find-file-noselect file))
+ (tinydesk-mode nil t))
+
+;;}}}
+;;{{{ code: save
+
+;;; ............................................................ &save ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydesk-get-save-files (&optional dirs)
+ "Return list of files to save, optionally DIRS too."
+ (let ( ;; See function tinydesk-dired-table for explanation
+ (sym 'dired-directory)
+ tmp
+ list)
+ (dolist (elt (buffer-list))
+ (with-current-buffer elt
+ (cond
+ ((and dirs
+ (eq major-mode 'dired-mode))
+ (push (symbol-value sym) list))
+ ((setq tmp (buffer-file-name))
+ (push tmp list)))))
+ list))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autolaod
+(defun tinydesk-save-state (file &optional mode files verb)
+ "Output all files in Emacs into FILE.
+Notice, that this concerns only buffers with filenames.
+
+Input:
+
+ FILE the STATE file being saved
+
+ MODE Control what is saved:
+ nil only filenames
+ '(4) \\[universal-argument], filenames and directories.
+ '(16) \\[universal-argument] \\[universal-argument], Use absolute paths to HOME.
+
+ FILES filenames , absolute ones. If nil then
+ `tinydesk-:get-save-file-function' is run to get files.
+ VERB verbose flag"
+ (interactive
+ (list (read-file-name "Save state to: " (tinydesk-get-save-dir))
+ current-prefix-arg))
+ (let* ((tmp-buffer (tinydesk-tmp-buffer 'clear))
+ (save-func tinydesk-:get-save-file-function)
+ (sort tinydesk-:save-and-sort)
+ (title tinydesk-:save-title)
+ (re-no tinydesk-:save-exclude-regexp)
+ (absolute-p (equal mode '(16)))
+ buffer)
+ (ti::verb)
+ (setq tinydesk-:directory-last (file-name-directory file))
+ ;; #todo: Kill buffer if it is not modified and reload it
+ ;; after save
+ (when (setq buffer (get-file-buffer file))
+ (pop-to-buffer buffer)
+ (error "\
+TinyDesk: State saving aborted. Please save to new file or kill buffer: %s" file ))
+ (run-hooks 'tinydesk-:save-before-hook)
+ (or files
+ (setq files (and (fboundp save-func)
+ (funcall save-func mode))))
+ (if (null files)
+ (if verb ;no files
+ (message "TinyDesk: no files to save"))
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... . do save . .
+ (if (or (null file)
+ (and (file-exists-p file)
+ (null (file-name-directory file))))
+ (error (format "TinyDesk: access problem with: '%s'" file)))
+ ;; We kill this buffer later, so we don't need save-excursion
+ (set-buffer tmp-buffer)
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... insert files . .
+ (dolist (elt files)
+ ;; Remove some files...
+ (if (or (not (stringp re-no))
+ (and (stringp re-no)
+ (not
+ (ti::string-match-case re-no elt))))
+ ;; win32 needs complete path name, not just ~/path/...
+ (insert
+ (if absolute-p
+ ;; Don't try to expand ange-ftp filenames. It would
+ ;; cause a ftp connections to be opened and that's slow....
+ (unless (ti::file-name-remote-p elt)
+ (expand-file-name elt))
+ (abbreviate-file-name elt))
+ "\n")))
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... ... sort . .
+ (if sort
+ (sort-lines nil (point-min) (point-max)))
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... ... title . .
+ (when title
+ (ti::pmin)
+ (insert (eval title)))
+ (run-hooks 'tinydesk-:save-after-hook)
+ (write-region (point-min) (point-max) file)
+ (not-modified) (message "")
+ (kill-buffer tmp-buffer)
+ (if (interactive-p)
+ (message (concat "TinyDesk: State saved to file " file)))
+ ;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ catch ^^^
+ nil)
+ (tinydesk-trash)))
+
+;;}}}
+;;{{{ code: recover
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydesk-rename-buffer-maybe ()
+ "Rename buffer it FILENAME-DIR if there is <N> in the buffer name.
+If two or more of the files are loaded into emacs with the same name
+from different directories:
+
+ ~/tmp/file.txt => buffer file.txt
+ ~/txt/file.txt => buffer file.txt<1>
+ ~/abc/file.txt => buffer file.txt<2>
+ ..
+
+This function will change the buffer names to include previous
+directory part, instead of the <N>, so that the names would read:
+
+ file.txt
+ file.txt-txt
+ file.txt-abc"
+ (interactive)
+ (when (and (string-match "<[0-9]+>$" (buffer-name))
+ (buffer-file-name))
+ (let* ((dir (file-name-directory (buffer-file-name)))
+ (file (file-name-nondirectory (buffer-file-name)))
+ (dir1 (replace-regexp-in-string
+ "/" "-"
+ (or (ti::string-match
+ (concat
+ ;; Get Two levels up
+ ".*\\([\\/][^\\/]+[\\/][^\\/]+\\)\\|"
+ ;; Or one level if only one directory
+ ".*\\([\\/][^\\/]+\\)")
+ 1
+ dir)
+ ""))))
+ (rename-buffer (format "%s-%s" file dir1)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydesk-find-file (file)
+ "Load FILE or `recover-file' as needed. Rename buffer if buffer<2>"
+ (with-current-buffer (find-file-noselect file)
+ (when (and (null (buffer-modified-p))
+ (file-exists-p (make-auto-save-file-name)))
+ ;; Can't use (recover-file file), because it asks confirmation.
+ ;; Emacs should have flag for suppressing questions.
+ (erase-buffer)
+ (insert-file-contents-literally (make-auto-save-file-name))
+ (set-buffer-modified-p t) ;Not strictly needed...
+ (message "TinyDesk: Recovered file %s"
+ (make-auto-save-file-name))
+ (tinydesk-rename-buffer-maybe)
+ ;; Return value
+ (current-buffer))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autolaod
+(defun tinydesk-recover-state (file &optional ulp pop verb)
+ "Load all files listed in FILE into Emacs.
+FILE can have empty lines or comments. No spaces allowed at the
+beginning of filename. The state FILE itself is not left inside
+Emacs if everything loads well. When all files are already
+in Emacs, you may see message '0 files loaded'.
+
+In case there were problems, the FILE will be shown and the
+problematic lines are highlighted.
+
+Prefix arg sets flag ULP, unload previous.
+
+Input:
+
+ FILE state file to load
+
+ ULP 'unload previous' if non-nil then unload previously
+ loaded files according to `tinydesk-:last-state-file'
+
+ POP if non-nil, then show (pop to) first buffer in saved
+ state file. This flag is set to t in interactive calls.
+
+ VERB non-nil enables verbose messages. This flag is set to
+ t in interactive calls.
+
+References:
+
+ `tinydesk-:last-state-file' Name of state file that was loaded.
+ `tinydesk-:recover-before-hook' Hook to run before state file processing.
+ `tinydesk-:recover-after-hook' Hook to run after state file processing."
+ (interactive
+ (list
+ (read-file-name "Tinydesk: load state file: "
+ (tinydesk-get-save-dir))
+ current-prefix-arg
+ t))
+ (let* ((count 0)
+ (state-file (expand-file-name file))
+ (last-state tinydesk-:last-state-file)
+ buffer
+ kill-buffer
+ err
+ not-loaded
+ ;; first-entry
+ list)
+ (ti::verb)
+ ;; o read the config file
+ ;; o raise the kill flag if the file ISN'T already loaded, user
+ ;; may be editing it.
+ ;; o There may be buffers with the same name, but different dirs..
+ (unless (setq buffer (get-file-buffer state-file))
+ (setq kill-buffer t) ;different directory
+ (unless (file-exists-p state-file)
+ (error "TinyDesk: file does not exist %s" state-file))
+ (setq buffer (find-file-noselect state-file)))
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... unload previous ...
+ (if (and ulp (stringp last-state))
+ (if (not (file-exists-p last-state))
+ (message
+ (format "TinyDesk: Cannot unload, file does not exist '%s' "
+ last-state))
+ (tinydesk-unload last-state)))
+ (with-current-buffer (ti::temp-buffer buffer)
+ (setq list (tinydesk-find-file-whole-buffer) ;; before hook
+ count (nth 0 list)
+ err (nth 1 list)
+ ;; first-entry (nth 3 list)
+ not-loaded (nth 2 list))
+ (cond
+ ((null err)
+ (if verb (message (format "TinyDesk: %d files loaded" count)))
+ (run-hooks 'tinydesk-:recover-after-hook)
+ ;; kill the buffer only if it was loaded by us
+ (and kill-buffer
+ (kill-buffer buffer)))
+ (t
+ ;; Show failed files
+ (message (concat "TinyDesk: Not loaded> " not-loaded))
+ (sleep-for 0)
+ (pop-to-buffer buffer)
+ (tinydesk-mode 'no-face 'verbosee)
+ (tinydesk-set-face-non-files-buffer)
+ (ti::pmin)))
+ (setq tinydesk-:last-state-file file))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autolaod
+(defun tinydesk-recover-last-state ()
+ "If Emacs was closed / crashed, recover last saved session.
+References:
+ `tinydesk-:auto-save-interval'
+ `tinydesk-:auto-save-name-function'"
+ (let ((file (tinydesk-auto-save-file-name)))
+ (if file
+ (tinydesk-recover-state file)
+ (message (concat
+ "TinyDesk: [WARN] Couldn't recover *last* state file."
+ "function `tinydesk-auto-save-file-name' returned nil")))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydesk-recover-file-whole-buffer (&optional verb)
+ "Call `tinydesk-find-file' with argument `recover'. VERB."
+ (interactive)
+ (save-excursion
+ (tinydesk-find-file-whole-buffer 'recover (ti::verb))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydesk-find-file-whole-buffer (&optional recover verb)
+ "Load all files listed in buffer. Point is not preserved.
+
+Input:
+
+ RECOVER Flag. If non-nil, use `recover-file' instead of `find-file'.
+ VERB Verbose flag.
+
+References:
+
+ `tinydesk-:loaded-file-list'
+ `tinydesk-:rejected-file-list'
+ `tinydesk-:recover-before-hook' Hook to run before state file processing.
+
+Return:
+
+ '(count err not-loaded-string first-entry)
+
+ count how many files actually loaded
+ err error while load
+ not-loaded-string files that had problems.
+ first-entry first entry"
+ (interactive "P")
+ (let* ((count 0)
+ (sub-level tinydesk-:comment-start-level)
+ (ignore-re (tinydesk-comment-re))
+ (empty-re "^[ \t]*$")
+ (msg-str (if recover
+ "Recovering"
+ "Loading"))
+ first-entry
+ bp
+ not-loaded
+ load ;file ont the line to be processed
+ maxp ;max point
+ word
+ err ;per file basis
+ ERR) ;return status
+ (ti::verb)
+ (setq tinydesk-:loaded-file-list nil ;<< reset GLOBALS
+ tinydesk-:rejected-file-list nil)
+ (run-hooks 'tinydesk-:recover-before-hook)
+ (ti::pmin) ;there is *no* save excursion
+ (while (not (eobp))
+ (setq bp (point) err nil) ;BEG of line
+ (setq maxp (line-end-position))
+ (beginning-of-line)
+ (catch 'next
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... .. comments ...
+ (if (looking-at empty-re) ;emty lines
+ (throw 'next t))
+ (when (and (looking-at ignore-re)
+ (match-beginning sub-level))
+ (setq maxp (match-beginning sub-level)))
+ (if (eq maxp bp) ;full comment line ?
+ (throw 'next t))
+ ;; ... ... ... ... ... ... ... ... ... ... ... read file name ...
+ ;; Now load the file, raise error if not loaded
+ ;; Remember that Windows fiels may contain spaces c:\Program Files\
+ (setq word (tinydesk-read-word))
+ ;; --``-- --``-- --``-- --``-- --``-- --``-- --``-- --``-- --``--
+ (when word
+ (setq load (expand-file-name word))
+;;; (ti::d! "buffer?" (get-file-buffer load) (ti::file-find-file-p load) load)
+ (when (or recover
+ (or load ;file grabbed from line
+ (not (get-file-buffer load)))) ;already in Emacs
+ (if (not (ti::file-find-file-p load))
+ (setq err t)
+ (when (condition-case nil
+ (progn
+ (if verb
+ (message "TinyDesk: %s %s..." msg-str load))
+ (tinydesk-find-file load)
+ t)
+ (error
+ (setq err t)
+ nil))
+ (setq count (1+ count))
+ (if (null first-entry)
+ (setq first-entry word))
+ (ti::nconc tinydesk-:loaded-file-list word)))))
+ ;; --``-- --``-- --``-- --``-- --``-- --``-- --``-- --``-- --``--
+ (when err
+ (setq ERR t)
+ (push word tinydesk-:rejected-file-list)
+ (and (interactive-p)
+ (tinydesk-line-property-set-error))
+ (setq not-loaded
+ (concat
+ (or not-loaded "") ;start value
+ (or
+ (file-name-nondirectory load)
+ "[nil-word]")
+ " ")))) ;catch line
+ (forward-line 1))
+ (if verb
+ (message "TinyDesk: %s...done" msg-str))
+;;; (ti::d! "load-end" count ERR not-loaded)
+ (list count ERR not-loaded first-entry)))
+
+;;}}}
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydesk-install (&optional uninstall)
+ "Install or UNINSTALL package."
+ (interactive "p")
+ (unless tinydesk-mode-map
+ (setq tinydesk-mode-map (make-sparse-keymap))
+ (run-hooks 'tinydesk-:mode-define-keys-hook))
+ (cond
+ (uninstall
+ (remove-hook 'write-file-hooks 'tinydesk-auto-save)
+ (remove-hook 'find-file-hooks 'turn-on-tinydesk-mode-maybe))
+ (t
+ (add-hook 'write-file-hooks 'tinydesk-auto-save)
+ (add-hook 'find-file-hooks 'turn-on-tinydesk-mode-maybe))))
+
+(tinydesk-install)
+
+(provide 'tinydesk)
+(run-hooks 'tinydesk-:load-hook)
+
+;;; tinydesk.el ends here
--- /dev/null
+;;; tinydiff.el --- Diff and patch minor mode. Browsing, patching.
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 1996-2007 Jari Aalto
+;; Keywords: tools
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program use ident(1) or call M-x
+;; tinydiff-version Look at the code with folding.el
+
+;; COPYRIGHT NOTICE
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;; ....................................................... &t-install ...
+;; Put this file on your Emacs-Lisp load path, add following into your
+;; ~/.emacs startup file
+;;
+;; Here is the very basic setup. You don't necessarily need to set
+;; these variables, because they are determined at startup.
+;;
+;; (setq tinydiff-:diff-program "gdiff") ;; GNU diff
+;; (setq tinydiff-:patch-program "gpatch -t") ;; GNU patch
+;;
+;; (require 'tinydiff)
+;;
+;; OR use this; your .emacs will load much quicker
+;;
+;; (autoload 'tinydiff-mode "tinydiff" "" t)
+;; (autoload 'turn-on-tinydiff-mode "tinydiff" "" t)
+;; (autoload 'tinydiff-diff "tinydiff" "" t)
+;; (autoload 'tinydiff-diff-show "tinydiff" "" t)
+;; (autoload 'tinydiff-diff-show-noask "tinydiff" "" t)
+;;
+;; Here are some suggested key bindings. Reserve The "d" for diff map.
+;;
+;; (global-set-key "\C-cmd" nil) ;; Initialize prefix key
+;; (global-set-key "\C-cmdd" 'tinydiff-mode)
+;; (global-set-key "\C-cmdd" 'tinydiff-diff-show)
+;; (global-set-key "\C-cmdp" 'tinydiff-patch)
+;;
+;; If you have any questions, use these functions
+;;
+;; M-x tinydiff-debug-toggle turn on debug
+;; <... do as you did ...>
+;; M-x tinydiff-submit-bug-report send bug report
+
+;;}}}
+;;{{{ Documentation
+
+;; ..................................................... &t-commentary ...
+
+;;; Commentary:
+
+;; Preface, jan 1996
+;;
+;; Long ago there was set of simple functions lying around to generate
+;; instant diffs for the file that was being edited, before it was
+;; checked in with RCS. At the time *vc.el* was not in the Emacs
+;; distribution. Looking at diffs and using "goto-line" command in
+;; other buffer gave an idea to make a separate diff mode. The project
+;; turned out to be a bit bigger than just taking simple diff. You may
+;; wonder, why would you use this utility over ediff.el? If you like
+;; working with "command line" diff interface, then you may want to
+;; use this utility over *ediff.el*. There is a command prompt when
+;; various diff options can be manipulated with key bindings. Lik:
+;; Change rcsdiff to diff command, copy previous argument etc.
+;;
+;; Overview of features
+;;
+;; Taking diff
+;;
+;; o Buffer based simple diff/rcsdiff/patch package.
+;; o You can diff current buffer against last saved backup copy.
+;; o Give and manipulate diff command in echo-area: file name
+;; completion; switching between rcsdiff/diff, guess rcs version
+;; for buffer, various diff switches...
+;;
+;; Browsing diff
+;;
+;; o Supported: normal diff, context diff, gnu diff -u, gnu diff -n
+;; o When you have diff output in buffer, turning on `tinydiff-mode'
+;; allows you to browse source buffer by jumping diff blocks fwd/back
+;; and showing the source location.
+;; o You can kill single diff block with `tinydiff-block-kill'
+;; o You can apply only the current diff block (patch) with
+;; `tinydiff-block-apply-patch'
+;;
+;; Sending or saving diff
+;;
+;; o In diff buffer, you can save the diff to a file with "W"; write
+;; o In diff buffer, you can attach the content as MIME diff to
+;; the open mail buffer. Or if you don't have MIME-edit active,
+;; the diff is added without MIME tags. Command "M" for Mime.
+;;
+;; Patch
+;;
+;; o Easy patching. Finds file to patch (along user defined paths)
+;; and applies the diff. You can receive patches by email
+;; and apply them with one or two keystrokes.
+;; o Finds the file to patch through pre defined paths.
+;; o Can also patch compresses .gz file.
+;; o loads patch rejection file, if patch didn't succeed 100%
+;; o Re-evaluates patched lisp file if the file was used by Emacs
+;; o If you don't want to apply whole diff, use
+;; `tinydiff-block-apply-patch' for individual sections.
+;;
+;; Genrating diff -- parsing diff
+;;
+;; Be in buffer where you have diff file and just turn on the
+;;
+;; M-x tinydiff-mode
+;;
+;; Then take a look at the bindings you have available:
+;;
+;; C-x b
+;;
+;; If you want to generate [rcs]diff for current buffer, call function
+;;
+;; M-x tinydiff-diff-show
+;;
+;; And it generates diff and puts you on `tinydiff-mode'. X window users and
+;; those that have the highlighting capabitities can enjoy more about
+;; this mode, because it marks line numbers in buffer with
+;; `mouse-face'. You just click the point to jump to diff position
+;;
+;; Taking diffs
+;;
+;; The main purpose of this module is to help you taking "diff shots",
+;; inside emacs. This means that the file must be loaded into
+;; emacs and your cursor must be in the buffers, before you execute
+;;
+;; M-x tinydiff-diff-show
+;;
+;; o If the file is not rcs controlled you're offered regular diff
+;; o if file is rcs controlled, your're offered rcsdiff prompt
+;; o if the buffer has changed, you're offered to diff against
+;; last saved file to see recent changes you have done since you
+;; saved the buffer.
+;;
+;; Command prompt
+;;
+;; The help key is on `?', press it to get summary of command while
+;; you're in minibuffer prompt. The command prompt in minibuffer looks
+;; like this for rcs controlled file.
+;;
+;; > cd /users/foo/dir1/dir2; rcsdiff -c -r1.21 test.txt
+;;
+;; You can edit this command as much as you like, but please leave `cd'
+;; `XXX' alone because the minibuffer commands expect it it be
+;; present. The hotkey command won't work without it.
+;;
+;; Command prompt: rcsdiff and diff toggle
+;;
+;; To conveniently construct diff command against another file, say
+;; test2.txt, you can hit key `C-z' to chage the prompt immediately to
+;;
+;; > cd /users/foo/dir1/dir2; diff -c test.txt
+;;
+;; And add the `test2.txt' to the end of line. If you want to restore
+;; the previous rcsdiff form, just hit `C-z' again. This `C-z'
+;; facility works only if the initial command was rcsdiff. There is no
+;; point of converting initial diff command to rcsdiff command though.
+;;
+;; Command prompt: tab completes file name
+;;
+;; While your're editing the command you can also use the TAB key to
+;; complete filename in the 'cd' command directory. If you specify any
+;; directories for the file, the directory's files are completed.
+;; That feature should allow you to get filenames into the prompt
+;; easily.
+;;
+;; Command prompt: diffing between two Rcs revisions
+;;
+;; There is also more commands, like `C-r' which changes
+;;
+;; > cd /users/foo/dir1/dir2; rcsdiff -c -r1.21 test.txt
+;;
+;; prompt so that it has now two -r commands. You can take diffs
+;; between two versions easily with it. The `C-r' key is a toggle.
+;;
+;; > cd /users/foo/dir1/dir2; rcsdiff -c -r1.21 -r1.21 test.txt
+;;
+;; Case study:
+;;
+;; You see nice package on the net. You download it ;; and notice that
+;; it needs some fixes. You put the original version ;; to your
+;; private rcstree with the same version number as what ;; the package
+;; had; say 2.2. Then you CheckOut the original, make ;; changes, and
+;; put it back to tree with version 2.2.1.1. You dont't ;; put it back
+;; with 2.3, because that's not your file. You made the ;; correction
+;; to 2.2, so you must make a branch.
+;;
+;; Okay. You have the original 2.2 and you have the fixed version
+;; 2.2.1.1 and you want to send the diff to the author. Here is how
+;; you do it
+;;
+;; o Be on the file buffer 2.2.1.1 and hit M-x tinydiff-dif
+;; o Hit `C-r' toggle second revision (previous) and edit the line
+;; to look "-r2.2 -r2.2.1.1". You are usually comparing _old_ and
+;; new_ versions.
+;; o Hit `C-s' to toggle between `-u' or `-c'. You normally want
+;; to send `-u' gnu unified diff, because it is more readable.
+;; Provided that the receiver has gnu patch to understand it.
+;; o Hit `C-f' to add option `tinydiff-:cl-user-option' which by
+;; default is `-kk'. From the rcsdiff(1) man pages you will
+;; see that it roughly means: "When you take diff between versions,
+;; ignore the rcs tag differencies". Confused? It means that
+;; the keywords that changed, like version, author, log ..
+;; when you deposited 2.2 and 2.2.1.1 are ignored.
+;;
+;; And hit enter. Then you get clean diff that you can send to author.
+;; And when he responds back or sends you new version, say 2.5,
+;; you repeat the whole process again if you intend to make more
+;; changes 8put original 2.5 on ice and make branch 2.5.1.1 for your
+;; changes)
+;;
+;; Command prompt: autosave and backup file diff
+;;
+;; Other helpfull commands insert he #autosaved# and backup~ filenames
+;; into the current point. Remember to put the # or ~ file to the left
+;; and not to the right. you do want to diff current file against the
+;; saved one; right? The first one is original prompt. That second is
+;; after `C-r' and latter after `C-v'
+;;
+;; > cd /users/foo/dir1/dir2; diff -c test.txt
+;; * point here
+;;
+;; > cd /users/foo/dir1/dir2; diff -c #test.txt# test.txt
+;; > cd /users/foo/dir1/dir2; diff -c ~/backup/test.txt~ test.txt
+;;
+;; Notice that your backup file may not reside int he same directory.
+;; The backupfilename is returned by function `make-backup-file'.
+;;
+;; Generated diff: the Prereq tag
+;;
+;; It is important that when you send diff, it is diff between two
+;; rcs versions if possible (if you're author of program). In those
+;; cases where revision information can be found, the diff data
+;; is preceeded with this line:
+;;
+;; Prereq: N.NN e.g. Prereq: 1.76
+;;
+;; If the receiving end has GNU patch, the patch program first checks
+;; if the version that person has is exactly N.NN and aborts if
+;; he had some other version. This prevent applying diffs that
+;; are meant to other versions. Regular Unix *patch* program
+;; does not notice the *Prereq:* tag, so consider getting more
+;; safer GNU version as soon as possible.
+;;
+;; Patching
+;;
+;; There is also included little patching function.
+;;
+;; M-x tinydiff-patch non verbose
+;; C-u M-x tinydiff-patch verbose
+;;
+;; For elisp (.el) files the `load-path' is automatically searched
+;; for possible destination of the patch. You can set variable
+;;
+;; tinydiff-:patch-list
+;;
+;; To match files and their associated patch directories if you
+;; receive patches for other files regularly. This function is most
+;; useful for RCS diffs, because they can be easily detected and the
+;; file information is also included in the diff.
+;;
+;; Patch: general notes
+;;
+;; Note: normally when `patch' program is called it always makes
+;; backup with the suffix .orig. So if you have applied a patch,
+;; then there is two file in the directory.
+;;
+;; FILE.txt -- patched file
+;; FILE.txt.orig -- original file, before the patch
+;;
+;; It also creates rejections file if all dind't go as planned.
+;;
+;; FILE.txt.rej
+;;
+;; Patch: success or failure
+;;
+;; When the patch has been applied, This package checks if all went
+;; well. If rejection file was created; then the patch process's
+;; output is shown and the rejection file is loaded so that you can
+;; see what possibly went wrong and if you should be concerned.
+;;
+;; If you get this rejection file, then there propably is potential
+;; trouble. Please contact the sender of patch immediately and tell
+;; about your troubles. There are few common reasons why patch failure
+;; happened.
+;;
+;; o Sender forgot `-kk' switch when he run rcsdiff to the file
+;; that was not owned by him (See RCS for details about `-kk')
+;; o Too few context, Sender should try increasing context with
+;; `-C' switch (like `-C7')
+;; o The patch were modified during email transit. Ask
+;; to send the patch with some encoded format: uuencode, base64,
+;; PGP encrypted or PGP base64 signed (clearsig off) format.
+;;
+;; Patch: what happens after success
+;;
+;; When the patch succeeds, there is a bit special handling for Emacs
+;; elisp packages. Say we recieve correction to the following module
+;; and you have it loaded in emacs: (feature 'foo) returns true.
+;;
+;; foo.el
+;;
+;; After patch is applied, you're asked if you want to reload the
+;; new release of *foo* module (just patched). You should answer
+;; `Yes' to get the newest one running in your Emacs immediately.
+;;
+;; Patch: after success, returning to original version
+;;
+;; If the patched version, which is usually new version of the progrmam
+;; doesn't work as it is supposed to, you can go back to the original
+;; version by appluing the same patch again. You should report what
+;; problems you had to the maintainer and inform that you wnet back
+;; to previous version.
+;;
+;; *IMPORTANT* If you did get the rejection file, you can't use that
+;; patch to go back to original!! See next chapter how to go to
+;; original version in that case
+;;
+;; Patch: rejection file created -- what to do?
+;;
+;; If you want to go back to original version, apply the same diff
+;; again; this reverses just applied patch. Just call `M-x'
+;; `tinydiff-patch' in the buffer where you have the diff.
+;;
+;; When you do that, the function detects that there is already a
+;; .orig file and prompts you to choose an appropriate action.
+;; Here is the explanation what they do and what should you choose
+;;
+;; Command _*o*_
+;;
+;; Go back to (o)riginal. This copies the FILE.txt.orig over the
+;; FILE.txt and deletes FILE.txt.orig and doesn't do _anything_
+;; else (stops the patching process). You're back to starting
+;; point as if you never patched anything.
+;;
+;; Command _*r*_
+;;
+;; (R)etry means that the FILE.txt.orig is copied over FILE.txt and the
+;; pach is tried again for FILE.txt. You may have asked the author to
+;; send more context with using the -C10 switch and after you received
+;; this new patch you want to try if it now goes ok. The FILE.txt.orig
+;; still remains as a backup
+;;
+;; Command _*g*_
+;;
+;; (G)o says that we should apply the diff again to FILE.txt. Do this
+;; only if you did not get rejections last time. The intention
+;; is that you apply the patch again, and this reverses the situation.
+;; I mean 1) you patch; you get new version 2) you patch again: you
+;; degrade to the version before patch (original file before patch)
+;;
+;; Development note
+;;
+;; There is `ediff.el', which is much more complete package than
+;; this is. The aim was to develop a simple but handy package for
+;; everyday diff'ing and easy package patching.
+;;
+;; Bugs
+;;
+;; The "f" key, which shows the function identifier in diff browse
+;; mode `tinydiff-mode', can handle buffers which are narrowed, but if the
+;; buffer is using folding.el or similar package where goto-line does
+;; not work properly, the returned message shown to user is not
+;; correct.
+;;
+;; Please unfold the buffer and you get the correct result.
+;;
+;; Example
+;;
+;; This hook setup turns on the view mode for easy scrolling
+;; of buffer.
+;;
+;; (add-hook 'tinydiff-:diff-hook 'my-tinydiff-diff-hook)
+;;
+;; (defun my-tinydiff-diff-hook ()
+;; "Turn on view-mode in diff buffer."
+;; ;; See tinydiff-:diff-buffer.
+;; (view-mode 1))
+;;
+;; Sending good bug reports
+;;
+;; If you find anything funny happening in the command line prompt
+;; while you use the tdi minibuffer commands. Immediately do
+;; following.
+;;
+;; o Turn on debug: `M-x' `tinydiff-debug-toggle'
+;; o Turn on emacs debug: (setq debug-on-error t)
+;; o Clear the debug buffer *tinydiff-debug* if it exists
+;; o Start from original situation
+;; o Do what you did and when the weird condition is met
+;; immediately go to *tinydiff-debug* buffer and save the
+;; content and send it to the maintainer.
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+;;{{{ setup: require
+
+;;; ......................................................... &require ...
+
+;; make sure this is loaded so that the `tinydiff-mode' map can redefine
+;; keys "n" and "p"
+
+(require 'tinylibm)
+
+(eval-and-compile
+ (ti::package-use-dynamic-compilation)
+ (ti::package-require-view)
+ (defvar diff-command) ;; Byte compiler silencer
+ (defvar ediff-diff-program) ;; Byte compiler silencer
+ (autoload 'dired-get-filename "dired" "" t))
+
+(ti::package-defgroup-tiny TinyDiff tinydiff-: tools
+ "Take buffer diffs easily, browse diff and apply patch.
+ Overview of features.
+
+ o Buffer based simple diff/rcsdiff/patch package.
+ o You cab diff current buffer against last saved backup copy.
+ o Give and manipulate diff command in echo-area: file name
+ completion; switching between rcsdiff/diff, guess rcs version
+ for buffer ...
+ o When you have diff output in buffer, turning on `tinydiff-mode'
+ allows you to browse source buffer by jumping diff blocks fwd/back
+ and showing the source location.
+ o Supported: normal diff, context diff, gnu diff -u, gnu diff -n
+ o Easy patching. Finds file to patch (along user defined paths)
+ and applies the diff. You can receive patches by email
+ and apply them with one or two keystrokes.
+ o loads patch rejection file, if patch didn't succeed 100%")
+
+;;}}}
+;;{{{ setup: hooks
+
+;;; ......................................................... &v-hooks ...
+
+(defcustom tinydiff-:load-hook nil
+ "*Hook that is run when package is loaded."
+ :type 'hook
+ :group 'TinyDiff)
+
+(defcustom tinydiff-:diff-hook nil
+ "*Hooks that run after successful diff run."
+ :type 'hook
+ :group 'TinyDiff)
+
+(defcustom tinydiff-:mode-define-keys-minibuffer-hook
+ 'tinydiff-mode-define-keys-minibuffer-default
+ "*Function to define the keys for the minibuffer."
+ :type 'hook
+ :group 'TinyDiff)
+
+(defcustom tinydiff-:parse-buffer-hook nil
+ "Function called when diff buffer has been parsed. (highight)."
+ :type 'hook
+ :group 'TinyDiff)
+
+;;}}}
+;;{{{ setup: variables
+
+;;; ........................................................ &v-public ...
+;;; User configurable
+
+(defcustom tinydiff-:auto-mode-alist
+ '(("\\.diff\\'" . turn-on-tinydiff-mode)
+ ("\\.patch\\'" . turn-on-tinydiff-mode))
+ "Items to add to `auto-mode-alist' to activate `turn-on-tinydiff-mode'."
+ :type '(repeat
+ (list
+ (string :tag "File Regexp")
+ (const turn-on-tinydiff-mode)))
+ :group 'TinyDiff)
+
+;; We need this function in defvar; so instantiate it for compiler
+;; to use it.
+;;
+(eval-and-compile
+
+ (defun tinydiff-find-program (program-list default opt seek-option)
+ "Try to use GNU program. Return program name.
+Input:
+
+ PROGRAM-LIST list of program binaries to try (gnu)
+ DEFAULT if no gnu binary found, use DEFAULT binary
+ OPT additional option for binary
+ SEEK-OPTION When GNU product, it must know this option."
+ (let* ((exec-path exec-path)
+ (ret default)
+ gnu
+ path)
+ ;; Give precedence to GNU diff programs
+ (dolist (path '("/opt/local/bin/" "/usr/local/bin/"))
+ (if (file-directory-p path)
+ (push path exec-path )))
+ (if path
+ (setq path t)) ;XEmacs ByteCom silencer, no-op
+ (with-temp-buffer
+ ;; Select gnu if possible
+ (dolist (prg program-list)
+ (message "TinyDiff: Please wait. Searching for binary `%s'" prg)
+ (when (setq path (executable-find prg))
+ (call-process prg
+ nil
+ (current-buffer)
+ nil
+ seek-option)
+ (when (ti::re-search-check seek-option)
+ (setq gnu path)
+ (return))))
+ (if gnu
+ (setq ret gnu)
+ (message "TinyDiff: Hm, no GNU %s, but using it anyway" default)
+ (sit-for 1))
+ (set-buffer-modified-p nil)
+ ret)))) ;; eval-end
+
+;; Different users may want to set the keys differently.
+;; You could say
+;;
+;; (setq tinydiff-:diff-program (progn (my-diff-program-select)))
+;;
+;; Which would return appropriate diff program: maybe you want to use
+;; GNU diff for some files and normal diff other times.
+;; GNU diff offers line exlude options that you may want
+;; to set for RCS files.
+
+(defcustom tinydiff-:diff-program
+ (cond
+ ((and (boundp 'diff-command)
+ diff-command)
+ diff-command)
+ ((and (boundp 'ediff-diff-program)
+ ediff-diff-program)
+ ediff-diff-program)
+ ((ti::os-check-gnu-support-p)
+ "diff")
+ (t
+ (or (tinydiff-find-program '("gdiff" "diff") "diff" nil "--help")
+ "diff")))
+ "*Program to generate diff.
+It should print 'filename: FILE.XXX' tag which is read by function
+`tinydiff-get-buffer-name'. The variable can contain a Lisp expression
+which returns program name."
+ :type '(string :tag "Shell command")
+ :group 'TinyDiff)
+
+(defcustom tinydiff-:rcsdiff-program "rcsdiff"
+ "*Shell program to print RCS diff.
+It should output the 'filename: FILE' which is read by `tinydiff-get-buffer-name'.
+This variable is evaled to get the program name."
+ :type '(string :tag "Shell program")
+ :group 'TinyDiff)
+
+(defcustom tinydiff-:cvsdiff-program "cvs diff"
+ "*Shell command to print CVS diff."
+ :type '(string :tag "Command")
+ :group 'TinyDiff)
+
+;; The diff-switches is defined at least in vc.el
+
+(defcustom tinydiff-:diff-option
+ '(or (and (boundp 'diff-switches)
+ (stringp diff-switches)
+ diff-switches)
+ (and (ti::os-check-gnu-support-p)
+ "-u")
+ "-c")
+ "*Diff options as STRING.
+This variable is evaled to get the options, so it can contain Lisp
+FORM that returns option string."
+
+ :type '(string :tag "Options")
+ :group 'TinyDiff)
+
+(defcustom tinydiff-:cl-user-option "-kk"
+ "The option inserted or removed when user presses C - s in command line.
+The default option -kk is only meaningful on rcsdiff command where
+it excludes the rcs tags from diff."
+ :type 'string
+ :group 'TinyDiff)
+
+(defcustom tinydiff-:diff-tmp-file
+ (or (let ((temp (or (getenv "TEMPDIR")
+ (getenv "TMP")))
+ (file "tinydiff.diff"))
+ (dolist (dir (list
+ "~/tmp"
+ "~/temp"
+ "/tmp"
+ temp ;; this may be nil
+ "c:/tmp"
+ "c:/temp"
+ "c:/winnt/tmp"
+ "c:/windows/temp"))
+ (when (and (stringp dir)
+ (file-directory-p dir))
+ (return (concat (file-name-as-directory dir) file)))))
+ (error "TinyDiff: Please set tinydiff-:diff-tmp-file"))
+ "*Temporary file where the diff is stored for patching."
+ :type 'file
+ :group 'TinyDiff)
+
+(defcustom tinydiff-:patch-program
+ (if (ti::os-check-gnu-support-p)
+ ;; We Know this is GNU patch, do not search alternatives
+ ;; gnu patch : -t, --batch
+ ;; similar to -f, in that it suppresses questions,
+ ;; skip patches for which a file to patch can't be found
+ ;;
+ ;; Note: OLD patch command doesn not know -t switch!
+ "patch -t -N -F 3"
+ (tinydiff-find-program
+ '("gpatch" "patch")
+ "patch"
+ "-t -N -F 3"
+ "--help"))
+ "*Patch command and its options.
+This variable is evaluated to get the program name and switches."
+ :type '(string :tag "shell command")
+ :group 'TinyDiff)
+
+(defcustom tinydiff-:patch-list
+ '(( "[.]el$" load-path)
+ ( "." '("~/txt" "~/elisp")))
+ "*List of item that control how patching is applied.
+The list form is:
+
+ '((REGEXP EVAL-FORM) (REGEXP EVAL-FORM) ..)
+
+Where REGEXP is tried against the filename that is found from the patch
+itself. EVAL-FORM can be any form that return list of pathnames that can
+be searched for the filename. The first file that is found from the path
+is used."
+ :type '(repeat
+ (list
+ (string :tag "Regexp")
+ directory))
+ :group 'TinyDiff)
+
+(defcustom tinydiff-:font-lock-keywords
+ '(
+
+ ;; RCS diff
+
+ ("RCS file: +\\(.*\\)" 1 'highlight)
+ ("retrieving revision +\\(.*\\)" 1 'highlight)
+
+ ;; Lisp: "defun NAME" etc.
+
+ ("(def[^(\n]+" 0 font-lock-reference-face)
+ ("(interactive.*)" 0 font-lock-type-face)
+
+ ;; Lisp: some tokens
+
+ ("(\\(let\\|cond\\|when\\|unless\\|save-.*\\|with-.*\\)"
+ 1 font-lock-keyword-face))
+ "Font lock keywords."
+ :type 'sexp
+ :group 'TinyDiff)
+
+;;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. . misc . .
+
+(defcustom tinydiff-:register-function-name ?f
+ "*Register used to store the function name.
+Only used if `tinydiff-:function-name-handle-function' is set to
+'tinydiff-function-name-store."
+ :type 'character
+ :group 'TinyDiff)
+
+;; The diff data is inserted into register automatically, because
+;; many time the diff data is needed elswhere.
+
+(defcustom tinydiff-:register-diff ?d
+ "*Register name where diff is inserted.
+If this variable is nil, then no data is inserted into register.
+
+Variable is evaled to get the register name."
+ :type 'character
+ :group 'TinyDiff)
+
+;;; ......................................................... &v-funcs ...
+
+(defcustom tinydiff-:mail-buffer-function 'ti::mail-get-buffer
+ "Return some mail buffer for function `tinydiff-mime-compose'.
+Default value is `ti::mail-get-buffer'."
+ :type 'function
+ :group 'TinyDiff)
+
+(defcustom tinydiff-:find-ref-function 'beginning-of-defun
+ "*Elisp Function to find underlying code's function name around point.
+The cursor is positioned in the source buffer and on the referenced
+line before calling with no arguments. Function should move the point
+in the line below where the associated reference is located.
+
+If no reference is found, function _must_ call 'error'."
+ :type 'function
+ :group 'TinyDiff)
+
+;; - It's great to paste the function name into buffer.
+;; - C-x g REG put the name into current buffer...
+
+(defcustom tinydiff-:function-name-handle-function 'tinydiff-function-name-store
+ "*Function which find the code's function name string.
+
+Input args to function:
+
+ POINT where the `tinydiff-:find-ref-function' positioned the defun.
+ This function should store the function name into register
+ `tinydiff-:register-function-name'."
+ :type 'function
+ :group 'TinyDiff)
+
+(defcustom tinydiff-:source-buffer-function 'tinydiff-get-buffer-name
+ "*Function which return filename for the diff buffer.
+You shouldn't touch this function unless you're coping with very
+strange diff format. Default function is `tinydiff-get-buffer-name'."
+ :type 'function
+ :group 'TinyDiff)
+
+;;}}}
+;;{{{ setup: private
+
+;;; ....................................................... &v-private ...
+
+(defvar tinydiff-:patch-global-option nil
+ "Path options in effect. See `tinydiff-patch-set-option'.")
+
+(defvar tinydiff-:patch-reject-buffer "*tinydiff-patch-rejects"
+ "Buffer where to display rejected patch parts.")
+
+(defvar tinydiff-:diff-source-buffer nil
+ "Private. Source buffer for diff. See `tinydiff-:source-buffer-function'.")
+(make-variable-buffer-local 'tinydiff-:diff-source-buffer)
+
+(defvar tinydiff-:last-data nil
+ "Private. Data storage eg in `tinydiff-minibuffer--change-diff-command'.")
+
+(defvar tinydiff-:version-list nil
+ "All Version for file. Updated when diff command is being run.")
+
+(defvar tinydiff-:version-branch-list nil
+ "Branches. Updated when diff command is being run.")
+
+(defvar tinydiff-:diff-tmp-buffer "*tinydiff-tmp*"
+ "Temporary work buffer, patch shell results.")
+
+(defvar tinydiff-:patch-tmp-buffer " *tinydiff-tmp-patch*"
+ "Temporary work buffer, patch.")
+
+(defvar tinydiff-:package-exist-tinymy (locate-library "tinymy.el")
+ "Private. Has load path for package tinymy.el if it exist.
+It has some functions we may use from there.")
+
+(defvar tinydiff-:diff-buffer "*diff*"
+ "Buffer where diff is inserted.")
+
+(defvar tinydiff-:patch-to-file nil
+ "Name of the file to patch.
+This variable is made local to current patch/diff buffer.")
+
+(defvar tinydiff-:patch-hunk-count nil
+ "Counter how many patch hunks hvae been applied
+This variable is made local to current patch/diff buffer.")
+
+;;}}}
+;;{{{ setup: version
+
+;;; ....................................................... &v-version ...
+
+;;;###autoload (autoload 'tinydiff-version "tinydiff" "Display commentary." t)
+
+(eval-and-compile
+ (ti::macrof-version-bug-report
+ "tinydiff.el"
+ "tinydiff"
+ tinydiff-:version-id
+ "$Id: tinydiff.el,v 2.83 2007/05/01 17:20:43 jaalto Exp $"
+ '(tinydiff-:version-id
+ tinydiff-:debug
+ tinydiff-:load-hook
+ tinydiff-:mode-hook
+ tinydiff-:diff-hook
+ tinydiff-:mode-name
+ tinydiff-:diff-program
+ tinydiff-:rcsdiff-program
+ tinydiff-:cvsdiff-program
+ tinydiff-:source-buffer-function
+ tinydiff-:function-name-handle-function
+ tinydiff-:register-function-name
+ tinydiff-:find-ref-function
+ tinydiff-:source-buffer-function
+ tinydiff-:mode-define-keys-hook
+ tinydiff-:register-diff
+ tinydiff-:diff-buffer
+ tinydiff-:diff-option
+ tinydiff-:diff-tmp-file
+ tinydiff-:diff-tmp-buffer
+ tinydiff-:patch-global-option
+ tinydiff-:patch-program)
+ '(tinydiff-:debug-buffer)))
+
+;;}}}
+;;{{{ code: minor mode definition
+
+;;; ............................................................ &mode ...
+
+(defvar tinydiff-:minibuffer-map nil
+ "Minibuffer key map when asked for the right diff command.")
+
+;;;###autoload (autoload 'tinydiff-mode "tinydiff" "" t)
+;;;###autoload (autoload 'turn-on-tinydiff-mode "tinydiff" "" t)
+;;;###autoload (autoload 'turn-off-tinydiff-mode "tinydiff" "" t)
+;;;###autoload (autoload 'tinydiff-commentary "tinydiff" "" t)
+
+(eval-and-compile
+ (ti::macrof-minor-mode-wizard
+ "tinydiff-" " Tdi" nil " Tdiff" 'TinyDiff "tinydiff-:" ;1-6
+
+ "Diff browsing minor mode.
+
+Defined keys:
+
+\\{tinydiff-:mode-map}"
+
+ "Diff minor mode"
+
+ nil
+
+ "Diff browsing mode"
+
+ (list
+ tinydiff-:mode-easymenu-name
+ ["goto current point" tinydiff-goto-kbd t]
+ ["block forward" tinydiff-goto-next t]
+ ["block forward, no update" tinydiff-goto-next-no-update t]
+ ["block backward" tinydiff-goto-prev t]
+ ["block backward, no update" tinydiff-goto-prev-no-update t]
+ ["Set patch option" tinydiff-patch-set-option t]
+ "----"
+ ["Parse buffer" tinydiff-parse-buffer t]
+ ["Set source buffer for diff" tinydiff-set-source-buffer t]
+ ["Show function name" tinydiff-show-function-name t]
+ "----"
+ ;; ["Keyboard menu" tinydiff-menu-main t]
+ ["Package version" tinydiff-version t]
+ ["Package commentary" tinydiff-commentary t]
+ ["Mode help" tinydiff-mode-help t]
+ ["Mode off" tinydiff-mode t])
+
+ (progn
+
+ ;; I first thought to put goto line into " " or "\C-m"
+ ;; That is: SPACE or RETURN, but later realized that they were
+ ;; used in view-mode to scroll buffer up-down.
+ ;;
+ ;; Eg. in my setup whenever I turn on the read-only
+ ;; with C-x C-q it also automatically turns on view-mode for
+ ;; easy scrolling...
+ ;;
+
+ ;; This happens to be unsifted in HP-UX, a top-leftmost button.
+ ;; Select something that suit you more...
+
+ (define-key root-map "\C-m" 'tinydiff-goto-kbd)
+
+ (define-key root-map "e" 'tinydiff-parse-buffer)
+ (define-key root-map "!" 'tinydiff-set-source-buffer)
+ (define-key root-map "n" 'tinydiff-goto-next)
+ (define-key root-map "p" 'tinydiff-goto-prev)
+
+ ;; These are borrewd from unix more(1) and less(1)
+
+ (define-key root-map "y" 'tinydiff-goto-prev-no-update)
+ (define-key root-map "b" 'tinydiff-goto-next-no-update)
+
+ ;; But perhaps user feels more comfortable with these.
+
+ (define-key root-map "P" 'tinydiff-goto-prev-no-update)
+ (define-key root-map "B" 'tinydiff-goto-next-no-update)
+
+ (define-key root-map "f" 'tinydiff-show-function-name)
+
+ (define-key root-map "W" 'tinydiff-write-file)
+ (define-key root-map "M" 'tinydiff-mime-compose)
+ (define-key root-map "O" 'tinydiff-patch-set-option)
+
+ (define-key root-map "-k" 'tinydiff-block-kill)
+ (define-key root-map "-\C-?" 'tinydiff-block-kill) ;; backspace
+ (define-key root-map "--" 'tinydiff-block-apply-patch)
+
+ (define-key map "?" 'tinydiff-mode-help)
+ (define-key map "Hm" 'tinydiff-mode-help)
+ (define-key map "Hc" 'tinydiff-commentary)
+ (define-key map "Hv" 'tinydiff-version)
+
+ (if (ti::emacs-p)
+ (define-key root-map [mouse-2] 'tinydiff-goto-mouse)
+ (define-key root-map [(button2)] 'tinydiff-goto-mouse)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydiff-install (&optional uninstall)
+ "Install TinyDiff package, or optionally UNINSTALL.
+A .diff or .patch file invokes `tinydiff-mode' in `automode-alist'."
+ (interactive "P")
+ (cond
+ (uninstall
+ (ti::assoc-replace-maybe-add
+ 'auto-mode-alist tinydiff-:auto-mode-alist 'remove))
+ (t
+ (ti::assoc-replace-maybe-add
+ 'auto-mode-alist tinydiff-:auto-mode-alist)
+ (if (interactive-p)
+ (message "TinyDiff installed")))))
+
+;;}}}
+;;{{{ code: keymap
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydiff-mode-define-keys-minibuffer-default ()
+ "This function defines some extra bindings to minibuffer.
+Eg. TAB that completes current filename."
+ (setq tinydiff-:minibuffer-map (copy-keymap minibuffer-local-map))
+ ;;
+ ;; Here we define nice tab filename completion inside minibuffer
+ ;; This may be superflous, but what the heck :-)
+ ;;
+ (define-key tinydiff-:minibuffer-map "\t"
+ 'tinydiff-minibuffer--complete-filename)
+ (define-key tinydiff-:minibuffer-map [(kp-tab)]
+ 'tinydiff-minibuffer--complete-filename)
+ ;;
+ ;; More command line handling
+ ;;
+ ;; There is no logic in naming the key settings other than
+ ;; simple rule: they must me as lower left as possible
+ ;; to be reached quickly.
+ ;;
+ ;; You won't need any of these in echo area prompt
+ ;;
+ (define-key tinydiff-:minibuffer-map "\C-z"
+ 'tinydiff-minibuffer--change-diff-command)
+ (define-key tinydiff-:minibuffer-map "\C-r"
+ 'tinydiff-minibuffer--rev-add-command)
+ (define-key tinydiff-:minibuffer-map "\C-c"
+ 'tinydiff-minibuffer--insert-file-autosave)
+ (define-key tinydiff-:minibuffer-map "\C-v"
+ 'tinydiff-minibuffer--insert-file-backup)
+ (define-key tinydiff-:minibuffer-map "\C-s"
+ 'tinydiff-minibuffer--toggle-diff-type)
+ (define-key tinydiff-:minibuffer-map "\C-f"
+ 'tinydiff-minibuffer--user-option)
+ (define-key tinydiff-:minibuffer-map "\C-p"
+ 'tinydiff-minibuffer--insert-previous-word)
+ (define-key tinydiff-:minibuffer-map "?"
+ 'tinydiff-minibuffer--minibuffer-help))
+
+;;}}}
+;;{{{ code: misc
+
+;;; ............................................................ &misc ...
+
+;;;###autoload (autoload 'tinydiff-debug-toggle "tinydiff" "" t)
+
+(eval-and-compile (ti::macrof-debug-standard "tinydiff" "-:"))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinydiff-kill-revision-list ()
+ "Deletes private version lists."
+ (setq tinydiff-:version-list nil
+ tinydiff-:version-branch-list nil))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydiff-splice-command (string)
+ "Splice off directory from string and return '(DIR CMD REST)"
+ (when (string-match
+ (concat
+ "cd[ \t]+\\([^;]+\\);" ;; dir
+ "[ \t]*\\([^ \t\r\n]+\\)" ;; cmd
+ "[ \t]+\\(.+\\)") ;; rest
+ string)
+ (list
+ ;; Delete trailing whitespace
+ (replace-regexp-in-string "[ \t\r\n]+$" ""
+ (match-string 1 string))
+ (match-string 2 string)
+ (match-string 3 string))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydiff-shell-command (cmd buffer)
+ "Run CMD and output to BUFFER.
+The passed CMD must be in the format:
+
+ cd DIRECTORY; BINARY option option option ...."
+ (let* ((fid "tinydiff-shell-command"))
+ (multiple-value-bind (dir cmd rest)
+ (tinydiff-splice-command cmd)
+ (when (or (not dir)
+ (not (file-directory-p dir)))
+ (error "Tinydiff: No directory found `%s'" dir))
+ (let ((default-directory (file-name-as-directory dir)))
+ (tinydiff-debug fid
+ 'default-directory default-directory
+ 'cmd cmd
+ 'rest rest
+ 'buffer buffer)
+ (setq buffer (get-buffer-create buffer))
+ (let* (args
+ (rargs (reverse (split-string rest)))
+ (file2 (expand-file-name (pop rargs)))
+ (file1 (expand-file-name (pop rargs))))
+ (push file1 rargs)
+ (push file2 rargs)
+ (setq args (reverse rargs))
+ (tinydiff-debug fid 'CMD cmd 'FILE1 file1 'FILE2 file2)
+ (apply 'call-process
+ cmd
+ nil
+ buffer
+ nil
+ args))
+ (when (or (null buffer)
+ (null (get-buffer buffer))
+ (not (buffer-live-p buffer)))
+ (error "TinyDiff: Shell dind't return results [ %s ]" cmd))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydiff-update-revision-list (file &optional version)
+ "Read all revision numbers for FILE starting from VERSION."
+ (let* ((fid "tinydiff-update-revision-list: ")
+ (ver (or version "1.1"))
+ (dots (count-char-in-string ?. ver)))
+ (unless fid ;; XEmacs byte compiler silencer
+ (setq fid nil))
+ (when (null tinydiff-:version-list)
+ (tinydiff-debug fid ver dots)
+ (setq tinydiff-:version-list (ti::vc-rcs-all-versions file)))
+ (when (or (null tinydiff-:version-branch-list)
+ ;; Chck that there is right brach list
+ ;; "1.1" -- "1.1.1.1" ?
+ (not (eq dots
+ (count-char-in-string
+ ?.
+ (car tinydiff-:version-branch-list)))))
+ (setq tinydiff-:version-branch-list
+ (ti::vc-rcs-get-all-branches
+ ver tinydiff-:version-list))
+ (tinydiff-debug fid "ver" version))
+ tinydiff-:version-list))
+
+;;; ----------------------------------------------------------------------
+;;; - Doing the version getting is SLOW with lisp. Use some external
+;;; shell program to do the job for you. It is MUCH quicker.
+;;;
+(defun tinydiff-rcs-diff-between-versions (dir file)
+ "Return VC diff command that diffs current version and previous version.
+DIR and FILE is passed to function."
+ (interactive)
+ (let* ((ver (ti::vc-rcs-buffer-version))
+ v-list
+ ret
+ prev)
+ (if (null ver)
+ (error "TinyDiff: Cannot find version number."))
+ (setq v-list (tinydiff-update-revision-list (concat dir file)))
+ (setq prev (ti::vc-rcs-previous-version ver v-list))
+ (if (null prev)
+ (error "TinyDiff: Cannot find previous version number."))
+ (setq ret
+ (format "cd %s; %s -r%s -r%s %s %s "
+ dir
+ (if (ti::vc-rcs-file-exists-p file)
+ tinydiff-:rcsdiff-program
+ tinydiff-:cvsdiff-program)
+ prev ver
+ (or (eval tinydiff-:diff-option)
+ "")
+ file))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinydiff-source ()
+ "Return source buffer of diff."
+ (if (and tinydiff-:diff-source-buffer
+ (buffer-live-p (get-buffer tinydiff-:diff-source-buffer)))
+ tinydiff-:diff-source-buffer
+ (setq tinydiff-:diff-source-buffer
+ (funcall tinydiff-:source-buffer-function))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydiff-set-source-buffer (buffer)
+ "Set source BUFFER for current diff."
+ (interactive "bSource buffer: ")
+ (if (not (get-buffer buffer))
+ (error "TinyDiff: Buffer does not exist")
+ (setq tinydiff-:diff-source-buffer buffer)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydiff-function-name-store (line)
+ "Store found function name from LINE into `tinydiff-:register-function-name'.
+Currently works well only Lisp functions."
+ (let* ((reg tinydiff-:register-function-name)
+ (mode (symbol-name major-mode))
+ txt)
+ (when (string-match "lisp" mode)
+ ;; try to extract symbol-name
+ ;; see tinydiff-get-function-name, because point sits on DEFUN already
+ ;; and the ti::buffer-defun-function-name searches it again..
+ (forward-line 1))
+ (setq txt (ti::buffer-defun-function-name))
+ (when reg
+ (if txt
+ (set-register reg txt)
+ ;; empty it
+ (set-register reg "")))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydiff-get-function-name (buffer line)
+ "Return function or variable name at current point.
+Switches to BUFFER and go to LINE and calls `beginning-of-defun'"
+ (let* ((func tinydiff-:function-name-handle-function)
+ (find-func tinydiff-:find-ref-function)
+ (max-leap 100) ;lines
+ point
+ ret)
+ (with-current-buffer buffer
+ (ti::widen-safe
+ (goto-line line)
+ (ignore-errors
+ (setq point (point))
+ (funcall find-func) ;exit , if error generated
+ ;; Let's be little intelligent
+ (if (< (count-lines (point) point) max-leap)
+ ;; Okay, we believe that function was found
+ (setq ret (ti::read-current-line))
+ ;; Can't be that far away... reset the pointer
+ (goto-char point))
+ (if func
+ (setq ret (funcall func (point))))) ;; ignore-errors
+ ret))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydiff-show-function-name (&rest args)
+ "Show possible function name in mode line on the current diff point. ARGS."
+ (interactive)
+ (let* ((line (tinydiff-get-line-number))
+ (buffer (tinydiff-source))
+ desc)
+ (cond
+ ((not (and line buffer))
+ (message "Tinydiff: Sorry, No line and buffer info."))
+ (t
+ (setq desc (tinydiff-get-function-name buffer line))
+ (if (stringp desc)
+ ;; Moving mouse wipes this away...
+ (message desc)
+ (message "Tinydiff: Can't find reference."))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydiff-turn-on-view-mode ()
+ "Turn on view mode and read-only status."
+ (view-mode 1)
+ (unless buffer-read-only
+ (setq buffer-read-only t)))
+
+;;}}}
+;;{{{ code: command line
+
+;;; ..................................................... &commandLine ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydiff-minibuffer--replace-text (beg end text)
+ "Command line. Replace region between BEG and END with TEXT."
+ (ti::save-line-column-macro
+ nil nil
+ (delete-region beg end)
+ (goto-char beg)
+ (insert text)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydiff-minibuffer--read-revision ()
+ "Command line. Read revision.
+
+Return:
+ (nbr . pos) ,where pos is point at line.
+ nil"
+ (interactive)
+ (let* ((fid "tinydiff-minibuffer--read-revision:")
+ nbr
+ pos)
+ (unless fid ;; XEmacs byte compiler silencer
+ (setq fid nil))
+ (save-excursion
+ ;; a) in the top of REV number
+ ;; b) pick REV forward
+ (or (eq 0 (skip-chars-backward "0-9."))
+ (eq 0 (skip-chars-forward "^0-9.")))
+ ;; cd /users/foo/elisp/; rcsdiff -c -r1.25 -r1.8 tinydiff.el
+ (cond
+ ((setq nbr (ti::buffer-match "[0-9.]+" 0))
+ (setq pos (match-beginning 0)))
+ (t
+ (beginning-of-line)
+ (setq nbr (ti::buffer-match ".*-[rul]\\([0-9.]+\\)" 1))
+ (setq pos (match-beginning 1)))))
+ (tinydiff-debug fid "col"(current-column) "nbr" nbr "pos" pos )
+ (if nbr
+ (cons nbr pos))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydiff-minibuffer--directory ()
+ "Return directory name from 'cd' command."
+ (save-excursion
+ (beginning-of-line)
+ (ti::buffer-match "cd +\\([^;]+\\)" 1)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydiff-minibuffer--read-rcs-file-name (&optional line or-diff-name)
+ "Read RCS filename from LINE.
+If OR-DIFF-NAME is non-nil, look for 'diff' command instead."
+ (let* ((fid "tinydiff-minibuffer--read-rcs-file-name:")
+ (line (or line (ti::read-current-line)))
+ (rcsdiff tinydiff-:rcsdiff-program)
+ (diff tinydiff-:diff-program)
+ (re (concat
+ "cd[ \t]+\\([^;]+\\);[ \t]*"
+ (if or-diff-name diff rcsdiff)
+ ".* \\([^ \t]+\\)"))
+ dir
+ file
+ ret)
+ (unless fid ;; XEmacs byte compiler silencer
+ (setq fid nil))
+ ;; The directory name is gotten after 'cd' command
+ (tinydiff-debug fid line re)
+ (when (and (string-match re line)
+ (setq dir (match-string 1 line))
+ (setq file (match-string 2 line)))
+ (setq ret (concat dir file)))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;; Don't ask: This function should be rewritten someday, someday...
+;;;
+(defun tinydiff-minibuffer--rev-add-command ()
+ "Adding two -rX.x string to the command line.
+This is only done if there is rcsdiff command and less the 2 -rX.x
+switches
+
+Eg.
+ rcsdiff -r1.3 file.cc
+--> rcsdiff -r1.2 -r1.3 file.cc
+
+ rcsdiff -r1.1 -r1.1 file.cc
+--> Do nothing, since there is already two -r switches."
+ (interactive)
+ (let* ((fid "tinydiff-minibuffer--rev-add-command:")
+ (line (ti::remove-properties (ti::read-current-line)))
+ ;; (rcsdiff tinydiff-:rcsdiff-program)
+ (re (concat "^.*;[ \t]*"
+ "\\("
+ tinydiff-:rcsdiff-program
+ "\\|cvs[ \t]+diff"
+ "\\|"
+ tinydiff-:cvsdiff-program
+ "\\)"
+ "\\(.*\\)"))
+ (i 0)
+ prev-list elt
+ r-list
+ args
+ list
+ revision
+ nbr
+ tmp
+ copy)
+ (unless fid ;; XEmacs byte compiler silencer
+ (setq fid nil))
+ (tinydiff-debug "IN:\n\n" fid line re)
+ (when (string-match re line)
+ (setq args (match-string 1 line)
+ list (split-string line)
+ copy (copy-list list))
+ (tinydiff-debug fid "ARGS" args "LIST" list)
+ (setq args list)
+ (while (setq elt (pop copy))
+ (if (not (string-match "^-r" elt)) ;Find this
+ (ti::nconc prev-list elt)
+ ;; Here we make list
+ ;; '((NTH-POS CAR-LIST CDR-LIST) (N CA CD) ..)
+ ;; -- all-the-elements before
+ ;; -- and the rest
+ (push (list i
+ (copy-list prev-list)
+ (nthcdr i list))
+ r-list)
+ (tinydiff-debug fid "R-LIST>>" r-list))
+ (incf i))
+ (tinydiff-debug fid "r-list NOW:" (length r-list) r-list)
+ (cond
+ ((eq (length r-list) 0) ;no -r --> add it
+ ;; looks complicated? The idea is to
+ ;; -- get last element, but only if it's NOT an option
+ ;; -- get all, but not the last element.
+ (setq r-list (nreverse args))
+ (setq elt (car r-list)) ;This is the added -rN.N
+ (tinydiff-debug fid "ELT" elt r-list)
+ (if (not (string-match "^-" elt))
+ (setq args (reverse (cdr (reverse args))))
+ (setq elt nil)) ;it was an option
+ (ti::nconc args "-r" )
+ (if elt ;file name set ?
+ (ti::nconc args elt )))
+ ((eq (length r-list) 2) ;-r -r remove first
+ (setq elt (car r-list))
+ (setq args (nth 2 elt)) ;Revision and rest of the args
+ (setq args ;car-list to the beginning
+ (reverse (union (reverse (nth 1 elt)) args))))
+ ((eq (length r-list) 1) ;Only one -r
+ (setq elt (car r-list))
+ (setq args (nth 2 elt)) ;Revision and rest of the args
+ ;; elt = (POS LIST-UNTIL-R LIST-INClUDING-R-AND-AFTER)
+ (setq tmp (car (nth 2 elt)) ;copy the -rN.N
+ i (count-char-in-string ?. tmp)) ;; How many dots?
+ (tinydiff-debug fid "1>" elt "ARGS" args "I=" i "TMP" tmp)
+ ;; ........................................... Change revision ...
+ (when (string-match "\\.\\([0-9]+\\)$" tmp)
+ (setq revision (string-to-int (match-string 1 tmp))
+ nbr (string-to-int
+ (ti::string-right (match-string 1 tmp) 1)))
+ (tinydiff-debug fid "1>REV" revision "last NBR" nbr)
+ (cond
+ ((or (eq i 1) ; Like 2.2, one dot
+ (and (> i 1) ; Can't make 1.1.1.1 --> 1.1.1.0
+ (> nbr 1)))
+ ;; 2.2 --> 2.1
+ (setq revision (1- revision))
+ (setq tmp (ti::replace-match 1 (int-to-string revision) tmp))
+ (tinydiff-debug fid "1>CHANGED" revision tmp))
+ ((and (> i 1)
+ (= nbr 1))
+ ;; Remove last 1.1.N.N --> 1.1
+ (if (string-match "\\(.*\\)\\.[0-9]+\\.[0-9]+$" tmp)
+ (setq tmp (match-string 1 tmp)))
+ (tinydiff-debug fid "2>CHANGED" tmp))))
+ (push tmp args) ;--> '(-rN.N -rN.N FILE)
+ (setq args ;car-list to the beginning
+ (reverse (union (reverse (nth 1 elt)) args)))))
+ (setq args (ti::list-to-string args))
+ (tinydiff-debug fid "args" args )
+ (delete-region (line-beginning-position) (line-end-position))
+ (insert args))
+ (end-of-line)
+ ;; Go after last revision number, so that user can change it easily
+ (beginning-of-line)
+ (if (re-search-forward "-r" nil t)
+ (skip-chars-forward "^ \t")
+ (end-of-line))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydiff-minibuffer--toggle-diff-type ()
+ "Toggle -c context or -u unified diff option in command line."
+ (interactive)
+ (let* ((line (ti::remove-properties (ti::read-current-line)))
+ ret)
+ (cond
+ ((string-match "^\\(.+ -[^ \t]*\\)c\\(.+\\)" line)
+ (setq ret (format "%su%s"
+ (match-string 1 line)
+ (match-string 2 line))))
+ ((string-match "^\\(.+ -[^ \t]*\\)u\\(.+\\)" line)
+ (setq ret (format "%sc%s"
+ (match-string 1 line)
+ (match-string 2 line)))))
+ (when ret
+ (beginning-of-line)
+ (kill-line)
+ (insert ret)
+ ;; Preserve approx point.
+ (goto-char (min (point-max) (point))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydiff-minibuffer--user-option ()
+ "Add or remove tinydiff-:cl-user-option from the line."
+ (interactive)
+ (let* ((line (ti::remove-properties (ti::read-current-line)))
+ (rcsdiff tinydiff-:rcsdiff-program)
+ (diff tinydiff-:diff-program)
+ (opt tinydiff-:cl-user-option)
+ ret)
+ (when (not (ti::nil-p opt))
+ (cond
+ ((string-match (regexp-quote opt) line)
+ (setq ret (ti::replace-match 0 "" line)))
+
+ ((or (string-match (concat rcsdiff "\\( +\\)") line)
+ (string-match (concat diff "\\( +\\)") line))
+ (setq ret (ti::replace-match 1 (concat " " opt " ") line)))))
+ (when ret
+ (beginning-of-line) (kill-line)
+ (insert ret))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydiff-minibuffer--change-diff-command ()
+ "Change diff command in minibuffer."
+ (interactive)
+ (let* ((fid "tinydiff-minibuffer--change-diff-command: ")
+ (rcsdiff tinydiff-:rcsdiff-program)
+ (diff tinydiff-:diff-program)
+ word
+ line
+ list
+ done)
+ (unless fid ;; XEmacs byte compiler silencer
+ (setq fid nil))
+ (tinydiff-debug fid "in")
+ (save-excursion
+ (beginning-of-line)
+ (cond
+ ;; Make sure it's our command.
+ ((and (re-search-forward "; *" nil t)
+ (setq word (ti::buffer-read-word)))
+ (setq line (buffer-substring-no-properties
+ (point) (line-end-position)))
+ (setq list (split-string line))
+ (tinydiff-debug fid
+ "\n\nLINE " line "\n"
+ "LIST " list "\n"
+ "1 string= word rcsdiff " word rcsdiff "\n"
+ "2 string= word diff " word diff "\n"
+ "2 tinydiff-:last-data " tinydiff-:last-data "\n"
+ "3 " (and (string-match word diff)
+ list
+ (not (stringp tinydiff-:last-data))))
+
+ (cond
+ ;; ................................................... case-1 ...
+ ((or (string= word rcsdiff)
+ (string= word "cvs"))
+ (tinydiff-debug fid "rcsdiff INPUT:" list)
+ (setq tinydiff-:last-data line)
+ ;; Remove some elements from list
+ (setq list (ti::list-find
+ list
+ (concat "^-r\\|" rcsdiff "\\|cvs\\|diff" )
+ (function
+ (lambda (arg elt)
+ (not (string-match arg elt))))
+ 'all))
+ (tinydiff-debug fid "1 FILTERED:" list)
+ (kill-line)
+ (insert diff " " (ti::list-to-string list))
+ (setq done t))
+ ;; ................................................... case-2 ...
+ ;; Did the last command have the same filename ? --> if not
+ ;; then we cannot use C-z
+ ((and (string-match word diff)
+ list
+ (stringp tinydiff-:last-data)
+ (ti::string-match-case
+ (regexp-quote (nth (1- (length list)) list) )
+ tinydiff-:last-data))
+ (kill-line)
+ (insert tinydiff-:last-data)
+ (setq done t))
+ ;; ................................................... case-3 ...
+ ;; (3) diff --> rcs diff thing
+ ((and (string-match word diff)
+ list
+ (not (stringp tinydiff-:last-data)))
+ (kill-line)
+ (insert (concat
+ rcsdiff
+ " -r "
+ (ti::list-to-string (cdr list))))
+ (setq done t))))))
+ (when done
+ ;; Move after the 'cd' and 'diff commands to add/change options easily
+ (beginning-of-line)
+ (re-search-forward "; *" nil t)
+ (forward-word 2))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydiff-minibuffer--sweep-unix () ;; win32
+ "Change all backslashes to forward slashes."
+ (let* ((line (ti::remove-properties (ti::read-current-line))))
+ (when (string-match "[\\]" line)
+ (setq line (ti::file-name-forward-slashes line))
+ (beginning-of-line) (kill-line)
+ (insert line)
+ ;; Preserve approx point.
+ (goto-char (min (point-max) (point))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydiff-minibuffer--complete-filename ()
+ "Complete filename."
+ (interactive)
+ (tinydiff-minibuffer--sweep-unix)
+ (let* ((fid "tinydiff-minibuffer--complete-filename")
+ (word (save-excursion
+ (forward-char -1)
+ (ti::buffer-read-space-word)))
+ (dir default-directory))
+ (unless fid ;; XEmacs byte compiler silencer
+ (setq fid nil))
+ (tinydiff-debug fid "BEGIN" word dir)
+ (unless (ti::nil-p word)
+ ;; The directory name we get from the 'CD' prompt if the
+ ;; filename lacks dir part.
+ (let ((cddir (tinydiff-minibuffer--directory)))
+ (cond
+ ((not (string-match "/" word))
+ (setq dir cddir))
+ ((string-match "^\\.\\." word) ;; relative path
+ (setq dir (expand-file-name (concat
+ (file-name-as-directory cddir)
+ (file-name-directory word)))
+ word (file-name-nondirectory word)))))
+ (tinydiff-debug fid "END" word dir)
+ (let ((default-directory (or dir
+ default-directory)))
+ (ti::file-complete-file-name-word word)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydiff-minibuffer--insert-file-autosave (&optional backup)
+ "Insert auto-save filename into current point if it exists.
+Prefix arg says to insert BACKUP filename instead."
+ (interactive)
+ (let* ((line (ti::read-current-line))
+ (rcsdiff tinydiff-:rcsdiff-program)
+ (fid "tinydiff-minibuffer--insert-file-autosave: ") ;function id
+ file
+ file2
+ stat)
+ (unless fid ;; XEmacs byte compiler silencer
+ (setq fid nil))
+ (setq file (tinydiff-minibuffer--read-rcs-file-name line 'diff))
+ (tinydiff-debug fid "arg" backup "file" file)
+ (cond
+ ((string-match rcsdiff line)
+ (message
+ (substitute-command-keys
+ (concat
+ "Tinydiff: Don't use rcsdiff command; Change command with "
+ "\\[tinydiff-minibuffer--change-diff-command] "))))
+ ((not file)
+ (message "Tinydiff: Can't read file from prompt. Include 'cd'"))
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. . process file ..
+ (t
+ (cond
+ (backup
+ (setq file2 (make-backup-file-name file))
+ (setq stat (file-exists-p file2)))
+ (t
+ ;; The autosave fiel must be surrounded with '' because
+ ;; # is shell comment
+ (setq file2 (format
+ "#%s#"
+ (file-name-nondirectory file)))
+ (setq stat
+ (file-exists-p (concat (file-name-directory file) file2)))))
+ (if (null stat)
+ (message "Tinydiff: Not found %s " file2 )
+ (setq file2 (concat "'" file2 "'"))
+ ;; put spaces around filename if needed
+ (setq file2
+ (concat
+ (if (ti::space-p (preceding-char))
+ ""
+ " ")
+ file2
+ (if (ti::space-p (following-char))
+ ""
+ " ")))
+ (insert file2))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydiff-minibuffer--insert-file-backup ()
+ "Command line. Inset backup filename if it exists."
+ (interactive)
+ (tinydiff-minibuffer--insert-file-autosave 'backup))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydiff-minibuffer--minibuffer-help ()
+ "Show brief help."
+ (interactive)
+ (with-output-to-temp-buffer "*Help*"
+ (princ
+ (substitute-command-keys
+ "TinyDiff minibuffer command line keys\n\n \\{tinydiff-:minibuffer-map}")))
+ (with-current-buffer "*Help*"
+ (ti::pmin)
+ (forward-line 4)
+ (delete-non-matching-lines "tinydiff-minibuffer-")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydiff-minibuffer--insert-previous-word ()
+ "Insert previous word: like filename or rcs switch."
+ (interactive)
+ (let* (
+;;; (char (if (line-end-position)
+;;; (preceding-char)
+;;; (or (following-char)
+;;; (preceding-char))))
+
+ (word (save-excursion
+ (when (re-search-backward "[^ \t]" nil t)
+ (ti::buffer-read-space-word)))))
+ (when word
+ (insert word))))
+
+;;}}}
+
+;;{{{ code: diff type, patch
+
+;;; ........................................................... &patch ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinydiff-patch-get-dir-from-cmd (cmd)
+ "Return FILE from CMD."
+ (when cmd
+ (setq cmd (ti::string-match "cd +\\([^ \t;]+\\)" 1 cmd))
+ (ti::file-make-path cmd)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinydiff-patch-get-file-from-cmd (cmd)
+ "Return FILE from CMD."
+ (when cmd
+ (setq cmd (ti::string-match
+ (format "cd .*%s +\\([^ \t;]+\\)" tinydiff-:patch-program)
+ 1
+ cmd))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydiff-patch-minibuffer-cleanup ()
+ "Check if we can use the patch as is, PGP change must be restored."
+ (save-excursion
+ ;; PGP breaks the dashed lines:
+ ;; - --- 1.2.1.1 1996/06/11 11:36:03
+ ;; - --- 212,219 ----
+ ;;
+ ;; Correct the lines back.
+ (let (done)
+ (ti::pmin)
+ (while (re-search-forward "^\\(- \\)\\(--- [0-9]+.*\\)" nil t)
+ (message "Tinydiff: Correcting patch: PGP's broken lines...")
+ (setq done t)
+ (ti::replace-match 1 (match-string 2)))
+ (ti::pmin)
+ (when (re-search-forward "^--+BEGIN +PGP +SIGNATURE" nil t)
+ (message "Tinydiff: Correcting patch: removing PGP tags...")
+ (setq done t)
+ (delete-region (line-beginning-position) (point-max)))
+ (when done
+ (message "Tinydiff: Correcting patch: done.")))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydiff-get-file-name (&optional arg)
+ "Try to get file name for the diff.
+Optionally read line \"RCS file: xxx.el\"
+
+ARG says which to look:
+
+ 1 pick line *** file.xx
+ 2 pick line --- file.xx
+ 3 pick line +++ file.xx GNU unified diff.
+
+Return list:
+ '(file (type pos))
+ nil"
+ (let* ((stat (ti::buffer-diff-type-p))
+ (re1 "^[ \t]*[*][*][*] +\\([^ \t\n]+\\)")
+ (re2 "^[ \t]*--- +\\([^ \t\n]+\\)")
+ (re3 "^[ \t]*[+][+][+] +\\([^ \t\n]+\\)")
+ (re re1) ;default
+ list
+ file)
+ (when stat ;only if diff found
+ (if arg ;set search regexp
+ (cond
+ ((eq 1 arg) (setq re re1))
+ ((eq 2 arg) (setq re re2))
+ ((eq 3 arg) (setq re re3))))
+
+ (save-excursion
+ (goto-char (cdr stat))
+ (cond
+ ((save-excursion
+ ;; Ignore path
+ (and (or (re-search-backward
+ "RCS +file: +\\([^/]+\\),v" nil t)
+ (re-search-backward
+ "RCS +file: +.*/\\\(.*\\),v" nil t))
+ (setq file (match-string 1)))))
+ ((save-excursion
+ (when (re-search-backward "diff -c.*" nil t)
+ (setq list (split-string (ti::read-current-line)))
+ ;; get last element
+ (setq file (nth (length list) list)))))
+ ((save-excursion
+ (when (or (re-search-backward re nil t)
+ (re-search-forward re nil t))
+ (setq file (match-string 1))))))))
+
+ (if file ;pick the return values
+ (list (ti::remove-properties file) stat)
+ nil)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydiff-patch-check-if-load (file buffer &optional flag)
+ "See if we want to load FILE by looking results in BUFFER.
+If file was RCS controlled and not in Emacs, ask to load it.
+If file is active in Emacs ad to do `load-file' to refresh current Emacs.
+
+Input:
+
+ FILE File name
+ BUFFER The patch(1) command output buffer
+ FLAG If 'hunk, this is only partial diff."
+ (let* (case-fold-search ;case sensitive matches
+ (fid "tinydiff-patch-check-if-load")
+ (fbuffer (find-buffer-visiting file))
+ (modified (if fbuffer (ti::buffer-modified-p fbuffer)))
+ (was-rcs (ti::re-search-check "RCS/"))
+
+ ;; Is package active in Emacs? Was patched file .el?
+ el-file
+ sym
+ feature
+ no-ask)
+ (unless fid ;; XEmacs byte compiler silencer
+ (setq fid nil))
+ (and file
+ (setq el-file (ti::string-match "\\(.*\\)\\.el$" 1 file))
+ (setq sym (intern-soft (file-name-nondirectory el-file)))
+ (setq feature (featurep sym)))
+
+ (tinydiff-debug fid "in:" file buffer el-file sym feature
+ "FBUFFER" fbuffer "MODIFIED" modified
+ "WAS-RCS" was-rcs)
+ ;; Be sure about success
+ (when (with-current-buffer buffer (ti::re-search-check "[Hh]unk.*succeed"))
+ (cond
+ ((and fbuffer
+ (not modified)
+ ;; If autorevert.el is turned on with
+ ;; M-x global-auto-revert-mode, do not ask from user
+ (or (not (boundp 'global-auto-revert-mode))
+ (null (symbol-value 'global-auto-revert-mode)))
+ (or (y-or-n-p "Buffer for the file exist, revert? ")
+ (progn
+ (setq no-ask t)
+ ;; Set flag and Stop case
+ nil)))
+ (pop-to-buffer fbuffer)
+ (revert-buffer))
+ ((and fbuffer modified)
+ (display-buffer buffer)
+ (message "Tinydiff: file's buffer in Emacs is modified.."))
+ ((and was-rcs
+ (null no-ask) ;Maybe set in 1st cond case
+ (y-or-n-p (format "RCS file patched, find-file %s " file "? ")))
+ (find-file file))
+ ((and feature
+ (not (eq flag 'hunk))
+ (y-or-n-p (format "%s is running in your Emacs, reload it? "
+ file)))
+ (load file)
+ (message
+ "Tinydiff: %s reloaded. Your Emacs is now running the latest patch."
+ file))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydiff-patch-check-failure (&optional buffer)
+ "Check patch failure messages from BUFFER.
+Return:
+ filename rejection file if failure happened.
+ '(\"\") some unknown failure happened; rejection file not available
+ String holds matched failure condition.
+ nil Patch succeeded ok."
+ (interactive)
+ (let* ((fid "tinydiff-patch-check-failure")
+ (re "failed.*saving +rejects +to +\\([^ \t\n]+\\)")
+ (case-fold-search t)
+ file)
+ (unless fid ;; XEmacs byte compiler silencer
+ (setq fid nil))
+ (with-current-buffer (or buffer (current-buffer))
+ (or
+ ;; 1 out of 2 hunks failed--saving rejects to test.el.rej
+ (setq file (ti::re-search-check re 1 nil 'get-matched))
+ ;; patch: **** this file doesn't appear to be the 1.7 version--aborting
+ (and (setq file
+ (ti::re-search-check
+ "^patch:.*--aborting" 1 nil 'get-matched-text))
+ (setq file (list file)))
+
+ ;; In SunOS it simply prints the following on success.
+ ;;
+ ;; Looks like a new-style context diff.
+ ;; done
+ (and (save-excursion ;Check second line first
+ (ti::pmin) ;If we care to dig deeper then...
+ (forward-line 2)
+ (looking-at ".*done\\.?"))
+ (save-excursion
+ (let (stat1 stat2 stat3 str)
+ (ti::pmin)
+ (setq stat1 (looking-at ".*Looks like.*"))
+ (forward-line 1)
+ (setq stat2 (looking-at ".*done\\.?"))
+ (forward-line 1)
+ (setq str (buffer-substring-no-properties
+ (point) (point-max)))
+ (setq stat3 (string-match "^[\n\r]*\\'" str))
+ (or (and stat1 stat2 stat3)
+ (setq file
+ (list
+ "TinyDiff: Hm. Can't tell if patch succeeded."))))))
+ ;; Maybe shell error has terminated the command
+ ;; "Unrecognized switch: -t"
+ (and (not (ti::re-search-check "hunk.*succeed"))
+ (prog1 nil
+ (setq file
+ (list
+ "TinyDiff: Hm. No 'hunk succeed' message found."))))))
+ (tinydiff-debug fid file)
+ file))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydiff-patch-check-rejections (cmd buffer)
+ "After CMD, check rejections from BUFFER.
+If the the patch command says in this buffer:
+
+ 1 out of 1 hunks failed--saving rejects to file.rej
+
+Then loading the rejection file.
+
+CMD is the original patch command used.
+
+References:
+
+ `tinydiff-:patch-reject-buffer'"
+ (let* ((fid "tinydiff-patch-check-rejections: ")
+ file
+ stat
+ tmp
+ dir
+ file-load)
+ (unless fid ;; XEmacs byte compiler silencer
+ (setq fid nil))
+ (tinydiff-debug fid "in:" cmd buffer)
+ (setq stat (tinydiff-patch-check-failure buffer))
+;;; (pop-to-buffer (current-buffer)) (ti::d! "rejections" stat cmd)
+ (cond
+ ((ti::listp stat)
+ (message (car stat)))
+ ((stringp stat)
+ (setq file stat)
+ (if cmd
+ (setq dir (tinydiff-patch-get-dir-from-cmd cmd))
+ (setq dir default-directory))
+ (setq file-load (concat dir file))
+ (tinydiff-debug fid file-load)
+ (cond
+ ((file-exists-p file-load)
+ (setq tmp (ti::temp-buffer tinydiff-:patch-reject-buffer 'clear))
+ (with-current-buffer tmp (insert-file-contents file-load))
+ (display-buffer tmp)
+ t)
+ (t
+ (message "TinyDiff: Can't find DIR for file...") (sit-for 1)
+ (call-interactively 'find-file)
+ t))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydiff-patch-with-diff-1 (file beg end &optional interactive type)
+ "Apply diff to file i.e. patch a FILE.
+
+Input:
+
+ FILE absolute file name where to store diff.
+ BEG diff start point in buffer
+ END diff end point
+ INTERACTIVE User interaction, allow editing the patch command etc.
+ TYPE Type of patch: 'hunk means partial diff."
+ (let* ((fid "tinydiff-patch-with-diff-1")
+ (file (expand-file-name file))
+ (opt-global (or tinydiff-:patch-global-option
+ ""))
+ (diff-tmp (if (ti::win32-shell-p)
+ ;; Must use DOS paths
+ (expand-file-name tinydiff-:diff-tmp-file)
+ ;; Otherwise take it as it is
+ tinydiff-:diff-tmp-file))
+ (prg (eval tinydiff-:patch-program))
+ (map tinydiff-:minibuffer-map)
+ (source-buffer (current-buffer))
+ (file-buffer (find-buffer-visiting file))
+ buffer ;shell messages
+ data-buffer
+ ff
+ dir
+ cmd)
+ (unless fid ;; XEmacs byte compiler silencer
+ (setq fid nil))
+ (tinydiff-debug fid "in:" file beg end interactive)
+ (tinydiff-debug fid "vars:" diff-tmp prg source-buffer file-buffer)
+ (when (and
+ file-buffer
+ (ti::buffer-modified-p file-buffer)
+ interactive
+ (not (y-or-n-p
+ (format
+ "TinyDiff: buffer %s not saved, continue ?" file-buffer))))
+ (error "TinyDiff: Aborted."))
+ (if (not (file-exists-p file))
+ (error "Tinydiff: file not found: %s" file ))
+ (setq dir (file-name-directory file)
+ ff (file-name-nondirectory file)
+ buffer (ti::temp-buffer tinydiff-:diff-tmp-buffer 'clear)
+ data-buffer (ti::temp-buffer tinydiff-:patch-tmp-buffer 'clear))
+ ;; Sometimes user's UMASK is not ok. PErhaps the file is
+ ;; not readable after the write.
+ (when (and (file-exists-p diff-tmp)
+ (not (file-writable-p diff-tmp)))
+ (error "TinyDiff: [ERROR] Not writable. Check UMASK or permissions %s"
+ diff-tmp))
+ (ti::write-file-as-is-macro
+ (write-region (point-min) (point-max) diff-tmp))
+ (unless (file-readable-p diff-tmp)
+ (set-file-modes diff-tmp 384)) ;; -rw-------
+ (with-current-buffer data-buffer
+ (insert-buffer-substring source-buffer beg end)
+ (tinydiff-patch-minibuffer-cleanup)
+;;; (pop-to-buffer (current-buffer)) (ti::d! "ok")
+ (setq cmd (format "cd %s ; %s %s %s %s" dir prg opt-global ff diff-tmp))
+ (tinydiff-debug fid "cmd:" cmd)
+ (when interactive
+ (let* (tinyef-mode ;Electric file mode OFF
+ tinycompile-mode) ;Make sure this is off too
+ (if tinyef-mode
+ (setq tinyef-mode nil)) ;No-op, bytecomp silencer
+ (if tinycompile-mode
+ (setq tinycompile-mode nil)) ;No-op
+ (setq cmd (ti::remove-properties
+ (read-from-minibuffer "> " cmd map)))
+ ;; Record command line prompt to *Messages* buffer
+ (message (concat "TinyDiff: RUN " cmd))))
+ (if (ti::nil-p cmd) ;user cleared the line ?
+ (message "Tinydiff: Patching cancelled.")
+ (tinydiff-shell-command cmd buffer)
+ (when interactive
+ (display-buffer buffer)
+ (or (tinydiff-patch-check-rejections cmd buffer)
+ (and (stringp file)
+ (tinydiff-patch-check-if-load
+ file
+ buffer
+ type))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydiff-file-to-patch ()
+ "Suggest possible filename to patch.
+
+References:
+
+ `tinydiff-:patch-list'
+
+Return:
+
+ string suggested file to patch
+ list list of filenames read from diff."
+ (let* ((fid "tinydiff-get-file-name-list")
+ (list tinydiff-:patch-list)
+ stat
+ file
+ file-list
+ re
+ search-path
+ dest-file)
+ (unless fid ;; XEmacs byte compiler silencer
+ (setq fid nil))
+ (ti::dotimes counter 1 4
+ (setq stat (tinydiff-get-file-name counter))
+ (when stat
+ (setq file (nth 0 stat)
+ stat (nth 1 stat))
+ ;; Try to find also gzipped files
+ (push file file-list)
+ (pushnew (concat file ".gz") file-list :test 'string=)
+ (if (string-match "/" file)
+ (push (file-name-nondirectory file) file-list))))
+ ;; Preserve the order. Try to find the original file first.
+ (setq file-list (nreverse file-list))
+ (tinydiff-debug fid "file-list:" file-list)
+ (when file-list
+ ;; Normally the directory part cannot be used, because people have
+ ;; files in different places, search it anyway in case the
+ ;; file structure is the same..
+ ;;
+ ;; 1. "/dir/dir/file.el"
+ ;; 2. "file.el"
+ ;;
+ ;; ClearCase diff:
+ ;; *** /work/jackr/Emacs/folding.el@@/main/5 Wed Mar 13 09:39:36 1996
+ ;; --- /work/jackr/Emacs/folding.el Wed Mar 13 13:50:26 1996
+ (catch 'done
+ (dolist (file file-list)
+ (cond
+ ((file-exists-p file)
+ (setq dest-file file)
+ (throw 'done t))
+ ((stringp file)
+ (setq file (file-name-nondirectory file))
+ (dolist (elt list) ;; User '((REGEXP DIR) ..)
+ ;; Get next element from patch table
+ (setq re (nth 0 elt)
+ search-path (eval (nth 1 elt)))
+ (when (and (string-match re file)
+ (or (setq dest-file
+ (ti::file-get-load-path file search-path))
+ (and (string-match "\\.el$" file)
+ (setq
+ dest-file
+ (ti::file-get-load-path
+ file
+ search-path)))))
+ (throw 'done t))))))))
+ (if dest-file
+ dest-file)))
+
+;;; ----------------------------------------------------------- &patch ---
+;;;
+(defun tinydiff-patch
+ (arg &optional beg end dest-file verb type orig-buffer)
+ "Try to guess diff type and region in the buffer.
+If automatic detection fails user must select diff region by hand.
+
+Input:
+
+ PREFIX ARG lets user to edit the diff command before executing.
+ This is enabled by default for interactive calls.
+ BEG END diff region; defaults to whole buffer if nil.
+ DEST-FILE file to patch
+ VERB Be verbose.
+ TYPE Type of diff: 'hunk or nil (whole diff)
+ ORIG-BUFFER Original buffer where the whole patch is."
+ (interactive
+ (progn
+;;; This is not a good idea if you get many patches; to
+;;; ask every time...
+;;;
+;;; (if (and tinydiff-:package-exist-tinymy
+;;; (y-or-n-p "Do you want to make a safe copy? "))
+;;; (call-interactively 'tinymy-copy-file))
+ (cond
+ ((region-active-p)
+ (list
+ current-prefix-arg
+ (region-beginning) ;avoids region active check
+ (region-end)
+ (tinydiff-file-to-patch)))
+ (t
+ (list
+ current-prefix-arg
+ nil
+ nil
+ (tinydiff-file-to-patch))))))
+ (let* ((fid "tinydiff-patch")
+ (go-status t) ;should we proceed patching?
+ buffer
+ rej-flag
+ char
+ ZIP)
+ (or orig-buffer
+ (setq orig-buffer (current-buffer)))
+ (let* ((patch-buffer-file-name
+ (with-current-buffer orig-buffer
+ buffer-file-name))
+ (guess-dir (if patch-buffer-file-name
+ (file-name-directory
+ patch-buffer-file-name)))
+ (guess-file (if patch-buffer-file-name
+ (file-name-nondirectory
+ patch-buffer-file-name)))
+ (guess-path patch-buffer-file-name))
+ (if (and guess-file
+ (string-match "\\.rej$" guess-file))
+ (setq guess-file (file-name-sans-extension guess-file)
+ guess-path (concat guess-dir guess-file)))
+ (unless fid ;; XEmacs byte compiler silencer
+ (setq fid nil))
+ (setq verb (or arg verb (interactive-p)))
+ (tinydiff-debug fid "in:" arg beg end)
+ (or orig-buffer
+ (setq orig-buffer (current-buffer)))
+ (or dest-file
+ (with-current-buffer orig-buffer
+ (setq dest-file tinydiff-:patch-to-file)))
+ (tinydiff-debug fid "dest-file:" dest-file)
+ ;; ......................................................... patch ...
+ ;;
+ (unless (stringp dest-file)
+ (message
+ "Tinydiff: Can't detect file along paths in tinydiff-:patch-list.")
+ (sit-for 0.7)
+ (let ((default-directory default-directory))
+ ;; The ask prompt will start from HOME in that case.
+ (unless patch-buffer-file-name
+ (setq default-directory "~"))
+ (setq dest-file (read-file-name
+ "Apply diff to: "
+ guess-dir
+ nil
+ t
+ guess-file))))
+ (if (or (not (stringp dest-file))
+ (not (file-exists-p dest-file)))
+ (error "TinyDiff: Cannot patch non-existing file. Aborted."))
+ (with-current-buffer orig-buffer
+ (set (make-local-variable 'tinydiff-:patch-to-file) dest-file))
+ ;; ........................................................... zip ...
+ (when (string-match "\\(.*\\)\\.gz$" dest-file)
+ (setq dest-file (match-string 1 dest-file))
+ (setq ZIP t)
+ (message "TinyDiff: Uncompressing gzip file...")
+ (ti::temp-buffer tinydiff-:diff-tmp-buffer 'clear)
+ (call-process
+ "gzip"
+ nil ;; Input
+ tinydiff-:patch-tmp-buffer ;; Output buffer
+ nil ;; display
+ "-d"
+ (format "%s.gz" dest-file))
+ (message "TinyDiff: Uncompressing %s file...done." dest-file))
+ ;; ....................................................... rejects ...
+ (when (file-exists-p (concat dest-file ".rej"))
+ (setq rej-flag t))
+ (when (and (not (or (null tinydiff-:patch-hunk-count)
+ (eq 0 tinydiff-:patch-hunk-count))))
+ (if (not
+ (and
+ (file-exists-p (concat dest-file ".orig"))
+ (prog1 t
+ (setq
+ char
+ (ti::read-char-safe-until
+ (format "%s\
+.orig found: r = retry patch, o = back to .orig, g = go and patch"
+ (if rej-flag
+ "[.rej]"
+ ""))
+ '(?o ?r ?g ?\e ?q ?\b ?\C-g))))))
+ (when rej-flag
+ (message "Tinydiff: Hm... rejection file found.")
+ (sit-for 1))
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .orig exist ..
+ (cond
+ ((char= char ?r) ;Retry patch to original
+ (delete-file dest-file) ;copy-file won't work otw
+ (copy-file (concat dest-file ".orig") dest-file))
+ ((char= char ?g) ;Go ahead
+ nil)
+ ((char= char ?o)
+ (delete-file dest-file)
+ (copy-file (concat dest-file ".orig") dest-file)
+ (delete-file (concat dest-file ".orig"))
+ (setq go-status nil)
+ (message
+ "Tinydiff: Original file restored: .orig copied over %s"
+ dest-file))
+ (t
+ (setq go-status nil)
+ (message "Tinydiff: Cancelled patching.")))))
+ (when go-status
+ (with-current-buffer orig-buffer
+ (set (make-local-variable 'tinydiff-:patch-hunk-count)
+ (1+ (or tinydiff-:patch-hunk-count 0))))
+ (tinydiff-patch-with-diff-1
+ dest-file (point-min) (point-max) verb type))
+ (when ZIP
+ (message "TinyDiff: Compressing gzip file...")
+ (call-process "gzip"
+ nil
+ nil ; (current-buffer)
+ nil
+ "-9"
+ (format "%s.gz" dest-file))
+ (message "TinyDiff: Compressing %s file...done" dest-file)))))
+
+;;}}}
+;;{{{ code: command generate
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydiff-diff-command-generate (&optional no-ask)
+ "Return diff command as string; optionally NO-ASK."
+ (if (null tinydiff-:minibuffer-map)
+ (run-hooks 'tinydiff-:mode-define-keys-minibuffer-hook))
+ (let* ((map tinydiff-:minibuffer-map)
+ (tmp-file (expand-file-name
+ tinydiff-:diff-tmp-file))
+ (diff-prg (or (eval tinydiff-:diff-program)
+ (error "TinyDiff: tinydiff-:diff-program is nil")))
+ (rcsdiff-prg (eval tinydiff-:rcsdiff-program))
+ (cvsdiff-prg (eval tinydiff-:cvsdiff-program))
+ (options (or (eval tinydiff-:diff-option) ""))
+ (ange (and (stringp default-directory)
+ (string-match "@" default-directory)))
+ (dired (and (null ange)
+ (string-match "dired" (symbol-name major-mode))))
+ (bf (cond
+ (dired
+
+ ;; If point is out of file listing dired flags
+ ;; error, don't mind it.
+
+ (ignore-errors (dired-get-filename)))
+ ((buffer-file-name))))
+ (file "")
+ (file2 "")
+ (dir "")
+ rev
+ prompt
+ ans
+ cvs-info)
+ ;; This flag is used to to signal that buffer should not be
+ ;; saved, because the underlying file has changed.
+ (put 'tinydiff-diff-command-generate 'buffer-not-modified nil)
+ (tinydiff-debug default-directory bf "DIRED-ANG" dired ange "OPT" options)
+ (tinydiff-kill-revision-list)
+ (when bf
+ (setq dir (file-name-directory bf)
+ file (file-name-nondirectory bf)))
+ (cond
+ ;; .............................................. buffer change ...
+ ;; - The buffer has changed. Or file has changed.
+ ((and bf
+ (null dired)
+ (file-exists-p bf)
+ (or (buffer-modified-p)
+ ;; someone else edited or changed the same file
+ (null (verify-visited-file-modtime (current-buffer))))
+ (y-or-n-p "Diff between buffer and file on disk? "))
+ (put 'tinydiff-diff-command-generate 'buffer-not-modified bf)
+ (ti::widen-safe ;make sure whole buffer is saved
+ (write-region (point-min) (point-max) tmp-file))
+ (setq file2 tmp-file))
+ ;; ........................................................ rcs ...
+ ;; - Buffer is RCS controlled.
+ ((and bf
+ (null dired)
+ (ti::vc-rcs-file-exists-p bf))
+ ;; - if the revision information cannot be found, then the
+ ;; '-rX.x' switch is not used.
+ (setq rev (ti::vc-rcs-buffer-version))
+ (unless rev
+ (message "Tinydiff: RCS Revision not detected.") (sit-for 1))
+ (setq options
+ (format "%s %s"
+ options
+ (if rev
+ (concat "-r" rev " ")
+ "")))
+ (setq diff-prg
+ (or rcsdiff-prg
+ (error "TinyDiff: tinydiff-:rcsdiff-program is nil"))))
+ ;; .......................................................... cvs ...
+ ((and bf
+ (null dired)
+ (or (boundp 'tinydiff-cvs-flagged)
+ (setq cvs-info (ti::vc-cvs-file-exists-p bf))))
+ ;; It's too expensive to call `ti::vc-cvs-file-exists-p' every time,
+ ;; so we create intermediate variable to flag this buffer as CVS
+ ;; controlled.
+ (make-local-variable 'tinydiff-cvs-flagged)
+ ;; (setq rev (ti::vc-rcs-buffer-version))
+ (setq rev (car (ti::vc-cvs-entry-split-info
+ (ti::vc-cvs-entry-split cvs-info)
+ 'revision)))
+ (unless rev
+ (message "Tinydiff: CVS Revision not detected.") (sit-for 1))
+ (setq options
+ (format "%s %s"
+ options
+ (if rev
+ (concat "-r" rev " ")
+ "")))
+ (setq diff-prg
+ (or cvsdiff-prg
+ (error "TinyDiff: tinydiff-:cvsdiff-program is nil"))))
+ ;; .................................................... default ...
+ ;; General diff prompt
+ ((null ange)
+ (setq dir default-directory))
+ (t
+ (setq dir (expand-file-name "~"))))
+ ;; ... ... ... ... ... ... ... ... ... ... command generated . .
+ (setq prompt (format
+ "cd %s; %s %s %s %s "
+ dir
+ (or diff-prg
+ (error
+ "TinyDiff: No diff program available. Check PATH."))
+ options
+ file
+ file2))
+ (if no-ask
+ (setq ans prompt)
+ (let* (tinyef-:mode) ;Electric file mode OFF
+ (if tinyef-:mode
+ (setq tief-mode nil)) ;No-op, bytecompier silencer
+ ;; Record command line prompt to *Messages* buffer
+ (message (concat "TinyDiff: " prompt))
+ (setq ans (read-from-minibuffer ">" prompt map))))
+ (if (ti::nil-p ans)
+ (setq ans nil))
+ (ti::remove-properties ans)))
+
+;;}}}
+;;{{{ code: generating, parsing diff
+
+;;; .................................................... &diff-parsing ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydiff-parse-buffer (&optional verb)
+ "Prepare diff buffer for `tinydiff-mode'. VERB.
+Mark diff lines for special handling."
+ (interactive)
+ (let* ((diff-type (car-safe (ti::buffer-diff-type-p)))
+
+ ;; In GNU diff , there is option --initial-tab
+ ;; which adds tab before each diff line to make the
+ ;; text look "as it was originally"
+ ;;
+ ;; That's why allowed whitespace at the beginning.
+
+ (re-c2 "^[ \t]*[*][*][*] \\([0-9]+\\)")
+ (re-c3 "^[ \t]*[-][-][-] \\([0-9]+\\)")
+ (re-normal "^\\([0-9]+\\)\\(,[0-9]+\\)?+[acd][0-9]")
+
+ (re-gnu-u "^@@[ \t]+[-+][0-9]+,[0-9]+[ \t]+[-+]+\\([0-9]+\\)")
+ (re-gnu-n "^[dac]\\([0-9]+\\) [0-9]+$")
+
+ (prop-list '(mouse-face highlight
+ owner tinydiff)))
+ (ti::verb)
+ (let ((sym 'font-lock-keywords))
+ (set sym tinydiff-:font-lock-keywords))
+ (ti::text-clear-region-properties
+ (point-min) (point-max) '(owner tinydiff))
+ (save-excursion
+ (ti::pmin)
+ (cond
+ ((eq diff-type 'context)
+ (ti::text-re-search re-c2 nil 1 nil prop-list)
+ (ti::pmin)
+ (ti::text-re-search re-c3 nil 1 nil prop-list))
+ ((eq diff-type 'normal)
+ (ti::text-re-search re-normal nil 1 nil prop-list))
+ ((eq diff-type 'gnu-u)
+ (ti::text-re-search re-gnu-u nil 1 nil prop-list))
+ ((eq diff-type 'gnu-n)
+ (ti::text-re-search re-gnu-n nil 1 nil prop-list))))
+ (if diff-type
+ (if verb
+ (message (concat "Tinydiff: Diff parsed, type: "
+ (prin1-to-string diff-type))))
+ (if verb
+ (message "Tinydiff: Diff not recognized.")))
+ (run-hooks 'tinydiff-:parse-buffer-hook)))
+
+;;; ......................................................... &diff-do ...
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinydiff-diff-show (cmd)
+ "Generate diff CMD for the buffer and show it in the other window.
+Lets user to edit option in the command line."
+ (interactive
+ (progn
+ (when (and
+ (buffer-file-name)
+ (file-exists-p
+ (format
+ "%s#%s#"
+ (file-name-directory (buffer-file-name))
+ (file-name-nondirectory (buffer-file-name)))))
+ (message
+ "Tinydiff: There is autosave file, use minibuffer %s binding"
+ (ti::keymap-function-bind-info
+ 'tinydiff-minibuffer--insert-file-autosave
+ tinydiff-:minibuffer-map)
+ (sit-for 1)))
+ (list
+ (tinydiff-diff-command-generate))))
+ (if (and (stringp cmd)
+ (buffer-modified-p)
+ (buffer-file-name)
+ ;; If this is in the commend, we're diffing buffer against
+ ;; file on disk
+ (not (or (string-match (regexp-quote tinydiff-:diff-tmp-file) cmd)
+ (string-match
+ (regexp-quote (expand-file-name tinydiff-:diff-tmp-file))
+ cmd)))
+ (y-or-n-p "Save buffer before running diff? "))
+ (save-buffer))
+ (when (stringp cmd)
+ (tinydiff-diff cmd 'show)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinydiff-diff-show-noask (cmd)
+ "Generate diff CMD for the buffer. Guess all parameters."
+ (interactive
+ (list
+ ;; - The first one runs fine for rcsdiff (ie. buffer is in RCS)
+ ;; but if it fails, we have to ask paramters from user.
+ (or (tinydiff-diff-command-generate 'no-ask)
+ (tinydiff-diff-command-generate))))
+ ;; the `get' is set in `tinydiff-diff-command-generate'
+ ;; to indicate that buffer and file content are no in synch, user
+ ;; does not want to save modified buffer, but check against the copy
+ ;; at disk.
+ (if (and (null (get 'tinydiff-diff-command-generate 'buffer-not-modified))
+ (buffer-modified-p)
+ (y-or-n-p "Save buffer before running diff? "))
+ (save-buffer))
+ (if (not (ti::nil-p cmd))
+ (tinydiff-diff cmd 'show)))
+
+;;; ------------------------------------------------------------- &cmd ---
+;;; - The diff data is inserted into register automatically, because
+;;; many time the diff data is pasted to somewhere else. Eg. by sending it
+;;; via mail to someone else in projects.
+;;;
+;;;
+;;;###autoload
+(defun tinydiff-diff (cmd &optional show verb)
+ "Run diff on buffer, possibly using rcsdiff if file is version controlled.
+Inserts contents into register.
+
+The version control is determined by searching RCS strings 'Id' or 'Log'
+
+Input:
+
+ CMD diff command
+ SHOW show the results
+ NO-ASK run diff without asking any questions.
+ VERB enable verbose messages
+
+References:
+
+ `tinydiff-:extra-diff-program'
+ `tinydiff-:diff-buffer'
+ `tinydiff-:diff-options'
+
+Return:
+
+ nil ,the no-ask parameter could not determine right diff.
+ buffer ,the shell output buffer. Note, that the diff may have
+ failed, in that case the buffer does not hold valid output."
+ (let* ((fid "tinydiff-diff")
+ (bf (buffer-file-name))
+ (buffer (ti::temp-buffer tinydiff-:diff-buffer 'clear))
+ (reg (eval tinydiff-:register-diff)) ;where to put the diff content
+ prereq
+ tmp)
+ (tinydiff-debug fid 'cmd cmd 'show show 'verb verb)
+ (ti::verb)
+ ;; It the command is rcsdiff, then we must include
+ ;; Prereq: tag to the beginning of diff. Thhat tells patch
+ ;; that when applying the diff, it must find that string
+ ;; from the file before it can prosess applying the patch.
+ ;;
+ ;; It prevents patching wrong versions.
+ ;;
+ ;; Prereq: 1.10
+ ;;
+ ;; Or we use this which is more stricter. It supposes you have
+ ;; rcs 'id' string in a file.
+ ;;
+ ;; Prereq: tinylib.el,v 1.10
+ ;;
+ ;; Nov 8 1996: Hm the latter isn't supported, if picks only
+ ;; "tinylib.el,v" and not whole string in the linew
+ ;; I'm going to request imprevement to GNU patch....
+ (cond
+ ((setq tmp (ti::string-match "-r\\([0-9.]+\\)" 1 cmd))
+ ;; Add file name too
+ (if (or t
+ (null (tinydiff-minibuffer--read-rcs-file-name cmd)))
+ (setq prereq (format "Prereq: %s\n" tmp))
+;;; disabled now.
+;;; (setq tmp2 (file-name-nondirectory tmp2))
+;;; (setq prereq (format "Prereq: %s,v %s" tmp2 tmp))
+ nil)))
+ (if (and (null cmd)
+ (null bf))
+ (message "Tinydiff: Sorry, this is not a file buffer.")
+ (if (null cmd)
+ ;; if the NO-ASK parameter is set, then we can't ask anything
+ ;; from the user. What if the file is not RCS file? Then what we
+ ;; diff against? --> give up and return nil pointer
+ (setq buffer nil)
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... shell command . .
+ ;; ELSE
+ (tinydiff-shell-command cmd buffer)
+ (with-current-buffer buffer
+ (ti::pmin)
+ (when prereq
+ (insert prereq "\n"))
+ (when show
+ (setq tmp (current-buffer))
+ ;; Unless it's already visible in some frame.
+ (if (setq tmp (get-buffer-window buffer t))
+ (raise-frame (window-frame tmp))
+ (display-buffer buffer)))
+ (when reg
+ (set-register reg (buffer-string))
+ (if verb
+ (message
+ (concat "Tinydiff: Diff stored in register ..."
+ (char-to-string reg)))))
+ (run-hooks 'tinydiff-:diff-hook))))
+ buffer))
+
+;;}}}
+;;{{{ code: Misc; mime write
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydiff-compose-diff-filename ()
+ "Compose filename by reading the original filename from diff buffer.
+Filename is composed like this: ~/tmp + FILE + .diff suffix."
+ (let* ((dir
+ (cond
+ ((file-directory-p "~/tmp/") "~/tmp/")
+ ((file-directory-p "/tmp/") "/tmp/")
+ (t
+ default-directory)))
+ file
+ stat
+ ret)
+ (ti::dotimes counter 1 4 ;; #todo: remove ti::dotimes
+ (setq stat (tinydiff-get-file-name counter))
+ (when stat
+ (setq file (nth 0 stat)
+ stat (nth 1 stat))
+ ;; If the name is not .diff or .patch, then it will do
+ (when (not (string-match "\\.diff\\|\\.patch" file))
+ (setq ret file counter 6))))
+ (when ret
+ (ti::file-make-path
+ (if (ti::win32-shell-p)
+ (expand-file-name dir)
+ dir)
+ (concat file ".patch")))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydiff-write-file (file)
+ "Write current diff to temporary file.
+This is purely an interactive function.
+The suggested to be written is named like this: ~/tmp + FILE + .diff suffix."
+ (interactive
+ (let* ((file-name (tinydiff-compose-diff-filename))
+ (file (and file-name
+ (file-name-nondirectory file-name)))
+ (default-directory (if file-name
+ (file-name-as-directory
+ (file-name-directory file-name))
+ default-directory)))
+ (list (read-file-name "Write diff to: " nil nil nil file))))
+ (unless (ti::nil-p file)
+ (write-region (point-min) (point-max) file)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydiff-mime-compose (&optional insert-to-mail verb)
+ "Read current buffer and make TM MIME attachement.
+Save attachement to `tinydiff-:register-diff' or to a mail buffer,
+which must have MIME-edit mode active.
+
+The TM MIME spec is used: 7bit, type=patch.
+If you need other specifications, insert diff via TM's insert file.
+
+Input:
+
+ INSERT-TO-MAIL Flag, if non-nil, add MIME block to the end of
+ buffer pointed by `tinydiff-:mail-buffer-function'.
+ VERB Be verbose."
+ (interactive "P")
+ (let* ((file (file-name-nondirectory (tinydiff-compose-diff-filename)))
+ (mime-tag
+ (format
+ (concat
+ "--[[application/octet-stream; type=patch\n"
+ "Content-Disposition: attachment; "
+ "filename=\"%s\"][7bit]]\n")
+ file))
+ (obuffer (current-buffer))
+ (mime-p t)
+ mail-buffer)
+ (ti::verb)
+ (cond
+ (insert-to-mail
+ (unless (setq mail-buffer (funcall tinydiff-:mail-buffer-function))
+ (error "Tinydiff: Can't find mail buffer where to insert to"))
+ (with-current-buffer mail-buffer
+ (when (not (or (ti::mail-mime-tm-edit-p)
+ (ti::mail-mime-semi-edit-p)))
+ (setq mime-p nil)))
+ ;; Do not add the mime tag, if there is noTM mime edit mode
+ (if mime-p
+ (ti::append-to-buffer mail-buffer mime-tag))
+ (append-to-buffer mail-buffer (point-min) (point-max))
+ (when verb
+ (message "Tinydiff: %sdiff appended to buffer: %s"
+ (if mime-p "Mime " "")
+ (buffer-name mail-buffer))))
+ (t
+ (with-temp-buffer
+ (insert mime-tag)
+ (insert-buffer obuffer)
+ (set-register tinydiff-:register-diff (buffer-string))
+ (when verb
+ (message "TinyDiff: MIME diff in register `%c'"
+ tinydiff-:register-diff)))))))
+
+;;}}}
+
+;;{{{ code: Line functions
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydiff-get-buffer-name ()
+ "Return buffer name of the current diff."
+ (let* (file
+ ret
+ list)
+ (save-excursion
+ (cond
+ ((progn (ti::pmin)
+;;; (ti::d! "RCS file")
+ (re-search-forward "^RCS file: .*/\\(.*\\),v" nil t))
+
+ ;; RCS file: RCS/folding.el,v
+ ;; retrieving revision 1.18
+ ;; retrieving revision 1.19
+ (setq file (match-string 1)))
+ ((progn (ti::pmin)
+;;; (ti::d! "---")
+ (re-search-forward "^---[ \t]+\\([^\t ]+\\)" nil t))
+ ;; --- copy/tinydiff.el Wed Jan 24 16:08:05 1996
+ ;; +++ tinydiff.el Wed Jan 24 16:29:07 1996
+ ;; @@ -1,6 +1,6 @@
+ (setq file (match-string 1))
+ (or (or (setq ret (and (string-match "/" file)
+ (find-buffer-visiting file)))
+ (setq ret (get-buffer (file-name-nondirectory file))))
+ ;; Hmm; the "---" file was not found; try "***" file
+ (and
+ (progn
+ (ti::pmin)
+;;; (ti::d! "***")
+ (re-search-forward "^\\*\\*\\*[ \t]+\\([^\t ]+\\)" nil t)
+ ;; *** copy/tinydiff.el Wed Jan 24 16:08:05 1996
+ ;; --- /tmp/tdi.diff Wed Jan 24 16:29:07 1996
+ (setq file (match-string 1)))
+ (or (setq ret (and (string-match "/" file)
+ (find-buffer-visiting file)))
+ (setq ret (get-buffer (file-name-nondirectory file)))))))
+ ((progn (ti::pmin)
+ (re-search-forward "^filename: \\([^\t ]+\\)$" nil t))
+ ;; User tag, e.g. output from shell script that generates the
+ ;; 'filename' tag + runs the diff program.
+ (setq file (match-string 1)))
+ (t
+ ;; other diff formats .. Still open
+ nil))
+ ;; ............................................. examine results ...
+ (when (and (not ret)
+ file)
+ (if file ;remove directory part
+ (setq file ;; returns nil if no "/" found
+ (file-name-nondirectory file)))
+ (cond
+ ((get-buffer file)
+ (setq ret file)) ;; - buffer name == file name
+ ((setq list (ti::dolist-buffer-list (string-match file (buffer-name))))
+ ;; - Eg name tinydiff.el may be in name tinydiff.el<2>
+ ;; - just pick the first from list
+ (setq ret (car list)))))
+
+ ret)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydiff-get-line-number ()
+ "Return diff line number if line has one."
+ (let* ((diff-type (car-safe (ti::buffer-diff-type-p)))
+ (re-c2 "^[*][*][*] \\([0-9]+\\)")
+ (re-c3 "^[-][-][-] \\([0-9]+\\)")
+ (re-normal "^\\([0-9]+\\)\\(,[0-9]+\\)?+[acd][0-9]")
+ ;; Wrong: this returned left hand number
+;;; (re-gnu-u "^@@ [-+]\\([0-9]+\\),[0-9]+[ \t]+[-+]+")
+ (re-gnu-u "^@@ [-+][0-9]+,[0-9]+[ \t]+[-+]+\\([0-9]+\\)")
+ (re-gnu-n "^[dac]\\([0-9]+\\) [0-9]+$")
+ ret)
+ (save-excursion
+ (beginning-of-line)
+ (cond
+ ((eq diff-type 'context)
+ (or (setq ret (ti::buffer-match re-c2 1))
+ (setq ret (ti::buffer-match re-c3 1))))
+ ((eq diff-type 'normal)
+ (setq ret (ti::buffer-match re-normal 1)))
+ ((eq diff-type 'gnu-n)
+ (setq ret (ti::buffer-match re-gnu-n 1)))
+ ((eq diff-type 'gnu-u)
+ (setq ret (ti::buffer-match re-gnu-u 1)))))
+;;; (ti::d! (match-string 0) diff-type)
+ (when ret
+ (setq ret (string-to-int ret)))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydiff-goto (buffer line)
+ "Show BUFFER and put cursor at LINE in other window."
+ (let* ((ob (current-buffer)) ;original buffer
+ (delay 0.1))
+ (switch-to-buffer-other-window buffer)
+ (goto-line line)
+ ;; Flash the cursor and go back to diff buffer
+ (and delay
+ (sit-for delay))
+ (pop-to-buffer ob)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydiff-goto-next (&optional back verb no-update)
+ "Search next position, or BACKWARD.
+
+Input:
+
+ BACK if non-nil then search backward
+ VERB enable verbose messages
+ NO-UPDATE do not update diff source buffer
+
+Return:
+
+ t if successful
+ nil no more hits"
+ (interactive)
+ (let* ((diff-type (car-safe (ti::buffer-diff-type-p)))
+ (re-c2 "^[*][*][*] \\([0-9]+\\)")
+;;; (re-c3 "^[-][-][-] \\([0-9]+\\)")
+ (re-normal "^[0-9]+\\(,[0-9]+\\)?+[acd][0-9]")
+
+;;; (re-gnu-u "^@@ [-+]\\([0-9]+\\),[0-9]+[ \t]+[-+]+")
+ (re-gnu-u "^@@ [-+][0-9]+,[0-9]+[ \t]+[-+]+\\([0-9]+\\)")
+ (re-gnu-n "^[dac]\\([0-9]+\\) [0-9]+$")
+ (type-list
+ (list
+ (cons 'context
+ re-c2)
+ (cons 'normal
+ re-normal)
+ (cons 'gnu-u
+ re-gnu-u)
+ (cons 'gnu-n
+ re-gnu-n)))
+ (func (if back 're-search-backward 're-search-forward))
+ buffer
+ ret
+ re)
+ (ti::verb)
+ (setq re (cdr-safe (assoc diff-type type-list)))
+ (ignore-errors
+ (when (setq buffer (funcall tinydiff-:source-buffer-function))
+ (setq tinydiff-:diff-source-buffer buffer) ))
+ (when (stringp re)
+ (if back
+ (beginning-of-line)
+ (end-of-line))
+ (if (null (funcall func re nil t))
+ (if verb (message "Tinydiff: No more hits."))
+ ;; Adjust the display to middle of the screen
+ (unless no-update
+ (goto-char (match-beginning 0))
+ (recenter '(4)) ;show it
+ (tinydiff-goto-kbd 'verb))
+ (setq ret t)))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydiff-goto-prev ()
+ "Search diff position backward."
+ (interactive)
+ (beginning-of-line)
+ (tinydiff-goto-next 'back 'verb))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydiff-goto-prev-no-update ()
+ "Search diff position backward."
+ (interactive)
+ (beginning-of-line)
+ (tinydiff-goto-next 'back 'verb 'no-update))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydiff-goto-next-no-update ()
+ "Search next position."
+ (interactive)
+ (end-of-line)
+ (tinydiff-goto-next nil 'verb 'no-update))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydiff-goto-kbd (&optional verb)
+ "Show the diff source in another window. VERB."
+ (interactive)
+ (let* ((line (tinydiff-get-line-number))
+ (buffer (tinydiff-source)))
+ (ti::verb)
+ (if (null line)
+ ;; nothing to do, not valid line
+ (if verb (message
+ "Tinydiff: Can't find source line reference."))
+ (if (null buffer)
+ (if verb (message "Tinydiff: Cannot find buffer name for diff."))
+ (tinydiff-goto buffer line)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydiff-goto-mouse (event)
+ "Show current line in other window. Use mouse EVENT.
+Activate only if point underneath has 'mouse-property."
+ (interactive "e")
+ (let* ((buffer (tinydiff-source))
+ line)
+ (when (ti::text-get-mouse-property)
+ (setq line (ti::remove-properties (ti::buffer-read-word "[0-9]+")))
+ (if (and buffer
+ (not (ti::nil-p line)))
+ (tinydiff-goto buffer (string-to-int line))
+ (message "Tinydiff: Sorry, missing Line Number or filenname.")))))
+
+;;}}}
+;;{{{ code: patch block handling
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydiff-header ()
+ "Return the diff header."
+ (save-excursion
+ (ti::pmin)
+ ;; --- foo-2.4.orig/config.guess
+ ;; +++ foo-2.4/config.guess
+ (when (looking-at "^--- ")
+ (forward-line 2)
+ (buffer-substring (point-min) (point)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydiff-block-region ()
+ "Return (beg . end) of diff block around current point or nil."
+ (let* ( ;; (type (ti::buffer-diff-type-p))
+ beg
+ end)
+ (end-of-line)
+ (setq end (point))
+ (or (tinydiff-goto-next nil nil 'no-update) ;; *** 2720,2727 ****
+ (goto-char (point-max)))
+ ;; If the point moved to somewhere.
+ (if (eq end (point))
+ (setq end nil)
+ ;; We need the previous line too
+ ;;
+ ;; ***************
+ ;; *** 4687,4692 ****
+ ;;
+ (forward-line -1)
+ (setq end (line-beginning-position)))
+ (setq beg (point))
+ (tinydiff-goto-next 'back nil 'no-update)
+ (if (eq beg (point))
+ (setq beg nil)
+ ;; Take the whole hunk
+ (if (looking-at "^[*][*][*] ")
+ (forward-line -1))
+ (setq beg (line-beginning-position)))
+ (if (and beg end)
+ (cons beg end))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydiff-block-kill ()
+ "Kill Diff block around point."
+ (interactive)
+ (let* ((region (tinydiff-block-region))
+ buffer-read-only)
+ (if (and (interactive-p)
+ (null region))
+ (message "TinyDiff: can't determine diff block bounds.")
+ (delete-region (car region) (cdr region)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydiff-block-apply-patch ()
+ "Apply diff block around point.
+References:
+ `tinydiff-patch-set-option'."
+ (interactive)
+ (let* ((add-opt tinydiff-:patch-global-option)
+ (region (save-excursion
+ (or (tinydiff-block-region)
+ (error "TinyDiff: Hunk region not found."))))
+ (header (or (tinydiff-header)
+ (progn
+ (message "TinyDiff: [WARN] Patch header not found.")
+ "")))
+ (buffer (current-buffer))
+ file)
+ (if (and (interactive-p)
+ (null region))
+ (message "TinyDiff: can't determine diff block bounds.")
+ (setq file (tinydiff-file-to-patch))
+ (with-temp-buffer
+ (insert header)
+ (insert-buffer-substring buffer (car region) (cdr region))
+ (tinydiff-patch nil nil nil file 'verb 'hunk buffer)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydiff-patch-set-option (opt-string)
+ "Set `tinydiff-:patch-global-option' to OPT-STRING.
+E.g. to apply revese diff, you may want to set the option to: -R"
+ (interactive
+ (list
+ (read-string
+ (format
+ "Tinydiff patch option%s: "
+ (if (and (stringp tinydiff-:patch-global-option)
+ (not (string-match "^[ \t]*$"
+ tinydiff-:patch-global-option)))
+ (format " [%s]"
+ tinydiff-:patch-global-option)
+ "")))))
+ (setq tinydiff-:patch-global-option opt-string))
+
+;;}}}
+;;{{{ setup: Install
+
+(defadvice cvs-mode-diff (after tinydiff-turn-on-diff-mode act)
+ "Call `turn-on-tinydiff-mode'."
+ (when (boundp 'cvs-diff-buffer-name)
+ (with-current-buffer (symbol-value 'cvs-diff-buffer-name)
+ (unless (fboundp 'diff-mode)
+ (turn-on-tinydiff-mode)))))
+
+(add-hook 'tinydiff-:mode-define-keys-hook 'tinydiff-mode-define-keys)
+(add-hook 'tinydiff-:parse-buffer-hook 'turn-on-font-lock-mode)
+
+;; These have to be here, because when someone says
+;; (add-hook 'tinydiff-:diff-hook 'my-tinydiff-:diff-hook)
+;;
+;; The variable gets defined immediately. --> following does nothing...
+;; (defvar tinydiff-:diff-hook '(tinydiff-parse-buffer tinydiff-mode))
+
+(ti::add-hooks 'tinydiff-:diff-hook
+ '(tinydiff-parse-buffer
+ turn-on-tinydiff-mode
+ tinydiff-turn-on-view-mode))
+
+(tinydiff-install)
+
+;;}}}
+
+(provide 'tinydiff)
+(run-hooks 'tinydiff-:load-hook)
+
+;;; tinydiff.el ends here
--- /dev/null
+;;; tinydired.el --- Dired enchancements. Backgroud Ange ftp support
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 1996-2007 Jari Aalto
+;; Keywords: extensions
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program use ident(1) or call M-x
+;; tinydired-version. Look at code with folding.el
+
+;; COPYRIGHT NOTICE
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;; ....................................................... &t-install ...
+;; Put this file on your Emacs-Lisp load path, add following into your
+;; ~/.emacs startup file.
+;;
+;; ;; Make sure the keys will be defined.
+;; (setq tinydired-:force-add-keys-flag 'override)
+;;
+;; (autoload 'tinydired-hook-control "tinydired" "" t)
+;; (autoload 'tinydired-switch-to-some-ange-ftp-buffer "tinydired" "" t)
+;; (add-hook 'tinydired-:load-hook 'tinydired-hook-control)
+;; (add-hook 'dired-mode-hook '(lambda () (require 'tinydired) nil))
+;;
+;; For more personal setup, you have to look at the calls in function
+;; `tinydired-hook-control' and put your own initializations into
+;; `dired-mode-hook' and `dired-after-readin-hook'.
+;;
+;; To select/kill ange buffers, use these bindings
+;;
+;; (global-set-key "\C-cab" 'tinydired-switch-to-some-ange-ftp-buffer)
+;; (global-set-key "\C-cak" 'tinydired-kill-all-ange-buffers)
+;; (global-set-key "\C-caK" 'tinydired-kill-all-ange-and-dired-buffers)
+;;
+;; If you don't want default keybindings, modify variable
+;;
+;; tinydired-:bind-hook
+;;
+;; Help about keys - do this in dired buffer after you've loaded this file
+;;
+;; t C-h enchanced "tiny" dired commands
+;; a C-h enchanced "ange-ftp" commands
+;;
+;; If you have any questions, always use function
+;;
+;; M-x tinydired-submit-bug-report
+
+;;}}}
+;;{{{ Documentation
+;; ..................................................... &t-commentary ...
+
+;;; Commentary:
+
+;; Preface, Jan 1996
+;;
+
+;; This package started evolving, when there was need for something
+;; more from ange-ftp, like background file loading. Ange-ftp also had
+;; nasty habbit of putting user to just downloaded .zip or .tar.gz
+;; buffer. That not what was usually wanted, but to download the files
+;; somewhere other than inside emacs. There was need for ability to
+;; *mark* files for download and get them all at once to a download
+;; directory. With standard `ange-ftp' you would have to load them one
+;; by one. Sometimes you may want to go associated `ange-ftp' buffer
+;; and give commands directly there, so a command to switch between
+;; ange-ftp and dired buffers would be handy.
+;;
+;; Now you can do this with standard `ange-ftp' and Emacs dired.
+;;
+;; Note: This paskage is just extension to `ange-ftp', consider
+;; getting next generation ange-ftp, the `EFS', if you want
+;; overall better and more complete interface. Use this package if
+;; you only need features like batch put/get at backround.
+;; (Further note: EFS was later installed to XEmacs and it does not work
+;; any more with Emacs.)
+;;
+;; Overview of features
+;;
+;; o Few enchancements to dired mode. Eg. keep only one
+;; dired buffer when ascending to directory. Shorten symlinks.
+;; o User can mark and put files into STORE and start a backgroud
+;; ange-ftp session to get STORED files into download directory
+;; o Easy switching between ange-ftp session buffer and dired buffer
+;; o Dealing with ange ftp buffers in general
+;; (x) killing all ange buffers at once
+;; (x) killing all ange + dired ange buffers at once.
+;; (x) switching to ange buffers with completion
+;; o Run "!" on ange ftp dired buffer (operate on local copy)
+;; o customizable backup file flagging.
+;; o other handy dired commands, like "pop to this file in emacs."
+;; "find all marked files"...
+;;
+;; XEmacs note
+;;
+;; The dired and ange-ftp implementation (nowadays efs) is
+;; completely differen than in Emacs
+;;
+;; ** THIS PACKAGE IS FOR Emacs ONLY **
+;;
+;; General dired additions
+;;
+;; In simplest form. This module installs some functions in your
+;; dired hooks. Their purpose is
+;;
+;; o To keep your dired buffer sorted so that directories are
+;; always put first.
+;; o Delete unwanted files from dired buffer automatically.
+;; o Shorten the symlink references, so that they don't spread
+;; multiple lines and ruin your view.
+;;
+;; It also changes one dired function with `defadvice', so that you
+;; can control if you want to have only one dired buffer when
+;; ascending to another directory. See variable:
+;;
+;; tinydired-:use-only-one-buffer-flag
+;;
+;; Dired and ange-ftp additions
+;;
+;; When you want to start ftp session in emacs you just do
+;;
+;; C-x C-f /login@site:/dir/dir/file
+;;
+;; Let's take an example: To see what new things has arrived
+;; to GNU site, you'd do this:
+;;
+;; C-x C-f /ftp@prep.ai.mit.edu:/pub/gnu/
+;;
+;; After that you are put into the dired listing, where you
+;; can mark files with dired-mark command
+;;
+;; m Mark file
+;;
+;; Now you have files ready. Next put files into batch STORAGE.
+;; There is "a" prefix for ange-ftp related commands.
+;;
+;; a S Big S put selected files into storage
+;; a q To check what files you have batched
+;; a c To clear the batch storage
+;;
+;; Now start ftp'ding the files in background. You're prompted
+;; for the download directory.
+;;
+;; a g Get marked file(s)
+;;
+;; If you want to operate on the associated ftp buffer
+;; directly, there is command
+;;
+;; a b For "buffer change"
+;;
+;; that puts you into ftp, where the dired buffer refers. When
+;; you're in the ftp buffer you have some keybinding available.
+;;
+;; C-c f insert stored files on the line
+;; C-c d insert directory name
+;; C-c b back to dired window
+;;
+;; It's sometimes handy that you can give direct ftp commands.
+;;
+;; Setting up ange ftp
+;;
+;; Here is my settings, which you can use as a reference so that you
+;; get the ange running. For more details, see the ange-ftp.el's
+;; source code. These settings include firewall "ftpgw.example.com"
+;;
+;; ;; (setq ange-ftp-generate-anonymous-password t)
+;; (setq ange-ftp-dumb-unix-host-regexp "tntpc") ;PC hosts
+;; (setq ange-ftp-gateway-host "ftpgw.example.com")
+;; (setq ange-ftp-smart-gateway t)
+;; (setq ange-ftp-local-host-regexp "\\.myhost\\.\\(com|fi\\)|^[^.]*$")
+;; ;; Always use binary
+;; (setq ange-ftp-binary-file-name-regexp ".")
+;; (autoload 'ange-ftp-set-passwd "ange-ftp" t t)
+;; (setq ange-ftp-generate-anonymous-password "jdoe@example.com")
+;;
+;; How to use this module 3 -- special vc
+;;
+;; There are some extra commands that you may take a look at.
+;; See source code of bind function
+;;
+;; tinydired-default-other-bindings
+;;
+;; What additional commands you get when loading this module.
+;;
+;; The VC special commands were programmed, because I felt that the
+;; C-x v v in dired mode didn't quite do what I wanted. I wanted
+;; simple ci/co/revert commands for files that were in VC control.
+;; And I wanted to handle them individually, expecially when ci'ing.
+;; (written for Emacs 19.28).
+;;
+;; This VC part of the package is highly experimental.
+;; I'm not sure if I support it in further releases.
+;;
+;; Important ange-ftp interface note
+;;
+;; The ange ftp batch interface used here may cause unpredictable
+;; problems. Sometimes the `get' or `put' process doesn't start at all
+;; although you see message saying it started the job. I have had
+;; several occurrances where `lcd' cmd succeeded, but then nothing
+;; happened. Repeating the `put' or `get' command cleared the problem
+;; whatever it was.
+;;
+;; So, never trust the message `completed', unless you saw that the
+;; download percentage count started running. If you're downloading
+;; important file, double check the real ftp buffer for correct response.
+;; Try again if ftp wasn't started. Another way to clear the problem: kill
+;; the ange ftp buffer and try the command from dired again. It
+;; automatically opens session to the site.
+;;
+;; Advertise -- other useful packages
+;;
+;; There are exellent dired extensions around, please consider getting
+;; these packages:
+;;
+;; o dired-sort.el (requires date-parse.el)
+;; o dired-tar.el
+;;
+;; Note: Slow autoload
+;;
+;; When you have added the autoloads into your .emacs, the first time
+;; you bring up dired buffer may be quite slow. This is normal, Emacs
+;; just need to load some additional files that this package uses.
+;;
+;; Note: Refreshing the view takes long time / point isn't exatly the same
+;;
+;; This is normal, dired is just slow and program has to do lot of
+;; work to maintain the "view". Eg. save view, save marks, delete
+;; marks, revert, sort, restore marks... Only the current line
+;; position is preserved where user was, not point.
+;;
+;; Note: Code
+;;
+;; Emacs ships with package `dired-x.el', which seems to offer some
+;; more goodies to dired. Currently, if the `dired-x' is detected the
+;; appropriate functions in this package are diabled, to prevent
+;; overlapping behavior. However, if the function behaves differently
+;; than the one in some dired extension package, then the function
+;; isn't disabled. Eg. see `tinydired-load-all-marked-files', which can turn
+;; off marks.
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+;;{{{ setup: require
+
+;;; ......................................................... &require ...
+
+(require 'backquote)
+(require 'dired)
+(require 'advice)
+
+(require 'tinylibm)
+
+(eval-and-compile
+ (autoload 'dired-do-shell-command "dired-x" "" t)
+
+ ;; We really don't need to load full packages, so use these..
+ (defvar vc-dired-mode)
+ (autoload 'vc-dired-mode "vc")
+ (autoload 'vc-finish-logentry "vc")
+ (autoload 'vc-next-action-on-file "vc")
+ (autoload 'vc-workfile-unchanged-p "vc")
+
+ ;; Too bad that can't autoload this one...
+ (defvar vc-dired-mode nil)
+ (autoload 'vc-registered "vc-hooks")
+
+ ;; The ange interface in this package is based on Emacs only
+ (if (ti::emacs-p)
+ (autoload 'ange-ftp-ftp-name "ange-ftp"))
+
+ (autoload 'dired-bunch-files "dired-aux")
+ (autoload 'dired-run-shell-command "dired-aux")
+ (autoload 'dired-shell-stuff-it "dired-aux")
+
+ (defvar diff-switches) ;; in diff.el
+ (autoload 'ediff-files "ediff" "" t))
+
+(eval-when-compile
+ (ti::package-use-dynamic-compilation)
+ (when (ti::xemacs-p)
+ (message "\n\
+ ** tinydired.el: This package is for Emacs only.\n\
+ Dired and ange-ftp interfaces are incompatible between\n\
+ Emacs and XEmacs.
+ If you see XEmacs byte compiler error:
+ evaluating (< nil 0): (wrong-type-argument..
+ you can ignore it safely. The problem is in
+ dired.el::dired-map-over-marks"))
+
+ (unless (boundp 'dired-move-to-filename-regexp)
+ (message "\
+ ** tinydired.el: Error, this Emacs did not define dired-move-to-filename-regexp"))
+ (defvar dired-move-to-filename-regexp))
+
+(ti::package-defgroup-tiny TinyDired tinydired-: extensions
+ "Dired enchancements. Backgroud Ange ftp support.
+ Overview of features
+
+ o Few enchancements to dired mode. Eg. keep only one
+ dired buffer when ascending to directory. Shorten symlinks.
+ o User can mark and put files into STORE and start a backgroud
+ ange-ftp session to get STORED files into download directory
+ o Easy switching between ange-ftp session buffer and dired buffer
+ o Dealing with ange ftp buffers in general
+ (x) killing all ange buffers at once
+ (x) killing all ange + dired ange buffers at once.
+ (x) switching to ange buffers with completion
+ o Run ! on ange ftp dired buffer (operate on local copy)
+ o customizable backup file flagging.
+ o other handy dired commands, like: pop to this file in emacs.
+ find all marked files ...")
+
+;;}}}
+;;{{{ setup: vars
+
+;;; .......................................................... &v-bind ...
+;;; handle extra keybindings.
+
+(defcustom tinydired-:bind-hook
+ '(tinydired-default-ange-bindings
+ tinydired-default-other-bindings)
+ "*Single function or list of functions to bind keys.
+These are installed to `dired-mode-hook' automatically when this package
+is loaded."
+ :type 'hook
+ :group 'Tinydired)
+
+;;; ......................................................... &v-hooks ...
+
+(defcustom tinydired-:readin-hook
+ (delq nil
+ (list
+ (cond
+ ((ti::emacs-p "21")
+ ;; Includes variable ls-lisp-dirs-first
+ (message "TinyDired: `ls-lisp-dirs-first' set to t, DO NOT CHANGE.")
+ (setq ls-lisp-dirs-first t)
+ nil)
+ (t
+ 'tinydired-sort-dir))
+ 'tinydired-kill-files
+ 'tinydired-shorten-links))
+ "*List of functions to run after dired read.
+These are inserted into `dired-after-readin-hook' when package
+installs itself. Do not remove 'tinydired-sort-dir' or
+it paralyzes package, because it relies on seeing directories first
+in the dired listing."
+ :type 'hook
+ :group 'Tinydired)
+
+(defcustom tinydired-:load-hook nil
+ "*Hook run when package has been loaded."
+ :type 'hook
+ :group 'Tinydired)
+
+;;; ....................................................... &v-private ...
+
+(defvar tinydired-:file-store nil
+ "Private. Storage of filenames.")
+(make-variable-buffer-local 'tinydired-:file-store)
+
+(defvar tinydired-:directory nil
+ "Private. Directory name.")
+
+(defvar tinydired-:mark-list nil
+ "Private. Saved filename mark list.")
+
+(defvar tinydired-:mput-last-ftp nil
+ "Private. Last ftp mput site string.")
+(make-variable-buffer-local 'tinydired-:mput-last-ftp)
+
+(defvar tinydired-:mput-history nil
+ "Private. History variable.")
+
+(defvar tinydired-:previous-buffer nil
+ "Private. Recorded buffer, before leaping in another.")
+
+(defvar tinydired-:dir-copy-buffer "*tinydired-dir*"
+ "Private. Copy of current directory. Created every time when needed.")
+
+(defvar tinydired-:dired-directory-ange-regexp "[@:]"
+ "Regexp to match `dired-directory' to find ange-ftp buffers.")
+
+;;}}}
+;;{{{ setup: User vars
+
+;;; ........................................................ &v-public ...
+;;; User configurable
+
+(defcustom tinydired-:tmp-dir
+ (dolist (dir '("~/tmp/dired/"
+ "~/tmp"
+ "~"))
+ (when (file-directory-p dir)
+ (return dir)))
+ "*Temporary directory where to store ange ftp files.
+This should be user's private directory, and _must_not_ not be
+/tmp, because someone else may be running tinydired too and using
+same filenames."
+ :type 'directory
+ :group 'Tinydired)
+
+(defcustom tinydired-:download-dir
+ (dolist (dir '("~/tmp/ftp"
+ "~/ftp"
+ "~/tmp"
+ "~"))
+ (when (file-directory-p dir)
+ (return dir)))
+ "*Directory where to down load selected files in dired listing."
+ :type 'directory
+ :group 'Tinydired)
+
+(defcustom tinydired-:force-add-keys-flag 'overrride
+ "*Non-nil means to install and override default keys to dired.
+Normally the keys are defined _only_ if the prefix key is in state
+'undefined"
+ :type 'boolean
+ :group 'Tinydired)
+
+(defcustom tinydired-:use-only-one-buffer-flag t
+ "*Non-nil means the previous dired buffer is killed when ascending to next.
+This makes sure you have only one dired buffer for each dired session.
+This feature is not used if dired-x is present."
+ :type 'boolean
+ :group 'Tinydired)
+
+(defcustom tinydired-:page-step 10
+ "*Page Up step size in lines."
+ :type 'integer
+ :group 'Tinydired)
+
+(defcustom tinydired-:unwanted-files-regexp
+ "\\.o$\\|~$\\|\\.class\\|\\.pyc"
+ "*Regexp to match files that should not be shown in dired buffer.
+Set to nil, if you want to see all files.
+This feature is not used if dired-x is present."
+ :type '(string :tag "Regexp")
+ :group 'Tinydired)
+
+(defcustom tinydired-:backup-file-regexp
+ ;; Like files from CVS: .#ChangeLog.1.3288
+ "\\(\\.bak\\|\\.backup\\|[~#]\\)\\|\\.#$"
+ "*Backup filename regexp, used by advised `dired-flag-backup-files'."
+ :type '(string :tag "Regexp")
+ :group 'Tinydired)
+
+(defcustom tinydired-:mput-sites nil
+ "*List of ange-ftp style site location strings, where user can upload files.
+
+Format '(\"ANGE-FTP-REF\" ..), ange-ftp-ref is like /login@site:dir/dir/"
+ :type '(repeat (string :tag "Ange-Ftp"))
+ :group 'Tinydired)
+
+(defcustom tinydired-:tmp-dir-function 'tinydired-create-tmp-dir
+ "*Create directory for `tinydired-:tmp-dir'."
+ :type 'function
+ :group 'Tinydired)
+
+(defcustom tinydired-:show-storage-function
+ (function
+ (lambda (args)
+ (message "%d: %s" (length args) (ti::list-to-string args))))
+ "*How to show the storage to user. Default is to use `message' function.
+The function is called with list of files in storage."
+ :type 'function
+ :group 'Tinydired)
+
+;;}}}
+;;{{{ version
+
+;;; ....................................................... &v-version ...
+
+(eval-and-compile
+ (ti::macrof-version-bug-report
+ "tinydired.el"
+ "tinydired"
+ tinydired-:version-id
+ "$Id: tinydired.el,v 2.49 2007/05/06 23:15:19 jaalto Exp $"
+ '(tinydired-:version-id
+ tinydired-:bind-hook
+ tinydired-:readin-hook
+ tinydired-:load-hook
+ tinydired-:file-store
+ tinydired-:mark-list
+ tinydired-:mput-last-ftp
+ tinydired-:mput-last-ftp
+ tinydired-:previous-buffer
+ tinydired-:dir-copy-buffer
+ tinydired-:tmp-dir
+ tinydired-:tmp-dir-function
+ tinydired-:force-add-keys-flag
+ tinydired-:use-only-one-buffer-flag
+ tinydired-:unwanted-files-regexp
+ tinydired-:download-dir
+ tinydired-:mput-sites
+ tinydired-:show-storage-function
+ tinydired-:page-step
+ ;; This tells if used has dired-x loaded
+ dired-find-subdir)))
+
+;;}}}
+
+;;; ########################################################### &Funcs ###
+
+;;{{{ code: install, bind, hook control
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydired-default-ange-bindings (&optional force)
+ "Add Extra dired bindings. Optionally FORCE adding bindings."
+ (interactive)
+ ;; "a" for Ange ftp related commands, since the file information
+ ;; stored is best used in *ftp* buffer itself.
+ (when (or tinydired-:force-add-keys-flag
+ force
+ (eq 'undefined (lookup-key dired-mode-map "a")))
+ ;; clear this only it the map is not in our use.
+ (if (not (keymapp (lookup-key dired-mode-map "a")))
+ (define-key dired-mode-map "a" nil))
+ ;; "b" for buffer handling
+ (define-key dired-mode-map "abb" 'tinydired-switch-to-ange-ftp-buffer)
+ (define-key dired-mode-map "abp" 'tinydired-switch-to-mput-ange-ftp-buffer)
+ (define-key dired-mode-map "abk" 'tinydired-kill-dired-and-ange-session)
+ ;; Redefine key "q" too. Was 'dired-delete-and-exit'
+ (define-key dired-mode-map "q" 'tinydired-kill-dired-and-ange-session)
+ (when (ti::emacs-p) ;XEmacs has EFS, these don't work
+ (define-key dired-mode-map "as" 'tinydired-store-filename)
+ (define-key dired-mode-map "ad" 'tinydired-store-delete-filename)
+ (define-key dired-mode-map "aS" 'tinydired-store-add-marked)
+ (define-key dired-mode-map "ar" 'tinydired-store-remove-file)
+ (define-key dired-mode-map "aR" 'tinydired-store-delete-marked)
+ (define-key dired-mode-map "ac" 'tinydired-store-clear)
+ ;; the "q" is just close to "a" key, no other particular logic used.
+ (define-key dired-mode-map "aq" 'tinydired-store-show)
+ ;; "g" for "get"
+ (define-key dired-mode-map "ag" 'tinydired-store-ftp-mget)
+ (define-key dired-mode-map "ap" 'tinydired-store-ftp-mput)))
+ nil)
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydired-default-other-bindings (&optional force)
+ "Add extra dired bindings. Optionally FORCE adding bindings."
+ (when (or tinydired-:force-add-keys-flag
+ force
+ (eq 'undefined (lookup-key dired-mode-map "t")))
+ ;; make prefix key available for us.
+ (ti::use-prefix-key dired-mode-map "t")
+ ;; You propably want to do also
+ ;; (define-key dired-mode-map "!" 'tinydired-dired-do-shell-command)
+ (define-key dired-mode-map "t!" 'tinydired-dired-do-shell-command)
+ (define-key dired-mode-map "t-" 'tinydired-one-dir-up)
+ ;; "f" for find-file related
+ (ti::use-prefix-key dired-mode-map "tf")
+ (define-key dired-mode-map "tff" 'tinydired-load-all-marked-files)
+ (define-key dired-mode-map "tfr" 'tinydired-marked-revert-files)
+ (define-key dired-mode-map "tg" 'tinydired-refresh-view)
+ (define-key dired-mode-map "tG" 'tinydired-read-dir-as-is)
+ (ti::use-prefix-key dired-mode-map "tk")
+ (define-key dired-mode-map "tkk" 'tinydired-kill-lines)
+ (define-key dired-mode-map "tkm" 'tinydired-kill-marked-lines)
+ (define-key dired-mode-map "tkM" 'tinydired-kill-unmarked-lines)
+ (define-key dired-mode-map "tl" 'tinydired-leave-only-lines)
+ (define-key dired-mode-map "tp" 'tinydired-pop-to-buffer)
+ (define-key dired-mode-map "te" 'tinydired-ediff)
+ (define-key dired-mode-map "t<" 'tinydired-shorten-links)
+ (define-key dired-mode-map "t>" 'tinydired-lenghten-links)
+ ;; Mark related commands in "m" map
+ (ti::use-prefix-key dired-mode-map "tf")
+ (define-key dired-mode-map "tme" 'tinydired-mark-files-in-Emacs)
+ (define-key dired-mode-map "tmd" 'tinydired-mark-today-files)
+ (define-key dired-mode-map "tmo" 'tinydired-mark-opposite-toggle)
+ (define-key dired-mode-map "tmr" 'tinydired-mark-read-only-files)
+ (define-key dired-mode-map "tms" 'tinydired-marks-save)
+ (define-key dired-mode-map "tmS" 'tinydired-marks-restore)
+ (define-key dired-mode-map "tmw" 'tinydired-mark-writable-files)
+ (ti::use-prefix-key dired-mode-map "tmv")
+ (define-key dired-mode-map "tmvv" 'tinydired-mark-vc-files-in-Emacs)
+ (define-key dired-mode-map "tmvd" 'tinydired-mark-vc-has-diffs)
+ ;; some special VC functions for marked files in "v" map
+ (ti::use-prefix-key dired-mode-map "tv")
+ (define-key dired-mode-map "tvi" 'tinydired-marked-vc-ci)
+ (define-key dired-mode-map "tvo" 'tinydired-marked-vc-co)
+ (define-key dired-mode-map "tvu" 'tinydired-marked-vc-revert)
+ ;; Override some Emacs default bindings to better follow
+ ;; this buffer's content.
+ (define-key dired-mode-map "\M-<" 'tinydired-first-line)
+ (define-key dired-mode-map "\M->" 'tinydired-last-file)
+ (define-key dired-mode-map [(home)] 'tinydired-first-file)
+ (define-key dired-mode-map [(end)] 'tinydired-last-file)
+ (define-key dired-mode-map [(select)] 'tinydired-last-file) ;; 'end' key
+ (define-key dired-mode-map [(prior)] 'tinydired-pgup)
+ (define-key dired-mode-map [(next)] 'tinydired-pgdown))
+ nil)
+
+;;; ----------------------------------------------------------------------
+;;; - If user has relocated some keys...well, we don't handle those.
+;;;
+(defun tinydired-remove-bindings ()
+ "Remove bindings from this dired session.
+User must be in dired buffer. Makes the `dired-mode-map'
+local to current buffer."
+ (interactive)
+ (let* ((list
+ '("abb" "abp" "as" "aS" "ar" "aR" "ac" "aq" "ag" "ap"
+ "t!" "tf" "tg" "tk" "tl" "tp" "t<" "t>"
+ "tmd" "tml" "tms" "tmS" "tmv"
+ "tvi" "tvo" "tvu")))
+ (when (and (memq major-mode '(dired-mode))
+ dired-mode-map)
+ (make-local-variable 'dired-mode-map)
+ (dolist (elt list)
+ (define-key dired-mode-map elt 'tinydired-ignore))
+ ;; And the rest
+ (define-key dired-mode-map "\M-<" 'beginning-of-buffer)
+ (define-key dired-mode-map "\M->" 'end-of-buffer)
+ (define-key dired-mode-map [(home)] 'beginning-of-buffer)
+ (define-key dired-mode-map [(end)] 'end-of-buffer))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinydired-hook-control (&optional remove)
+ "Add hooks to dired mode. Optional REMOVE all hooks inserted by package."
+ (interactive "P")
+ (let* ((list (ti::list-make tinydired-:bind-hook)))
+ (cond
+ (remove
+ (ti::add-hooks 'dired-after-readin-hook tinydired-:readin-hook 'remove)
+ (ti::add-hooks 'dired-mode-hook tinydired-:bind-hook 'remove))
+ (t
+ ;; Now, install the package
+ (ti::add-hooks 'dired-after-readin-hook tinydired-:readin-hook)
+ (dolist (x list) ;bind the keys
+ (add-hook 'dired-mode-hook x)
+ ;; This is due to autoload: while the package is beeing loaded,
+ ;; it should also set the bindings immediately
+ (if (boundp 'dired-mode-map)
+ (funcall x)))))
+ nil))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydired-install (&optional remove)
+ "Install package. Optionally REMOVE."
+ (interactive "P")
+ (cond
+ (remove
+ (tinydired-hook-control remove)
+ (tinydired-advice-control remove))
+ (t
+ (tinydired-hook-control)
+ (tinydired-advice-control)
+ (tinydired-xemacs-note))))
+
+;;}}}
+;;{{{ XEmacs compatibility
+
+;;; ----------------------------------------------------------------------
+;;; Some functions are not found from XEmacs, mimic them
+;;;
+(defun tinydired-dired-unmark-all-files-no-query ()
+ "XEmacs compatibility."
+ (if (fboundp 'dired-unmark-all-files-no-query)
+ (ti::funcall 'dired-unmark-all-files-no-query)
+ (ti::save-line-column-macro nil nil
+ (tinydired-first-line)
+ (while (or (not (eobp))
+ (not (looking-at "^[ \t]*$")))
+ ;; Just use brute force for all lines.
+ (dired-unmark 1)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydired-xemacs-note ()
+ "Warn that tinydired.el may work improperly in XEmacs."
+ (when (and (ti::xemacs-p)
+ (not (y-or-n-p
+ "You know that TinyDired's features won't work in XEmacs?")))
+ (tinydired-advice-control 'disable)
+ (error "Abort.")))
+
+;;}}}
+;;{{{ code: ange-ftp.el
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydired-advice-control-old (&optional disable verb)
+ "Activate all advises. Use extra argument to DISABLE all. VERB."
+ (interactive "P")
+ (let* ((re "^tdd")
+ (doit t)
+ msg)
+ (ti::verb)
+ (if verb
+ (setq
+ doit
+ (y-or-n-p (format "advices %s: No mistake here? "
+ (if disable "off" "on")))))
+ (when doit
+ (cond
+ (disable
+ (ad-disable-regexp re) ;only sets flag
+ (setq msg "All advices deactivated"))
+ (t
+ (ad-enable-regexp re) ;only sets flag
+ (setq msg "All advices activated")))
+ (ad-update-regexp re)
+ (if verb
+ (message msg)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydired-advice-control (&optional disable)
+ "Activate or DISABLE advices in this package."
+ (interactive "P")
+ (ti::advice-control
+ '(ange-ftp-set-binary-mode
+ dired-move-to-end-of-filename
+ ange-ftp-get-pwd
+ ange-ftp-expand-file-name
+ ange-ftp-get-file-entry
+ dired-flag-backup-files
+ dired-find-file)
+ "^tinydired-"
+ disable
+ 'verbose
+ "TinyDired advices "))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defadvice ange-ftp-set-binary-mode (before tinydired-error-prevent-fix dis)
+ "Sometimes you can get error:
+ash(nil -4)
+
+ `ange-ftp-set-binary-mode'(\"ftp.uit.no\" \"ftp\")
+
+Which is due to missing variables
+
+ `ange-ftp-ascii-hash-mark-size'
+ `ange-ftp-binary-hash-mark-size'
+
+This advice resets them to some default values, so that you don't get
+errors."
+ (save-excursion
+ (set-buffer (ange-ftp-ftp-process-buffer host user))
+ (if (null ange-ftp-ascii-hash-mark-size)
+ (setq ange-ftp-ascii-hash-mark-size 1024))
+ (if (null ange-ftp-binary-hash-mark-size)
+ (setq ange-ftp-binary-hash-mark-size 1024))))
+
+;;}}}
+;;{{{ code: misc
+
+;;; ----------------------------------------------------------------------
+;;; - See dired-repeat-over-lines
+;;;
+(defmacro tinydired-map-over-regexp (re &rest body)
+ "If '(looking-at RE)' then do BODY over all lines matching.
+Start from current point. The point is positioned at the beginning of line.
+Buffer read-only is removed.
+
+The BODY should move the pointer to next file and bol, until eob reached."
+ (`
+ (let* ((end (tinydired-last-file-point))
+ buffer-read-only)
+ (beginning-of-line)
+ (while (and (not (eobp))
+ (< (point) end))
+ (beginning-of-line)
+ (if (looking-at (, re))
+ (progn
+ (,@ body))
+ (forward-line 1))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinydired-map-over-files 'lisp-indent-function 0)
+(defmacro tinydired-map-over-files (&rest body)
+ "Map over files. No No dirs are included.
+You must advance the cursor in the BODY. See `tinydired-map-over-regexp'."
+ (`
+ (progn
+ (tinydired-first-file)
+ (tinydired-map-over-regexp "^. +[^d]" (,@ body)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinydired-map-over-unmarked 'lisp-indent-function 0)
+(defmacro tinydired-map-over-unmarked (&rest body)
+ "Map over unmarked lines and execute BODY at the beginning of line.
+The calling BODY should position the cursor for next search so
+that current line is skipped when BODY finishes.
+
+The buffer is writable during mapping."
+ (`
+ (let* (buffer-read-only
+ (ReGexp (dired-marker-regexp)))
+ (progn
+ (tinydired-map-over-files
+ (if (looking-at ReGexp)
+ (forward-line 1)
+ (beginning-of-line)
+ (,@ body)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro tinydired-remember-marks (var-sym &optional beg end)
+ "Save mark list to variable VAR-SYM between points BEG and END.
+START and END defaults to all files"
+ (`
+ (setq (, var-sym)
+ (dired-remember-marks
+ (or (, beg)
+ (tinydired-first-line-point))
+ (or (, end)
+ (tinydired-last-file-point))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydired-ignore ()
+ "Ignore message."
+ (interactive)
+ (message "TinyDired: Function is not available in this dired buffer."))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydired-create-tmp-dir ()
+ "Create directory `tinydired-:tmp-dir' if possible."
+ (make-directory (expand-file-name tinydired-:tmp-dir)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydired-get-tmp-dir ()
+ "Return temp directory with slash at the end."
+ (let* ((dir tinydired-:tmp-dir)
+ (func tinydired-:tmp-dir-function))
+ (unless (not (file-exists-p dir))
+ (setq dir (funcall func)))
+ (setq dir (expand-file-name dir))
+ (unless (file-exists-p dir)
+ (error "TinyDired: Directory not exist %s" dir))
+ (file-name-as-directory dir)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinydired-get-filename ()
+ "Return only filename without directory."
+ ;; The (dired-get-filename t) almos does the same, but it _may_
+ ;; contains slahes.. docs say so.
+ (ti::string-match "\\([^/]+\\)$" 1 (dired-get-filename)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinydired-get-mark ()
+ "Return first char to the left. Point is not preserved."
+ (beginning-of-line)
+ (following-char))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinydired-get-marked-files ()
+ "Signal no errors."
+ (ignore-errors (dired-get-marked-files)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydired-get-marked-files-no-dir ()
+ "Return LIST of marked files."
+ ;; #todo: See this code via macroexpand And you'll find test
+ ;;
+ ;; (if (< nil 0) (nreverse results) results))
+ ;;
+ ;; Which flags an compile error in XEmacs.
+ ;;
+ (dired-map-over-marks
+ (tinydired-get-filename)
+ nil))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinydired-first-line-point ()
+ "Return first file point."
+ (save-excursion
+ (tinydired-first-line)
+ (line-beginning-position)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinydired-last-file-point ()
+ "Return last file point."
+ (save-excursion (tinydired-last-file) (line-end-position)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinydired-mark-re (re &optional unmark)
+ "Mark files matching RE. Give prefix argument to UNMARK."
+ (save-excursion
+ (ti::pmin)
+ (while (re-search-forward re nil t)
+ (if unmark
+ (dired-unmark 1)
+ (dired-mark 1)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinydired-mark-file-list (list &optional unmark)
+ "Mark files in LIST. Give prefix argument to UNMARK."
+ (dolist (elt (ti::list-make list))
+ (tinydired-mark-re (concat (regexp-quote elt) "$") unmark)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydired-feature-p (arg)
+ "Check if we already have this functionality in dired. See ARG from code."
+ ;; Emacs with with `dired-x', which I just noticed had some of
+ ;; the same functionality. We don't use TDD if those
+ ;; are present in some cases.
+ (cond
+ ((eq arg 'auto-delete)
+ ;; see dired-omit-files-p
+ (and (featurep 'dired-x)
+ (> emacs-minor-version 27)))
+ (t
+ nil)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;
+(defun tinydired-normal-buffer-p ()
+ "Check if buffer's first line look like dired."
+ (interactive)
+ (and (not (ti::buffer-narrowed-p))
+ (save-excursion
+ (ti::pmin)
+ (and (looking-at "^[ \t]+\\([a-z]:\\)?/")
+;;; In VAX these don't exist.
+;;;
+;;; (forward-line 1)
+;;; (looking-at "^[ \t]+total[ \t]+[0-9]")
+ t))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydired-kill-files ()
+ "After each dired read, remove unwanted files."
+ (let* ((re tinydired-:unwanted-files-regexp)
+ buffer-read-only)
+ (unless (tinydired-feature-p 'auto-delete)
+ ;; Is this new directory buffer ..
+ (if (and (eq major-mode 'dired-mode)
+ (stringp re))
+ (flush-lines re)) ;don't wanna see these
+ nil)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydired-file-list (&optional arg mode)
+ "Gets all files/dir entries in the view.
+The ARG is `dired-get-filename' parameter.
+
+Input:
+
+ ARG If non-nil, no absolute names
+ MODE if 're then make regexp out of files.
+ if 'files then return just filenames
+
+Return list:
+
+ (re re ..) If mode is 're
+ (file file ...) If mode is 'plain
+ ((mark file) ..) default
+
+The `mark' is first character in the left for file or dir."
+ (let* (last-point
+ list
+ file)
+ (save-excursion
+ (setq last-point (tinydired-last-file-point))
+ (tinydired-first-line)
+ (if (setq file (ignore-errors (dired-get-filename arg)))
+ (cond
+ ((eq mode 're)
+ (beginning-of-line)
+ (if (looking-at dired-re-sym)
+ (push (concat (regexp-quote file) " +->") list)
+ (push (format " %s$" (regexp-quote file)) list)))
+ ((eq mode 'files)
+ (push file list))
+ (t
+ (push (list (tinydired-get-mark) file) list))))
+ (while (< (point) last-point)
+ (dired-next-line 1)
+ (if (setq file (ignore-errors (dired-get-filename arg)))
+ (cond
+ ((eq mode 're)
+ (beginning-of-line)
+ (if (looking-at dired-re-sym)
+ (push (concat (regexp-quote file) " +->") list)
+ (push (format " %s$" (regexp-quote file)) list)))
+ ((eq mode 'files)
+ (push file list))
+ (t
+ (push (list (tinydired-get-mark) file) list))))))
+ list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydired-sort-dir ()
+ "Put directories first in dired listing."
+ (let (buffer-read-only
+ marks
+ p1 p2 ;points
+ region)
+ ;; - Buffer gets narrowed in some dired internal operations, like
+ ;; pressing "l", dired-do-redisplay
+ ;; - We do nothing in these cases
+ ;;
+ ;; - We have to save position, because e.g. pressing "Z" to
+ ;; compress file, causes reading the whole dir --> point moved.
+ ;;
+ (when (tinydired-normal-buffer-p)
+ (ti::save-with-marker-macro
+ (tinydired-first-line)
+ (tinydired-remember-marks marks (point))
+ (tinydired-dired-unmark-all-files-no-query) ; sort goes nuts otherwise
+ (message "") ; stupid message from dired-un...
+ ;; Sort regexp by
+ ;; 19 Nov 1995, sof@dcs.glasgow.ac.uk (Sigbjorn Finne), comp.Emacs
+ ;;
+ (tinydired-first-line) (beginning-of-line)
+ (sort-regexp-fields t "^.*$" "[ ]*." (point) (point-max))
+ ;; now, We prefer to have dirs first, and then links, allthough
+ ;; some links may be dirs (we can't know anything about links)
+ ;;
+ (ti::pmin)
+ (when (re-search-forward "^[ \t]+lr" nil t)
+ (setq p1 (line-beginning-position))
+ ;; We know that dirs are after links, because the listing is
+ ;; sorted.
+ ;;
+ (re-search-forward "^[ \t]+d" nil t)
+ (setq p2 (line-beginning-position))
+ (setq region (buffer-substring p1 p2))
+ (delete-region p1 p2)
+ (re-search-forward "^[ \t]+-" nil t) ;go after dirs
+ (beginning-of-line)
+ (insert region))
+ (dired-mark-remembered marks)
+ (set-buffer-modified-p nil)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydired-dir-original (dir &optional buffer)
+ "Do same as `dired-insert-directory'.
+Insert DIR to BUFFER, which defaults to `tinydired-:dir-copy-buffer'"
+ (save-excursion
+ ;; See dired.el dired-readin-insert
+ (ti::temp-buffer (or buffer tinydired-:dir-copy-buffer) 'clear)
+ (set-buffer (or buffer tinydired-:dir-copy-buffer))
+ (insert-directory (expand-file-name dir)
+ dired-listing-switches nil t)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydired-dir-original-get-line (file)
+ "Return original line for FILE.
+Be sure you have called `tinydired-dir-original' first.
+Signal no error. Use `regexp-quote' for FILE if it contains unusual characters.
+
+Return:
+ line
+ nil ,no line was found"
+ (save-excursion
+ (set-buffer tinydired-:dir-copy-buffer)
+ (ti::pmin)
+ ;; Pick first match
+ (if (re-search-forward (concat " " file) nil t)
+ (ti::read-current-line))))
+
+;;}}}
+;;{{{ code: interactive
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinydired-ediff (file &optional switches)
+ "Compare file at point with file FILE using `ediff'.
+FILE defaults to the file at the mark.
+The prompted-for file is the first file given to `ediff'.
+With prefix arg, prompt for second argument SWITCHES,
+ which is options for `diff'."
+ (interactive
+ (let ((default (if (mark t)
+ (save-excursion (goto-char (mark t))
+ (dired-get-filename t t)))))
+ (list
+ (read-file-name ;ARG 1
+ (format "Ediff %s with: %s"
+ (dired-get-filename t)
+ (if default
+ (concat "(default " default ") ")
+ ""))
+ (dired-current-directory) default t)
+ (if current-prefix-arg ;ARG 2
+ (read-string
+ "Options for diff: "
+ (if (stringp diff-switches)
+ diff-switches
+ (mapconcat 'identity diff-switches " ")))))))
+ ;; Interactive part end
+ (ediff-files file
+ (dired-get-filename t) switches))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinydired-read-dir-as-is ()
+ "Read the directory without any filtering."
+ (interactive)
+ (let* (dired-after-readin-hook)
+ (revert-buffer)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinydired-mark-files-in-Emacs ()
+ "Mark all files in current directory that are in Emacs."
+ (interactive)
+ (let* ((dir (expand-file-name dired-directory)) ;get rid of "~"
+ (list (ti::dolist-buffer-list
+ (and (buffer-file-name)
+ (string-match (regexp-quote dir) (buffer-file-name))))))
+ (if (null dir)
+ (setq dir dir)) ;Shut up byteCompiler
+ (dolist (elt list)
+ (save-excursion
+ (tinydired-first-file)
+ (if (re-search-forward elt nil t)
+ (dired-mark 1))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinydired-marked-revert-files (&optional arg)
+ "Revert ie. replace files in Emacs with true copies in directory.
+If ARG is non-nil, remove any marks if file was loaded.
+
+Exceptions:
+ Only reload files in Emacs whose modify flag is non-nil.
+ If file does not exist in Emacs, do nothing."
+ (interactive "P")
+ (let* ((list (tinydired-get-marked-files))
+ buffer)
+ (dolist (file list)
+ (when (setq buffer (get-file-buffer file))
+ (with-current-buffer buffer
+ (unless (buffer-modified-p)
+ (revert-buffer nil t) ;no confirmation
+ (setq buffer 'done) )))
+ (when (and arg (eq 'done buffer))
+ (tinydired-mark-re
+ (regexp-quote (file-name-nondirectory file)) 'unmark)))))
+
+;;; ----------------------------------------------------------------------
+;;; - It's lot faster to use direct command, than search the buffer
+;;; for ".." and use "f" or click mouse over it.
+;;;
+;;;###autoload
+(defun tinydired-one-dir-up ()
+ "Go up one directory."
+ (interactive)
+ (find-file (concat dired-directory "..")))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinydired-dired-do-shell-command (command &optional arg)
+ "Like `dired-do-shell-command', but run running command in dired ange-ftp.
+This is not remote shell, but instead it
+transfers the file to your local system and then executes the dired
+command on the file.
+
+Remember: Every time you run this command this files are copied _blindly_
+to your local directory. No file cache information is kept.
+
+Input:
+
+ COMMAND
+ ARG
+
+References:
+
+ `tinydired-:tmp-dir'"
+ (interactive
+ (list
+ (dired-read-shell-command
+ (concat "! on "
+ "%s: ")
+ current-prefix-arg
+ (dired-get-marked-files
+ t current-prefix-arg))
+ current-prefix-arg))
+ (let* ((to-dir (tinydired-get-tmp-dir))
+ (ange (ange-ftp-ftp-name dired-directory))
+ (on-each (not (string-match "\\*" command)))
+ host user dir
+ file-list
+ list)
+ (cond
+ ((null ange)
+ ;; Simple local dired.
+ (dired-do-shell-command command arg))
+ (t
+ (setq host (nth 0 ange)
+ user (nth 1 ange)
+ dir (nth 2 ange))
+ (setq file-list (dired-get-marked-files t))
+ (ti::file-ange-file-handle 'get user host dir to-dir file-list 'foreground)
+ (dolist (file file-list) ; All directory to every filename
+ (push (concat to-dir file) list))
+ (setq file-list list)
+ ;; ......................................... copy from dired-aux ...
+ (if on-each
+ (dired-bunch-files
+ (- 10000 (length command))
+ (function
+ (lambda (&rest files)
+ (dired-run-shell-command
+ (dired-shell-stuff-it command files t arg))))
+ nil
+ file-list)
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... .. then ...
+ ;; execute the shell command
+ (dired-run-shell-command
+ (dired-shell-stuff-it command file-list nil arg)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinydired-lenghten-links ()
+ "Opposite to `tinydired-shorten-links'.
+This may take a while, because the whole directory structure must
+be read again."
+ (interactive)
+ (let* ((line (ti::current-line-number))
+ file
+ marks
+ buffer-read-only)
+ (when (tinydired-normal-buffer-p)
+ ;; Now create copy of original directory.
+ (tinydired-dir-original dired-directory)
+ (tinydired-remember-marks marks)
+ (tinydired-dired-unmark-all-files-no-query)
+ (message "")
+ (dired-mark-symlinks nil)
+ ;; This didn't update full line, only the data part, not the
+ ;; linked name portion "->"
+ ;; (dired-do-redisplay)
+ (dired-map-over-marks
+ (progn
+ (setq file (dired-get-filename 'no-dir))
+ (setq line (tinydired-dir-original-get-line (regexp-quote file)))
+ ;; now, delete line and relace it with original entry.
+ (when line
+ (beginning-of-line)
+ (re-search-forward " l")
+ (backward-char 1)
+ (delete-region (point) (line-end-position))
+ (insert line) ))
+ nil)
+ (dired-mark-symlinks 'unmark)
+ (if marks
+ (dired-mark-remembered marks))
+ (set-buffer-modified-p nil))))
+
+;;; ----------------------------------------------------------------------
+;;; - It's awfull to see 30 linked files whyen they don't fit on one line...
+;;;
+;;;###autoload
+(defun tinydired-shorten-links ()
+ "Shortens all linked files. The link part is removed."
+ (interactive)
+ (let* ((line (ti::current-line-number))
+ buffer-read-only)
+ (when (tinydired-normal-buffer-p)
+ (ti::pmin)
+ (while (not (eobp))
+ (if (looking-at ".* +->\\([^\n]+\\)")
+ (ti::replace-match 1))
+ (forward-line 1))
+ (goto-line line)
+ (dired-move-to-filename))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinydired-marks-save ()
+ "Save mark list to private storage.
+Use this function if you know next operation will remove the marks.
+You can get the marks back with `tinydired-marks-restore'."
+ (interactive)
+ (save-excursion ;due to next command
+ (tinydired-remember-marks tinydired-:mark-list)
+ (message "TinyDired: Marks saved.")))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinydired-marks-restore ()
+ "Restore mark list saved by `tinydired-marks-save'."
+ (interactive)
+ (if (null tinydired-:mark-list)
+ (message
+ (substitute-command-keys
+ "No marks saved. Use '\\[tinydired-marks-save]' first."))
+ (dired-mark-remembered tinydired-:mark-list)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinydired-pgup ()
+ "Move cursor to _last_ file in dired mode."
+ (interactive)
+ (dired-next-line (- tinydired-:page-step))
+ (if (bobp)
+ (tinydired-first-line)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinydired-pgdown ()
+ "Move cursor up."
+ (interactive)
+ (dired-next-line tinydired-:page-step)
+ (if (eobp)
+ (tinydired-last-file)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinydired-first-line ()
+ "Move to first _line_ in dired."
+ (interactive)
+ (let* (point)
+ (save-excursion
+ (ti::pmin)
+ (forward-line 2)
+ (when (looking-at "^ .*[rwx]")
+ (dired-move-to-filename)
+ (setq point (point))))
+ (if point
+ (goto-char point)
+ ;; Then, it's some strange non-unix propably ...
+ nil)))
+
+;;; ----------------------------------------------------------------------
+;;; - Supposing the directory is in order...dirs first then files...
+;;;
+;;;###autoload
+(defun tinydired-first-file ()
+ "Move to first file in dired."
+ (interactive)
+ (let* (point)
+ (save-excursion
+ (ti::pmin)
+ (while (and (null point)
+ (not (eobp)))
+ (forward-line 1)
+ (dired-move-to-filename)
+ (unless (eq 0 (current-column))
+ (setq point (point))) ))
+ (if point
+ (goto-char point)
+ ;; Then, it's some strange non-unix propably ...
+ nil)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinydired-last-file ()
+ "Move to last file in dired."
+ (interactive)
+ (let* (point)
+ (save-excursion
+ (ti::pmax)
+ (while (and (null point)
+ (not (bobp)))
+ (forward-line -1)
+ (dired-move-to-filename)
+ (unless (eq 0 (current-column))
+ (setq point (point))) ))
+ (if point
+ (goto-char point)
+ ;; Then, it's some strange non-unix propably ...
+ nil)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydired-kill-marked-lines ()
+ "Remove lines that are unmarked."
+ (interactive)
+ (let (buffer-read-only
+ list)
+ (dired-map-over-marks
+ (push (regexp-quote (ti::read-current-line)) list)
+ nil)
+ (dolist (re list)
+ (ti::pmin)
+ (if (re-search-forward re nil t)
+ (ti::buffer-kill-line)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinydired-kill-unmarked-lines ()
+ "Remove unmarked lines. Ignore directories and symlinks."
+ (interactive)
+ (tinydired-map-over-unmarked
+ (let* (char)
+ ;; We're at the beginning of line, suppose std unix 'ls'
+ ;; drwx--x--x
+ (setq char (buffer-substring (+ 2 (point)) (+ 3 (point))))
+ (if (not (or (string= char "d")
+ (string= char "l")))
+ (ti::buffer-kill-line)
+ ;; Continue mapping
+ (end-of-line))))
+ (tinydired-first-file))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinydired-kill-lines (re)
+ "Delete lines matching RE."
+ (interactive "sKill files re: ")
+ (let* (buffer-read-only)
+ (unless (ti::nil-p re)
+ (ti::save-line-column-macro (tinydired-first-file) (dired-move-to-filename)
+ (tinydired-first-file) ;; do this in ti::save-line-column-macro
+ (flush-lines re)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinydired-leave-only-lines (re)
+ "Leave only lines matching RE. Directory lines are skipped.
+You can easily undo this with reverting the buffer (dired \"g\")."
+ (interactive "sLeave regexp: ")
+ (unless (ti::nil-p re)
+ (ti::pmin)
+ (tinydired-map-over-files
+ (if (string-match re (ti::read-current-line))
+ (forward-line 1)
+ (ti::buffer-kill-line)))
+ (tinydired-first-file)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinydired-pop-to-buffer ()
+ "Pop to buffer if it exists in Emacs."
+ (interactive)
+ (let* ((file (ignore-errors (dired-get-filename)))
+ buffer)
+ (cond
+ ((and (stringp file)
+ (setq buffer (get-file-buffer file)))
+ (pop-to-buffer buffer))
+ (t
+ (message (format "TinyDired: Can't pop ... Not in Emacs. [%s]"
+ file))))))
+
+;;; ----------------------------------------------------------------------
+;;; - This behaves differently than dired-x.el dired-do-find-marked-files
+;;;
+;;;###autoload
+(defun tinydired-mark-today-files ()
+ "Mark all files, not dirs, that are created today.
+Point sits on first today file. If no today's files are found, point stays
+on current filename."
+ (interactive)
+ (let* ((list (ti::date-time-elements))
+ (line (ti::current-line-number))
+ ;; 1024 Oct 3
+ (re (concat ".*[0-9] " (nth 5 list) " +"
+ (int-to-string (nth 0 list))
+ " +"
+ ;; This year's file have time in this field
+ "[0-9]+:")))
+ (tinydired-map-over-files
+ (if (not (looking-at re))
+ (forward-line)
+ (dired-mark 1) ))
+ (tinydired-first-file)
+ (if (re-search-forward re nil t)
+ (dired-move-to-filename)
+ (goto-line line)
+ (dired-move-to-filename))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydired-mark-writable-files ()
+ "Mark Your files that have writable flag set."
+ (interactive)
+ (let* ((re ".*.w..[-w]..[-w]. "))
+ (tinydired-map-over-files
+ (if (not (looking-at re))
+ (forward-line)
+ (dired-mark 1)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydired-mark-read-only-files ()
+ "Mark Your files that have writable flag set."
+ (interactive)
+ (let* ((re ".*r-.[-r]..[-r].. "))
+ (tinydired-map-over-files
+ (if (not (looking-at re))
+ (forward-line)
+ (dired-mark 1)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydired-mark-opposite-toggle ()
+ "Mark opposite files.
+Ie. if you have marked some files, unmark those and mark all other files."
+ (interactive)
+ (let* ((re (dired-marker-regexp)))
+ (ti::save-line-column-macro nil nil
+ (tinydired-map-over-files
+ (beginning-of-line)
+ (if (looking-at re)
+ (dired-unmark 1)
+ (dired-mark 1))))))
+
+;;; ----------------------------------------------------------------------
+;;; - This behaves differently than dired-x.el dired-do-find-marked-files
+;;;
+;;;###autoload
+(defun tinydired-mark-vc-files-in-Emacs (&optional unmark verb)
+ "Mark all files in the current _view_ that are in Emacs _and_ in VC control.
+Optionally UNMARK. VERB."
+ (interactive)
+ (let* ((dir (expand-file-name dired-directory))
+ (msg (if unmark
+ "Unmarking..."
+ "Marking..."))
+ list)
+ (ti::verb)
+ (if (null dir)
+ (setq dir dir)) ;Shut up XEmacs 19.14 ByteComp
+ (setq list
+ (ti::dolist-buffer-list
+ (and buffer-file-name
+ (string-match dir buffer-file-name)
+ (vc-registered buffer-file-name))))
+ (if verb
+ (message msg))
+ (cond
+ ((and (null list) verb)
+ (message "Tinydired: No VC files of this dir in Emacs."))
+ (t
+ (tinydired-mark-file-list list unmark)
+ (if verb
+ (message (concat msg "Done")))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinydired-refresh-view (&optional verb)
+ "Refresh current dired view.
+If you have used `tinydired-leave-only-lines' and have done some changes to
+the files. You can use this function to re-read the current view.
+
+The dired \"g\" will load full view back. This instead caches the
+current view, executes read, and deletes lines that weren't in the
+cache --> you get refreshed view. All this may take a while...
+
+Input:
+
+ VERB Verbose messages
+
+Return:
+
+ t if refreshed
+ nil"
+ (interactive)
+ (let* ((cache (tinydired-file-list 'no-path-names 're))
+ (line (ti::current-line-number)) ;save user position
+ (re "")
+ buffer-read-only ;allow write
+ marks)
+ (ti::verb)
+ (cond
+ (cache
+ (setq re (mapconcat 'concat cache "\\|"))
+ (setq marks
+ (dired-remember-marks
+ (tinydired-first-line-point)
+ (tinydired-last-file-point)))
+ ;; sort goes nuts otherwise
+ (tinydired-dired-unmark-all-files-no-query)
+ (message "") ; stupid message from dired-un...
+ (revert-buffer)
+ (ti::pmin)
+ (forward-line 2) ;leave headers
+ (tinydired-first-file)
+ (beginning-of-line)
+ (let ((case-fold-search nil)) ;case sensitive
+ (delete-non-matching-lines re))
+ (dired-mark-remembered marks)
+ (goto-line line)
+ (dired-move-to-filename)
+ (if verb
+ (message "TinyDired: Refresh done."))
+ t)
+ (t
+ (if verb
+ (message "TinyDired: Can't cache view."))
+ nil))))
+
+;;; ----------------------------------------------------------------------
+;;; - This behaves differently than dired-x.el dired-do-find-marked-files
+;;;
+;;;###autoload
+(defun tinydired-load-all-marked-files (&optional arg verb)
+ "Load all marked files into Emacs.
+Does not load files which are already in Emacs.
+If ARG is non-nil, remove mark if file was loaded. VERB."
+ (interactive "P")
+ (let* ((files (tinydired-get-marked-files))
+ (loaded 0)
+ (not-loaded 0)
+ (all 0))
+ (ti::verb)
+ (cond
+ ((and verb (null files))
+ (message "Tinydired: No marked files."))
+ ((y-or-n-p "Tinydired: Load all marked files, No kidding? ")
+ (dolist (file files)
+ (incf all)
+ (if (get-file-buffer file)
+ (incf not-loaded)
+ (incf loaded)
+ (find-file-noselect file))
+ (if arg
+ (save-excursion (dired-unmark 1))))))
+ (if verb
+ (cond
+ ((eq all not-loaded)
+ (message "Hmm, all files are in Emacs already.."))
+ (t
+ (message "Tinydired: %s files loaded." loaded))))))
+
+;;}}}
+;;{{{ code: vc special
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydired-mark-vc-has-diffs (&optional arg)
+ "Leave mark to files: VC controlled, have diffs and are in Emacs.
+If ARG is non-nil, examine file whether it was in Emacs or not.
+
+Note:
+ Please be patient, taking diffs may be slow per file."
+ (interactive)
+ (let* ((list (tinydired-get-marked-files))
+ fn
+ buffer
+ vc-reg-stat
+ diff-no-stat)
+ (dolist (file list)
+ (setq fn (file-name-nondirectory file)
+ buffer (get-file-buffer file)
+ vc-reg-stat (vc-registered file))
+ (cond
+ ((or (not vc-reg-stat)
+ ;; Not exist in Emacs, do not bother looking
+ (and (null arg) (null buffer)))
+ (tinydired-mark-re (regexp-quote fn) 'unmark))
+ (t
+ (setq diff-no-stat (vc-workfile-unchanged-p file 'get-diffs))
+ (if diff-no-stat
+ (tinydired-mark-re (regexp-quote fn) 'unmark)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydired-marked-vc-revert (&optional arg verb)
+ "Revert all version controlled/no changed/marked files. Ignore ARG. VERB."
+ (interactive "P")
+ (let* ((list (tinydired-get-marked-files))
+ (display (if list t))
+ (vc-dired-mode nil) ;turn mode off
+ (count 0)
+ (handled 0)
+ load
+ buffer
+ vc-reg-stat
+ diff-no-stat)
+ (ti::verb)
+ (dolist (file list)
+ (setq buffer (get-file-buffer file)
+ vc-reg-stat (vc-registered file)
+ load nil
+ diff-no-stat nil)
+ (incf count)
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... possible load . .
+ (when (and (null buffer)
+ (file-writable-p file)
+ vc-reg-stat)
+ (setq buffer (find-file-noselect file)
+ load t))
+ (if buffer
+ (setq diff-no-stat (vc-workfile-unchanged-p file 'get-diffs)))
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... .. handle . .
+ (cond
+ ((null buffer)
+ nil) ;no file, no vc controlled
+ (diff-no-stat
+ (incf handled)
+ (save-window-excursion
+ (vc-next-action-on-file file 'verbose)
+ (if load
+ (kill-buffer buffer))))))
+ (if display
+ (dired-do-redisplay))
+ (if verb
+ (message "Tinydired: VC revert: %s/%s handled " handled count))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydired-marked-vc-co (&optional arg)
+ "Check Out all marked files and load them inside Emacs.
+Do some checking, before doing co.
+o if file is writable, skip over.
+o if file is not in RCS, skip over.
+
+Optional ARG skips all load confirmations.
+
+Marks are left only to files which were loaded into Emacs."
+ (interactive "P")
+ (let* ((list (tinydired-get-marked-files))
+ (dired-vc-mode nil) ;turn mode off
+ (count 0)
+ (loaded 0)
+ (handled 0)
+ fn
+ buffer
+ load
+ vc-reg-stat
+ modify-stat
+ read-stat)
+ (if dired-vc-mode
+ (setq dired-vc-mode nil)) ;ByteComp silencer
+ (dolist (file list)
+ (setq fn (file-name-nondirectory file)
+ buffer (get-file-buffer file)
+ vc-reg-stat (vc-registered file)
+ load nil)
+ (if buffer ;read stat only if it's in Emacs
+ (save-excursion
+ (set-buffer buffer)
+ (setq modify-stat (buffer-modified-p)
+ read-stat buffer-read-only)))
+ (incf count)
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... possible load . .
+ (cond
+ ((and (null buffer)
+ vc-reg-stat ;; in VC
+ (not (file-writable-p file)) ;; -r--r--r--
+ (or arg
+ (y-or-n-p
+ (concat "file " fn " not in Emacs. Load? " ))))
+ (incf loaded)
+ (setq buffer (find-file-noselect file)
+ load t)))
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... .. handle . .
+ (cond
+ (load
+ ;; nothing
+ nil)
+ ((and buffer ;; in Emacs, be extra carefull
+ vc-reg-stat ;; in VC
+ (not (file-writable-p file)) ;; -r--
+ (null modify-stat) ;; %*
+ read-stat) ;; %%
+ ;; --> no-op, valid state
+ nil)
+ (t ;; User has modified it!
+ ;; This situation may occur very easily
+ ;; - You load -r-- file in Emacs that's in VC
+ ;; - you want to temporary play with it, like changing one
+ ;; flag in .mak temporarily
+ ;; - you go and M-x toggle-read-only, change it, C-x C-s
+ ;; ...
+ ;; Now you have modified the read-only file !
+ (setq buffer nil)))
+ (cond
+ ((null buffer)
+ ;; 18 15:09 test3.txt
+ (tinydired-mark-re (concat "[0-9] +" fn) 'unmark)
+ nil)
+ (t
+ (save-window-excursion
+ (incf handled)
+ (vc-next-action-on-file file 'verbose)))))
+ (if (not (eq 0 handled))
+ (dired-do-redisplay))
+ (message (format "Tinydired: VC co: %s/%s handled, loaded %s"
+ handled count loaded))))
+
+;;; ----------------------------------------------------------------------
+;;; - This is vastly different than C-x v v in dired mode
+;;;
+(defun tinydired-marked-vc-ci (&optional arg &optional verb)
+ "Check In all marked files and load them inside Emacs. Ignore ARG.
+Do some heavy checking, before doing ci.
+o if file is not writable, skip over
+o if file is not in Emacs, load it first
+o if file is in Emacs, but read only, suppose no diffs
+o if file is in Emacs, check rcsdiff, --> do nothing if no diffs
+o if file is in Emacs, check rcsdiff, if file not saved, offer save
+
+Notice, that this function enters `recursive-edit' if it thinks file should
+be Checked In. Use \\[exit-recursive-edit] to get back to this function
+and continue with rest of the files.
+
+Recursive edit is shown with those [ ] marks in the modeline.
+VERB print verbose messages.
+
+Note
+
+ There is plenty of messages for each file in marked, because
+ used should know if the marked file couldn't be processed with ci.
+
+ Marks are removed from handled files.
+
+Bugs:
+
+ This function automatically removes marks from files where user has
+ used recursive edit. If user didn't ci the file, this program
+ can't know that.
+
+ Anyway, the mark is gone."
+ (interactive "P")
+ (let* ((list (tinydired-get-marked-files))
+ (count 0)
+ (handled 0)
+ (loaded 0)
+ fn
+ buffer
+ load ;flag
+ diff-no-stat
+ modify-stat
+ read-stat
+ vc-reg-stat)
+ (ti::verb)
+ (if (and (null vc-dired-mode)
+ (y-or-n-p "Buffer must be in VC dired mode. Turn it on? "))
+ (vc-dired-mode)
+ (error "Aborted."))
+ (dolist (file list)
+ (setq fn (file-name-nondirectory file)
+ buffer (get-file-buffer file)
+ vc-reg-stat (vc-registered file)
+ load nil)
+ (incf count)
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... possible load . .
+ (cond
+ ((and (null buffer)
+ vc-reg-stat
+ (file-writable-p file) ; "-r--r--r--" , not ci'able file
+ (y-or-n-p (concat "file " fn " not in Emacs. Load? " )))
+ (setq buffer (find-file-noselect file)
+ load t)
+ (incf loaded)))
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... ... stat . .
+ (cond
+ ((setq buffer (get-file-buffer file))
+ (save-excursion
+ (set-buffer buffer)
+ (setq modify-stat (buffer-modified-p)
+ read-stat buffer-read-only)
+ ;; Can't ask stat if not in VC control
+ (and vc-reg-stat
+ (setq diff-no-stat
+ (vc-workfile-unchanged-p file 'get-diffs))))))
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... set diff stat . .
+ (cond
+ ((and buffer
+ (null vc-reg-stat))
+ nil)
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... ... ... ...
+ ((and buffer
+ read-stat) ;is file in CheckOut state ?
+ (ti::read-char-safe-until
+ (concat fn " in VC, but _buffer_ is read-only. (ok)" ))
+ (and load
+ (y-or-n-p (concat "Unload " fn " ? "))
+ (kill-buffer buffer)
+ (decf loaded)))
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... ... ... ...
+ ((and buffer
+ vc-reg-stat
+ diff-no-stat
+ (null modify-stat))
+ (if (null load)
+ (ti::read-char-safe-until
+ (concat fn " contains NO changes. (ok) "))
+ (if (y-or-n-p (concat fn " contains NO changes, unload NOW? "))
+ (kill-buffer buffer))))
+ ((and buffer
+ vc-reg-stat)
+ (incf handled)
+ (save-excursion
+ (save-window-excursion
+ (unwind-protect
+ (progn
+ (tinydired-mark-re (concat "[0-9] +" file) 'unmark)
+ (pop-to-buffer buffer)
+ (call-interactively 'vc-next-action)
+
+ (ad-enable-advice 'vc-finish-logentry
+ 'after 'tinydired-recursive-edit)
+ (ad-activate 'vc-finish-logentry)
+ (recursive-edit)
+ (message
+ (substitute-command-keys
+ (concat
+ "Use \\[exit-recursive-edit] to abort action."
+ "to next file")))
+ (sleep-for 1))
+ (ad-disable-advice 'vc-finish-logentry
+ 'after 'tinydired-recursive-edit)
+ (ad-activate 'vc-finish-logentry))))
+ (ti::pmin) ;remove file after VC
+ (if (re-search-forward fn nil t)
+ (dired-unmark 1))))
+ ;; ........................................................ loop ...
+ nil)
+ (if verb
+ (message (format "VC ci: %s/%s handled, loaded %s"
+ handled count loaded)))))
+
+;;}}}
+;;{{{ code: advice
+
+;;; ----------------------------------------------------------------------
+;;; - Until someone fixes dired to honor the backup-file-name-p
+;;; this stays replaced...
+;;; - This is copy from 19.30 dired.el
+;;;
+(defadvice dired-flag-backup-files (around tdd dis)
+ "Replace original function.
+This function honours the `backup-file-name-p' function and
+additionally flag files that match regexp `tinydired-:backup-file-regexp'."
+ (let ((dired-marker-char (if unflag-p ?\040 dired-del-marker))
+ (re tinydired-:backup-file-regexp)
+ file)
+ (dired-mark-if
+ (progn
+ (beginning-of-line)
+ (when (not (looking-at dired-re-dir))
+ (setq file (dired-get-filename t t))
+ (if (stringp file)
+ (or (backup-file-name-p file)
+ (and re
+ (string-match re file))))))
+ "backup file")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defadvice vc-finish-logentry (after tinydired-recursive-edit dis)
+ "When this advice is enabled, it call `exit-recursive-edit'.
+Only if f recursive edit is in effect.
+
+This advice is controlled by function `tinydired-marked-vc-ci' and it is never
+enabled outside of that function."
+ (ignore-errors (exit-recursive-edit)))
+
+;;; ----------------------------------------------------------------------
+;;; - When using "f" it loads directory to same buffer.
+;;; - only kills the Dired buffer if a prefix arg is given
+;;;
+(defadvice dired-find-file (around tinydired-kill-dired-buffer last dis)
+ "If a prefix argument is given, kill the Dired buffer.
+
+If you have loaded dired-x and it contains variable
+`dired-find-subdir', this advice does nothing."
+ (let* ((dired-buffer (current-buffer)))
+ (prog1
+ ad-do-it
+ (if (and (eq major-mode 'dired-mode)
+ (not (eq (current-buffer) dired-buffer))
+ (or current-prefix-arg
+ tinydired-:use-only-one-buffer-flag)
+ (or (not (featurep 'dired-x)) ;not loaded
+ (and (featurep 'dired-x) ;is loaded, but this var not exist
+ (not (boundp 'dired-find-subdir)))))
+ (kill-buffer dired-buffer)))))
+
+;;}}}
+;;{{{ code: store
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinydired-store-get-string ()
+ "Return content of storage as string."
+ (ti::list-to-string tinydired-:file-store))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydired-store-show ()
+ "Show filenames in storage."
+ (interactive)
+ (if (null tinydired-:file-store)
+ (message "Tinydired: Store is empty.")
+ (funcall tinydired-:show-storage-function tinydired-:file-store)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydired-store-filename ()
+ "Save current filename into variable."
+ (interactive)
+ (let* ((file (tinydired-get-filename)))
+ (if (member file tinydired-:file-store)
+ (message "TinyDireds: %s already in storage." file)
+ (push file tinydired-:file-store) file)
+ (if (interactive-p)
+ (tinydired-store-show))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydired-store-delete-filename ()
+ "Remove filename from store."
+ (interactive)
+ (let* ((file (tinydired-get-filename)))
+ (setq tinydired-:file-store (delete file tinydired-:file-store))
+ (if (interactive-p)
+ (message "Tinydired: %s" (ti::list-to-string tinydired-:file-store)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydired-store-clear ()
+ "Clear variable holding files."
+ (interactive)
+ (setq tinydired-:file-store nil)
+ (if (interactive-p)
+ (message "Tinydired: Storage cleared.")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydired-store-remove-file ()
+ "Delete current filename from storage."
+ (interactive)
+ (let* ((file (tinydired-get-filename))
+ (verb (interactive-p))
+ (store tinydired-:file-store)
+ list)
+ (if (null store)
+ (if verb (message "Tinydired: Storage is empty."))
+ (dolist (x store)
+ (if (not (string= x file))
+ (push x list)) )
+ (setq tinydired-:file-store list)
+ (if verb
+ (tinydired-store-show)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydired-store-delete-marked ()
+ "Delete marked files from store."
+ (interactive)
+ (tinydired-store-add-marked 'delete (interactive-p)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydired-store-add-marked (&optional delete verb)
+ "Add marked files into store. No duplicates are inserted.
+If parameter DELETE is non-nil, removes marked files from store. VERB."
+ (interactive)
+ (let* ((list tinydired-:file-store)
+ (marked (tinydired-get-marked-files-no-dir)))
+ (ti::verb)
+ (if (null delete)
+ (dolist (x marked)
+ (if (not (member x list))
+ (push x tinydired-:file-store)))
+ (dolist (x marked)
+ (if (member x list)
+ (setq tinydired-:file-store
+ (delete x tinydired-:file-store)))))
+ (if verb
+ (tinydired-store-show))))
+
+;;}}}
+;;{{{ code: ange ftp
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydired-store-ftp-message (&rest args)
+ "Show Message from ange ftp after finishing the mget. Ange ARGS."
+ (message "Tinydired: Store, ftp completed.") (sleep-for 1))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydired-back-to-dired-buffer ()
+ "Switch back to dired buffer, which is associated with ange-ftp buffer.
+If no such buffer is found, do nothing."
+ (interactive)
+ (let* ((buffer (ti::buffer-find-ange-to-dired-buffer)))
+ (if buffer
+ (pop-to-buffer (car buffer))
+ (message "Tinydired: No dired buffer found."))))
+
+;;; ----------------------------------------------------------------------
+;;; - If I have 2-3 dired ftp sessions and I want to close the current
+;;; one, this is a handy command.
+;;;
+;;;###autoload
+(defun tinydired-kill-dired-and-ange-session (&optional verb)
+ "Kill the current dired buffer and possible ange-ftp buffer. VERB.
+This is like `dired-delete-and-exit'."
+ (interactive)
+ (let* ((buffer (tinydired-ange-ftp-buffer-for-this-dired)))
+ (ti::verb)
+ (if buffer
+ (kill-buffer buffer))
+ (kill-buffer (current-buffer))
+ (if verb
+ (message
+ (if buffer
+ "Ange buffer killed too."
+ "No ange buffer associated with dired.")))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinydired-kill-all-ange-and-dired-buffers (&optional verb)
+ "Kill all ange-ftp buffers _and_ all remote dired buffers. VERB."
+ (interactive)
+ (let* ((ange (ti::buffer-get-ange-buffer-list))
+ (dired (ti::dolist-buffer-list
+ (and (eq major-mode 'dired-mode)
+ (string-match tinydired-:dired-directory-ange-regexp
+ dired-directory))))
+ (ange-count 0)
+ (dired-count 0))
+ (ti::verb)
+ (dolist (elt ange)
+ (kill-buffer elt)
+ (incf ange-count))
+ (dolist (elt dired)
+ (kill-buffer elt)
+ (incf dired-count))
+ (if verb
+ (message "Tinydired: Killed %s ange, %s dired buffers."
+ ange-count dired-count))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinydired-kill-all-ange-buffers ()
+ "Kill all ange-ftp process buffers.
+If you want to kill one buffer at a time, use
+`tinydired-switch-to-some-ange-ftp-buffer' to switch to individual buffer
+and use \\[kill-buffer] to kill session.
+
+This function is primarily used for cleanups. After a while
+you may end up with many ftp session and it's nice if
+you can get rid of them fast.
+
+Don't worry about the dired buffers, Ange will automatically
+create connection, if you use \"g\" -- rever-buffer, in a dired
+that is associated with ange-ftp."
+ (interactive)
+ (let* ((list (ti::buffer-get-ange-buffer-list))
+ (i 0))
+ (dolist (elt list)
+ (incf i) (kill-buffer elt))
+ (if (> i 0 )
+ (message (concat "Tinydired: Ange buffers killed: " i))
+ (message "Tinydired: No ange buffers found."))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinydired-switch-to-some-ange-ftp-buffer ()
+ "Gather all ange FTP buffers and offer completion menu.
+If there is only one Ange buffer, switches to it without asking."
+ (interactive)
+ (let* ((list (ti::buffer-get-ange-buffer-list))
+ buffer
+ go)
+ (if (null list)
+ (message "no Ange-ftp sessions at the moment.")
+ (if (eq 1 (length list))
+ (setq buffer (car list))
+ (setq buffer
+ (completing-read "go ange: " (ti::list-to-assoc-menu list))))
+ (if (setq go (get-buffer buffer))
+ (switch-to-buffer go)
+ (message (concat "No ange buffer: " buffer))))))
+
+;;; ----------------------------------------------------------------------
+;;; - This is handy, when you want to check that the mput went ok.
+;;;
+(defun tinydired-switch-to-mput-ange-ftp-buffer ()
+ "Switch to ange buffer where last mput was made.
+Does nothing if no mput were recorded or such ange buffer does not exist.
+
+Binds local keys to ftp buffer
+
+ C - c b switch back to previous buffer
+
+References:
+
+ `tinydired-:previous-buffer'
+ `tinydired-:mput-last-ftp'
+
+Return
+
+ nil no action taken.
+ t"
+ (interactive)
+ (let* ((file tinydired-:mput-last-ftp)
+ (buffer (current-buffer))
+ list
+ host
+ ret)
+ (cond
+ ((null tinydired-:mput-last-ftp)
+ (message "Tinydired: Sorry, No mput information."))
+ ((not (string-match "/.*@.*:" file))
+ (message "Tinydired: Sorry, No ange reference in `tinydired-:mput-last-ft'p"))
+ (t
+ ;; This return 3 member list: SITE LOGIN DIRECTORY/FILE
+ (setq list (ange-ftp-ftp-name file)
+ host (nth 0 list))
+ (setq tinydired-:previous-buffer buffer)
+ ;; Try to find buffer , ange uses SITE name for buffer names
+ ;; *ftp omc@venus*
+ (cond
+ ((and list
+ (setq buffer (car (ti::dolist-buffer-list
+ (string-match
+ (concat "[*]ftp.*" (regexp-quote host))
+ (buffer-name))
+ 'temp-buffers))))
+ (switch-to-buffer-other-window buffer)
+ (ti::pmax)
+ ;; Switching back to previous (b)uffer
+ (local-set-key "\C-cb"
+ (function
+ (lambda ()
+ "TinyDired: mput ange, back to previous buffer"
+ (interactive)
+ (pop-to-buffer tinydired-:previous-buffer))))
+ (setq ret t))
+ (t
+ (message
+ "Tinydired: Sorry, can't find ange buffer for `%s'" host)))))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydired-ange-ftp-buffer-for-this-dired (&optional file)
+ "Return ange ftp buffer-name-string for current dired or FILE, or nil."
+ (let* (host
+ buffer
+ list)
+ (setq file (or file (dired-get-filename)))
+ ;; This return 3 member list: SITE LOGIN DIRECTORY/FILE
+ (setq list (ange-ftp-ftp-name file)
+ host (nth 0 list))
+ (when list ;This dired is not in remote site
+ ;; Remove that ange-ftp site information from the string.
+ (setq tinydired-:directory
+ (ti::string-index-substring dired-directory ?: nil 'right))
+ ;; Try to find buffer , ange uses SITE name for buffer names
+ ;; *ftp omc@venus*
+ (when list
+ (setq buffer
+ (car (ti::dolist-buffer-list
+ (string-match
+ (concat "[*]ftp.*" (regexp-quote host))
+ (buffer-name))
+ 'temp-buffers)))
+ (unless (get-buffer buffer)
+ (setq buffer nil))))
+ buffer))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinydired-switch-to-ange-ftp-buffer (&optional verb)
+ "If the dired is ange ftp buffer, switch to the real ftp buffer. VERB.
+
+Sets global
+ `tinydired-:directory' filename for current line
+
+Binds local keys in ftp buffer
+
+ C - c af insert files stored in current point
+ C - c ad insert directory name
+ C - c ab switch back to dired buffer"
+ (interactive)
+ (let* (buffer
+ dir)
+ (ti::verb)
+ ;; 1. try normal ange ftp
+ ;; 2. did user used 'put' to remove site ?
+ ;;
+ (setq buffer (tinydired-ange-ftp-buffer-for-this-dired))
+ (cond
+ ((and (null buffer)
+ tinydired-:file-store
+ tinydired-:mput-last-ftp
+ (null (tinydired-switch-to-mput-ange-ftp-buffer)))
+ (if verb
+ (message "Tinydired: can't locate associated ftp buffer.")))
+ ((null buffer)
+ (if verb
+ (message "Tinydired: can't locate associated ftp buffer.")))
+ (buffer
+ (switch-to-buffer-other-window buffer)
+ (set (make-local-variable 'tinydired-:directory) dir)
+ (ti::pmax)
+ ;; "f" for file information
+ (local-set-key
+ "\C-caf"
+ (function
+ (lambda (&optional arg)
+ "TinyDired: Inserts file storage string."
+ (interactive "P")
+ (setq arg (tinydired-store-get-string))
+ (if (ti::nil-p arg)
+ (message "Tinydired: No files in storage.")
+ (insert (tinydired-store-get-string))))))
+ ;; "d" for directory information
+ (local-set-key
+ "\C-cad"
+ (function
+ (lambda ()
+ "TinyDired: Inserts dired's directory string."
+ (interactive)
+ (insert tinydired-:directory))))
+ ;; Switching back to dired (b)uffer
+ (local-set-key
+ "\C-cab"
+ (function
+ (lambda ()
+ "TinyDired: Back to dired buffer"
+ (interactive)
+ (tinydired-back-to-dired-buffer))))))))
+
+;;; ----------------------------------------------------------------------
+;;; mget = multiple get
+;;;
+(defun tinydired-store-ftp-mget ()
+ "Send command to ange to fetch all files in store."
+ (interactive)
+ (let* ((files tinydired-:file-store)
+ (down tinydired-:download-dir)
+ (store (tinydired-store-get-string))
+ (ange (ange-ftp-ftp-name dired-directory))
+ to-dir
+ host
+ user
+ dir)
+ (cond
+ ((null ange)
+ (message "Tinydired: Can't find ftp process. Start one first."))
+ ((ti::nil-p files)
+ (message "Tinydired: No files in store."))
+ (t
+ (if (or (not
+ (y-or-n-p (concat "Tinydired: really get: "
+ ;; Get nicer prompt
+ (if (> (length store) 50)
+ (concat (substring store 0 50 )
+ "...")
+ (concat store " ")))))
+ (ti::nil-p
+ (setq to-dir
+ ;; Hack to read directory easily
+ (let ((default-directory down))
+ (call-interactively
+ (function
+ (lambda (dir)
+ (interactive "Ddownload dir: ")
+ dir)))))))
+ (message "Tinydired: Cancelled.")
+ ;; ................................................. then part ...
+ ;; - First update the value, so that user gets the old selection
+ (setq tinydired-:download-dir to-dir)
+ ;; Next, get all needed parameters
+ (setq host (nth 0 ange)
+ user (nth 1 ange)
+ dir (nth 2 ange)
+ to-dir (expand-file-name to-dir))
+ (ti::file-ange-file-handle
+ 'get user host dir to-dir files))))))
+
+;;; ----------------------------------------------------------------------
+;;; - remember to be in DIRED before you call this
+;;; mput = multiple put
+;;;
+(defun tinydired-store-ftp-mput (ange-ref-to)
+ "Send all files in store to remote site ANGE-REF-TO."
+ (interactive
+ (list
+ (completing-read
+ "mput site: "
+ (ti::list-to-assoc-menu tinydired-:mput-sites)
+ nil nil tinydired-:mput-last-ftp
+ 'tinydired-:mput-history)))
+ (if (null dired-directory)
+ (error "Tinydired: Must execute command in dired buffer."))
+ ;; Record the site name where the mput was made
+ (setq tinydired-:mput-last-ftp ange-ref-to)
+ (let* ((files tinydired-:file-store)
+ (store (tinydired-store-get-string))
+ (dir dired-directory)
+ ange
+ to-dir
+ host
+ user)
+ ;; If user is in remote dired buffer, signal error
+ ;; We don't support this. At least not now.
+ ;;
+ (if (string-match "@" dired-directory)
+ (error "Tinydired: sorry, load files first to your site."))
+ (if (not (ti::nil-p ange-ref-to))
+ (setq ange (ange-ftp-ftp-name ange-ref-to) ;crack it
+ host (nth 0 ange)
+ user (nth 1 ange)
+ to-dir (nth 2 ange)))
+ (cond
+ ((ti::nil-p ange-ref-to)
+ (message "Tinydired: No site given"))
+ ((ti::nil-p files)
+ (message "Tinydired: No files in store."))
+ ((ti::nil-p to-dir)
+ (message "Tinydired: No destination download directory given"))
+ (t
+ (if (not (y-or-n-p (concat "Put " host ": "
+ ;; Get nicer prompt
+ (if (> (length store) 50)
+ (concat (substring store 0 50)
+ "...")
+ (concat store " ")))))
+ (message "Tinydired: Cancelled.")
+ ;; ................................................. then part ...
+ ;; (mode user host dir lcd file-list &optional not-bg msg-func)
+ (ti::file-ange-file-handle 'put user host to-dir dir files))))))
+
+;;}}}
+
+(provide 'tinydired)
+
+(tinydired-install)
+(run-hooks 'tinydired-:load-hook)
+
+;;; tinydired.el ends here
--- /dev/null
+;; tinyeat.el --- Eat blocks of text at point, forward and backward
+
+; This file is not part of Emacs
+
+;;{{{ Documentation
+
+;; Copyright (C) 1995-2007 Jari Aalto
+;; Keywords: extensions
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program call C-u M-x
+;; tinyeat-version. Look at the code with folding.el
+
+;; COPYRIGHT NOTICE
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;; ....................................................... &t-install ...
+;; Put this file on your Emacs-Lisp load path, add following into your
+;; emacs startup file.
+;;
+;; ;; Rebind BACKSPACE and DEL-related keys
+;; (setq tinyeat-:load-hook '(tinyeat-install))
+;; (require 'tinyeat)
+;; (global-set-key "\M-z" 'tinyeat-kill-buffer-lines-main)
+;;
+;; Or use autoload and Emacs starts up faster
+;;
+;; (autoload 'tinyeat-forward-preserve "tinyeat" "" t)
+;; (autoload 'tinyeat-backward-preserve "tinyeat" "" t)
+;; (autoload 'tinyeat-delete-paragraph "tinyeat" "" t)
+;; (autoload 'tinyeat-kill-line "tinyeat" "" t)
+;; (autoload 'tinyeat-zap-line "tinyeat" "" t)
+;; (autoload 'tinyeat-kill-line-backward "tinyeat" "" t)
+;; (autoload 'tinyeat-kill-buffer-lines-point-max "tinyeat" "" t)
+;; (autoload 'tinyeat-kill-buffer-lines-point-min "tinyeat" "" t)
+;;
+;; (global-set-key (kbd "ESC C-k") 'tinyeat-kill-line-backward)
+;; (global-set-key (kbd "ESC d") 'tinyeat-forward-preserve)
+;; (global-set-key (kbd "ESC z") 'tinyeat-kill-buffer-lines-main)
+;; (global-set-key (kbd "ESC C-k") 'tinyeat-zap-line)
+;;
+;; (global-set-key (kbd "M-DEL") 'tinyeat-forward-preserve)
+;; (global-set-key (kbd "<C-delete>") 'tinyeat-backward-preserve)
+;; (global-set-key (kbd "<S-backspace>") 'tinyeat-delete-whole-word)
+;;
+;; Investigate problems with:
+;;
+;; M-x tinyeat-debug-toggle
+;; M-x tinyeat-debug-show
+;;
+;; If you have any questions, use this function to contact maintainer
+;;
+;; M-x tinyeat-submit-bug-report
+
+;;}}}
+;;{{{ Documentation
+
+;;; Commentary:
+
+;; Preface, overview of features
+;;
+;; o Determines how much text should be eaten around current cursor
+;; position. Eat extra spaces, extra newlines, next word
+;; next statement, next comment ... whatever is appropriate
+;; o Can also eat inside mixed case word: WordsThatAreLikeThis
+;; o Yank and "overwrite" text under cursor with Meta mouse-2 or
+;; `Meta' `C-y'. (Std Emacs in `overwrite-mode' doesn't allow you to
+;; yank and overwrite at the same time.)
+;;
+;; Today's suggestion
+;;
+;; If using Windowed Emacs and the prompt is at minibuffer and
+;; you would like to clean the whole prompt, hit key
+;; `Esc-backspace'. In non-windowed emacs, you have to repeat the
+;; keystroke as needed (this is due to "backspace key detection
+;; problem syndrome").
+;;
+;; Non-windowed and Windowed Emacs
+;;
+;; This package works _best_ in windowed Emacs, because in windowed
+;; environment you can use the modifiers *Control*, *Alt* and *Meta*
+;; freely with other keys. The idea of this package is to overload
+;; your single key, `backspace', as much as possible with various
+;; delete functionalities.
+;;
+;; In non-windowed Emacs there is no key named `backspace', so
+;; standard Emacs bindings are bound instead. Many of this
+;; package's features are left unused because there are no
+;; suitable keys to bind the commands to. In non-windowed Emacs the
+;; command marked with (*) are not available. Emacs bindings
+;; that are redefined when you call `tinyeat-activate' are:
+;;
+;; was now
+;; ---------------------------------------------------------
+;; M-d kill-word tinyeat-forward-preserve
+;; S-backspace <none> tinyeat-delete-whole-word (*)
+;; M-k kill-sentence tinyeat-kill-line-backward
+;; M-C-d down-list tinyeat-delete-paragraph
+;; M-C-y <none> tinyeat-yank-overwrite
+;;
+;; Story behind this package
+;;
+;; One day the developer got frustrated of moving cursor around the
+;; point and using keys del or backspace to write C++ and LISP
+;; symbols. The start situation was like this while cursor was at (*):
+;;
+;; (defun lisp-symbol-name-myname ()
+;; *
+;;
+;; He decided to change 'myname' to something else. Normally he
+;; would reach out for M-d for `kill-word' to delete `myname' and
+;; type the new name:
+;;
+;; (defun lisp-symbol-name-mynew ()
+;; *
+;;
+;; Next, he noticed that there were extra spaces involved.
+;; A call to `fixup-whitespace' would make it go away ... Hmm that was
+;; not bound to any key by default (in this particular Emacs used
+;; at the time), so he had to type it the long way round: `M-x'
+;; `fixup-whitespace'. His thoughts were: "Oh, I should have bound it
+;; to some easily reacheable key". The story continues.
+;; He looked at the function once more and decided that the name
+;; `symbol-name-mynew' wasn't a good one after all. He decided to
+;; delete 3 words backward. Now, how do you do that?
+;;
+;; (defun lisp-symbol-name-mynew ()
+;; *
+;;
+;; He murmurs, "where is the command to delete backward ...". After
+;; spending valuable minutes to find the `delete-backward-word'
+;; command with the `M-x' `apropos', hitting the page up and down
+;; to find anything that would look like what he wanted, he leaned
+;; back with despair, "Doh, there is no such command". Silently
+;; he ends up tapping the backspace until he reaches the correct point:
+;;
+;; (defun lisp- ()
+;; *
+;;
+;; and starts typing a new name...
+;;
+;; (defun lisp-my-func ()
+;;
+;; All is perfect for a moment. Then, he notices that there are too
+;; many newlines above the newly created function and says to himself:
+;; "I really should delete those 5 extra empty lines above the
+;; function. Now, how do I kill backward 5 empty lines backward? The
+;; `kill-line' in C-k kills only forward" ...". The story teller
+;; rests here and leaves reader's imagination to fly forward.
+;;
+;; Lesson learned
+;;
+;; As you can notice, people often spend most of the time to
+;; position the cursor to the right spot and deleting text over
+;; there.. over here .. typing more .. changing our mind ... and
+;; so on.
+;;
+;; It was time to do something creative, so that user wouldn't have to
+;; worry about the deletion of text so much. This package provides
+;; atempts to provide _smart_ deleting capabilities: whether it was
+;; to delete forward of backward. Naturally the art of deletion is
+;; not accurate, a few guesses need to be made and they may be
+;; wrong. If it so happens that a lot of text have suddenly
+;; retired (vanished, vaporized) from the buffer, remember, there
+;; is no need to panic. Emacs has friendly `undo' (C-_ or C-x u).
+;;
+;; Default keybindings
+;;
+;; Line delete
+;;
+;; << >> <<>>
+;; M-k C-k M-C-k
+;; zap whole line
+;;
+;; Chunk delete: words, spaces, symbols ...
+;;
+;; << >> <<>> \//\
+;; M-Backspace C-backspace S-Backspace C-M-d / C-S-backspace
+;; Delete whole word Paragraph delete
+;;
+;; Other functions that you might want to bind to keys:
+;;
+;; M-x tinyeat-erase-buffer
+;; M-x tinyeat-kill-buffer-lines-main
+;; M-x tinyeat-join-lines
+;;
+;; Known Bugs
+;;
+;; This package heavily relies on various modifiers that can be
+;; attached to the *BACKSPACE* key and binding it can be a difficult
+;; subject under Unix. For example the *Alt* key may not exist and to
+;; make it "seen" under Unix you have to introduce yourself to
+;; `xmodmap(1)' or `keycaps(1)' and possibly `xev(1)' in order to find
+;; the key symbols correctly.
+;;
+;; Worse, in the same environment Emacs and XEmacs may disagree what
+;; BACKSPACE means. To get some taste, here is what XEmacs 20.4 and
+;; Emacs 20.3 in Redhat Linux 6.2 return:
+;;
+;; XEmacs Emacs
+;;
+;; <esc backspace> M-backspace ESC DEL
+;; <shift backspace> delete S-delete
+;; <alt backspace> <nothing> <nothing>
+;;
+;; There is nothing this package can do to cope with these changes in
+;; key symbols or the environemnt you use. If you can, try to get the
+;; ALT key working and shift-modifier for backspace and everything
+;; is well. If that is not possible, the power of the predefined
+;; keybindings are mostly left unused and you have to look at the
+;; install function and determine how would you use your keyboard best
+;; with these functions.
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+;;{{{ setup: variables
+
+(require 'tinylibm)
+(eval-when-compile (ti::package-use-dynamic-compilation))
+
+(ti::package-defgroup-tiny TinyEat tinyeat-: extension
+ "Eat blocks of text forward, backward.
+Overview of features
+
+ o Determine how much text should be eaten around current cursor
+ position. Eat extra spaces, extra newlines, next word
+ next statement , next comment ... whatever is appropriate
+ o Can also eat only 'inside' words: WordsThatAreLikeThis")
+
+(defcustom tinyeat-:load-hook nil
+ "*Hook that is run when package is loaded."
+ :type 'hook
+ :group 'TinyEat)
+
+(defcustom tinyeat-:verbose-flag t
+ "*Non-nil means allow informational messages to be displayed."
+ :type 'boolean
+ :group 'TinyEat)
+
+(defcustom tinyeat-:non-word-chars
+ "][=_~+!@#$%&*:;'\"`,.<>(){}$<>?/|\\\\\n \t-"
+ "*Characters that _stop_ eating word.
+Character ][ be in this order and in the beginning of variable,
+because this string is converted into regexp later."
+ :type '(string :tag "Charset")
+ :group 'TinyEat)
+
+(defcustom tinyeat-:eat-full-word-charset "^][ \t\n(){};'\","
+ "*Character set to use when determining word boundary.
+Normally word is terminated by whitespace or newlines."
+ :type '(string :tag "Charset")
+ :group 'TinyEat)
+
+;;}}}
+;;{{{ version
+
+;;;###autoload (autoload 'tinyeat-version "tinyeat" "Display commentary." t)
+(eval-and-compile
+ (ti::macrof-version-bug-report
+ "tinyeat.el"
+ "tinyeat"
+ tinyeat-:version-id
+ "$Id: tinyeat.el,v 2.62 2007/05/01 17:20:43 jaalto Exp $"
+ '(tinyeat-:version-id
+ tinyeat-:debug
+ tinyeat-:load-hook
+ tinyeat-:verbose-flag
+ tinyeat-:non-word-chars
+ tinyeat-:eat-full-word-charset)
+ '(tinyeat-:debug-buffer)))
+
+;;}}}
+;;{{{ install
+
+;;;###autoload (autoload 'tinyeat-debug-toggle "tinyeat" "" t)
+;;;###autoload (autoload 'tinyeat-debug-show "tinyeat" "" t)
+
+(eval-and-compile (ti::macrof-debug-standard "tinyeat" "-:"))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyeat-install-default-bindings-terminal ()
+ "Install extra binding for dummy terminals."
+ (let ((status (lookup-key global-map (kbd "ESC [ 3"))))
+ ;; Will be number, if this is a prefix key
+ (when (or (integerp status)
+ (and status
+ (keymapp status)))
+ ;; C-delete
+ (global-set-key (kbd "ESC [ 3 ^") 'tinyeat-forward-preserve)
+ ;; S-delete
+ (global-set-key (kbd "ESC [ 3 $") 'tinyeat-delete-whole-word)
+ ;; C-S-delete
+ (global-set-key (kbd "ESC [ 3 @") 'tinyeat-delete-paragraph))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyeat-install-default-bindings ()
+ "Add default bindings to the backspace key with modifiers."
+ (interactive)
+ (global-set-key (kbd "ESC C-y") 'tinyeat-yank-overwrite)
+
+ ;; was `kill-sentence'
+ (global-set-key (kbd "ESC C-k") 'tinyeat-kill-line-backward)
+
+ ;; was `kill-word'
+ (global-set-key (kbd "ESC d") 'tinyeat-forward-preserve)
+ (global-set-key (kbd "<C-delete>") 'tinyeat-forward-preserve)
+ (global-set-key (kbd "<C-backspace>") 'tinyeat-forward-preserve)
+
+ ;; Alt-backspace
+ (global-set-key (kbd "ESC DEL") 'tinyeat-backward-preserve)
+ (global-set-key (kbd "M-DEL") 'tinyeat-backward-preserve)
+
+ (global-set-key (kbd "<S-backspace>") 'tinyeat-delete-whole-word)
+ (global-set-key (kbd "<S-delete>") 'tinyeat-delete-whole-word)
+
+;;; (when (ti::xemacs-p)
+;;; (global-set-key (kbd "M-BS") 'tinyeat-backward-preserve)
+;;; (global-set-key (kbd "C-BS") 'tinyeat-forward-preserve))
+
+ ;; Was `down-list'
+ (global-set-key (kbd "ESC C-d") 'tinyeat-delete-paragraph)
+ (global-set-key (kbd "<C-S-backspace>") 'tinyeat-delete-paragraph)
+ (global-set-key (kbd "<C-S-delete>") 'tinyeat-delete-paragraph)
+
+ (global-set-key (kbd "ESC C-k") 'tinyeat-zap-line)
+
+ (unless (ti::compat-window-system)
+ (tinyeat-install-default-bindings-terminal))
+
+ (message "\
+TinyEat: ** keys were bound to TinyEat functions."))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyeat-install (&optional arg)
+ "Call `tinyeat-install-default-bindings' with ARG."
+ (interactive)
+ (tinyeat-install-default-bindings))
+
+;;}}}
+;;{{{ misc
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinyeat-repeat-macro 'lisp-indent-function 1)
+(defmacro tinyeat-repeat-macro (end &rest body)
+ "Loop using VAR from BEG to END and do BODY."
+ (` (loop for var from 1 to (, end)
+ do
+ (progn
+ (,@ body)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinyeat-verbose-macro 'lisp-indent-function 0)
+(defmacro tinyeat-verbose-macro (&rest body)
+ "Run BODY if tinyeat-:verbose-flag' is set.
+Minibuffer is excluded."
+ (`
+ (when (and (not (ti::buffer-minibuffer-p))
+ tinyeat-:verbose-flag)
+ (,@ body))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyeat-erase-buffer ()
+ "Erase buffer. If read-only buffer, do nothing."
+ (interactive)
+ (unless buffer-read-only
+ (if (ti::buffer-minibuffer-p)
+ ;; `erase-buffer' signals error in minibuffer:
+ ;; read-only-text (like that in prompt)
+ (delete-region
+ (line-beginning-position)
+ (line-end-position))
+ (erase-buffer))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyeat-zap-line (&optional count)
+ "Kill COUNT times whole lines including the final newline."
+ (interactive "p")
+ (tinyeat-repeat-macro (or count 1)
+ (beginning-of-line)
+ (if (looking-at "\n")
+ (kill-line)
+ (kill-line 1))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyeat-backward (&optional count)
+ "Eat backward COUNT times. See `tinyeat-eat'."
+ (interactive "p")
+ (tinyeat-repeat-macro (or count 1)
+ (tinyeat-eat 'back)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyeat-backward-preserve (&optional count)
+ "Eat forward, but handle spaces differently. See `tinyeat-eat'."
+ (interactive "p")
+ (tinyeat-repeat-macro (or count 1)
+ (tinyeat-eat 'back 'preserve)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyeat-forward (&optional count)
+ "Eat forward COUNT times. See `tinyeat-eat'."
+ (interactive "p")
+ (tinyeat-repeat-macro (or count 1)
+ (tinyeat-eat)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyeat-forward-preserve (&optional count)
+ "Eat forward COUNT times. See `tinyeat-eat'."
+ (interactive "p")
+ (tinyeat-repeat-macro (or count 1)
+ (tinyeat-eat nil 'preserve)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyeat-join-lines (&optional count)
+ "Join this and next line with one space, and go to the joint."
+ (interactive "p")
+ (tinyeat-repeat-macro (or count 1)
+ (end-of-line)
+ (unless (eobp)
+ (kill-line)
+ (fixup-whitespace))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyeat-delete-whole-word-1-charset (charset)
+ "Delete word based on CHARSET. See `skip-chars-backward' and *-forward."
+ (let* (beg
+ end)
+ (skip-chars-backward charset)
+ (setq beg (point))
+ (skip-chars-forward charset)
+ (setq end (point))
+ (delete-region beg end)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyeat-delete-whole-word-1-main (&optional charset)
+ "Delete one word at point. Optional CHARSET is for `skip-chars-backward'.
+References:
+ `tinyeat-:eat-full-word-charset'"
+ (interactive)
+ (or charset
+ (setq charset tinyeat-:eat-full-word-charset))
+ (cond
+ ((or (looking-at "[ \t\r\n][ \t\r\n]")
+ (and (not (bolp))
+ (string= " " (char-to-string (preceding-char)))
+ (looking-at "[ \t\r\n]")))
+ (fixup-whitespace))
+ ((looking-at "[ \t\r\n]")
+ (delete-horizontal-space))
+ (t
+ (tinyeat-delete-whole-word-1-charset charset)
+ ;; (unless (zerop (skip-chars-forward " \t")) ; delete white space
+;;; (delete-region beg (point)))
+ nil)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyeat-delete-whole-word (&optional count)
+ "Delete COUNT words at point.
+
+- If there are multiple whitespaces around, call `fixup-whitespace'.
+- If on top of only one whitespcae, call `delete-horizontal-space'.
+- If on top of word, delete whole word.
+
+References:
+ `tinyeat-:eat-full-word-charset'"
+ (interactive "p")
+ (tinyeat-repeat-macro (or count 1)
+ (tinyeat-delete-whole-word-1-main)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyeat-kill-line (&optional count)
+ "Like `kill-line'; COUNT times. Killed text isn't put into cut buffer.
+This way you can retain mouse selection in cut buffer."
+ (interactive "p")
+ (tinyeat-repeat-macro (or count 1)
+ (cond
+ ((eobp)) ;Do nothing
+ ((eolp)
+ (delete-char 1))
+ (t
+ (delete-region (point) (line-end-position))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyeat-kill-line-backward (&optional count)
+ "Like `kill-line' back; COUNT times. Killed text isn't put into cut buffer."
+ (interactive "p")
+ (tinyeat-repeat-macro (or count 1)
+ (when (not (bobp))
+ (if (bolp) ;Kill previous newline (shift line up)
+ (backward-delete-char 1)
+ (delete-region (point) (line-beginning-position))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyeat-kill-buffer-lines-point-max (&optional back)
+ "Kill to the `point-max' or if BACK, then to the `point-min'."
+ (interactive "P")
+ (cond
+ (back
+ (delete-region (point) (point-min)))
+ (t
+ (delete-region (point) (point-max)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyeat-kill-buffer-lines-point-min ()
+ "Kill until `point-min'."
+ (interactive "p")
+ (tinyeat-kill-buffer-lines-point-max 'back))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyeat-kill-buffer-lines-main (&optional backward)
+ "Kill until `point-max' or if BACKWARD, until `point-min'."
+ (interactive "p")
+ (if backward
+ (tinyeat-kill-buffer-lines-point-min)
+ (tinyeat-kill-buffer-lines-point-max)))
+
+;;}}}
+;;{{{ misc2
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyeat-delete-paragraph ()
+ "Delete current paragraph, separated by empty lines."
+ (interactive "*")
+ (let* ((re "^[ \t]*$")
+ beg
+ end)
+ (cond
+ ((save-excursion ;sitting on empty line
+ (beginning-of-line) ;kill empty lines around the point
+ (looking-at "^[ \t]*$"))
+ (skip-chars-backward " \t\n")
+ (forward-line 1)
+ (setq beg (point))
+ (skip-chars-forward " \t\n")
+ (forward-line -1)
+ (setq end (point)))
+ ((save-excursion
+ ;; Kill paragraph.
+ (if (not (re-search-backward re nil t))
+ (setq beg (point-min))
+ (beginning-of-line)
+ (forward-line 1) ;exlude space
+ (setq beg (point))))
+ (save-excursion
+ (cond
+ ((re-search-forward re nil t)
+ (beginning-of-line)
+ (setq end (point)))
+ (t
+ (if (not (eq beg (point-max)))
+ (setq end (point-max))
+ (setq end (point-min))))))))
+ (if (and (not (and beg end))
+ (not (ti::buffer-minibuffer-p)))
+ (message "TinyEat: Can't find paragraph bounds (empty line)")
+ (unless (eq beg end)
+ (kill-region beg end)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyeat-space-delete-at-point (&optional back preserve)
+ "Delete whitespace at point. Optionally BACK.
+If optional PRESERVE is given, then deletes towards the BACK only.
+if BACK is non-nil the deletion is headed backward."
+ (let* ( ;; character function selection
+ (charf (if back 'skip-chars-backward 'skip-chars-forward))
+ (p (point))
+ (ch (ti::buffer-read-char back 0)) ;sitting on it if looking fwd
+ (ch-p (ti::buffer-read-char back -1))
+ (ch-n (ti::buffer-read-char back 1)))
+ (cond
+ ((and back
+ (ti::space-p (or ch-p ?\ ))
+ (char= ch ?\n))
+ (delete-horizontal-space)
+ (if (null back)
+ (tinyeat-verbose-macro
+ (message "TinyEat: line cleared")))
+ t)
+ ((char= ch ?\n) ;no spaces before, do nothing
+ nil)
+ ((or (and ch ch-n
+ (ti::space-p ch)
+ (ti::space-p ch-n)) ;at least two spaces
+ (and ch ch-p
+ (ti::space-p ch-p)
+ (ti::space-p ch)))
+ (if (null preserve)
+ (fixup-whitespace)
+ (funcall charf " \t")
+ (delete-region p (point)))
+ t)
+ (t
+ (delete-horizontal-space)
+ t))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyeat-word-move-point (&optional back)
+ "Move to suitable word kill point. Mixed case words are special.
+Optionally BACK.
+See variable `tinyeat-:non-word-chars' how to delimit word parts.
+
+* = cursor position
+
+ThisIsMixedWord --> ThisIsMixedWord
+* *
+THISmixedWord --> THISmixedWord
+* *"
+ (let* ((fid "tinyeat-word-move-point")
+ (charf (if back 'skip-chars-backward 'skip-chars-forward))
+ (non-word tinyeat-:non-word-chars)
+ (nonw-re (concat "[" non-word "]+"))
+ (ch (ti::buffer-read-char back))
+ p
+ str
+ mb
+ me ;match beg end
+ mixed)
+ (unless fid ;; Quiet XEmacs byte compiler
+ (setq fid nil))
+ (tinyeat-debug fid "ENTRY" 'back back
+ 'char ch
+ (if ch
+ (char-to-string ch)
+ "no CHARACTER??"))
+ ;; Check if this is special mixedCase before vaporizing word...
+ (save-excursion
+ (setq p (point))
+ (if back
+ (backward-word 1)
+ (forward-word 1))
+ (setq str (buffer-substring p (point)))
+ (setq mixed (ti::string-match-case "[A-Z][a-z]" str)))
+ (cond
+ (mixed
+ (tinyeat-debug fid "CASE MIXED" 'point (point))
+ (if (eq ch (downcase ch))
+ (funcall charf "a-z")
+ (setq p (point))
+ ;; Skip all big letters
+ (funcall charf "A-Z")
+ ;; If this was only one letter, continue deleting. Otw stay put.
+ (if (eq 1 (abs (- p (point))))
+ (funcall charf "a-z")))
+ ;; The previous statements only moved 2 first statements
+ ;; ThisIsWord start,
+ ;; *
+ ;; ThisIsWord after,
+ ;; *
+ ;; ThisIsWord correction. This is needed
+ ;; *
+ (if (and back
+ (not (bobp)))
+ (backward-char 1)))
+ (t
+ ;; if there is non-word we must remove it.
+ ;; - There is some problems in backward deltion, eg deleting "...."
+ ;; backward in text-mode does not delete all dots. Don't
+ ;; know why not.
+ (cond
+ ((if back ;select FWD of BCK looking
+ (cond
+ ((string-match nonw-re (char-to-string ch))
+ (re-search-backward nonw-re nil t)))
+ (looking-at nonw-re))
+ (setq mb (match-beginning 0)
+ me (match-end 0))
+ (tinyeat-debug
+ fid "CASE 1" ch 'point (point)
+ 'match-begin mb
+ 'match-end me)
+ ;; 1. if there is multiple items like "....", delete only
+ ;; those
+ ;; 2. if there is only one member like ".member", delete
+ ;; dot and the word that follows it.
+ ;;
+ (if back (setq p mb)
+ ;; selet direction
+ (setq p me))
+ (if (not (eq 1 (abs (- me mb))))
+ (goto-char p)
+ (goto-char p)
+ (funcall charf (concat "^" non-word))))
+ (t
+ (tinyeat-debug "CASE default ")
+ ;; The skip-chars-forward _requires_ that the "-"
+ ;; character is the first item. That's why we have
+ ;; to add extra "-" to the front of string if user
+ ;; has defined "-" to be word stopper.
+ (if (ti::string-match-case "-" non-word)
+ (setq non-word (concat "^-" non-word))
+ (setq non-word (concat "^" non-word)))
+ (tinyeat-debug "CASE default " charf non-word)
+ (funcall charf non-word)))))))
+
+;;}}}
+;;{{{ Yanking
+
+;;; ----------------------------------------------------------------------
+;;; Having overwrite-mode on, does not support this kind of behavior?
+;;;
+(defun tinyeat-yank-overwrite ()
+ "Yank text by overwriting previous content."
+ (interactive)
+ (let* ((p (point)) ;insertion point
+ len
+ end)
+ (with-temp-buffer
+ (yank)
+ (setq len (1- (point-max)))) ;how many chars in there ?
+ (cond
+ ((= len 0)
+ (unless (ti::buffer-minibuffer-p)
+ (message "TinyEat: Nothing to yank")))
+ (t
+ ;; we must untabify the line, otw we get unpleasant results
+ (untabify p (line-end-position))
+ (setq end (+ p len))
+ (if (> end (point-max))
+ (setq end (point-max)))
+ (delete-region p end)
+ (yank)))))
+
+;;}}}
+;;{{{ engine
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyeat-eat (&optional back ti::space-preserve)
+ "Eat *appropriate* text forward, if BACK then backward.
+
+The optional SPACE-PRESERVE changes the space eating.
+
+A. when it is NIL and BACK is anything. * marks the cursor.
+ text1 text1 * text2 text2
+ --> text1 text1 text2 text2 ;one space left
+
+B. when it is NON-NIL and BACK nil
+ text1 text1 * text2 text2
+ --> text1 text1 *text2 text2 ;delete right spaces
+
+C. when it is NON-NIL and BACK t
+ text1 text1 * text2 text2
+ text1 text1* text2 text2 ;delete left spaces
+
+References:
+
+ `tinyeat-:non-word-chars'"
+ (let ((fid "tinyeat-eat ")
+ (p (point))
+ (syntaxf (if back 'skip-syntax-backward 'skip-syntax-forward))
+ (charf (if back 'skip-chars-backward 'skip-chars-forward))
+ ch
+ ch-n)
+ ;; XEmacs byte compiler thinks 'fid' is unused? Well, on the contrary.
+ ;; Quiet it. This is no-op.
+ (unless fid
+ (setq fid nil))
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. ..
+ (setq ch (ti::buffer-read-char back 0)) ;; sitting on it if looking fwd
+ (setq ch-n (ti::buffer-read-char back 1)) ;; next
+ (tinyeat-debug
+ fid
+ "CHARACTER " ch (char-to-string ch)
+ "NEXT CHARACTER" ch-n (char-to-string ch-n))
+ (cond
+ ;; --``-- --``-- --``-- --``-- --``-- --``-- --``-- --``-- --``-- --``--
+ ;; BEG of buffer or END of buffer
+ ((eq nil ch)
+ (tinyeat-debug fid "CHARCTER is nil, maybe bop or eob")
+ (tinyeat-verbose-macro
+ (message
+ "TinyEat: "
+ (concat
+ (if (bobp)
+ "Beginning"
+ "End")
+ " of buffer"))))
+ ;; --``-- --``-- --``-- --``-- --``-- --``-- --``-- --``-- --``-- --``--
+ ((ti::space-p ch) ;one whitespace
+ (tinyeat-debug fid
+ "SPACE-P choice" 'back back 'preserve ti::space-preserve)
+ (tinyeat-space-delete-at-point back ti::space-preserve)
+ (if (and (null back)
+ (looking-at "$")) ;it handled this
+ (tinyeat-verbose-macro
+ (message "TinyEat: line cleared."))))
+ ;; --``-- --``-- --``-- --``-- --``-- --``-- --``-- --``-- --``-- --``--
+ ;; - Multiple newlines, squeeze to one only
+ ((and (char= ch ?\n)
+ ch-n
+ (char= ch-n ?\n))
+ (funcall charf "\n")
+ (if (null back)
+ (backward-char 1) ;do not join, leave 1 EMPTY newline
+ (forward-char 1))
+ (tinyeat-debug fid "MULTIPLE newlines" 'was-point p 'now-point (point))
+ (delete-region p (point)))
+ ;; --``-- --``-- --``-- --``-- --``-- --``-- --``-- --``-- --``-- --``--
+ ;; - at the end of line I suppose add previous line to it.
+ ((char= ch ?\n)
+ (tinyeat-debug
+ fid "NEWLINE" 'back back 'ti::space-preserve ti::space-preserve)
+ (unless (tinyeat-space-delete-at-point back ti::space-preserve)
+ (if (null back) ;which direction
+ (delete-char 1)
+ (if (not (eq 0 (funcall syntaxf "_"))) ;try to move
+ (delete-region p (point)) ;moveti::d!
+ (backward-char 1)
+ (delete-region p (point))))))
+ ;; --``-- --``-- --``-- --``-- --``-- --``-- --``-- --``-- --``-- --``--
+ ;; WORD handling (blocks)
+ (t ;eat next word
+ (funcall syntaxf " ") ;ignore spaces
+ (tinyeat-debug fid "default - WORD CASE\n"
+ "CHARACTER " (char-to-string ch)
+ "CHARACTER SYNTAX " (char-to-string (char-syntax ch)))
+ ;; - What is next char after whitespace ??
+ ;; - With these following conditionals we set the point
+ ;; to appropriate position and after COND we run the kill command
+ (cond
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. ..
+ ((and (not (ti::char-in-list-case ch '(?- ?_ ?:)))
+ (equal ?w (char-syntax ch)))
+ (tinyeat-debug fid "-- CASE 1 syntaxes [-_:]")
+ (tinyeat-word-move-point back))
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. ..
+ ((and (ti::char-in-list-case ch '(?- ?_ ?:))
+ ch-n
+ (memq (char-syntax ch-n) '(?w ?\ )))
+ (tinyeat-debug fid "-- CASE 2")
+ ;; This is really hard to understand... execpt for the author
+ ;; 1) Is CH variable start, a delimiter ?
+ ;; 2) AND is the NEXT-CH word or whitespace
+ ;; (funcall syntaxf "_w")
+ ;; (funcall syntaxf " w")
+ (funcall charf "-_:"))
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. ..
+ (t
+ ;; punctuation, comment, the rest ... skip non important stuff
+ (tinyeat-debug fid "-- CASE other")
+ (funcall charf "^ \t\na-zA-Z0-9")))
+ (delete-region p (point))))))
+
+;;}}}
+
+(provide 'tinyeat)
+(run-hooks 'tinyeat-:load-hook)
+
+;;; tinyeat.el ends here
--- /dev/null
+;;; tinyef.el --- (E)lectric (f)ile minor mode. Easy C-x C-f filename composing
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 1995-2007 Jari Aalto
+;; Keywords: extensions
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program call M-x tinyef-version.
+;; Look at the code with folding.el
+
+;; COPYRIGHT NOTICE
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;; ....................................................... &t-install ...
+;; Put this file on your emacs-lisp load path, add following into your
+;; ~/.emacs startup file
+;;
+;; (add-hook 'tinyef-load-hook 'tinyef-minibuffer-define-key-extras)
+;; (require 'tinyef)
+;;
+;; Or use this autoload choice and your ~/.emacs will load quicker.
+;; This is the preferred method:
+;;
+;; (add-hook 'tinyef-load-hook 'tinyef-minibuffer-define-key-extras)
+;; (autoload 'turn-on-tinyef-mode "tinyef" "" t)
+;; (add-hook 'minibuffer-setup-hook 'turn-on-tinyef-mode)
+;;
+;; If you have any questions, use this function to contact maintainer
+;;
+;; M-x tinyef-submit-bug-report
+
+;;}}}
+
+;;{{{ Documentation
+
+;; ..................................................... &t-commentary ...
+
+;;; Commentary:
+
+;; Preface, Apr 1995
+;;
+;; There was a post in gnu.emacs.sources where Anders Lindgren
+;; <andersl@csd.uu.se> presented the basic code that allowed electric
+;; ~ and electric / characters to wipe out full (mini)buffer in certain
+;; cases. What you see here, is complete rewrite and enchancement of
+;; that code. This is a real must for any minibuffer file handling.
+;;
+;; Overview of features
+;;
+;; o Easy filename editing. Deletes directories at time, delete line
+;; backward, electric tilde, electric slash, electric colon etc.
+;; o Useful to go along with `C-x' `C-f' command prompt.
+;; o Mouse-3 in minibuffers clears the input.
+;;
+;; Description
+;;
+;; This package is only slightly *electric*, in a sense that it only
+;; defines some keys to be electric and it needs some other keys
+;; solely to its own use (you can't insert these chars to buffer
+;; without `C-q' `CHAR'). The term electric refers to feature where a
+;; pressed character behaves differently if the pressing happens
+;; around certain other charcters (some condition is met which
+;; triggers this other behavior). Other than that, the character
+;; behaves normally. Below there is a sample graph to give you an
+;; overview of what the so called "electricity" is is practice. In
+;; these presented cases cursor it at the end of line. Jusr load this
+;; file, press `C-x' `C-f' and experiment with keys "<>|/~".
+;;
+;; o b>> means what's on the line *before*
+;; o a>> means what's there *after*
+;; o "" means what you just pressed
+;; o [] means which action the character triggered
+;;
+;; Delete actions:
+;;
+;; b>> ~/dir1/dir2/dir3/ "<" [step-delete-back]
+;; a>> ~/dir1/dir2/
+;; The action wiped previous directory name or until
+;; special mark, See code, defaults are ":/@" (ange-ftp things)
+;;
+;; b>> ~/dir1/dir2/dir3/ ">" [step-delete-fwd]
+;; *Cursor here
+;; a>> ~/dir1/dir3/
+;; The action wiped one directory forward.
+;;
+;; b>> ~/dir1/dir2/ "|" [chunk-delete]
+;; a>>
+;; The action deleted whole line. It deletes until special marks
+;; like "@:". If repeated, it deletes constantly backward
+;;
+;; Electric actions:
+;;
+;; b>> http:/www.site.com/~userFoo/dir1/dir2/dir3/ "/" [e-slash]
+;; a>> http:/
+;; The e-slash action wiped out the line, because writing
+;; two slashes normally indicates, that you want to give
+;; another path
+;;
+;; b>> ~/dir1/dir2/dir3/ "~" [e-tilde]
+;; a>> ~
+;; The action wiped the line away, because it assumed
+;; you want to give "~userFoo" or another "~" relative path
+;;
+;; Movement actions:
+;;
+;; b>> ~/dir1/dir2/dir3/ "'" [move-back]
+;; *Cursor here
+;; a>> ~/dir1/dir2/dir3/
+;; *Cursor here
+;; The cursor goes backward logical steps.
+;;
+;; b>> ~/dir1/dir2/dir3/ "*" [move-fwd]
+;; *Cursor here
+;; a>> ~/dir1/dir2/dir3/
+;; *Cursor here
+;; The cursor goes forward logical steps.
+;;
+;; Other minibuffer keys that you can activate with:
+;;
+;; (add-hook 'tinyef-load-hook 'tinyef-minibuffer-define-key-extras)
+;;
+;; o `C-c' `C-b' Insert most recent buffer name to prompt
+;; o `C-c' `C-d' Insert date: ISO8601 YY-MM-DD--HH-MM into prompt
+;; o `C-c' `C-f' Insert most recent buffer's file name to prompt
+;; o `C-c' `\t' Complete from minibuffer history
+;;
+;; Automatic Isntallation
+;;
+;; This file includes function `tinyef-install' which hooks the mode
+;; to the appropriate places. E.g. to your minibuffer. If you're in
+;; trouble, you can always turn this mode off with the supplied
+;; hotkey, which is by default `C-c' `/'. You can't "see" whether mode
+;; is on or off in minibuffer, since it doesn't have its own mode
+;; line. But calling the hotkey will tell you the state change. You
+;; can also remove this mode completely from your emacs if you need to
+;; do that in emergencies. just call following function with some
+;; prefix argument like `C-u' to `tinyef-install'
+;;
+;; Mouse bindings in minibuffer
+;;
+;; When this package loads, it calls function `tinyef-install-mouse'
+;; which defines following bindings to your minibuffer
+;;
+;; o Mouse-3 = BIG erase backward from point
+;; o C-mouse-1 = Small delete backward
+;;
+;; This should give your free hands to cut, paste and Delete, without
+;; lifting your hand off the mouse.
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+;;{{{ setup: require
+
+(require 'tinylibm)
+
+(eval-when-compile
+ (ti::package-use-dynamic-compilation))
+
+(eval-and-compile
+ (autoload 'apropos-internal "apropos"))
+
+(ti::package-defgroup-tiny TinyEf tinyef-: extensions
+ "Electric file minor mode. Designed for minibuffer file prompt editing.
+ Overview of features
+
+ o Easy filename editing. Deletes directories at time, delete line
+ backward, electric tilde, electric slash, electric colon etc.
+ o This is useful e.g. in minibuffer's C-x C-f promt
+ ")
+
+;;}}}
+;;{{{ setup: variables
+
+(defcustom tinyef-:load-hook nil
+ "*Hook that is run when package is loaded."
+ :type 'hook
+ :group 'TinyEf)
+
+(defcustom tinyef-:mode-key "\C-c/"
+ "*Key to toggle function `tinyef-mode' on/off in minibuffer map."
+ :type '(string :tag "Key sequence")
+ :group 'TinyEf)
+
+(defcustom tinyef-:mode-key-table
+ '((?\< . step-delete-back)
+ (?\> . step-delete-fwd)
+ (?\| . chunk-delete)
+ (?\; . move-back)
+ (?\' . move-fwd)
+ (?\~ . e-tilde) ;electric keys
+ (?\/ . e-slash)
+ (?\$ . e-dollar))
+ "*Map keys to actions.
+Refer source file's default values for action names.
+If you change this; you must call function \\[tinyef-mode-map-define-keys]."
+ :type '(repeat
+ (list
+ (character :tag "Electric char")
+ (choice
+ :tag "Action"
+ (const step-delete-back)
+ (const step-delete-fwd)
+ (const chunk-delete)
+ (const move-back)
+ (const move-fwd)
+ (const e-tilde)
+ (const e-slash)
+ (const e-dollar)
+ (const undo))))
+ :group 'TinyEf)
+
+(defcustom tinyef-:step-delete-chars "-./@:"
+ "*When using step-delete action, kill until these chars. This is charset.
+The \"-\" character must be first in the string."
+ :type '(string "Charset")
+ :group 'TinyEf)
+
+(defcustom tinyef-:mode-defined-maps ;== if you need to change this; report
+ (delq nil ;== change to maintainer
+ (list
+ 'global-map
+ 'read-expression-map
+ 'minibuffer-local-map
+ 'minibuffer-local-must-match-map ;eg C-x C-f uses this
+ 'minibuffer-local-completion-map
+ ;; Only in Emacs
+ ;; the minibuffer when spaces are not allowed
+ (if (boundp 'minibuffer-local-ns-map)
+ 'minibuffer-local-ns-map)))
+ "*Keymap list where to install Electric file minor mode hotkey-
+See `tinyef-:mode-key'."
+ :type '(symbol :tag "Keymap")
+ :group 'TinyEf)
+
+;;}}}
+;;{{{ version
+
+(eval-and-compile
+ (ti::macrof-version-bug-report
+ "tinyef.el"
+ "tinyef"
+ tinyef-:version-id
+ "$Id: tinyef.el,v 2.42 2007/05/01 17:20:43 jaalto Exp $"
+ '(tinyef-:version-id
+ tinyef-:load-hook
+ tinyef-:mode-hook
+ tinyef-mode
+ tinyef-:mode-map
+ tinyef-:mode-defined-maps
+ tinyef-:mode-name
+ tinyef-:mode-key-table)))
+
+;;}}}
+;;{{{ code: misc, keys, install
+
+;;;###autoload (autoload 'tinyef-mode "tinyef" "" t)
+;;;###autoload (autoload 'turn-off-tinyef-mode "tinyef" "" t)
+;;;###autoload (autoload 'turn-on-tinyef-mode "tinyef" "" t)
+;;;###autoload (autoload 'tinyef-commentary "tinyef" "" t)
+;;;###autoload (autoload 'tinyef-version "tinyef" "" t)
+
+(eval-and-compile
+
+ (ti::macrof-minor-mode-wizard
+ "tinyef-" " Tef" nil "Tef" 'TinyEf "tinyef-:" ;1-6
+
+ "Electric file name mode.
+This mode helps you composing filename more easily. Some keys
+are \"electric\", meaning that they have two behavior. By default
+character \"~/$\" are electric. Some other keys have special meaning and you
+cannot insert them into buffer unless you press C-q before the key-.
+These special keys do are mapped to movement keys and delete keys.
+
+See variable `tinyef-:mode-key-table' which specifies actions
+for each electric character. Consult also `tinyef-:step-delete-chars'.
+The default action table is as follows:
+
+ (setq tinyef-:mode-key-table
+ '((?\< . step-delete-back) ;KEY -- action symbol
+ (?\> . step-delete-fwd)
+ (?| . chunk-delete)
+ (?\; . move-back)
+ (?\' . move-fwd)
+ (?\~ . e-tilde) ;electric keys
+ (?\/ . e-slash)
+ (?\$ . e-dollar)))
+
+Here is smple graph to give you an overview of what this mode does.
+In these presented cases cursor it at the end of line.
+Alternatively, just load this file, press C-x C-f and experiment
+with keys `[]\/~'.
+
+o b>> means what's on the line *before*
+o a>> means what's there *after*
+o `' means what you just pressed
+o [] means which action the character triggered
+
+ b>> http:/www.site.com/~userFoo/dir1/dir2/dir3/ `/` [e-slash]
+ a>> http:/
+ The e-slash action wiped out the line, because writing
+ two slashes normally indicates, that you want to give
+ another path
+
+ b>> ~/dir1/dir2/dir3/ `~' [e-tilde]
+ a>> ~
+ The action wiped the line away, because it assumed
+ you want to give `~userFoo or another `~' relative path
+
+ b>> ~/dir1/dir2/dir3/ `[' [step-delete-back]
+ a>> ~/dir1/dir2/
+ The action wiped previous directory name or until
+ special mark, See code, defaults are `:/@' (ange-ftp things)
+
+ b>> ~/dir1/dir2/ `=' [undo]
+ a>> ~/dir1/dir2/dir3/
+ The action works like normal undo.
+
+ b>> ~/dir1/dir2/ `\' [chunk-delete]
+ a>>
+ The action deleted whole line. It deletes until special marks
+ like `@:'. If repeated, it deletes constantly backward
+
+Defined keys:
+
+\\{tinyef-:mode-map}"
+
+ "Tief"
+ nil
+ "Electric file mode"
+ nil
+ nil))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro tinyef-function-macro (action)
+ "Define interactive command ACTION."
+ (let* ((sym (intern (format "tinyef-%s" (symbol-name (` (, action)))))))
+ (`
+ (defun (, sym) ()
+ (interactive)
+ (tinyef-char nil (quote (, action)))))))
+
+(tinyef-function-macro chunk-delete)
+(tinyef-function-macro step-delete-back)
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinyef-key-p (map key)
+ "Test if function `tinyef-mode' is in MAP with KEY."
+ (eq 'tinyef-mode (lookup-key map key)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinyef-action (char)
+ "Return action for CHAR."
+ (cdr-safe (char-assq char tinyef-:mode-key-table)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyef-install-maps (&optional remove force)
+ "Define Electric file mode's hot key. Optionally REMOVE.
+The install is done only once, but you can FORCE reinstall.
+
+See `tinyef-:mode-defined-maps'."
+ (let* ((key tinyef-:mode-key)
+ (fun 'tinyef-mode)
+ map)
+ (dolist (x tinyef-:mode-defined-maps)
+ (setq map (eval x))
+ (if remove
+ ;; eval or symbol-value function
+ (if (tinyef-key-p (eval x) key)
+ (define-key (eval x) key nil))
+ (unless (get 'tinyef-install-maps 'installed)
+ (if (lookup-key map key)
+ (progn
+ ;;(message "TinyMy: tinyef-:mode-key already taken in %s"
+ ;; (symbol-name x))
+ nil)
+ (define-key (eval x) key fun)))))
+ ;; Mark as installed
+ (put 'tinyef-install-maps 'installed t)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyef-mode-map-define-keys ()
+ "Define `tinyef-:mode-map' keys.
+Always clears the keymap first and reinstalls the minor mode."
+ (interactive)
+ (setq tinyef-:mode-map (make-sparse-keymap)) ;always refresh
+ ;; Minor modes have copy of the keymap. Get rid of it and
+ ;; replace it with new one.
+ (ti::keymap-add-minor-mode 'tinyef-mode nil nil 'remove)
+ (dolist (elt tinyef-:mode-key-table)
+ (define-key tinyef-:mode-map (char-to-string (car elt)) 'tinyef-char))
+ (ti::keymap-add-minor-mode 'tinyef-mode
+ 'tinyef-:mode-name
+ tinyef-:mode-map))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyef-install (&optional arg)
+ "Install package. With optional ARG, cancel installation."
+ (interactive)
+ (tinyef-install-mouse arg)
+ (cond
+ (arg
+ (remove-hook 'minibuffer-setup-hook 'tinyef-minibuffer-setup)
+ (remove-hook 'minibuffer-exit-hook 'turn-off-tinyef-mode)
+
+ (ti::keymap-add-minor-mode 'tinyef-mode nil nil 'remove)
+ (tinyef-install-maps 'remove))
+ (t
+ (add-hook 'minibuffer-setup-hook 'tinyef-minibuffer-setup 'end)
+ (add-hook 'minibuffer-exit-hook 'turn-off-tinyef-mode 'end)
+ (tinyef-mode-map-define-keys) ;installs also minor-mode
+ (tinyef-install-maps))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyef-install-mouse (&optional arg)
+ "Install default mouse binding. With ARG, remove."
+ (dolist (map (list
+ minibuffer-local-map
+ minibuffer-local-must-match-map
+ minibuffer-local-completion-map))
+ (cond
+ ((ti::emacs-p)
+ ;; Have to bind down event; because MSB occupies it.
+ (define-key map [C-down-mouse-1] 'tinyef-step-delete-back)
+ (define-key map [C-down-mouse-3] 'undo)
+ (define-key map [mouse-3] 'tinyef-chunk-delete))
+ (t
+ (define-key map [(control button1)] 'tinyef-step-delete-back)
+ (define-key map [(control button3)] 'undo)
+ (define-key map [(button3)] 'tinyef-chunk-delete)))))
+
+;;}}}
+
+;;{{{ code: extra minibuffer commands
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyef-buffer-name-not-minibuffer ()
+ "Return the name of current buffer, as a string.
+If current buffer is the *mini-buffer* return name of previous-window."
+ (buffer-name (if (window-minibuffer-p)
+ (if (eq (get-lru-window) (next-window))
+ (window-buffer (previous-window))
+ (window-buffer (next-window)))
+ nil)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyef-insert-buffer-name ()
+ "Insert buffer name of most recent buffer."
+ (interactive)
+ (insert (tinyef-buffer-name-not-minibuffer)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyef-insert-buffer-dir-name ()
+ "Insert dir name of most recent buffer."
+ (interactive)
+ (let* ((bfn (buffer-file-name
+ (get-buffer (tinyef-buffer-name-not-minibuffer)))))
+ (if bfn
+ (insert (file-name-directory bfn)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyef-insert-buffer-file-name ()
+ "Insert file name of most recent buffer."
+ (interactive)
+ (let* ((bfn (buffer-file-name
+ (get-buffer (tinyef-buffer-name-not-minibuffer)))))
+ (if bfn
+ (insert bfn))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyef-complete-from-minibuffer-history ()
+ "Take the history list and make it available as a `completions' buffer"
+ (interactive)
+ (with-output-to-temp-buffer "*Completions*"
+ (display-completion-list (symbol-value minibuffer-history-variable))
+ (save-excursion
+ (set-buffer standard-output)
+ (setq completion-base-size 0))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyef-insert-current-date-time-minibuf ()
+ "Insert the current date and time."
+ (interactive)
+ (insert (format-time-string "%Y-%m-%d--%H%-%M" (current-time))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyef-minibuffer-define-key-extras ()
+ "Define keys to minibuffer maps."
+ (dolist (map (apropos-internal
+ "^mini"
+ '(lambda (var)
+ (and (boundp var)
+ (keymapp (symbol-value var))))))
+ (setq map (symbol-value map))
+ (define-key map "\C-c\C-b" 'tinyef-insert-buffer-name)
+ (define-key map "\C-c\C-d" 'tinyef-insert-buffer-dir-name)
+ (define-key map "\C-c\C-f" 'tinyef-insert-buffer-file-name)
+ (define-key map "\C-c\C-t" 'tinyef-insert-current-date-time-minibuf)
+ (define-key map "\C-c\t" 'tinyef-complete-from-minibuffer-history)))
+
+;;}}}
+;;{{{ code: minibuffer
+
+;;; ----------------------------------------------------------------------
+;;; by Anders Lindgren.
+;;;
+(defun tinyef-minibuffer-setup ()
+ "Turn on function `tinyef-mode' when entering minibuffer."
+ (setq
+ tinyef-mode
+ (if (boundp 'minibuffer-completion-table)
+ (eq minibuffer-completion-table 'read-file-name-internal)))
+ (if (and (boundp 'tinypair-mode) ;Turn off TinyPair.el
+ (fboundp 'turn-off-tinypair-mode))
+ (ti::funcall 'turn-off-tinypair-mode)))
+
+;;}}}
+;;{{{ code: main
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyef-step (&optional back)
+ "Position cursor, optionally BACK."
+ (let* ((set tinyef-:step-delete-chars)
+ (rset (concat "^" set)) ;reverse set
+ (func (if back 'skip-chars-backward 'skip-chars-forward))
+ (point (point))
+ limit)
+ (if back
+ (setq limit (line-beginning-position))
+ (setq limit (line-end-position)))
+ (funcall func rset limit) ;do the movement
+ (when (eq (point) point) ;not moved
+ (funcall func set limit)
+ (funcall func rset limit)) ;try again
+ (when (not (eq (point) point)) ;moved ok
+ (when (and (null back) (not (eolp)))
+ ;; fix position a little
+ (forward-char 1)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyef-char (&optional character action)
+ "Handle Electric file mode's commands.
+If there is no action for character insert it as is.
+If this command is called interactively outside of minibuffer,
+turn off function `tinyef-mode' and insert character as is.
+
+Input:
+
+ CHARACTER The character is read from input argument or it it is nil, then
+ `last-command-char' is used.
+ ACTION If nil `tinyef-:mode-key-table' is consulted for character.
+ If non-nil, then should ve valid action symbol.
+
+Current keymap:
+
+\\{tinyef-:mode-map}"
+ (interactive)
+ (let* ((char (or character last-command-char)) ;char pressed
+ (act (or action (tinyef-action char)))
+ (re '(".*@" ".*:"))
+ (e-list '(?/ ?@ ?\" ?\'))
+ (pnow (point))
+ (point (point))
+ str
+ eolp
+ bolp
+ hits)
+ (if (or (null act) ;no action recognized
+ (and (interactive-p)
+ (not (eq (selected-window) (minibuffer-window)))
+ (prog1 t
+ (setq tinyef-mode nil))))
+ (insert char)
+ (setq bolp (line-beginning-position) eolp (line-end-position))
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... e-kill-point . .
+ ;; find suitable kill point
+ (save-excursion
+ (beginning-of-line)
+ (dolist (regexp re)
+ (if (and (looking-at regexp)
+ (not (eq eolp (match-end 0))))
+ (push (match-end 0) hits)))
+ (if hits (setq point (apply 'max hits))) ;;find longest position
+ (if (eq point eolp) ;;end of line ?
+ (setq point (point)))
+ (cond
+ ((eq pnow point) ;no different than current point?
+ (setq str (buffer-substring bolp pnow))
+ ;; make the end position not to go past string delimiter "
+ (if (not (string-match ".*\"" str))
+ (setq point bolp)
+ (setq point (+ bolp (match-end 0))))))) ;; cond-save-excursion
+ (cond
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... ... undo ..
+ ((eq act 'undo)
+ (undo))
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... .. chunk ..
+
+ ((eq act 'chunk-delete)
+ (delete-region point (point))) ;; The kill point is already set
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... ... step ..
+ ((memq act '(step-delete-fwd move-fwd))
+ (setq point (point))
+ (tinyef-step)
+ (if (eq act 'step-delete-fwd)
+ (delete-region point (point))))
+ ((memq act '(step-delete-back move-back))
+ (setq point (point))
+ (tinyef-step 'back)
+ (if (eq act 'step-delete-back)
+ (delete-region point (point))))
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... electric ..
+ ((and (memq act (list 'e-slash))
+ (ti::char-in-list-case (preceding-char) e-list)
+ ;; permit `//hostname/path/to/file'
+ (not (eq (point) (1+ (point-min))))
+ ;; permit `http://url/goes/here'
+ (not (char= ?: (char-after (- (point) 2)))))
+ (delete-region point (point))
+ (insert char))
+
+ ((memq act '(e-tilde))
+ (cond
+ ((char= (preceding-char) ?~)
+ ;; /ftp@some:~ pressing "~" now deletes full line
+ (delete-region bolp (point)))
+ ((and (not (ti::win32-p)) (char= (preceding-char) ?:))
+ ;; In NT, it's best to delete immediately, because you have
+ ;; those MS-DOS filename C:/ ...
+ ;;
+ ;; In Unix:
+ ;; /ftp@some: allow adding "~"
+ nil)
+ ((let ((filename (buffer-substring bolp (point))))
+ (if (not (string= (file-name-nondirectory filename) ""))
+ ;; find file which would have tilde in the name.
+ (file-name-completion (file-name-nondirectory filename)
+ (file-name-directory filename))))
+ ;; skip electric: tilde is part of an existing filename
+ nil)
+ (t
+ (delete-region point (point))
+ (if (save-excursion (beginning-of-line) (looking-at "[a-z]:[/\\]?"))
+ ;; Kill MS-DOS fabsolute path c:/this/dir
+ (delete-region (line-beginning-position) (point))
+ (delete-region point (point)))))
+ (insert char))
+ ((memq act '(e-dollar))
+ (delete-region bolp (point))
+ (insert char))
+ (t
+ (insert char))))))
+
+;;}}}
+
+(tinyef-install)
+(provide 'tinyef)
+
+(run-hooks 'tinyef-:load-hook)
+
+;;; tinyef.el ends here
--- /dev/null
+;;; tinygnus.el --- Gnus Plug-in. Additional functions. UBE fight etc.
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 1997-2007 Jari Aalto
+;; Keywords: extensions
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program, call M-x tinygnus-version.
+;; Look at the code with folding.el.
+
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;;; Install:
+
+;; ....................................................... &t-install ...
+;; Put this file on your Emacs-Lisp load path, add following into your
+;; ~/.gnus startup file. This file should be loaded only after gnus
+;; startup.
+;;
+;; (require 'tinygnus)
+;;
+;; Alternatively you can add this autoload code to integrate the package
+;; with Gnus startup:
+;;
+;; (add-hook 'gnus-startup-hook '(lambda () (require 'tinygnus)))
+;;
+;; If you have any questions, use this function to contact maintainer
+;;
+;; M-x tinygnus-submit-bug-report
+
+;;}}}
+;;{{{ Documentation
+
+;; ..................................................... &t-commentary ...
+
+;;; Commentary:
+
+;;
+;; Preface, Sep 1997
+;;
+;; I haven't have a chance to try the new Gnus for a long time
+;; because the envinronment didn't have Emacs 19.34. And when the
+;; sysadm installed it, I started slowly moving from my dear RMAIL
+;; (which I had configured to work very well) to the bold and beatiful
+;; Gnus. I had also started using procmail and subscribed to many
+;; mailing lists, so the only choice to manage all my mail was
+;; Gnus. Here you find some functions that I found useful.
+;;
+;; Overview of features
+;;
+;; o Automatic reload of files when entring group with SPACE
+;; (mimic Newsgroup behavior)
+;; o You can have compresses .eld file. If you compress .gnus to
+;; .gnus.gz then the .eld files will be compressed too to .eld.gz
+;; This saves you disk space in low quota account.
+;;
+;; o Fast read group by showing only unread (newly arrived)
+;; articles. Speeds up reading your mail groups.
+;; o Show immediately dormants in non-nntp groups. Some people
+;; use dormant mark ? in their private mail groups as `todo'
+;; and to be able to see those todo articles immediately saves
+;; you 5x time, when you don't have to separately limit to
+;; dormants.
+;;
+;; o Ready %uX user function that you can use in the *-line-format
+;; strings.
+;; o Group User format function: "expiry", Tell the expiry value
+;; for the group and varaious other values.
+;; o Group User format function: "comment", Tell the group comment.
+;; o Group User format function: "tick", Tell if group has ticks.
+;;
+;; o Send UBE complaint to all postmasters in Received headers.
+;; The ip addresses of postmasters are nslookup verified. You
+;; can select either individual article or process mark multiple
+;; articles.
+;;
+;; Url pointers
+;;
+;; o Procmail information can be found at
+;; http://www.procmail.org/ and http://pm-doc.sourceforge.net/
+;; o Gnus can be found at http://www.gnus.org/
+;;
+;; Fighting against UBE messages
+;;
+;; Please visit http://spam.abuse.net/ for up to date information.
+;; Other good sites: http://spamcop.net/ and http://www.spamcop.com/
+;;
+;; [2000-11] Automatically generated Gnus blacklist by Brian Edmonds
+;; is at http://www.gweep.bc.ca/~edmonds/usenet/index.html
+;;
+;; Many of us receive UBE (Unsolicited Bulk Email) and if we don't do
+;; anything to stop them, then the practice comes approved de facto
+;; internet convention. It is important that you complaint about every
+; piece of UBE you may receive, your vote counts and it will also
+;; give you satisfaction to know that most of the postmasters kick off
+;; the idiot in the other end of the wire. There are two functions
+;; in this module:
+;;
+;; tinygnus-article-ube-send-to-postmasters U UBE
+;; tinygnus-summary-ube-send-to-postmasters C-c'u send UBE
+;;
+;; The first function is fully interactive and it reads the current
+;; active article and composes `forward' message to all postmasters
+;; mentioned in the `received' header chain. Before sending you have
+;; a chance to reformat the article anyway you like.
+;;
+;; The latter function is useful to batch send complaints: you
+;; process mark(#) articles in summary buffer, Hit C-c'u, and each
+;; article is processes and complaint is sent to postmasters. Before
+;; sending message, the function asks confirmation. You can suppress
+;; the confirmation with `C-u' prefix argument. _Note_: It may take some
+;; time to compose all complaints if you have marked many articles,
+;; because parsing *Received:* headers and checking them with `nslookup'
+;; may be slow. If you use `procmail' or Gnus split methods to flter
+;; your UBE mail to one single newsgroup, say `junk.ube', Then you can
+;; mark all messages in the newsgroup and handle all the UBE you have
+;; received in a whip.
+;;
+;; Why is the complaint message sent to *postmaster* address, while
+;; recent sites have set up an *abuse* addresses as well? That's
+;; simply because RFC822 requires that each site must have postmaster
+;; account and you should be able to count on delivery to that address.
+;;
+;; [RFC822] (...) standard specifies a single, reserved mailbox address
+;; (local-part) which is to be valid at each site. Mail sent to that
+;; address is to be routed to a person responsible for the site's
+;; mail system or to a person with responsibility for general site
+;; operation. The name of the reserved local-part address is:
+;; Postmaster
+;;
+;; From the standard, "postmaster@domain" is required to be valid.
+;; Some domains have opened specific addresses where you can send
+;; these complains, e.g. abuse@aol.com, fraud@uu.net. If you know a
+;; specific address where to send the complaint, update
+;; `tinygnus-:ube-abuse-account-table'
+;;
+;; Gathering information from articles (e.g. URLs)
+;;
+;; If you read group that has very high traffic, and don't have to
+;; time to read all articles, but you're are still interested in
+;; seeing if there are any good urls mentioned, you can use function
+;; below. It will not record duplicate urls, only unique ones.
+;;
+;; C-c ' g u tinygnus-summary-gather-urls
+;;
+;; Function steps through all marked articles (Mark command in summary
+;; buffer is in M P submap), examines each message and puts the urls
+;; in `tinygnus-:output-buffer'. You can clear and display with
+;; commands:
+;;
+;; C-c ' g d tinygnus-summary-gather-display
+;; C-c ' g c tinygnus-summary-gather-clear
+;;
+;; Configuring the user format functions
+;;
+;; Before you load this file, it might be good to configure variable
+;; `tinygnus-:uff-table' so that it won't clash the definitions of
+;; your own `gnus-user-format-function-X'. If you load this file
+;; without modifying the table, it will replace all existing functions
+;; according to that table. In case you don't know what this is all
+;; about, go to Emacs info pages `C-h' `i', go to Gnus node, press
+;; 's' to search for 'Summary Buffer Lines' RET. Look at the specifier
+;; %uX, where X is anything.
+;;
+;; Miscellaneous commands
+;;
+;; `tinygnus-make-group-from-dir-nndoc' can be used to generate all nndoc
+;; groups fast from bunch of mailboxes that you dropped to some
+;; directory. You might have downloaded archives of mailing lists
+;; sorted by month and year and you want to genrate Gnus groups for
+;; them. This is it.
+;;
+;; Nnml handling commands
+;;
+;; TinyGnus is mainly designed for nnml backend. Gnus can be easily
+;; used for mailing lists; Gnus customisations; moving groups from one
+;; place to another. In TinyGnus there are some exotic functions that
+;; may prove handy when you have the same need. See below.
+;;
+;; `tinygnus-make-group-nnml-from-dir'. If you have nnml
+;; groups in ~/Mail; this function can create the equivalent nnml
+;; groups to your gnus easily. Give a REGEXP to match directories to
+;; include for group creation (E.g. "list\." for all
+;; mailing list list.* directories)
+;;
+;; `tinygnus-make-group-from-dir-nnml-procmail-spool'. A procmail
+;; (never mind if you don't know what that is); is a tool to deliver
+;; each incoming mail to correct mailbox as it arrives and it is very
+;; efective for filtering mailing lists. Procmail users have to
+;; reserve separate directory for these mailboxes; usually
+;; ~/Mail/spool/ and all files end to *.spool ( list.ding.spool,
+;; work.lab.spool ... ). Keeping Gnus aware of the mailboxes in the
+;; ~/Mail/spool would normally be manual work, but this function can
+;; create the nnml groups for you for each found spool file from the
+;; directory.
+;;
+;; `tinygnus-group-parameter-mailing-list'. Use this to read the last
+;; nnml mail from the directory and suggest an email address from
+;; From, To, Cc, Reply-To to be inserted into the group parameter
+;; `to-list'. When you start a fresh Gnus and create nnml groups, which
+;; are mailing lists (e.g. from old mail); the tedious part is to
+;; recover the "list status" of the group and insert correct `to-list'
+;; field into each group. With This function; just mark the groups
+;; where you want to add the parameter and you're set in few minutes.
+;;
+;; Enhanced Gnus functions
+;;
+;; Enter group in Topic mode with SPC
+;;
+;; Function `gnus-topic-read-group' is enhanced to maximize speed of
+;; reading new articles. Normally when you enter Group, gnus shows
+;; unread and ticked articles, but if you have any previously ticked
+;; articles in group, making the summary buffer is slow. If we ignore
+;; the ticked articles and display only the newly arrived, unread,
+;; articles, the time to generate Summary buffer is far less. If you
+;; have many private mail,work, mailing list groups, this saves you
+;; from lot of time to be able to track new messages.
+;;
+;; Show dormants immediately in non-nntp groups
+;;
+;; Function `gnus-summary-limit-children' is enhanced so that it will
+;; include dormant articles in Summary creation in non-nntp groups.
+;; Some people found out that the dormant mark ? is handy in mail
+;; groups to mean `todo' or `see this later' or `urgent'. Normally
+;; gnus treats all groups the same: nntp or private mail makes no
+;; difference. However the dormant mark can be used to mean different
+;; meaning in nntp group and non-nntp groups and this enchancement
+;; does just that. You get fast Summary with dormants now and you
+;; don't need to separately limit the buffer to show the dormants. To
+;; turn off this feature, set `tinygnus-:show-dormants' to nil.
+;;
+;; Compressed Gnus newsrc files
+;;
+;; Having a unix account that has unlimited disk space is very rare
+;; and for that reason being able to keep files in compressed format s
+;; preferrable to avoid going over Quota with message "Quota limit
+;; exceed, remove nnnK withing N days...".
+;;
+;; Gnus has compression support for Group files, but not for the
+;; bloating .newsrc or .eld files. Gawk. They consume your disk real
+;; fast because they become big in no time.
+;;
+;; For that reason there is included adviced Gnus code that
+;; automatically starts using compressed startup files if your
+;; `gnus-init-file' has extension `.gz'. Changing from normal init
+;; file to compressed one is easy:
+;;
+;; . gzip your .newsrc and .eld files
+;; . (setq tinygnus-:z ".gz")
+;; . M-x load-library RET tinygnus RET
+;;
+;; If you later want to restore this settings: Unzip, do (setq
+;; tinygnus-:z nil), and reload the package. But if you're low
+;; of quota, you propably do the reverse operation.
+;;
+;; Gnus version note
+;;
+;; This file installs only features to Gnus 5.8.2 (Emacs 20.5) and
+;; if you're using newer gnus version the advice code is not activated.
+;; Using this package should be safe with any existing Gnus version
+;; later than 5.8.2
+;;
+;; Line format example for *Group* buffer
+;;
+;; The personal Group buffer line can be configured as follows. If you
+;; try this with very old Gnus, drop away that fancy ~(cut 6) and use
+;; plain %d.
+;;
+;; (setq gnus-topic-line-format "%i%(%{%n%}%) %A -- %g %v\n")
+;;
+;; (add-hook 'gnus-select-group-hook 'gnus-group-set-timestamp)
+;;
+;; (setq gnus-group-line-format
+;; "%M%S%p%3uZ[%L]%-4uE%uT %5y: %-40,40g %7,7~(cut 6)d %uC\n")
+;;
+;; Which looks like the following in the buffer, notice that the topic
+;; mode is on.
+;;
+;; Procmail 34 -- 9
+;; [2]3.g 0: nnml:list.ding 30T1810
+;; [2]3. 0: nnml:list.ntemacs 30T1819
+;; * [2]3. ! 0: nnml:list.procmail 30T1850
+;; [2]2.t 33: nnml:list.flamenco 30T1849
+;; | | | %d
+;; | | %uT
+;; | The whole "2.t" comes from %uE
+;; %L
+;;
+;; There you can see the benefit of the user functions. The [2] tells
+;; the group level, "2.t" says "2" day total Expiry, "." means that the
+;; period is explicitely defined as a group parameter and "t" means
+;; that total expiry in the group parameter list is on. Do you
+;; see the extra `g' at the top line? It tells that the `gcc-self'
+;; group parameter is activated in group parameter list. If group has
+;; ticked articles, the %uT will show it. The %ud says "Day 30 in the
+;; month, Time 18:10" when you read the group.
+;;
+;; All these additional functions that display these status informations
+;; can be found from this package.
+;;
+;; Displaying the group parameter info
+;;
+;; As you saw above, the %uE function, or more precisely,
+;; `tinygnus-uff-group-expiry' controls what information is returned by
+;; looking at `tinygnus-:uff-table'. Please configure it to display
+;; whatever you want from group parameters.
+;;
+;; Article wash functions
+;;
+;; If you are interested, you can add following function(s) to the
+;; `gnus-article-display-hook'
+;;
+;; o `tinygnus-article-fix-msword-quotes'
+;;
+;; Debuging Gnus: can't select group
+;;
+;; If something is wrong with the Gnus and you can't enter the group
+;; for a reason or another, something has happened to your setup.
+;; There is *experimental* funtions in this package that may shed some
+;; help. The first thing to try is calling
+;; `tinygnus-gnus-debug-investigate-problem' Which asks for a group
+;; name, give fully qualifies name like "nnml:list.ding". This
+;; function is geared towards debugging nnml groups, so you may
+;; not benefit a lot for other backends.
+;;
+;; Thre is no detailled instructions how to fix the situation after
+;; the function has run, but the printed results in
+;; `tinygnus-:debug-buffer' should at least give better clues. LOOK
+;; CLOSELY THE RESULTS. And supply them to gnus newsgroup or mailing
+;; list. Maybe someone can by looking at the values what's the
+;; problem.
+;;
+;; o It's mostly trial and error; after you get used to reading
+;; what values are important and what to do with it.
+;; o The `tinygnus-gnus-debug-investigate-problem' is EXPERIMENTAL
+;; and it is not guarranteed to work with any Gnus version.
+;; It was created to debug setup problems with 5.8.2 1999-12-24.
+;;
+;; Gnus summary minor mode
+;;
+;; `tinygnus-summary-mode' is turned on when summary buffer gets
+;; created. There are some keybindings that you may wish to
+;; relocate for faster access, e.g. the search functions that
+;; repeat the last search. In Gnus, pressing Esc-s to search again
+;; would require a confirmation of the search string each time,
+;; while using ``tinygnus-gnus-summary-search-article-forward' uses
+;; the supplied string immediatedly. To relocate keys, use this code:
+;;
+;; (defun my-tinygnus-summary-mode-hook ()
+;; "Define new keybindings."
+;; (let* ((map tinygnus-:summary-mode-map))
+;; (define-key map [(alt ?<)]
+;; 'tinygnus-gnus-summary-search-article-forward)
+;; (define-key map [(control ?<)]
+;; 'tinygnus-gnus-summary-search-article-backward)))
+;;
+;; (add-hook 'tinygnus-summary-mode-hook
+;; 'my-tinygnus-summary-mode-hook)
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+;;; Code:
+
+;;{{{ require: basic
+
+;;; ......................................................... &require ...
+
+(eval-and-compile
+ (message (locate-library "gnus")) ;; Leave location to compile output
+ ;; 2000-01 When compiling CVS gnus with XEmacs ....
+ (condition-case err
+ (require 'gnus)
+ (error
+ (message " ** tinygnus.el: Wow, (require 'gnus) dies on error %s"
+ (prin1-to-string err)))))
+
+(require 'timezone)
+(require 'pp)
+(require 'tinylibm)
+
+(autoload 'gnus-summary-mark-article "gnus-sum")
+(autoload 'gnus-summary-select-article "gnus-sum")
+(autoload 'gnus-summary-work-articles "gnus-sum")
+(autoload 'gnus-summary-move-article "gnus-sum")
+(autoload 'gnus-summary-show-all-threads "gnus-sum")
+(autoload 'gnus-summary-first-subject "gnus-sum")
+(autoload 'gnus-summary-mark-article-as-read "gnus-sum")
+(autoload 'gnus-summary-find-next "gnus-sum")
+(autoload 'gnus-summary-mark-as-read-forward "gnus-sum")
+(autoload 'gnus-summary-mark-as-expirable "gnus-sum")
+(autoload 'gnus-summary-search-article-forward "gnus-sum")
+(autoload 'gnus-read-move-group-name "gnus-sum")
+(autoload 'gnus-set-global-variables "gnus-sum")
+(autoload 'gnus-set-mode-line "gnus-sum")
+(autoload 'nnfolder-group-pathname "nnfolder")
+
+(eval-when-compile
+ (ti::package-use-dynamic-compilation)
+ (require 'advice))
+
+(eval-and-compile
+ ;; Yes, this variable is purposively put to "tinypath" package.
+ ;; See that package for better explanation.
+ ;;
+ (defconst tinypath-:gnus-load-path
+ (locate-library "gnus"))
+ (message "tinygnus.el: Gnus path %s"
+ (or tinypath-:gnus-load-path "<path not found>"))
+ (defvar bbdb/gnus-summary-show-bbdb-names)
+ (defvar bbdb/gnus-summary-prefer-bbdb-data)
+ (defvar bbdb/gnus-summary-prefer-real-names)
+ (defvar bbdb/gnus-summary-mark-known-posters)
+ (defvar bbdb-message-marker-field)
+ (defvar bbdb/gnus-summary-known-poster-mark)
+ (defvar bbdb-canonicalize-net-hook)
+ (defvar gnus-last-search-regexp)
+ (defvar gnus-expirable-mark)
+ (defvar gnus-init-inhibit)
+ (defvar mail-send-hook)
+ (defvar tinyurl-mode)
+ (defvar gnus-version)
+ (if (not (locate-library "bbdb"))
+ (message "\
+tinymail.el: ** No bbdb.el along load-path. Please do not compile this file.
+ http://bbdb.sourceforge.net/")
+ (autoload 'bbdb-search-simple "bbdb")
+ (autoload 'bbdb-canonicalize-address "bbdb")
+ (autoload 'bbdb-record-net "bbdb")
+ (autoload 'bbdb-record-getprop "bbdb")
+ (autoload 'bbdb-record-name "bbdb")))
+
+;;}}}
+;;{{{ trquire: advanced
+
+(eval-and-compile
+
+ ;; (autoload 'mail-header-extra "nnheader.el" "" nil 'macro) ;; 2000-01 Gnus
+
+ ;; ................................................... version check ...
+
+ (defun tinygnus-check-gnus-installation-libraries ()
+ "Verify that new enough Gnus version is installed to the Emacs."
+ (let* ((i 0))
+ (flet ((load-it
+ (lib)
+ (let* ((name (if (stringp lib)
+ lib
+ (prin1-to-string lib)))
+ (path (locate-library name))
+ (status (ignore-errors
+ (if (symbolp lib)
+ (require lib)
+ (load path 'noerr)))))
+ (unless status
+ (message "TinyGnus: ** [ERROR] couldn't load %s %s. "
+ name
+ (or path
+ (concat
+ "Load error or package not along `load-path'."
+ " Please check Gnus path>")))
+ (incf i)))))
+ (dolist (lib '(gnus-group
+ message
+ nnml
+ nnfolder
+ nnheader
+ gnus-agent
+ ;; mm-util defined mm-char-int, which is used
+ ;; in gnus.el::gnus-continuum-version
+ ;;
+ ;; => continuum fails, if mm-char-int is not defined.
+ mm-util))
+ (load-it lib))
+ i)))
+
+ (defun tinygnus-check-gnus-installation-gnus ()
+ "Verify that new enough Gnus version is installed to the Emacs."
+ ;; Standard Gnus than comes with Old Emacs versions
+ ;; is not accepted. User must be running development
+ ;; version of Gnus or the latest Emacs
+
+ (unless (or (ti::emacs-p "21.1")
+ (ti::xemacs-p "21.4"))
+ (message (emacs-version))
+ (string-match
+ (concat
+ ;; Win32 installs to emacs-20.6
+ "emacs-[0-9]+\\.[0-9]+"
+ ;; Unix Emacs installs to /usr/share/emacs/20.6/lisp/
+ "\\|/emacs/[0-9]+\\.[0-9]+/")
+ (or tinypath-:gnus-load-path
+ (locate-library "gnus")
+ ""))))
+
+ (defun tinygnus-check-gnus-installation-emacs ()
+ "Verify that new enough Gnus version is installed to the Emacs."
+ (cond
+ ((not (fboundp 'mail-header-extra))
+ "nnheader.el::mail-header-extra was not defined.")
+ ((tinygnus-check-gnus-installation-gnus))))
+
+ (defun tinygnus-check-gnus-installation ()
+ "Verify that new enough Gnus version is installed to the Emacs."
+ (let* ((i (tinygnus-check-gnus-installation-libraries))
+ emacs-gnus
+ error)
+ (when (string-match "rest" (ti::function-args-p 'mm-char-int))
+ ;; Hm, the function is alias to `ignore', fix it.
+ (defalias 'mm-char-int 'identity))
+
+ (setq error
+ (if (not (zerop i))
+ (format "%d load errors happened" i)
+ (tinygnus-check-gnus-installation-emacs)))
+ (when error
+ (message
+ "\
+ ** tinygnus.el: [Error: %s]
+ %s.
+ Emacs version is %s. %s
+ This file works and compiles only with the very
+ latest development gnus.
+ http://www.gnus.org/dist/ => gnus.tar.gz (see time stamps)
+ Be sure to include latest Gnus along the `load-path'
+ when you compile this file.
+ If you do not plan to use Gnus, ignore this message.
+ -- You will now see load aborted message --"
+ error
+ (if (boundp 'gnus-version)
+ gnus-version
+ "<error loading gnus.el>")
+ emacs-version
+ (if emacs-gnus
+ "\n ** tinygnus.el: [Gnus from Emacs installation - no good]"
+ ""))
+ (error "Load aborted. See *Messages* buffer"))))
+
+ (tinygnus-check-gnus-installation))
+
+;;}}}
+;;{{{ setup: variables
+
+(ti::package-defgroup-tiny TinyGnus tinygnus-: extensions
+ "Gnus utilities grabbag.")
+
+(defcustom tinygnus-:load-hook nil
+ "*Hook run when file has been loaded."
+ :type 'hook
+ :group 'TinyGnus)
+
+(defcustom tinygnus-:summary-ube-send-to-postmasters-hook nil
+ "Hook run after each UBE message has been forwarded to postmasters."
+ :type 'hook
+ :group 'TinyGnus)
+
+(defcustom tinygnus-:article-ube-send-to-postmasters-hook nil
+ "Hook run after the UBE forward has been composed.
+References:
+ `tinygnus-article-ube-send-to-postmasters'
+ `tinygnus-:use-postmaster-addresses'"
+ :type 'hook
+ :group 'TinyGnus)
+
+;; but it was not a good idea to reduce to top level domain.
+;; for example
+;;
+;; nslookup sdn-ts-037txfwoRP08.dialsprint.net OK
+;; nslookup dialsprint.net NOK
+;;
+;; So the top level domain addresses are not necessarily reliable.
+;; Hm. Too bad. This could have been general function, but now it seems that
+;; you have to use some regexp based function
+;;
+;; xx.aol.com --> aol.com
+;; yy.aol.com
+
+(defcustom tinygnus-:canonilize-ip-functions
+ '(tinygnus-domain tinygnus-article-received-top-level-domain-maybe)
+ "List of function to change host address.
+Function should top level domain for passed HOST.
+Eg: '(\"aa.foo.com\" \"bb.foo.com\") --> '(\"foo.com\")
+References:
+ `tinygnus-:domain-table'"
+ :type '(list function)
+ :group 'TinyGnus)
+
+(defcustom tinygnus-:ube-forward-mail-addresses
+ ;; "uce@ftc.gov" no more active
+ '()
+ "*Addresses of archives where to send UBE messages."
+ :type '(list string)
+ :group 'TinyGnus)
+
+(defcustom tinygnus-:show-dormants t
+ "*If non-nil, show dormants immediately when entering non-nntp group.
+Some people like to use dormant mark ? as `important todo' in their
+private mail groups, while gnus usually reserves dormant mark to
+articles that do not need to show up if there is no replies."
+ :type 'boolean
+ :group 'TinyGnus)
+
+(defcustom tinygnus-:save-mail-notify-regexp (user-login-name)
+ "Regexp to match To field when mail is saved.
+A message is printed in the echo area when the regexp matches.
+References:
+ `tinygnus-save-mail-notify'"
+ :type 'regexp
+ :group 'TinyGnus)
+
+(defcustom tinygnus-:nslookup-file
+ (ti::package-config-file-prefix "tinygnus.el")
+ "File where to store `tinygnus-:nslookup-table' cache.
+This speeds up processing the UBE messages so that nslookup hosts can
+be found from cache instead of calling expensive `nslookup'"
+ :type 'file
+ :group 'TinyGnus)
+
+(defcustom tinygnus-:z nil ;; ".gz"
+ "*Extension to use in .newsrc and .eld files.
+If you set this to `.gz' then compressed files are in use.
+You have to reload the package every time you change this settings."
+ :type 'string
+ :group 'TinyGnus)
+
+(defcustom tinygnus-:gnus-version-for-advice "."
+ "Which version of gnus should have compressed .eld.gz support."
+ :type 'regexp
+ :group 'TinyGnus)
+
+(defcustom tinygnus-:ube-exclude-ip-regexp nil
+ "Regexp to matc IP domains that are not included in SPAM complain.
+When function `tinygnus-ube-send-to-postmasters' is called, all the IP
+addresses in Received headers are gathered and a message to all
+ostmasters are composed. This regexp filter out the read IP addresses.
+
+A good value would be to filter out your local domain."
+ :type 'regexp
+ :group 'TinyGnus)
+
+(defcustom tinygnus-:ube-abuse-account-table
+ '(("aol\\|globecomm\\|nortel\\.net\\|\\<usa\\.net"
+ . "abuse")
+ ("mindspring"
+ . "abuse")
+ ("PRSERV.NET$"
+ . "postmaster@attglobal.net")
+ ("prodigy"
+ . "abuse")
+ ("\\<uu\\.net"
+ . "fraud"))
+ "The account address where to send complaint.
+Many domains have opened `abuse' address in addition to RFC `postmaster'.
+
+1) If regexp matches the domain, the complaint is directed to `ACCOUNT@DOMAIN'
+2) If the ACCOUNT contains `@', then the ACCOUNT is supposed to have complete
+email address where to send complaint
+
+Format:
+ '((REGEXP . ACCOUNT)
+ (REGEXP . ACCOUNT)
+ ..)"
+ :type '(repeat (list regexp (string :tag "Account")))
+ :group 'TinyGnus)
+
+(defcustom tinygnus-:domain-table
+ '(("aol\\." . "aol.com")
+ ("soon\\.fi" . "soon.fi")
+ ("yahoo" . "yahoo.com")
+ ("wanadoo" . "wanadoo.fr")
+ ("compuserve" . "compuserve.com")
+ ("dialsprint" . "dialsprint.net")
+ ("\\<uu\\.net\\>" . "uu.net"))
+ "If REGEXP match address, use DOMAIN-ADDRESS.
+This table will efectively filter out duplicate addresses, e.g.
+xx.foo.com yy.foo.com are same as foo.com
+
+Table format:
+ '((REGEXP . DOMAIN-ADDRESS)
+ (REGEXP . DOMAIN-ADDRESS)
+ ..)"
+ :type '(repeat (list regexp (string :tag "Domain")))
+ :group 'TinyGnus)
+
+(defcustom tinygnus-:uff-table
+ '(
+ ;; *Group* buffer format functions in big letter
+
+ (?C tinygnus-uff-group-comment)
+ (?E tinygnus-uff-group-expiry)
+ (?F tinygnus-uff-summary-line-bbdb)
+ (?N tinygnus-uff-message-count)
+ (?T tinygnus-uff-group-tick)
+ (?Z tinygnus-uff-group-file-size)
+
+ ;; *Summary* buffer
+
+ (?d tinygnus-uff-summary-date))
+ "The gnus-user-format-function map table.
+
+Format:
+
+ '((CH FUNCTION)
+ (CH FUNCTION)
+ ..)
+
+The CH is the `X' character is used to run gnus-user-format-fnction-X
+where the FUNCTION will be mapped. For example if you want to
+run expiry function through %uE modified the elt in the pable is
+
+ (?E tinygnus-uff-group-expiry)"
+ :type '(repeat
+ (char :tag "gnus-user-format-fnction-")
+ (symbol :tag "Used TinyGnus function"))
+ :group 'TinyGnus)
+
+(defcustom tinygnus-:uff-summary-date
+ '(format "%02d-%02d" (string-to-int date-mon) date-day)
+ "This variable contain Lisp FORM to return summary line date string.
+If you want to customize this variable you have to look at the source
+code of `tinygnus-uff-summary-date' and use the dynamically bound variables.
+
+The default value is
+
+ '(format \"%02d-%02d\" (string-to-int date-mon) date-day)
+
+Which returns ISO date parts YY-MM. It is good to selects as brief
+date string as possible because the summary line is quite crowded place.
+
+Here is value for YY-MM-DD:
+
+ '(format \"%s-%02d-%02d\"
+ (ti::string-right date-yyyy 2)
+ (string-to-int date-mon)
+ date-day)"
+ :type 'sexp
+ :group 'TinyGnus)
+
+(defcustom tinygnus-:expiry-in-group-string "."
+ "Character to add to the end of expiry count if value is defined in group.
+When `tinygnus-uff-group-expiry' is called the number of days is returned.
+But if the expiry-wait is defined in group parameters, this string
+is added to the number."
+ :type 'string
+ :group 'TinyGnus)
+
+(defcustom tinygnus-:additional-group-info
+ '((gcc-self t eq "g")
+ (total-expire t eq "t"))
+ "*What additional grup parameter `tinygnus-uff-group-expiry' would return.
+When GROUP-PARAM run agains TEST is equal to VALUE then
+return RETURNED-STRING. You should return only one character in
+string to save space.
+
+For example the following entry
+
+ (gcc-self t eq \"c\")
+
+Will cause following test, the GCC-SELF-VALUE is read from group.
+
+ (if (eq GCC-SELF-VALUE t) ..return \"c\")
+
+Format:
+ '((GROUP-PARAM VALUE TEST RETURNED-STRING)
+ ...)"
+ :type '(repeat
+ (symbol :tag "Group param")
+ (sexp :tag "wanted value")
+ (function :tag "test function")
+ (string :tag "returned val"))
+ :group 'TinyGnus)
+
+(defcustom tinygnus-:get-news-symbolic-levels
+ '(("primary Mail" . 1)
+ ("secondary Mail" . 2)
+ ("mailing lists" . 3)
+ ("mail, some" . '(1 2 3))
+ ("some news" . 5)
+ ("News, all" . 'gnus-group-get-new-news)
+ ("Mail, all" . 'gnus-group-get-new-mail))
+ "*Symbolic `gnus-get-new-news' levels.
+Format:
+
+ '((COMPETION-STRING . NUMBER-OR-FUNCTION-OR-LIST)
+ ..)
+
+COMPETION-STRING
+
+ The completion name is offered when you call
+ `tinygnus-gnus-group-get-news-symbolic' and all news at level NUMBER is
+ read.
+
+NUMBER-OR-FUNCTION-OR-LIST
+
+ If the parameter is number, News in that Group level is read.
+
+ If the cdr parameter is function, then the function is called
+ interactively.
+
+ If the parmeter is list of numbers like '(1 2) then all news on
+ those group levels are read."
+ :type '(repeat
+ string
+ sexp)
+ :group 'TinyGnus)
+
+;;}}}
+;;{{{ setup: private
+
+(defvar tinygnus-:use-postmaster-addresses nil
+ "Variable contains postmaster address used to compose UBE response.
+You can use this in `tinygnus-:article-ube-send-to-postmasters-hook'
+This variable also has following properties: 'ip-list 'ns-list (nslookup)")
+
+(defvar tinygnus-:output-buffer "*tinygnus-buffer*"
+ "Temporary buffer to store miscellaneous user selected information.")
+
+;; Reloading file will reset this; which is good.
+;; By sitting on the Group Line in *Group* Try
+;;
+;; (get 'tinygnus-:gnus-group-info (make-symbol (gnus-group-group-name)))
+;; (symbol-plist 'tinygnus-group-info)
+
+(defconst tinygnus-:gnus-group-info nil
+ "Miscellaneous group information kept in property list.
+Keyed by full prefixed group name.")
+
+(defvar tinygnus-:nslookup-table nil
+ "List of nslookup's.")
+
+;;}}}
+;;{{{ Debug
+
+;;; ........................................................... &debug ...
+
+;;;###autoload (autoload 'tinygnus-debug-toggle "tinygnus" "" t)
+;;;###autoload (autoload 'tinygnus-debug-show "tinygnus" "" t)
+
+(eval-and-compile (ti::macrof-debug-standard "tinygnus" "-:"))
+
+;;}}}
+
+;;{{{ minor mode
+
+;;;###autoload (autoload 'tinygnus-version "tinygnus" "Display commentary." t)
+
+(eval-and-compile
+ (ti::macrof-version-bug-report
+ "tinygnus.el"
+ "tinygnus"
+ tinygnus-:version-id
+ "$Id: tinygnus.el,v 2.72 2007/08/03 20:16:25 jaalto Exp $"
+ '(tinygnus-:version-id
+ tinygnus-:debug
+ tinygnus-:load-hook
+ tinygnus-:gnus-group-info
+ tinygnus-:summary-ube-send-to-postmasters-hook
+ tinygnus-:article-ube-send-to-postmasters-hook
+ tinygnus-:canonilize-ip-functions
+ tinygnus-:ube-forward-mail-addresses
+ tinygnus-:output-buffer
+ tinygnus-:nslookup-table
+ tinygnus-:show-dormants
+ tinygnus-:save-mail-notify-regexp
+ tinygnus-:nslookup-file
+ tinygnus-:z
+ tinygnus-:gnus-version-for-advice
+ tinygnus-:ube-exclude-ip-regexp
+ tinygnus-:ube-abuse-account-table
+ tinygnus-:use-postmaster-addresses
+ tinygnus-:domain-table
+ tinygnus-:uff-table
+ tinygnus-:uff-summary-date
+ tinygnus-:expiry-in-group-string
+ tinygnus-:additional-group-info
+ tinygnus-:get-news-symbolic-levels)
+ '(tinygnus-:debug-buffer)))
+
+;;;###autoload (autoload 'tinygnus-summary-install-mode "tinygnus" "" t)
+;;;###autoload (autoload 'tinygnus-summary-mode "tinygnus" "" t)
+;;;###autoload (autoload 'turn-on-tinygnus-summary-mode "tinygnus" "" t)
+;;;###autoload (autoload 'turn-off-tinygnus-summary-mode "tinygnus" "" t)
+;;;###autoload (autoload 'tinygnus-summary-commentary "tinygnus" "" t)
+;;;###autoload (autoload 'tinygnus-summary-version "tinygnus" "" t)
+
+(eval-and-compile
+ (ti::macrof-minor-mode-wizard
+ "tinygnus-summary-" " Tg" "\C-c'" "Tgnus" 'TinyGnus "tinygnus-:summary-"
+
+ "Gnus utilities.
+This minor mode defines some additional commands to Gnus Group buffer.
+See also `tinygnus-summary-mode'
+
+Mode description:
+
+Prefix key to access the minor mode is defined in
+`tinygnus-:summary-mode-prefix-key' which is by deafult C - c '
+
+\\{tinygnus-:summary-mode-prefix-map}"
+
+ "Gnus summary mode extras"
+ (progn ;Some mode specific things
+ (when (and tinygnus-summary-mode
+ (not (eq major-mode 'gnus-summary-mode)))
+ (setq tinygnus-summary-mode nil)
+ (error
+ "TinyGnus mode can only be used in summary buffer. Mode is now `%' "
+ (symbol-name major-mode))))
+ "TinyGnus summary mode"
+ (list ;arg 10
+ tinygnus-:summary-mode-easymenu-name
+
+ ["Repeat search forward" tinygnus-gnus-summary-search-article-forward t]
+ ["Repeat search backward" tinygnus-gnus-summary-search-article-backward t]
+ "----"
+ ["Send UBE complaint" tinygnus-summary-ube-send-to-postmasters t]
+ ["Catchup, expire" tinygnus-gnus-summary-catchup-with-expire-all t]
+ ["Catchup this user" tinygnus-summary-expunge-all-from-user t]
+ ["Catchup, expire non-replied"
+ tinygnus-gnus-summary-catchup-with-expire-not-replied t]
+ ["Catchup, read" tinygnus-gnus-summary-catchup-with-read-all t]
+;;; ["Toggle original" tinygnus-summary-toggle-original t]
+ "----"
+ ["Gather headers" tinygnus-summary-gather-headers t]
+ ["Gather URLs" tinygnus-summary-gather-urls t]
+ ["Gather, display buffer" tinygnus-summary-gather-display t]
+ ["Gather, clear buffer" tinygnus-summary-gather-clear t]
+ "----"
+ ["Toggle original article" tinygnus-summary-toggle-original t]
+ ["Reload Gnus init file" tinygnus-gnus-group-read-init-file t]
+ "----"
+ ["Debug show" tinygnus-debug-show t]
+ ["Debug TinyGnus" tinygnus-debug-toggle t]
+ "----"
+ ;; ["Keyboard menu" tinygnus-menu-main t]
+ ["Package version" tinygnus-summary-version t]
+ ["Package commentary" tinygnus-summary-commentary t]
+ ["Mode help" tinygnus-summary-mode-help t]
+ ["Mode off" turn-off-tinygnus-summary-mode t])
+ (progn
+ (define-key map "M" 'tinygnus-summary-move-article)
+ ;; And the X-window keys, Unfortunately these may be
+ ;; be under the ESC key in some keyboards.
+ ;; see also `w32-alt-is-meta'
+ (define-key root-map [(alt s)]
+ 'tinygnus-gnus-summary-search-article-forward)
+ (define-key root-map [(alt r)]
+ 'tinygnus-gnus-summary-search-article-backward)
+ (define-key map "u" 'tinygnus-summary-ube-send-to-postmasters)
+ (define-key map "e" 'tinygnus-gnus-summary-catchup-with-expire-all)
+ (define-key map "E" 'tinygnus-gnus-summary-catchup-with-expire-not-replied)
+ (define-key map "C" 'tinygnus-summary-expunge-all-from-user)
+ (define-key map "d" 'tinygnus-gnus-summary-catchup-all-with-delete)
+ (define-key map "r" 'tinygnus-gnus-group-read-init-file)
+ (define-key map "t" 'tinygnus-summary-compose-current-mail-as-template)
+ (define-key map " " 'tinygnus-summary-toggle-original)
+ (define-key map "gh" 'tinygnus-summary-gather-headers)
+ (define-key map "gu" 'tinygnus-summary-gather-urls)
+ (define-key map "gd" 'tinygnus-summary-gather-display)
+ (define-key map "gc" 'tinygnus-summary-gather-clear)
+ (define-key map "Ds" 'tinygnus-debug-show)
+ (define-key map "Ds" 'tinygnus-debug-toggle)
+ (define-key map "?" 'tinygnus-summary-mode-help)
+ (define-key map "Hm" 'tinygnus-summary-mode-help)
+ (define-key map "Hc" 'tinygnus-summary-commentary)
+ (define-key map "Hv" 'tinygnus-summary-version)
+ (define-key map "x" 'turn-off-tinygnus-summary-mode))))
+
+;;; ----------------------------------------------------------------------
+
+;;;###autoload (autoload 'tinygnus-group-install-mode "tinygnus" "" t)
+;;;###autoload (autoload 'tinygnus-group-mode "tinygnus" "" t)
+;;;###autoload (autoload 'turn-on-tinygnus-group-mode "tinygnus" "" t)
+;;;###autoload (autoload 'turn-off-tinygnus-group-mode "tinygnus" "" t)
+;;;###autoload (autoload 'tinygnus-group-commentary "tinygnus" "" t)
+;;;###autoload (autoload 'tinygnus-group-version "tinygnus" "" t)
+
+(eval-and-compile
+ (ti::macrof-minor-mode-wizard
+ "tinygnus-group-" " Tg" "\C-c'" "Tgnus" 'TinyGnus "tinygnus-:group-"
+
+ "Gnus utilities.
+
+Mode description:
+
+Prefix key to access the minor mode is defined in `tinygnus-:group-mode-prefix-key'
+
+\\{tinygnus-:group-mode-prefix-map}"
+ "TinyGnus"
+ (progn ;Some mode specific things
+ (when (and tinygnus-group-mode
+ (not (eq major-mode 'gnus-group-mode)))
+ (setq tinygnus-group-mode nil)
+ (error "Mode Can only be used in Gnus Group buffer.")))
+ "Gnus group mode extras"
+ (list ;arg 10
+ tinygnus-:group-mode-easymenu-name
+ ["Read news with symbolic levels" tinygnus-gnus-group-get-news-symbolic t]
+ ["Crash box delete" tinygnus-crash-box-delete t]
+ ["Crash box find-file" tinygnus-crash-box-find-file t]
+;;; ["Make group from file" tinygnus-make-group-from-file t]
+ "----"
+ ["Set Group level in region" tinygnus-group-set-current-level-region t]
+ ["Add to-list mailing list parameter" tinygnus-group-parameter-mailing-list t]
+ ["nndoc Create groups from directory" tinygnus-make-group-from-dir-nndoc t]
+ ["nnml Read procmail spool and make groups"
+ tinygnus-make-group-from-dir-nnml-procmail-spool t]
+ ["nnml Recreate marked groups" tinygnus-make-group-nnml t]
+ ["nnml Create groups from directory" tinygnus-make-group-nnml-from-dir t]
+ "----"
+ ["Debug show" tinygnus-debug-show t]
+ ["Debug TinyGnus" tinygnus-debug-toggle t]
+ ["Debug Gnus group" tinygnus-gnus-debug-investigate-problem t]
+ "----"
+ ["Reload Gnus init file" tinygnus-gnus-group-read-init-file t]
+ ["Package version" tinygnus-group-version t]
+ ["Package commentary" tinygnus-group-commentary t]
+ ["Mode help" tinygnus-group-mode-help t]
+ ["Mode off" turn-off-tinygnus-group-mode t])
+ (progn
+ ;; The ' prefix is usually free
+ ;; "c" map for CrashBox
+ (define-key map "g" 'tinygnus-gnus-group-get-news-symbolic)
+ (define-key map "cd" 'tinygnus-crash-box-delete)
+ (define-key map "cf" 'tinygnus-crash-box-find-file)
+ (define-key map "mn" 'tinygnus-make-group-nnml)
+ (define-key map "mN" 'tinygnus-make-group-nnml-from-dir)
+ (define-key map "mf" 'tinygnus-make-group-from-file)
+ (define-key map "md" 'tinygnus-make-group-from-dir-nndoc)
+ (define-key map "mp" 'tinygnus-make-group-from-dir-nnml-procmail-spool)
+ (define-key map "ds" 'tinygnus-debug-show)
+ (define-key map "dd" 'tinygnus-debug-toggle)
+ (define-key map "dgo" 'tinygnus-gnus-debug-on)
+ (define-key map "dgf" 'tinygnus-gnus-debug-off)
+ (define-key map "dgi" 'tinygnus-gnus-debug-investigate-problem)
+ (define-key map "pm" 'tinygnus-group-parameter-mailing-list)
+ (define-key map "lr" 'tinygnus-group-set-current-level-region)
+ (define-key map "N" 'tinygnus-move-group-to-native-nnml)
+ (define-key map "?" 'tinygnus-group-mode-help)
+ (define-key map "Hm" 'tinygnus-group-mode-help)
+ (define-key map "Hc" 'tinygnus-group-commentary)
+ (define-key map "Hv" 'tinygnus-group-version)
+ (define-key map "r" 'tinygnus-gnus-group-read-init-file)
+ (define-key map "x" 'turn-off-tinygnus-group-mode))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-group-help ()
+ "Mode Help."
+ (interactive)
+ (describe-function 'tinygnus-group-mode))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-gnus-group-read-init-file ()
+ "Read Gnus init file always. sets `init-file-user' to t."
+ (interactive)
+ ;;
+ ;; Without these Gnus won't read the init file
+ ;; ´letf' is needed, because you cannot have macro expansion
+ ;; inside special form `let'. `letf' is just like let, but
+ ;; all values must be in (var value) format.
+ ;;
+ (letf ((gnus-init-inhibit nil)
+ ((ti::compat-load-user-init-file) t))
+ (gnus-group-read-init-file)))
+
+;;}}}
+;;{{{ Install
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinygnus-install (&optional uninstall)
+ "Install package. Optionally UNINSTALL."
+ (interactive "P")
+ (let* ((list '((gnus-group-mode
+ gnus-group-mode-hook
+ (turn-on-tinygnus-group-mode))
+ (gnus-summary-mode
+ gnus-summary-mode-hook
+ (turn-on-tinygnus-summary-mode))
+ (gnus-article-mode
+ gnus-article-mode-hook
+ (tinygnus-article-mode-keys))))
+ hook
+ hook-list)
+ (tinygnus-uff-table-install)
+ (ti::add-hooks 'tinygnus-:summary-ube-send-to-postmasters-hook
+ 'tinygnus-mark-deleted
+ uninstall)
+ (ti::add-hooks 'tinygnus-:summary-mode-define-keys-hook
+ 'tinygnus-summary-mode-define-keys
+ uninstall)
+ (ti::add-hooks 'tinygnus-:group-mode-define-keys-hook
+ 'tinygnus-group-mode-define-keys
+ uninstall)
+ (ti::add-hooks 'tinygnus-:article-ube-send-to-postmasters-hook
+ '(tinygnus-ube-cc-spam-archive
+ tinygnus-ube-postmaster-inform)
+ uninstall)
+ ;; Run the hook functions immediately if GNUS is already present.
+ (ti::dolist-buffer-list
+ (memq major-mode (mapcar 'car list))
+ 'temp-buffers
+ (not 'exclude)
+ (progn
+ (dolist (func (nth 2 (assq major-mode list)))
+ (funcall func))))
+ (dolist (elt list)
+ (setq hook (nth 1 elt)
+ hook-list (nth 2 elt))
+ (ti::add-hooks hook hook-list uninstall))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-article-mode-keys ()
+ "Install default keybindings to GNUS map."
+ (define-key gnus-article-mode-map "U"
+ 'tinygnus-article-ube-send-to-postmasters))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-uff-table-install ()
+ "Install `tinygnus-:uff-table'. Previous Gnus user functions will be wiped."
+ (interactive)
+ (let* (func
+ gnus-func)
+ (dolist (elt tinygnus-:uff-table)
+ (unless (fboundp (setq func (nth 1 elt)))
+ (error "Internal error. tinygnus-:uff-table, No func %s" func))
+ (setq gnus-func
+ (intern (format "gnus-user-format-function-%s"
+ (char-to-string (car elt)))))
+ (defalias gnus-func func))))
+
+;;}}}
+;;{{{ Final install
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-gnus-compile ()
+ "Compile all that is needed to get peak performance."
+ (interactive)
+ (tinygnus-gnus-compile-1
+ (mapcar (function (lambda (x) (car x)))
+ tinygnus-:uff-table)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-gnus-compile-1 (char-list)
+ "Compile the line formats and their user functions: CHAR-LIST."
+ (interactive)
+ (let* ((fmt "gnus-user-format-function-%s")
+ sym
+ func)
+ (message "TinyGnus: Compiling relevant parts...")
+ (save-window-excursion ;; Gnus and Compile changes the windowcfg
+
+ ;; File: gnus, Node: Compilation
+ ;;
+ ;; format specification variables ... `M-x' `gnus-compile' after you've
+ ;; This will result in the new specs being byte-compiled, and you'll get
+ ;; top speed again.
+ ;;
+ ;; ...user-generated function %uX are not compiled though
+ ;; See also M-x `gnus-update-format'
+
+ (dolist (ch char-list)
+ (setq func (format fmt (char-to-string ch)))
+ (setq sym (intern-soft func))
+;;; (ti::d! func (fboundp sym))
+ (if (not (fboundp sym))
+ (error "Not exist: %s" func)
+ (byte-compile sym)))
+ ;; see if we can find this
+ (when (not (fboundp 'gnus-update-format-specifications))
+ (load "gnus-spec" 'noerr))
+ ;; Update all formats in all Gnus buffer.
+ ;; Node: Formatting Variables
+ ;; Currently Gnus uses the following formatting variables:
+ (cond
+ ((fboundp 'gnus-update-format-specifications)
+ (ti::funcall 'gnus-update-format-specifications 'force))
+ ((fboundp 'gnus-update-format) ;19.34
+ (dolist (var '("gnus-group-line-format"
+ "gnus-group-mode-line-format"
+ "gnus-summary-line-format"
+ "gnus-summary-mode-line-format"
+ ;; Don't compile these because would require
+ ;; unnecessary packages
+ ;; "gnus-topic-line-format"
+ ;; "gnus-server-mode-line-format"
+ ;; "gnus-server-line-format"
+ "gnus-article-mode-line-format"))
+ ;; Use caution, I have several Gnus versions around.
+ ;; Define only those that exist.
+ (when (and (intern-soft var) (boundp (intern-soft var)))
+ (gnus-update-format var)))))
+ (if (get-buffer "*Gnus Format*") ;Where did this come from?
+ (kill-buffer "*Gnus Format*")))
+ ;; Too bad that this command gives compilation errors because
+ ;; the variables are dynamically bound in each user function
+ (when (fboundp 'gnus-compile) ;New Gnus only
+ (gnus-compile))))
+
+;;}}}
+;;{{{ General Misc
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro tinygnus-set-group ()
+ "Set variable `group'."
+ (` (or group
+ (setq group (symbol-value 'gnus-newsgroup-name))
+ (error "Can't know the group"))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinygnus-summary-map-articles-macro 'lisp-indent-function 0)
+(defmacro tinygnus-summary-map-articles-macro (&rest body)
+ "Map through marked mesaes in Summary buffer and execute BODY.
+The variable `nbr' has the current article number. Use command
+ (return) to stop the loop."
+ (`
+ (let* ((articles (gnus-summary-work-articles nil))
+ gnus-article-display-hook ;Do not run this
+ gnus-article-prepare-hook
+ gnus-select-article-hook
+ gnus-article-mode-hook
+ gnus-visual-mark-article-hook)
+ ;; ByteComp silencer, unused variables
+ (if gnus-article-display-hook (setq gnus-article-display-hook t))
+ (if gnus-article-prepare-hook (setq gnus-article-prepare-hook t))
+ (if gnus-select-article-hook (setq gnus-select-article-hook t))
+ (if gnus-article-mode-hook (setq gnus-article-mode-hook t))
+ (if gnus-visual-mark-article-hook (setq gnus-visual-mark-article-hook t))
+ ;; (gnus-summary-save-process-mark)
+ (dolist (nbr articles)
+ (,@ body)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinygnus-summary-map-article-body-macro 'lisp-indent-function 0)
+(defmacro tinygnus-summary-map-article-body-macro (&rest body)
+ "Run BODY inside articles that are marked.
+Variable `out' contains the output buffer and `buffer' points
+to the article buffer."
+ (`
+ (let* ((out (get-buffer-create tinygnus-:output-buffer))
+ buffer)
+ (tinygnus-summary-map-articles-macro
+ (gnus-summary-select-article 'all nil 'pseudo nbr)
+ (setq buffer (get-buffer gnus-original-article-buffer))
+ (when buffer
+ (with-current-buffer buffer
+ (ti::pmin)
+ (,@ body)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinygnus-output-buffer-macro 'lisp-indent-function 0)
+(defmacro tinygnus-output-buffer-macro (&rest body)
+ "Run BODY if `tinygnus-:output-buffer' exists. Signal error otherwise."
+ (`
+ (let* ((buffer (get-buffer tinygnus-:output-buffer)))
+ (if buffer
+ (progn (,@ body))
+ (error "TinyGnus: buffer %s does not exist." tinygnus-:output-buffer)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro tinygnus-files-from-dir-macro (dir &rest body)
+ "Read all files from DIR and do BODY.
+You can refer to `file' when processing the files. Stop loop with
+command (return)."
+ (`
+ (let* ((files (tinygnus-read-files-from-dir (, dir))))
+ (when (or (not (interactive-p))
+ (and (interactive-p)
+ (y-or-n-p
+ (format
+ "Found %d files, Proceed " (length files)))))
+ (dolist (file files)
+ (,@ body))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinygnus-summary-map-lines 'lisp-indent-function 0)
+(defmacro tinygnus-summary-map-line-macro (&rest body)
+ "Map line by line and run BODY in Summary buffer."
+ (`
+ (save-excursion
+ (ti::pmin)
+ (while (not (eobp))
+ (,@ body)
+ (forward-line 1)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinygnus-mark-deleted ()
+ "Mark current article expirable(mail) or deleted(news)."
+ (interactive)
+ (cond
+ ((string-match "nntp" gnus-newsgroup-name )
+ (gnus-summary-mark-article nil))
+ (t
+ (gnus-summary-mark-article gnus-expirable-mark))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-compose-return-address (address)
+ "Check that ADDRESS is usable. Discard er 0.0.0.
+Returns [N.N.N] for pure ip addresses."
+ (cond
+ ;; Drop addresses ^000.* or .0.0
+ ((string-match "^0+\\.\\|\\.0+\\.0|^127" address))
+ ((string-match "^[0-9.]+$" address)
+ (format "[%s]" address))
+ (address))) ;Return as is
+
+;;; ----------------------------------------------------------------------
+;;; #todo: Actually how can we tell when the address is same in the domain?
+;;;
+;;; postmaster@hub6.compuserve.com is same as postmaster@compuserve.com
+;;;
+;;; And we don't want to send duplicates, ehm?
+;;;
+;;;(defun tinygnus-address-uniquefy (list)
+;;; "Leave only shortest domain name: like DOMAIN.com over some.DOMAIN.com"
+;;; (let* (array ret domain)
+;;; (dolist (elt list)
+;;; (setq array (split-string elt "[.]")
+;;; domain (nth 1 (nreverse array))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-ube-cc-spam-archive ()
+ "Send copy of message to SPam archives.
+1998-06:
+ http://www.spam-archive.org/ --> spam-list@toby.han.de
+ http://www.ftc.gov/os/9806/email.htm --> uce@ftc.gov"
+ (dolist (address tinygnus-:ube-forward-mail-addresses)
+ (ti::mail-add-to-field-string "CC" address "To")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-ube-postmaster-inform ()
+ "Add a short Preface chapter to postmasters about UBE."
+ (ti::mail-text-start 'move)
+ (insert
+ "
+To postmasters: Please investigate this UBE (Unsolicited Bulk Email)
+message and take the necessary actions to prevent delivering similar
+messages in the future. You may have an open SMTP Relay or there
+is a person that is abusing your accounts.
+
+Thank you beforehand for your co-operation to stop UBE in the net.\n"))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinygnus-nslookup-save (&optional read)
+ "READ or save `tinygnus-:nslookup-table' to `tinygnus-:nslookup-file'.
+See function `tinygnus-article-ube-send-to-postmasters'."
+ (interactive "P")
+ (let* ((fid "tinygnus-nslookup-save")
+ (file tinygnus-:nslookup-file))
+ (unless fid ;; No-op. XEmacs byte compiler silencer
+ (setq fid nil))
+ (when (and (stringp file)
+ ;; 1) If we're saving, then go ahead
+ ;; 2) If we're reading, check that file exists
+ (or (null read)
+ (file-exists-p file)))
+ (if (string-match "\\.gz$" file)
+ (ti::use-file-compression))
+ (tinygnus-debug fid (if read "read") file)
+ (cond
+ (read
+ (load file)
+ (put 'tinygnus-:nslookup-table 'pos (length tinygnus-:nslookup-table))
+ (if (interactive-p)
+ "TinyGnus: nslookup loaded."))
+ (t
+ (ti::write-file-variable-state
+ file
+ "TinyGnus.el nslookup cache file"
+ '(tinygnus-:nslookup-table)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-nslookup-maybe-save ()
+ "Save every 5th new nslookup."
+ (let* ((fid "tinygnus-nslookup-maybe-save")
+ (count (get 'tinygnus-:nslookup-table 'pos))
+ (len (length tinygnus-:nslookup-table)))
+ (unless fid ;; No-op. XEmacs byte compiler silencer
+ (setq fid nil))
+ (when (or (not (integerp count))
+ (> (- len count) 4))
+ (tinygnus-debug fid "Calling save" len)
+ (tinygnus-nslookup-save)
+ (put 'tinygnus-:nslookup-table 'pos len))))
+
+;;}}}
+;;{{{ Article functions
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-summary-expunge-all-from-user ()
+ "Expunge all posts and followups from the current author"
+ (interactive)
+ (save-window-excursion
+ (gnus-summary-show-article)
+ (gnus-summary-select-article-buffer)
+ (let ((author (gnus-fetch-field "From")))
+ (gnus-summary-score-entry
+ "from" author 'substring -500000
+ (+ (date-to-day (time-stamp-string)) gnus-score-expiry-days))
+ (gnus-summary-score-entry
+ "followup" author 'substring -500000
+ (+ (date-to-day (time-stamp-string)) gnus-score-expiry-days)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-summary-compose-current-mail-as-template ()
+ "Use current article as template and compose new mail."
+ (interactive)
+ (let ((article (gnus-summary-article-number)))
+ (gnus-setup-message 'reply-yank
+ (gnus-summary-select-article t)
+ (set-buffer gnus-original-article-buffer)
+ ;; see message.el - message-supersede
+ (let ( ;; (sender (message-fetch-field "sender"))
+ ;; (from (message-fetch-field "from"))
+ (buffer (current-buffer)))
+ ;; Get a normal message buffer.
+ (message-pop-to-buffer (message-buffer-name "mail from template"))
+ (insert-buffer-substring buffer)
+ (message-narrow-to-head)
+ ;; Remove unwanted headers.
+ (message-remove-header "Message-ID")
+ (message-remove-header "Content-Type")
+ (when message-ignored-supersedes-headers
+ (message-remove-header message-ignored-supersedes-headers t))
+ ;; insert mail-header-separator if needed
+ (if (re-search-backward
+ (concat "\n" mail-header-separator "\n") nil t)
+ (goto-char (point-max))
+ (insert mail-header-separator))
+ (widen)
+ (forward-line 1))
+ (push
+ `((lambda ()
+ (when (gnus-buffer-exists-p ,gnus-summary-buffer)
+ (save-excursion
+ (set-buffer ,gnus-summary-buffer)
+ (gnus-cache-possibly-remove-article ,article nil nil nil t)
+ (gnus-summary-mark-as-read ,article gnus-canceled-mark)))))
+ message-send-actions))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-summary-toggle-original ()
+ "Toggle showing original article and *Article*."
+ (interactive)
+ (let* ((wlist (ti::window-list))
+ buffer
+ disp-win
+ disp-buffer
+ name)
+ ;; Is there any "article" buffer in this
+ (dolist (win wlist)
+ (setq name (buffer-name (setq disp-buffer (window-buffer win))))
+ (when (string-match "article" name)
+ (setq disp-win win)
+ (return)))
+ (cond
+ ((eq disp-buffer (get-buffer gnus-article-buffer))
+ (if (null (setq buffer (get-buffer gnus-original-article-buffer)))
+ (message "Can't find: %s" gnus-original-article-buffer)
+ ;; If we didn't found the window; user occupied the full
+ ;; *Summary* buffer
+ (if (null disp-win)
+ (pop-to-buffer buffer)
+ (select-window disp-win)
+ (switch-to-buffer buffer))
+ (ti::pmin)))
+ (t
+ (gnus-summary-select-article)
+ (pop-to-buffer gnus-article-buffer)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-summary-ube-send-to-postmasters (&optional no-confirm)
+ "Process all marked articles and send coplaint to postmasters.
+If NO-CONFIRM is non-nil, then the messages are enst directly without
+confirmations."
+ (interactive "P")
+ (let* ((fid "tinygnus-summary-ube-send-to-postmasters")
+ (count 0)
+ kill-flag)
+ (unless fid ;; No-op. XEmacs byte compiler silencer
+ (setq fid nil))
+ ;; (gnus-summary-save-process-mark)
+ (tinygnus-summary-map-articles-macro
+ (tinygnus-debug fid nbr)
+ (gnus-summary-select-article 'all nil 'pseudo nbr)
+ (message "TinyGnus: UBE processing article %d" nbr)
+ (tinygnus-article-ube-send-to-postmasters
+ 'send (not no-confirm)
+ kill-flag)
+ (run-hooks 'tinygnus-:summary-ube-send-to-postmasters-hook)
+ (setq kill-flag t)
+ (incf count))
+ (if (interactive-p)
+ (message "TinyGnus: Mapped %d ube messgaes" count))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-domain (address)
+ "Change ADDRESS xx.domain.com --> domain.com using `tinygnus-:domain-table'."
+ (let* ((ret address))
+ (when tinygnus-:domain-table
+ (dolist (elt tinygnus-:domain-table)
+ (when (string-match (car elt) address)
+ (setq ret (cdr elt))
+ (if (not (stringp ret))
+ (error "Invalid format in tinygnus-:domain-table: %s" elt))
+ (return)))
+ ret)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-article-ube-identify ()
+ "Examine all headers in Post and try to identify UBE source.
+This function will run `traceroute' to the found address and from
+the output, the upstream provider is usually the ISP where you can send
+complaint if the destination address won't handle your notes.
+
+The upstream provider in yraceroute output is the second/third last rows
+in the listing."
+ (interactive)
+ (let* ()
+ ;; #todo:
+ nil))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-ip-top-level-domain (host)
+ "Convert HOST a.b.c => b.c domain."
+ (when (string-match "\\.\\([^.]+\\.[^.]+\\)$" host)
+ (match-string 1 host)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-article-received-top-level-domain-maybe (host)
+ "If HOST looks suspicious, return HOST x.y.z => y.z.
+For example:
+
+ sdn-ap-002watacoP1727.foo.net => foo.net."
+ (when (and (stringp host)
+ ;; Skip 123.123.123.123
+ (not (ti::mail-ip-raw-p host)))
+ (let ((name (if (or (string-match "^\\([^.]+\\)\\....+\\..+$" host)
+ (string-match "^\\([^.]+\\)\\....+\\..+$" host))
+ (match-string 1 host))))
+ (when (and (stringp name)
+ (string-match "[0-9-]" name))
+ (setq host (ti::mail-ip-top-level-domain host)))))
+ host)
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-article-received-list-handle (received)
+ "Treat 3 sequence list differently.
+The first address(X) in Received header may be forged
+
+ Received: from X ( Y [Z] ) by
+
+From which we get addresses
+
+ '(X Y Z)
+
+The X May look like:
+
+ adsl-156-62-239.asm.foo.net
+
+Shorten the address to 2 significant parts only
+
+ foo.net."
+ (when (eq 3 (length received))
+ (let ((first (car received))
+ (rest (cdr received)))
+ (when (string-match "\\.\\([^.]+\\.[^.]+\\)$" first)
+ (setq first (match-string 1 first))
+ (push first rest)
+ (setq received rest))))
+ received)
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-host-canonilize (host)
+ "Send HOST to `tinygnus-:canonilize-ip-functions'."
+ (let ((fid "tinygnus-host-canonilize")
+ ret)
+ (unless fid ;; No-op. XEmacs byte compiler silencer
+ (setq fid nil))
+ (dolist (function tinygnus-:canonilize-ip-functions)
+ (when (setq ret (funcall function host))
+ (tinygnus-debug
+ (format "%s: %s (%s => %s)" fid function host ret))
+ (setq host ret)))
+ host))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-nslookup-filter (list)
+ "Filter out duplicates.
+
+Input:
+
+ list '(ip ip ...)
+
+Return:
+
+ ns-lookup-list Need nslookup.
+ ns-list known addresses.
+
+References:
+
+ `tinygnus-:nslookup-table' contains previous nslookup address."
+ (let ((fid "tinygnus-nslookup-filter")
+ elt
+ ns-lookup-list
+ ns-list)
+ (unless fid ;; No-op. XEmacs byte compiler silencer
+ (setq fid nil))
+ (dolist (ip list)
+ (when (stringp ip)
+ ;; Filter out dupliates
+ ;; xx.aaa.com --> aaa.com
+ ;; yy.aaa.com
+ (setq ip (tinygnus-host-canonilize ip))
+ (if (or (null tinygnus-:nslookup-table)
+ (and (null (setq elt
+ (assoc ip tinygnus-:nslookup-table)))
+ (null (setq elt
+ (rassoc ip tinygnus-:nslookup-table)))))
+ ;; Not known, put into ask list
+ ;; Sometimes we get address 8.8.5/8.7.3, which is actually
+ ;; a sendmail version. Filter out false hits
+ (if (not (string-match "/" ip))
+ (push ip ns-lookup-list))
+ ;; This is from cache. We have done the lookup already.
+ (push (list ip elt) ns-list))))
+ (tinygnus-debug fid "NS-LOOKUP-LIST" (nreverse ns-lookup-list))
+ (tinygnus-debug fid "NS-LIST" (nreverse ns-list))
+ (list ns-lookup-list
+ ns-list)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-nslookup-do (list)
+ "Run nslookup for LIST.
+Failed addresses are returned in ERR-LIST. Good address
+are added to `tinygnus-:nslookup-table'.
+
+Return:
+
+ '(err-list ok-list)."
+ (let ((fid "tinygnus-nslookup-do") ; Function id
+ err-list)
+ (unless fid ;; No-op. XEmacs byte compiler silencer
+ (setq fid nil))
+ (error "Sorry, this is disabled for now. New Spam mode is in sketch table.")
+ ;; #todo: ti::mail-nslookup function has changed.
+ (dolist (elt (ti::mail-nslookup list nil 'verb))
+ (tinygnus-debug fid elt)
+ (if (nth 1 elt) ;; Add new members to the cache.
+ (add-to-list 'tinygnus-:nslookup-table (nth 1 elt))
+ (push (car elt) err-list)))
+ (tinygnus-debug fid "ERR-LIST" (mapcar 'car err-list))
+ (list err-list)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-nslookup-examine-ip-top-level (ip-list)
+ "Examine IP-LIST by converting x.y.z => y.z."
+ (let (list)
+ (dolist (ip ip-list)
+ ;; Treat only DNS names, not raw ip's: a.b.c.d => c.d
+ (unless (ti::mail-ip-raw-p ip)
+ (setq ip
+ (ti::mail-ip-top-level-domain ip))
+ (multiple-value-bind (nok)
+ (tinygnus-nslookup-do ip)
+ (unless nok ;; Succeeded, top level was ok
+ (pushnew ip list :test 'string=)))))
+ list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-nslookup-examine-ip-list (ip-list)
+ "Examine `Received:' header IP-LIST.
+Return:
+
+ '(ns-err-list ns-list)."
+ (let (ns-err-list
+ ns-list)
+ (dolist (received ip-list) ; '((IP IP IP) ..)
+ (setq received (tinygnus-article-received-list-handle received))
+ (multiple-value-bind (need-lookup ok)
+ (tinygnus-nslookup-filter received)
+ (if ok
+ (setq ns-list (append ok ns-list)))
+ ;; Now run nslookup for ip's that are not known and
+ ;; add them to total list.
+ (multiple-value-bind (nok)
+ (tinygnus-nslookup-do need-lookup)
+ (if nok
+ (setq ns-err-list (append nok ns-err-list))))))
+ ;; In case non of the IPs succeeded, do rigorous search.
+ ;; Maybe top level domans are ok
+ (unless ns-list
+ (message
+ "TinyGnus: complete nslookup failure. Next: top-level search.")
+ (setq ns-list (tinygnus-nslookup-examine-ip-top-level ns-err-list)))
+ (list ns-err-list
+ ns-list)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-ube-address-compose (ns-list)
+ "Compose UBE return addresses from NS-LIST."
+ (let* ((fid "tinygnus-ube-address-compose")
+ str
+ done
+ tmp-list
+ addr-list
+ ip)
+ (unless fid ;; No-op. XEmacs byte compiler silencer.
+ (setq fid nil))
+ ;; ns-list: '(IP (name . addr))
+ ;; | |
+ ;; | the nslookup results
+ ;; Ip in the message
+ (dolist (elt ns-list)
+ (setq str (car-safe (nth 1 elt))
+ ip (cdr-safe (nth 1 elt)))
+ ;; The reverse lookup:
+ ;; nslookup mail.eic.com.mx : 200.23.239.146
+ ;; nslookup mty.eic.com.mx : 200.23.239.146
+ ;;
+ ;; Ie. the IP numeric addresses are the same, thus we don't send
+ ;; double copies to different symbolic addresses.
+ ;;
+ ;; The tmp-list will hold numeric ip addresses '((IP . t) (IP .t) ..)
+ ;; and if the ip is already there, the message to that site has
+ ;; already been composed,
+ (setq done nil)
+ (if (and ip (assoc ip tmp-list))
+ (setq done t)
+ (if (stringp ip)
+ (push (cons ip str) tmp-list)))
+;;; (ti::d! done str ip tmp-list)
+ (cond
+ (done) ;do nothing
+ ((stringp str)
+ (let ((abuse-list tinygnus-:ube-abuse-account-table)
+ tmp
+ login
+ email)
+ (setq str (tinygnus-host-canonilize str))
+ (setq tmp (ti::list-find abuse-list str))
+ (cond
+ ((and (stringp tmp)
+ (string-match "@" tmp))
+ (setq email tmp))
+ (t
+ (if (stringp tmp)
+ (setq login (concat (cdr tmp) "@"))
+ (setq login "postmaster@"))
+ (when (setq str (tinygnus-compose-return-address str))
+ (setq email (concat login str)))))
+ (when email
+ (add-to-list 'addr-list email))))
+ (t
+ ;; There is no point to send complaint to address where nslookup
+ ;; failed.
+ (message "TinyGnus: %s nslookup failed" (car str))
+ (setq str (car elt))
+ (when (stringp (tinygnus-compose-return-address str))
+ (add-to-list 'ns-err-list str)))))
+ ;; Save the values so that hook functions can use them.
+ (setq tinygnus-:use-postmaster-addresses addr-list)
+ (put 'tinygnus-:use-postmaster-addresses 'ns-list ns-list)
+ (tinygnus-debug fid "ADDR-LIST" addr-list)
+ addr-list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-article-ube-send-to-postmasters
+ (&optional send confirm kill)
+ "Parse all Received-headers and complain about UBE aka Spam.
+This function runs nslookup for each Received-header, so it may take
+some time to get all valid postmaster addresses. The found unique numeric
+and symbolic IP addresses are used when composing message to postmasters.
+
+We do not use any mail arresses that are in the message, because mail
+addresses cannot be checked and are usually forged in UBE message.
+
+Input:
+
+ SEND Flag, If prefix arg given, send the message.
+ CONFIRM Flag, If SEND is non-nil, should the sending be confirmed.
+ KILL Flag, if non-nil, kill possible mail that was being composed.
+
+References:
+
+ `tinygnus-:ube-exclude-ip-regexp'
+ `tinygnus-:use-postmaster-addresses'
+ `tinygnus-:nslookup-table'
+ `tinygnus-:nslookup-file'"
+ (interactive "P")
+ (let* ((message-included-forward-headers ".")
+ (fid 'tinygnus-article-ube-send-to-postmasters)
+ ;; Add-on package to message.el that generates keywords.
+ ;; DO NOT be intercative.
+ (message-keyword-interactive nil)
+ ;; Disable PGP auto signing.
+ tinypgp-mode
+ ;; Make copy, we modify this in correct buffer
+ (mail-send-hook mail-send-hook)
+ ip-list
+ ns-list
+ ns-err-list
+ addr-list
+ subject
+ buffer)
+ (unless fid ;; No-op. XEmacs byte compiler silencer
+ (setq fid nil))
+ (unless message-included-forward-headers ;; Byte Compiler silencer
+ (setq message-included-forward-headers nil))
+ ;; ................................................. byte-compiler ...
+ ;; Quiet Byte Compiler, unused variable.
+ (if tinypgp-mode
+ (setq tinypgp-mode nil))
+ (unless mail-send-hook
+ (setq mail-send-hook nil))
+ (if (and (boundp 'message-keyword-interactive)
+ message-keyword-interactive)
+ (setq message-keyword-interactive t))
+ ;; ......................................................... check ...
+ (unless (get-buffer gnus-original-article-buffer)
+ (error "TinyGnus: panic, no gnus-original-article-buffer exist."))
+ ;; Get the cache table if not set
+ (or tinygnus-:nslookup-table
+ (tinygnus-nslookup-save 'read))
+ (with-current-buffer gnus-original-article-buffer
+ (setq subject (mail-fetch-field "Subject"))
+ (ti::pmin)
+ ;; ............................................ received-headers ...
+ ;; We have to do nslookup for each ip to find out if
+ ;; it is alive and filter out duplicates
+ (setq ip-list (ti::mail-parse-received tinygnus-:ube-exclude-ip-regexp))
+ (tinygnus-debug fid "IP-LIST" ip-list)
+ (put 'tinygnus-:use-postmaster-addresses 'ip-list ip-list)
+ ;; ........................................ &check-need-nslookup ...
+ ;; Check if we have done nslookup for this already.
+ (multiple-value-bind (nok ok)
+ (tinygnus-nslookup-examine-ip-list ip-list)
+ (setq ns-err-list nok
+ ns-list ok))
+ (setq addr-list (tinygnus-ube-address-compose ns-list))
+ (cond
+ ((null addr-list)
+ (message
+ "'%s' Could not read ip addresses. Check ti::mail-parse-received."
+ subject))
+ (t
+ ;; The list is in order of appearence: Reference headers top-down,
+ ;; but the originating address is at the end. We reverse the list
+ ;; so that we get originator, next and the 2nd next ...
+ (setq addr-list (nreverse addr-list))
+ (when (and kill
+ (setq buffer (get-buffer (message-buffer-name "mail"))))
+ (with-current-buffer buffer (set-buffer-modified-p nil))
+ (kill-buffer buffer))
+ (message-forward nil)
+ (ti::mail-kill-field "^Subject" (format "ABUSE (Was: %s)" subject))
+ (ti::mail-kill-field "^To" (car addr-list))
+ (when (setq addr-list (cdr addr-list))
+ (ti::mail-add-field "CC" (ti::list-join addr-list ", ")
+ "To" nil 'replace))
+ (tinygnus-nslookup-maybe-save)
+ ;; disable few settings, like TinyPgp
+ (setq tinypgp-mode nil
+ mail-send-hook (delq 'tinypgp-auto-action mail-send-hook))
+ (run-hooks 'tinygnus-:article-ube-send-to-postmasters-hook)
+ (when ns-err-list
+ (ti::mail-text-start 'move)
+ (insert "\nReceived header IP addresses that failed nslookup,\n"
+ "possibly forged:\n")
+ (dolist (elt ns-err-list)
+ (insert " " elt "\n")))
+ (when send
+ (if (or (null confirm)
+ (and confirm
+ (progn
+ (ti::pmin)
+ (y-or-n-p "Send to postmasters? "))))
+ (message-send-and-exit nil))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-article-fix-msword-quotes ()
+ "Fixes MsWord style `smart quotes' back to normal ascii ones."
+ (interactive)
+ (with-current-buffer (symbol-value 'gnus-article-buffer)
+ (let ((buffer-read-only nil)
+ (inhibit-read-only t))
+ (subst-char-in-region (point-min) (point-max) ?\221 ?`)
+ (subst-char-in-region (point-min) (point-max) ?\222 ?')
+ (subst-char-in-region (point-min) (point-max) ?\223 ?\")
+ (subst-char-in-region (point-min) (point-max) ?\224 ?\"))))
+
+;;}}}
+
+;;{{{ user Format functions
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-uff-group-tick (params)
+ "Return `gnus-ticked-mark' if there are ticked articles in this group.
+Otherwise return empty ` '. PARAMS is passed by gnus."
+ (if (cdr (assq 'tick (symbol-value 'gnus-tmp-marked)))
+ (char-to-string (symbol-value 'gnus-ticked-mark))
+ " "))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-uff-group-comment (params)
+ "Return the comment field of a group. PARAMS is passed by gnus."
+ (if (not (boundp 'gnus-tmp-group))
+ ""
+ (let* ((comment1 (gnus-group-get-parameter
+ (symbol-value 'gnus-tmp-group )
+ 'comment))
+ (comment2 (if (consp comment1)
+ (car comment1)
+ comment1)))
+ (if (null comment2)
+ ""
+ (concat "(" comment2 ")")))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-uff-message-count (params)
+ "Return nubmber of message in file backend. Ignore PARAMS."
+ (if (not (boundp 'gnus-tmp-group))
+ ""
+ (let* ((group (symbol-value 'gnus-tmp-group))
+ (path (tinygnus-group-pathname group)))
+ (cond
+ ((not (stringp path))
+ "") ;Error!
+ ((string-match "^/.*@" path)
+ "@") ;Skip ange-ftp
+ ((file-directory-p path) ;nnml
+ ;; Don't count "." ".." and ".overview"
+ ;;
+ (- (length (directory-files path)) 3))
+ ((file-exists-p path)
+ ;; #todo: unfinished
+ ;; It's tougher with One file backends
+ nil)))))
+
+;;; ----------------------------------------------------------------------
+;;; #todo: 1999-02 This function is not tested. Inserted as is
+;;;
+(defun tinygnus-uff-summary-line-bbdb (&optional header)
+ "Display To: fields in summary buffers (g To From Newsgroups)
+This is a copy of bbdb/gnus-summary-get-author, where FROM is replaced
+with TO.
+
+replace %f, %n or %uB in `gnus-summary-line-format' by this user function.
+in groups where you want to use it."
+ (let* ((to (cdr-safe (assoc 'To (mail-header-extra header))))
+ (data (and bbdb/gnus-summary-show-bbdb-names
+ (ignore-errors (mail-extract-address-components to))))
+ (name (car data))
+ (net (car (cdr data)))
+ (record (and data
+ (bbdb-search-simple
+ name
+ (if (and net bbdb-canonicalize-net-hook)
+ (bbdb-canonicalize-address net)
+ net)))))
+ (if (and record name (member (downcase name) (bbdb-record-net record)))
+ ;; bogon!
+ (setq record nil))
+ (setq name
+ (or (and bbdb/gnus-summary-prefer-bbdb-data
+ (or (and bbdb/gnus-summary-prefer-real-names
+ (and record (bbdb-record-name record)))
+ (and record (bbdb-record-net record)
+ (nth 0 (bbdb-record-net record)))))
+ (and bbdb/gnus-summary-prefer-real-names
+ (or (and (equal bbdb/gnus-summary-prefer-real-names 'bbdb)
+ net)
+ name))
+ net to "**UNKNOWN**"))
+ ;; Return answer
+ (format "->%s%s"
+ (or (and record bbdb/gnus-summary-mark-known-posters
+ (or (bbdb-record-getprop
+ record bbdb-message-marker-field)
+ bbdb/gnus-summary-known-poster-mark))
+ " ")
+ name)))
+
+;;; ----------------------------------------------------------------------
+;;; By Gary Lawrence Murphy (garym@sos.on.ca) in
+;;; http://www.lebel.org/gnus/garym.gnus.el
+;;;
+;;; Used by permission 1997-09-29
+;;;
+(defun tinygnus-uff-summary-date (header)
+ "Return a date string from the Article HEADER.
+The format of date string is defined in `tinygnus-:uff-summary-date'"
+ (let* ((header-lines (mail-header-lines header))
+ (header-date (mail-header-date header))
+ (date-vector (ignore-errors (timezone-parse-date header-date))))
+ ;; If value is nil, then `header-date' contained something that couldn't
+ ;; be parsed by `timezone-parse-date'
+ (if (null date-vector)
+ ""
+ (let* ((date-yyyy (aref date-vector 0))
+ (date-mon (aref date-vector 1))
+ (date-day (string-to-int (aref date-vector 2)))
+ (string-lines (if (> header-lines 9999)
+ "????"
+ (number-to-string header-lines)))
+ (string-mon (or (capitalize
+ (car (nth
+ (1- (string-to-number date-mon))
+ timezone-months-assoc)))
+ "???"))
+ (string-day (format "%d" (or date-day "?"))))
+ ;; No-ops. Bytecomp silencers. User can use these dynamically bound
+ ;; variables in tinygnus-:uff-summary-date, but ByteCompiler can't
+ ;; kow that and it would say: variable bound but not referenced.
+ ;;
+ ;; Using "IF no-op-test NOTHING" statements silence byte compiler
+ (if (null string-day) (setq string-day t))
+ (if (null string-mon) (setq string-mon t))
+ (if (null string-lines) (setq string-lines t))
+ (if (null date-yyyy) (setq date-yyyy t))
+ (if tinygnus-:uff-summary-date
+ (eval tinygnus-:uff-summary-date)
+ "")))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-uff-group-expiry (params)
+ "Return the Expiry value for the group.
+Note: This function assumes that `nnmail-expiry-wait-function' is _not_
+used. Instead you should use `gnus-auto-expirable-newsgroups'
+and group parameter `nnmail-expiry-wait' combination.
+PARAMS is passed by gnus.
+
+Return:
+
+ empty string
+
+ or following where N is expiry number in days
+
+ char If the expiration value is symbol, the first character from it
+ is returned. Eg 'i' for 'immediate.
+
+ N Global `nnmail-expiry-wait' used
+
+ N. Value was defined in Group parameter. See
+ `tinygnus-:expiry-in-group-string'
+
+ ? Something is wrong
+
+References:
+
+ `tinygnus-:additional-group-info' Additional chacters added"
+ (if (not (boundp 'gnus-tmp-group))
+ ""
+ (let* ((group (symbol-value 'gnus-tmp-group))
+;;; (re gnus-auto-expirable-newsgroups)
+ (group-char tinygnus-:expiry-in-group-string)
+ (fmt "%s") ; I used to have e:%s
+ (ret "")
+ arg
+ param func str val
+ stat)
+ ;; ................................................... file test ...
+ ;; Looking the expiry value makes sense only for groups that
+ ;; have associated file. Do not check e.g. nntp
+ (when (tinygnus-group-pathname group)
+ (setq
+ arg (or
+ (gnus-group-get-parameter group 'expiry-wait)
+ (gnus-group-get-parameter group 'nnmail-expiry-wait)))
+ ;; .................................................. expiry get ...
+ (setq
+ ret
+ (cond
+ (arg
+ (cond
+ ((integerp arg)
+ (format fmt (concat (int-to-string arg) group-char )))
+ ((symbolp arg)
+ (substring (symbol-name arg) 0 1))
+ (t
+ "?.")))
+ ((gnus-group-auto-expirable-p group)
+ (cond
+ ((numberp nnmail-expiry-wait)
+ (format fmt (int-to-string nnmail-expiry-wait)))
+ ((symbolp nnmail-expiry-wait)
+ (substring (symbol-name arg) 0 1))
+ (t
+ "?")))
+ (t
+ ;; This group isn't defined as expirable.
+ ""))))
+ ;; ......................................................... other ...
+ (dolist (elt tinygnus-:additional-group-info)
+ (setq param (nth 0 elt)
+ val (nth 1 elt)
+ func (nth 2 elt)
+ str (nth 3 elt))
+ (setq
+ stat
+ (if (eq param 'total-expire)
+ ;; Ask from gnus directly.
+ (gnus-group-total-expirable-p group)
+ (funcall func arg val)))
+ (when stat
+ (setq ret (concat ret str))))
+ ret)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-uff-group-file-size (arg)
+ "Return File size if the group has attached file.
+ARG is passed by gnus.
+
+Returned strings:
+
+ @ Group has ange-ftp like path.
+ ? The path does not exist.
+ N Filesize in kilos (1000byte count) filesize lower that 1000 is
+ not returned."
+ ;; ARG is nil usually when us is called.
+ ;;
+ (if (not (and (boundp 'gnus-tmp-group) ;current group name
+ (string-match "nnfolder" (symbol-value 'gnus-tmp-group))))
+ ""
+ (let* ((group (symbol-value 'gnus-tmp-group))
+ (path (tinygnus-group-pathname group))
+ size)
+ (cond
+ ((not (stringp path))
+ "") ;Error!
+ ((string-match "^/.*@" path)
+ "@") ;Error!
+ ((not (file-exists-p path))
+ ;; Ugh; file does not exist? Make a warning to group buffer
+ "?")
+ (t
+ ;; Display file size in kilos, if size is < 1000, do not
+ ;; display 0 kilos.
+ ;;
+ (setq size (nth 7 (file-attributes path)))
+ (setq size (/ size 1000))
+ (if (zerop size)
+ ""
+ (int-to-string size)))))))
+
+;;}}}
+;;{{{ Summary: misc functions
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-summary-move-article (&optional n)
+ "Move articles N to another mail group.
+See `tinygnus-:summary-move-article-table'"
+ (interactive "P")
+ (let* ((group gnus-newsgroup-name)
+ (articles (gnus-summary-work-articles n))
+ (prefix (gnus-group-real-prefix group))
+ (action 'move)
+ (pfx (or (ti::string-match ".*:\\([^.]+.\\)" 1 group) ""))
+ select-method ;Make it nil
+ to-newsgroup)
+ (setq to-newsgroup
+ (gnus-read-move-group-name
+ "Move"
+ (concat (symbol-value
+ (intern (format "gnus-current-%s-group" action)))
+ pfx)
+ articles prefix))
+ (gnus-summary-move-article
+ n
+ to-newsgroup select-method action)))
+
+;;; ----------------------------------------------------------------------
+;;; See gnus-sum.el::gnus-summary-catchup-all
+;;; (&optional all quietly to-here not-mark)
+;;;
+(defun tinygnus-gnus-summary-catchup-all-with-mark
+ (&optional all to-here not-mark mark-char)
+ "Mark rest of the articles with marker char.
+Input:
+ ALL
+ TO-HERE
+ NOT-MARK
+ MARK-CHAR"
+ (gnus-set-global-variables)
+ (gnus-summary-show-all-threads)
+ (when (gnus-summary-first-subject (not all))
+ (while (and
+ (if to-here (< (point) to-here) t)
+ (gnus-summary-mark-article-as-read mark-char)
+ (gnus-summary-find-next (not all)))))
+ (gnus-set-mode-line 'summary))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-gnus-summary-catchup-with-expire-all (&optional all)
+ "Mark rest or ALL articles expriable."
+ (interactive "P")
+ (tinygnus-gnus-summary-catchup-all-with-mark
+ all
+ nil
+ nil
+ gnus-expirable-mark))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-gnus-summary-catchup-with-read-all (&optional all)
+ "Mark rest or ALL articles expriable."
+ (interactive "P")
+ (tinygnus-gnus-summary-catchup-all-with-mark
+ all
+ nil
+ nil
+ gnus-del-mark))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-gnus-summary-search-article-backward ()
+ "Repeat last search backward."
+ (interactive)
+ (tinygnus-gnus-summary-search-article-forward t))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-gnus-summary-search-article-forward (&optional backward)
+ "Repeat last search forward or BACKWARD."
+ (interactive)
+ (when (stringp gnus-last-search-regexp)
+ (gnus-summary-search-article-forward
+ gnus-last-search-regexp backward)
+ (message "Searched: %s" gnus-last-search-regexp)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-summary-gather-headers ()
+ "Read marked messages and gather all headers to `tinygnus-:output-buffer'.
+When you see some suspicious messages, the headers are all you need to spot
+the problem. This function makes it easy to collect such messages."
+ (interactive)
+ (tinygnus-summary-map-article-body-macro
+ (cond
+ ((re-search-forward "^[ \t]*$" nil t)
+ (forward-line 1)
+ (append-to-buffer out (point-min) (point)))
+ (t
+ (message "TinyGnus: Problem with article number %d" nbr)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-summary-gather-urls (&optional arg verb)
+ "Gathel all urls from marked messages. Duplicate ulrs are not gathered.
+
+Input:
+ ARG If non-nil, then include `group:atricle-nbr:' prefix to the
+ beginning of each gathered url.
+ VERB Verbose messages."
+ (interactive "P")
+ (ti::verb)
+ (let* (subject-field
+;;; from-field
+ (total 0)
+ count
+ url)
+ (tinygnus-summary-map-article-body-macro
+ (setq ;;; from-field (mail-fetch-field "From")
+ subject-field (mail-fetch-field "Subject"))
+ (setq count 0)
+ (while (re-search-forward "\\(http\\|ftp\\|telnet\\|wais\\):/" nil t)
+ (incf count)
+ (setq url (buffer-substring-no-properties
+ (line-beginning-position) (line-end-position)))
+ (with-current-buffer out
+ (ti::pmin)
+ (unless (re-search-forward (regexp-quote url) nil t)
+ (ti::pmax)
+ (if arg
+ (insert (format "%s:%d: %s\n" gnus-newsgroup-name nbr url))
+ (insert url "\n")))))
+ (incf total count)
+ (when verb
+ (message "TinyGnus: msg %d, %d (%d urls) %s"
+ nbr count total subject-field)))
+ ;; Turn on th URL jump mode.
+ (with-current-buffer tinygnus-:output-buffer
+ (when (and (fboundp 'turn-on-tinyurl-mode-1)
+ (boundp 'tinyurl-mode)
+ (null (symbol-value 'tinyurl-mode)))
+ (turn-on-tinyurl-mode-1)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-summary-gather-display ()
+ "Display `tinygnus-:output-buffer'."
+ (interactive)
+ (tinygnus-output-buffer-macro (pop-to-buffer buffer)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-summary-gather-clear ()
+ "Clear `tinygnus-:output-buffer'."
+ (interactive)
+ (let* ((buffer (get-buffer-create tinygnus-:output-buffer)))
+ (ti::erase-buffer buffer)
+ (if (interactive-p)
+ (message "TinyGnus: %s cleared" tinygnus-:output-buffer))))
+
+;;}}}
+
+;;{{{ Summary: exist, enter
+
+;;; ............................................... &summary-functions ...
+;;; Decriptions
+;;;
+;;; It is annoying that gnus won't re-read the file groups automatically
+;;; if the file underneath has changed. Eg if you have appended to a file
+;;; that is known to gnus, you should press "g" to rescan the file
+;;;
+;;; This piece of code saves the file attributes when you exit the Group
+;;; and when you re-enter it it checks if the file size is still
+;;; the same. If not, then it performs automatig "g" to re-read the file.
+;;;
+;;; So, you only have to hit SPACE to read the group and leave the
+;;; details to the rest of the code.
+
+(add-hook 'gnus-summary-prepare-exit-hook 'tinygnus-summary-prepare-exit-hook)
+(add-hook 'gnus-select-group-hook 'tinygnus-select-group-hook)
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-summary-prepare-exit-hook ()
+ "Save the group data before exit."
+ (tinygnus-group-params-set))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-group-file-p (group)
+ "Test if GROUP is file group."
+ (string-match "nnfolder\\|nndoc\\|archive" group))
+
+;;; ----------------------------------------------------------------------
+;;; gnus-valid-select-methods (("nntp" post address prompt-address) ...
+;;; gnus-server-alist
+;;; ( ("cache" nnspool "cache")
+;;; ("mbox" nnfolder "mbox"
+;;; (nnfolder-directory "~/Mail/mbox")
+;;; (nnfolder-active-file "~/Mail/mbox/active")
+;;; (nnfolder-get-new-mail nil)
+;;; (nnfolder-inhibit-expiry t)
+;;; )
+;;; ...
+;;;
+;;; gnus-group-real-prefix (group)
+;;;
+;;; gnus-server-to-method (server)
+;;; gnus-server-get-method (group method)
+;;; gnus-group-prefixed-name (group method)
+;;; ...whole name from GROUP and METHOD.
+;;;
+(defun tinygnus-group-pathname (&optional group)
+ "Return path of the GROUP."
+ (tinygnus-set-group)
+ (let* ((method (gnus-group-method group))
+ ;; (pfx (gnus-group-prefixed-name group method))
+ ;; (server1 (assoc server gnus-server-alist))
+ (group1 (ignore-errors (gnus-group-real-name group))))
+ (when (and group1
+ (ti::listp method))
+ (cond
+ ((eq (car method) 'nnfolder)
+ ;; (setq dir (memq 'nnfolder-directory method))
+ (or (ignore-errors (nnfolder-group-pathname group1))
+ ""))
+ ((eq (car method) 'nnml)
+ (or (ignore-errors (nnmail-group-pathname
+ group1 (symbol-value 'nnml-directory)))
+ ""))
+ ((eq (car method) 'nnmh)
+ (or (ignore-errors (nnmail-group-pathname
+ group1 (symbol-value 'nnmh-directory)))
+ ""))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-group-params-set (&optional group)
+ "Save extra GROUP information to group symbol plist."
+ (tinygnus-set-group)
+ (let* ((path (tinygnus-group-pathname group))
+ (sym 'tinygnus-:gnus-group-info)
+ attr
+ list)
+ (when (and path
+ (file-exists-p path))
+ (cond
+ ((file-directory-p path) ;nnml
+ ;; If you use nnml, then it's not that important to
+ ;; know the filesize. It would be too slow to map over all files
+ ;; and sum up the total size for nnml files.
+ ;;
+ ;; The nnfolder and others use single file, so getting the filesize
+ ;; is much simpler and faster.
+ nil)
+ (t
+ (setq attr (file-attributes path))
+ (setq list ;Make date list ((ATTR . VAL) ..)
+ (list
+ (cons 'file path)
+ (cons 'file path)
+ (cons 'file-attr attr)
+ (cons 'file-size (nth 7 attr))
+ (cons 'file-mod-time (nth 5 attr))))
+ (put sym (make-symbol gnus-newsgroup-name) list))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-select-group-hook (&optional group)
+ "Actions when GROUP is entered.
+If this is file group, check if the underlying file has changed and
+read it. Otherwise do nothing. This is like doing 'g' before entering
+the group."
+ (tinygnus-set-group)
+ (let* ((sym 'tinygnus-:gnus-group-info)
+ (path (tinygnus-group-pathname))
+ info
+ attr-now attr-was
+ s1
+ s2)
+ ;; Warn about missing .overview file
+ (when path
+ (setq s1 (ti::file-make-path path ".overview"))
+ (when (and (string= "nnml" (or (car (gnus-group-method group)) ""))
+ (not (file-exists-p s1)))
+ (message
+ "TinyGnus: .overview missing, Run nnml-generate-nov-databases")
+ (sit-for 2)))
+ (when (and (setq path (tinygnus-group-pathname))
+ (setq info (get sym (make-symbol group))))
+ ;; If we enter gruop for the first time the EXIT INFO is not
+ ;; yet available. When this is second time the info is there.
+ (cond
+ ((null (setq path (cdr (assq 'file-path info))))
+ (message "TinyGnus: invalid INFO for group."))
+ ((null (file-exists-p path))
+ (message "TinyGnus: File does not exist any more, %s" path))
+ (t
+ (setq attr-now (file-attributes path)
+ attr-was (assq 'file-attr info))
+ (when (not (eq (setq s1 (nth 7 attr-now))
+ (setq s2 (nth 7 attr-was))))
+ (message
+ "My Gnus: File sizes differ, rereading... %s (%d/%d) "
+ path s1 s2)
+ (gnus-group-get-new-news-this-group)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-gnus-summary-catchup-with-expire-not-replied ()
+ "Mark all not replied messages as read (nntp) or expired (other backends)."
+ (interactive)
+ (tinygnus-summary-map-line-macro
+ (when (and (looking-at "^ .*")
+ (not (looking-at "^.*Re:")))
+ (save-excursion
+ (if (string-match "nntp" (or gnus-newsgroup-name "nntp"))
+ (gnus-summary-mark-as-read-forward 1)
+ (gnus-summary-mark-as-expirable 1))))))
+
+;;}}}
+;;{{{ Group: e.g. Symbolic get levels
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-mail-extract-address-components (field)
+ "Extract addresses from current buffer matching FIELD."
+ (when (setq field (mail-fetch-field field))
+ (setq field (nth 1 (mail-extract-address-components field)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-group-parameter-mailing-list (n)
+ "Set `to-list' group parameter to one that is found from mails. This
+function is handy if you just dropped a nnml directory under gnus
+containing mailing list messages and you want to add the `to-list'
+defiitions easily to group parameters. (usually recovering the mailing list
+properties for Group.)
+
+The list of email address choices is gathered from last article in the group
+by looking at To, From, Reply-To, CC. Answer empty string \"\" if none
+match the mailing list address and fix the `to-list' Group parameter by hand
+with G p."
+ (interactive "P")
+ (dolist (group (gnus-group-process-prefix n))
+ ;; (setq group (gnus-group-group-name)))
+ (let* (
+;;; (name (gnus-group-real-name group))
+;;; (method (gnus-find-method-for-group group))
+;;; (type (nth 0 method)) ;; 'nnml
+;;; (server (or (nth 1 (assoc 'nnml-address method))
+;;; (nth 1 method)))
+;;; (dir (nth 1 (assoc 'nnml-directory method)))
+;;; (new-name (concat server "." name))
+ (to-list (gnus-group-get-parameter group 'to-list))
+ address
+ list)
+ (gnus-group-remove-mark group)
+ (if to-list
+ (message "TinyGnus: %s `to-list' already set to %s" group to-list)
+ (with-temp-buffer
+ (tinygnus-nnml-find-file (current-buffer) group)
+ (dolist (field '("From" "To" "Cc" "Reply-To"))
+ (when (setq address
+ (tinygnus-mail-extract-address-components field))
+ (push address list)))
+ (setq to-list
+ (completing-read
+ (format "TinyGnus: SET %s to-list? " group)
+ (ti::list-to-assoc-menu list)))
+ (unless (ti::nil-p to-list)
+ (message "TinyGnus: %s `to-list' set to %s" group to-list)
+ (gnus-group-set-parameter group 'to-list to-list)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-group-set-current-level-region (beg end level)
+ "Map over region BEG and END and set groups to LEVEL."
+ (interactive "r\nnTinyGnus set level to region: ")
+ (let* ((lines (count-lines beg end)))
+ (goto-char (min beg end))
+ (gnus-group-set-current-level lines level)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-read-files-from-dir (dir)
+ "Return files from DIR in sorted order."
+ (let* ((files
+ (ti::directory-files
+ dir "."
+ 'absolute
+ '(not (file-directory-p arg)))))
+ (sort files 'string<)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-move-group-to-native-nnml (n)
+ "Move nnml+SOME:name under nnml:SOME.name."
+ (interactive "P")
+ (let* ((nnml-server (assoc "nnml" gnus-server-alist))
+ (nnml-dir (or (assoc 'nnml-directory nnml-server)
+ "~/Mail/")))
+ (dolist (group (gnus-group-process-prefix n))
+ ;; (setq group (gnus-group-group-name)))
+ (let* ((level (gnus-group-group-level))
+ (name (gnus-group-real-name group))
+ (method (gnus-find-method-for-group group))
+;;; (type (nth 0 method)) ;; 'nnml
+ (server (or (nth 1 (assoc 'nnml-address method))
+ (nth 1 method)))
+ (dir (nth 1 (assoc 'nnml-directory method)))
+ (new-name (concat server "." name))
+ from
+ new-dir
+ status)
+ (cond
+ ((not (and nnml-dir dir))
+ (message "TinyGnus: move nmml doesn't know directory for %s" group))
+ ((not (file-directory-p dir))
+ (message "TinyGnus: move nmml directory not exist %s %s" group dir))
+ (t
+ (setq from (nnheader-concat dir name))
+ (setq new-dir (nnheader-concat nnml-dir new-name))
+;;; (ti::d! nnml-dir new-name from new-dir)
+ (setq status (ti::directory-move from new-dir))
+ (if (not (ti::nil-p status))
+ (message "TinGnus: ERROR while move %s %s %s" from new-dir status)
+ (message "Tinygnus: Moving %s --> %s" group new-dir)
+ (gnus-group-goto-group group)
+ (gnus-group-kill-group)
+ (gnus-group-make-group new-name '(nnml ""))
+ (gnus-group-set-current-level 1 level))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-make-group-nnml-from-dir (dir regexp)
+ "Create nnml groups from DIR matching REGEXP."
+ (interactive "DTinyGnus Nnml from directory: \nsRegexp: ")
+ (let* ((files (directory-files
+ (expand-file-name dir )
+ nil regexp)))
+ (dolist (group files)
+ (when (file-directory-p (nnheader-concat dir group))
+;;; (if (tinygnus-nnml-group-alist-p group)
+;;; (message "TinyGnus: Alredy in Gnus %s. Ignored." group)
+ (ignore-errors (gnus-group-make-group group '(nnml "")))
+ (message "Tinygnus: Created nnml group %s" group)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-make-group-nnml (n)
+ "Kill marked nnml groups and recreate them."
+ (interactive "P")
+ (let* (nnml-list)
+ (dolist (group (gnus-group-process-prefix n))
+ ;; (setq group (gnus-group-group-name)))
+ (gnus-group-remove-mark group)
+ (if (not (string-match "nnml" group))
+ (message "TinyGnus: Recreate skipping non-nnml group %s" group)
+ ;; (gnus-delete-line)
+ (push (cons group (gnus-group-group-level))
+ nnml-list)))
+ (dolist (elt nnml-list)
+ (let* ((group (car elt))
+ (level (cdr elt))
+ (name (gnus-group-real-name group))
+ (method (gnus-find-method-for-group group))
+ (type (nth 0 method)) ;; 'nnml
+ (server (or (nth 1 (assoc 'nnml-address method))
+ (nth 1 method)))
+ nnml-list)
+ (if nnml-list ;; Byte Compiler silencer
+ (setq nnml-list t))
+ (cond
+ ((not (and method type server))
+ (message "TinyGnus: Recreating failure. NIL method for %s" group))
+ (t
+ (setq type (format "%s:" (symbol-name type)))
+ (gnus-group-goto-group group)
+ (gnus-group-kill-group)
+ (gnus-group-make-group name type)
+ (gnus-group-set-current-level 1 level)
+ (message "Tinygnus: Recreating group %s with level %d"
+ group level)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-make-group-from-file (method)
+ "Make nndoc group from FILE with METHOD."
+ (interactive
+ (let* (file)
+ (setq file (read-file-name "Make group from file: " nil nil t))
+ (if (or (file-directory-p file)
+ (not (file-readable-p file)))
+ (error "invalid file: %s" file))
+ (setq method
+ (completing-read
+ "Method: "
+ (ti::list-to-assoc-menu '("nndoc" "nnfolder" "nnmbox" "nnspool"))
+ nil
+ t
+ "nndoc"))
+ (list (list (make-symbol method) file)))) ;; interactive
+ (gnus-group-make-group
+ (file-name-nondirectory (nth 1 method))
+ method))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-make-group-from-dir-nndoc (dir)
+ "Read DIR and make all files as nndoc groups."
+ (interactive "Ddirectory: ")
+ (tinygnus-files-from-dir-macro
+ dir
+ (ignore-errors (gnus-group-make-doc-group file nil))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-make-group-from-dir-nnml-procmail-spool ()
+ "This function is for old Gnus only that has `nnmail-procmail-directory'.
+Read and convert them to nnml backends.
+Say you have these files in in directory:
+
+ junk.daemon.spool list.java-linux.spool mail.emacs.spool
+ junk.dupli.spool list.java.spool mail.default.spool
+ junk.null.spool list.jcvs.spool
+
+then each of these spool files would become a nnml backend folder, so that
+`nnmail-procmail-suffix' is removed from the end filenames.
+
+This function is primarily meant for promail users that create spool file
+categories on the fly eg for new mailing lists. Alternatively, if you
+have to start Gnus from scratch, it is nice to have function to create
+nnml backends with one call."
+ (interactive)
+ (if (not (boundp 'nnmail-procmail-directory))
+ (error "sorry, this Gnus doen no longer have nnmail-procmail-directory.")
+ (when (y-or-n-p "Create many nnml backend folders from spool? ")
+ (tinygnus-files-from-dir-macro
+ (symbol-value 'nnmail-procmail-directory)
+ (ignore-errors
+ (let* ((name (replace-regexp-in-string
+ (symbol-value 'nnmail-procmail-suffix)
+ ""
+ (file-name-nondirectory file))))
+ (gnus-group-make-group name (quote (nnml "")))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-get-crash-box ()
+ "Return Gnus crash box."
+ (cond
+ ((boundp 'mail-source-crash-box)
+ (symbol-value 'mail-source-crash-box))
+ ((boundp 'nnmail-crash-box)
+ (symbol-value 'nnmail-crash-box))
+ (t
+ (error "TinyGnus: Can't find crash box for Gnus any more.\
+Contact maintainer."))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-crash-box-delete ()
+ "Delete `nnmail-crash-box'."
+ (interactive)
+ (let* ((box (tinygnus-get-crash-box)))
+ (cond
+ ((not (file-exists-p box))
+ (message "TinyGnus: File not found: %s" box))
+ ((and (file-exists-p box)
+ (y-or-n-p
+ (format
+ "TinyGnus: Really delete crashbox %s"
+ box)))
+ (delete-file box)))
+ (ti::kill-buffer-safe box)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-crash-box-find-file ()
+ "Find-file Gnus crash-box."
+ (interactive)
+ (let* ((box (tinygnus-get-crash-box)))
+ (cond
+ ((not (file-exists-p box))
+ (message "TinyGnus: File not found: %s" box))
+ (t
+ (find-file-other-window box)))))
+
+;;; ----------------------------------------------------------------------
+;;; Note: if yo hit just "3 g"; GNUS will read all level up till 3,
+;;; so you would actually read levels 1,2,3 and not just 3 :-)
+;;;
+(defun tinygnus-gnus-group-get-news-symbolic (elt)
+ "Ask for symbolic name which represents level where to get news.
+f ELT is nil then gel news for all groups.
+
+References:
+ `tinygnus-:get-news-symbolic-levels'"
+ (interactive
+ (let* ((table tinygnus-:get-news-symbolic-levels)
+ ans)
+ (setq
+ ans
+ (completing-read
+ "Get new nwes [empty=all levels]: "
+ tinygnus-:get-news-symbolic-levels nil nil))
+ (list (assoc ans table) )))
+ (let* ((cdr-elt (if elt (cdr elt))))
+ (if (integerp cdr-elt) ; 1-- > '(1)
+ (setq cdr-elt (ti::list-make cdr-elt)))
+ (cond
+ ((null elt)
+ (message "Reading all cdr-elts.")
+ (sit-for 1)
+ (call-interactively 'gnus-group-get-new-news))
+ ((fboundp cdr-elt)
+ (call-interactively cdr-elt))
+ ((ti::listp cdr-elt)
+ (dolist (n cdr-elt)
+ (message (format "Reading level %d" n)) (sit-for 0.5)
+ (gnus-group-get-new-news n))))))
+
+;;}}}
+;;{{{ Debugging Gnus
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-gnus-debug-insert-line (key value &optional id)
+ "Insert KEY and VALUE into buffer. Optionally prefix with function ID."
+ (with-current-buffer (get-buffer-create tinygnus-:debug-buffer)
+ (ti::pmax)
+ (insert (format " %s%-30s: %s\n"
+ (if (null id)
+ ""
+ (format " [%s] " (ti::string-value id)))
+ (if (stringp key) key (prin1-to-string key))
+ (ti::string-value value)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinygnus-debug-gnus-macro 'lisp-indent-function 1)
+(put 'tinygnus-debug-gnus-macro 'edebug-form-spec '(body))
+(defmacro tinygnus-debug-gnus-macro (func &rest body)
+ "Instantiate `pr' function to print debug information about FUNC."
+ (`
+ (flet ((pr (x y)
+ (tinygnus-gnus-debug-insert-line x y (, func))))
+ (,@ body))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-nnml-group-alist-p (group)
+ "Check if GROUP is in `nnml-group-alist'."
+ (assoc group nnml-group-alist))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-gnus-newsrc-alist (function)
+ "Return elts from `gnus-newsrc-alist' according to FUNCTION."
+ (let (list
+ ;; method
+ ;; backend
+ ;; server
+ group)
+ ;; (("dummy.group" 0 nil) ("comp.security.ssh" 3 nil nil nil) ...
+ (dolist (elt gnus-newsrc-alist)
+ (setq
+;;; method (gnus-find-method-for-group group)
+;;; backend (car method)
+;;; server (cdr method)
+ group (car elt))
+ (when (funcall function group)
+ (push elt list)))
+ list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-nnml-file-range (dir)
+ "Find the article range in directory (FIRST . LAST)."
+ (let* ((files (directory-files dir nil "^[0-9]+$"))
+ (list (sort
+ files
+ (lambda (a b)
+ (< (string-to-number a) (string-to-number b))))))
+ (when list
+ (cons (string-to-number (car list))
+ (string-to-number (car (nreverse list))) ))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-group-directory (group)
+ "Return directory for GROUP."
+ (let* ((method (gnus-find-method-for-group group))
+ (type (nth 0 method)) ;; 'nnml
+;;; (server (or (nth 1 (assoc 'nnml-address method))
+;;; (nth 1 method)))
+ base)
+ (cond
+ ((string-match (symbol-name type) "nnml")
+ (setq base
+ (or (nth 1 (assoc 'nnml-directory method))
+ nnml-directory))
+ (nnheader-concat base (gnus-group-real-name group)))
+ (t
+ (error "TinyGnus: Non-nnm;l backends not implemented.")))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-nnml-find-file (buffer group &optional nbr)
+ "Find to BUFFER a nnml GROUP article NBR or last article."
+ (let* ((dir (tinygnus-group-directory group))
+ (file (or nbr
+ (cdr (tinygnus-nnml-file-range dir))))
+ (path (concat (file-name-as-directory dir)
+ (int-to-string file))))
+ (with-current-buffer (get-buffer-create buffer)
+ (ti::pmax)
+ (insert-file-contents-literally path)
+ (current-buffer))))
+
+;;; ----------------------------------------------------------------------
+;;; ("sfnet.atk.laitteet.pc" (85772 . 90896))
+;;;
+(defun tinygnus-gnus-debug-update-nnml-group-alist (group dir &optional replace)
+ "Update `nnml-group-alist' to have the GROUP with DIR.
+Possibly REPLCE existing entry."
+ (let ((exist-p (tinygnus-nnml-group-alist-p group))
+ range)
+ (if (not (file-directory-p dir))
+ (message "TinyLisp: No directory %s %s" group dir)
+ (when (or replace
+ (null exist-p))
+ (if (not (setq range (tinygnus-nnml-file-range dir)))
+ (message "TinyLisp: No files %s %s" group dir)
+ (message "TinyGnus: Adding to `nnml-group-alist' %s" dir)
+ (if replace
+ (aput 'nnml-group-alist group range))
+ (push (list group range) nnml-group-alist))))))
+
+;;; 5.8.2
+(defadvice gnus-open-server (around tinygnus-debug dis)
+ ;; (gnus-command-method)
+ ;; "Open a connection to GNUS-COMMAND-METHOD."
+ (flet ((pr (x y)
+ (tinygnus-gnus-debug-insert-line x y 'gnus-open-server )))
+ (pr '(CALL-ARGS gnus-command-method)
+ (list gnus-command-method))
+ (when (stringp gnus-command-method)
+ (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
+ (let ((elem (assoc gnus-command-method gnus-opened-servers)))
+ ;; If this method was previously denied, we just return nil.
+ (pr 'gnus-opened-servers elem)
+ (setq
+ ad-return-value
+ (if (eq (nth 1 elem) 'denied)
+ (progn
+ (gnus-message 1 "Denied server")
+ nil)
+ ;; Open the server.
+ (pr '(gnus-get-function gnus-command-method 'open-server)
+ (gnus-get-function gnus-command-method 'open-server))
+ (let ((result
+ (funcall (gnus-get-function gnus-command-method 'open-server)
+ (nth 1 gnus-command-method)
+ (nthcdr 2 gnus-command-method))))
+ ;; If this hasn't been opened before, we add it to the list.
+ (unless elem
+ (setq elem (list gnus-command-method nil)
+ gnus-opened-servers (cons elem gnus-opened-servers)))
+ ;; Set the status of this server.
+ (setcar (cdr elem) (if result 'ok 'denied))
+ ;; Return the result from the "open" call.
+ result)))
+ (pr 'RETURN-VALUE ad-return-value))))
+
+;;; 5.8.2
+(defadvice gnus-summary-read-group-1 (around t-tinygnus-debug dis)
+ "Output trace to tinygnus-:debug-buffer"
+ ;; (group show-all no-article kill-buffer no-display &optional select-articles)
+ (flet ((pr (x y)
+ (tinygnus-gnus-debug-insert-line x y 'gnus-summary-read-group-1 )))
+ ;; Killed foreign groups can't be entered.
+ (when (and (not (gnus-group-native-p group))
+ (not (gnus-gethash group gnus-newsrc-hashtb)))
+ (error "Dead non-native groups can't be entered"))
+ (gnus-message 5 "Retrieving newsgroup: %s..." group)
+ (let* ((new-group (gnus-summary-setup-buffer group))
+ (quit-config (gnus-group-quit-config group))
+ (did-select (and new-group (gnus-select-newsgroup
+ group show-all select-articles))))
+ (pr 'my-gnus-summary-read-group-1::new-group new-group)
+ (pr 'my-gnus-summary-read-group-1::quit-config quit-config)
+ (pr 'my-gnus-summary-read-group-1::did-select did-select)
+ (cond
+ ;; This summary buffer exists already, so we just select it.
+ ((not new-group)
+ (gnus-set-global-variables)
+ (when kill-buffer
+ (gnus-kill-or-deaden-summary kill-buffer))
+ (gnus-configure-windows 'summary 'force)
+ (gnus-set-mode-line 'summary)
+ (gnus-summary-position-point)
+ (message "")
+ t)
+ ;; We couldn't select this group.
+ ((null did-select)
+ (when (and (eq major-mode 'gnus-summary-mode)
+ (not (equal (current-buffer) kill-buffer)))
+ (kill-buffer (current-buffer))
+ (if (not quit-config)
+ (progn
+ ;; Update the info -- marks might need to be removed,
+ ;; for instance.
+ (gnus-summary-update-info)
+ (set-buffer gnus-group-buffer)
+ (gnus-group-jump-to-group group)
+ (gnus-group-next-unread-group 1))
+ (gnus-handle-ephemeral-exit quit-config)))
+ (gnus-message 3 "Can't select group")
+ nil)
+ ;; The user did a `C-g' while prompting for number of articles,
+ ;; so we exit this group.
+ ((eq did-select 'quit)
+ (and (eq major-mode 'gnus-summary-mode)
+ (not (equal (current-buffer) kill-buffer))
+ (kill-buffer (current-buffer)))
+ (when kill-buffer
+ (gnus-kill-or-deaden-summary kill-buffer))
+ (if (not quit-config)
+ (progn
+ (set-buffer gnus-group-buffer)
+ (gnus-group-jump-to-group group)
+ (gnus-group-next-unread-group 1)
+ (gnus-configure-windows 'group 'force))
+ (gnus-handle-ephemeral-exit quit-config))
+ ;; Finally signal the quit.
+ (signal 'quit nil))
+ ;; The group was successfully selected.
+ (t
+ (gnus-set-global-variables)
+ ;; Save the active value in effect when the group was entered.
+ (setq gnus-newsgroup-active
+ (gnus-copy-sequence
+ (gnus-active gnus-newsgroup-name)))
+ ;; You can change the summary buffer in some way with this hook.
+ (gnus-run-hooks 'gnus-select-group-hook)
+ ;; Set any local variables in the group parameters.
+ (gnus-summary-set-local-parameters gnus-newsgroup-name)
+ (gnus-update-format-specifications
+ nil 'summary 'summary-mode 'summary-dummy)
+ (gnus-update-summary-mark-positions)
+ ;; Do score processing.
+ (when gnus-use-scoring
+ (gnus-possibly-score-headers))
+ ;; Check whether to fill in the gaps in the threads.
+ (when gnus-build-sparse-threads
+ (gnus-build-sparse-threads))
+ ;; Find the initial limit.
+ (if gnus-show-threads
+ (if show-all
+ (let ((gnus-newsgroup-dormant nil))
+ (gnus-summary-initial-limit show-all))
+ (gnus-summary-initial-limit show-all))
+ ;; When untreaded, all articles are always shown.
+ (setq gnus-newsgroup-limit
+ (mapcar
+ (lambda (header) (mail-header-number header))
+ gnus-newsgroup-headers)))
+ ;; Generate the summary buffer.
+ (unless no-display
+ (gnus-summary-prepare))
+ (when gnus-use-trees
+ (gnus-tree-open group)
+ (setq gnus-summary-highlight-line-function
+ 'gnus-tree-highlight-article))
+ ;; If the summary buffer is empty, but there are some low-scored
+ ;; articles or some excluded dormants, we include these in the
+ ;; buffer.
+ (when (and (zerop (buffer-size))
+ (not no-display))
+ (cond (gnus-newsgroup-dormant
+ (gnus-summary-limit-include-dormant))
+ ((and gnus-newsgroup-scored show-all)
+ (gnus-summary-limit-include-expunged t))))
+ ;; Function `gnus-apply-kill-file' must be called in this hook.
+ (gnus-run-hooks 'gnus-apply-kill-hook)
+ (if (and (zerop (buffer-size))
+ (not no-display))
+ (progn
+ ;; This newsgroup is empty.
+ (gnus-summary-catchup-and-exit nil t)
+ (gnus-message 6 "No unread news")
+ (when kill-buffer
+ (gnus-kill-or-deaden-summary kill-buffer))
+ ;; Return nil from this function.
+ nil)
+ ;; Hide conversation thread subtrees. We cannot do this in
+ ;; gnus-summary-prepare-hook since kill processing may not
+ ;; work with hidden articles.
+ (and gnus-show-threads
+ gnus-thread-hide-subtree
+ (gnus-summary-hide-all-threads))
+ (when kill-buffer
+ (gnus-kill-or-deaden-summary kill-buffer))
+ ;; Show first unread article if requested.
+ (if (and (not no-article)
+ (not no-display)
+ gnus-newsgroup-unreads
+ gnus-auto-select-first)
+ (progn
+ (gnus-configure-windows 'summary)
+ (cond
+ ((eq gnus-auto-select-first 'best)
+ (gnus-summary-best-unread-article))
+ ((eq gnus-auto-select-first t)
+ (gnus-summary-first-unread-article))
+ ((gnus-functionp gnus-auto-select-first)
+ (funcall gnus-auto-select-first))))
+ ;; Don't select any articles, just move point to the first
+ ;; article in the group.
+ (goto-char (point-min))
+ (gnus-summary-position-point)
+ (gnus-configure-windows 'summary 'force)
+ (gnus-set-mode-line 'summary))
+ (when (get-buffer-window gnus-group-buffer t)
+ ;; Gotta use windows, because recenter does weird stuff if
+ ;; the current buffer ain't the displayed window.
+ (let ((owin (selected-window)))
+ (select-window (get-buffer-window gnus-group-buffer t))
+ (when (gnus-group-goto-group group)
+ (recenter))
+ (select-window owin)))
+ ;; Mark this buffer as "prepared".
+ (setq gnus-newsgroup-prepared t)
+ (gnus-run-hooks 'gnus-summary-prepared-hook)
+ (setq ad-return-value t)))))))
+
+;; 5.8.2
+(defadvice gnus-select-newsgroup (around tinygnus-debug dis)
+ ;; (group &optional read-all select-articles)
+ "Output trace to tinygnus-:debug-buffer"
+ ;; (group &optional read-all select-articles)
+ ;; "Select newsgroup GROUP.
+ ;;If READ-ALL is non-nil, all articles in the group are selected.
+ ;; If SELECT-ARTICLES, only select those articles from GROUP."
+ (flet ((pr (x y)
+ (tinygnus-gnus-debug-insert-line x y 'gnus-select-newsgroup)))
+ (pr '(CALL-ARGS group read-all select-articles)
+ (list group read-all select-articles))
+
+ (let* ((entry (gnus-gethash group gnus-newsrc-hashtb))
+ ;;!!! Dirty hack; should be removed.
+ (gnus-summary-ignore-duplicates
+ (if (eq (car (gnus-find-method-for-group group)) 'nnvirtual)
+ t
+ gnus-summary-ignore-duplicates))
+ (info (nth 2 entry))
+ articles fetched-articles cached)
+ (pr 'gnus-current-select-method gnus-current-select-method)
+ (pr '(gnus-find-method-for-group group) (gnus-find-method-for-group group))
+ (unless (gnus-check-server
+ (setq gnus-current-select-method
+ (gnus-find-method-for-group group)))
+ (error "Couldn't open server"))
+ (or (and entry (not (eq (car entry) t))) ; Either it's active...
+ (gnus-activate-group group) ; Or we can activate it...
+ (progn ; Or we bug out.
+ (when (equal major-mode 'gnus-summary-mode)
+ (kill-buffer (current-buffer)))
+ (error "Couldn't request group %s: %s"
+ group (gnus-status-message group))))
+ (unless (gnus-request-group group t)
+ (when (equal major-mode 'gnus-summary-mode)
+ (kill-buffer (current-buffer)))
+ (error "Couldn't request group %s: %s"
+ group (gnus-status-message group)))
+ (setq gnus-newsgroup-name group)
+ (setq gnus-newsgroup-unselected nil)
+ (setq gnus-newsgroup-unreads (gnus-list-of-unread-articles group))
+ (gnus-summary-setup-default-charset)
+ ;; Adjust and set lists of article marks.
+ (when info
+ (gnus-adjust-marked-articles info))
+ ;; Kludge to avoid having cached articles nixed out in virtual groups.
+ (when (gnus-virtual-group-p group)
+ (setq cached gnus-newsgroup-cached))
+ (setq gnus-newsgroup-unreads
+ (gnus-set-difference
+ (gnus-set-difference gnus-newsgroup-unreads gnus-newsgroup-marked)
+ gnus-newsgroup-dormant))
+ (setq gnus-newsgroup-processable nil)
+ (gnus-update-read-articles group gnus-newsgroup-unreads)
+ (if (setq articles select-articles)
+ (setq gnus-newsgroup-unselected
+ (gnus-sorted-intersection
+ gnus-newsgroup-unreads
+ (gnus-sorted-complement gnus-newsgroup-unreads articles)))
+ (setq articles (gnus-articles-to-read group read-all)))
+
+ (setq
+ ad-return-value
+ (cond
+ ((null articles)
+ ;;(gnus-message 3 "Couldn't select newsgroup -- no articles to display")
+ 'quit)
+ ((eq articles 0) nil)
+ (t
+ ;; Init the dependencies hash table.
+ (setq gnus-newsgroup-dependencies
+ (gnus-make-hashtable (length articles)))
+ (gnus-set-global-variables)
+ ;; Retrieve the headers and read them in.
+ (gnus-message 5 "Fetching headers for %s..." gnus-newsgroup-name)
+ (setq gnus-newsgroup-headers
+ (if (eq 'nov
+ (setq gnus-headers-retrieved-by
+ (gnus-retrieve-headers
+ articles gnus-newsgroup-name
+ ;; We might want to fetch old headers, but
+ ;; not if there is only 1 article.
+ (and (or (and
+ (not (eq gnus-fetch-old-headers 'some))
+ (not (numberp gnus-fetch-old-headers)))
+ (> (length articles) 1))
+ gnus-fetch-old-headers))))
+ (gnus-get-newsgroup-headers-xover
+ articles nil nil gnus-newsgroup-name t)
+ (gnus-get-newsgroup-headers)))
+ (gnus-message 5 "Fetching headers for %s...done" gnus-newsgroup-name)
+ ;; Kludge to avoid having cached articles nixed out in virtual groups.
+ (when cached
+ (setq gnus-newsgroup-cached cached))
+ ;; Suppress duplicates?
+ (when gnus-suppress-duplicates
+ (gnus-dup-suppress-articles))
+ ;; Set the initial limit.
+ (setq gnus-newsgroup-limit (copy-sequence articles))
+ ;; Remove canceled articles from the list of unread articles.
+ (setq gnus-newsgroup-unreads
+ (gnus-set-sorted-intersection
+ gnus-newsgroup-unreads
+ (setq fetched-articles
+ (mapcar (lambda (headers) (mail-header-number headers))
+ gnus-newsgroup-headers))))
+ ;; Removed marked articles that do not exist.
+ (gnus-update-missing-marks
+ (gnus-sorted-complement fetched-articles articles))
+ ;; We might want to build some more threads first.
+ (when (and gnus-fetch-old-headers
+ (eq gnus-headers-retrieved-by 'nov))
+ (if (eq gnus-fetch-old-headers 'invisible)
+ (gnus-build-all-threads)
+ (gnus-build-old-threads)))
+ ;; Let the Gnus agent mark articles as read.
+ (when gnus-agent
+ (gnus-agent-get-undownloaded-list))
+ ;; Remove list identifiers from subject
+ (when gnus-list-identifiers
+ (gnus-summary-remove-list-identifiers))
+ ;; Check whether auto-expire is to be done in this group.
+ (setq gnus-newsgroup-auto-expire
+ (gnus-group-auto-expirable-p group))
+ ;; Set up the article buffer now, if necessary.
+ (unless gnus-single-article-buffer
+ (gnus-article-setup-buffer))
+ ;; First and last article in this newsgroup.
+ (when gnus-newsgroup-headers
+ (setq gnus-newsgroup-begin
+ (mail-header-number (car gnus-newsgroup-headers))
+ gnus-newsgroup-end
+ (mail-header-number
+ (gnus-last-element gnus-newsgroup-headers))))
+ ;; GROUP is successfully selected.
+ (or gnus-newsgroup-headers t))))
+ (pr 'RETURN-VALUE ad-return-value))))
+
+;;; 5.8.2
+(defadvice gnus-summary-read-group-1 (around tinygnus-debug dis)
+ ;; (group show-all no-article kill-buffer no-display &optional select-articles)
+ ;; Killed foreign groups can't be entered.
+ (tinygnus-debug-gnus-macro 'gnus-summary-read-group-1
+ (pr 'CALL-ARGS
+ (list group show-all no-article kill-buffer no-display select-articles))
+ (when (and (not (gnus-group-native-p group))
+ (not (gnus-gethash group gnus-newsrc-hashtb)))
+ (error "Dead non-native groups can't be entered"))
+ (gnus-message 5 "Retrieving newsgroup: %s..." group)
+ (let* ((new-group (gnus-summary-setup-buffer group))
+ (quit-config (gnus-group-quit-config group))
+ (did-select (and new-group (gnus-select-newsgroup
+ group show-all select-articles))))
+ (cond
+ ;; This summary buffer exists already, so we just select it.
+ ((not new-group)
+ (gnus-set-global-variables)
+ (when kill-buffer
+ (gnus-kill-or-deaden-summary kill-buffer))
+ (gnus-configure-windows 'summary 'force)
+ (gnus-set-mode-line 'summary)
+ (gnus-summary-position-point)
+ (message "")
+ t)
+ ;; We couldn't select this group.
+ ((null did-select)
+ (when (and (eq major-mode 'gnus-summary-mode)
+ (not (equal (current-buffer) kill-buffer)))
+ (kill-buffer (current-buffer))
+ (if (not quit-config)
+ (progn
+ ;; Update the info -- marks might need to be removed,
+ ;; for instance.
+ (gnus-summary-update-info)
+ (set-buffer gnus-group-buffer)
+ (gnus-group-jump-to-group group)
+ (gnus-group-next-unread-group 1))
+ (gnus-handle-ephemeral-exit quit-config)))
+ (gnus-message 3 "Can't select group")
+ nil)
+ ;; The user did a `C-g' while prompting for number of articles,
+ ;; so we exit this group.
+ ((eq did-select 'quit)
+ (and (eq major-mode 'gnus-summary-mode)
+ (not (equal (current-buffer) kill-buffer))
+ (kill-buffer (current-buffer)))
+ (when kill-buffer
+ (gnus-kill-or-deaden-summary kill-buffer))
+ (if (not quit-config)
+ (progn
+ (set-buffer gnus-group-buffer)
+ (gnus-group-jump-to-group group)
+ (gnus-group-next-unread-group 1)
+ (gnus-configure-windows 'group 'force))
+ (gnus-handle-ephemeral-exit quit-config))
+ ;; Finally signal the quit.
+ (signal 'quit nil))
+ ;; The group was successfully selected.
+ (t
+ (gnus-set-global-variables)
+ ;; Save the active value in effect when the group was entered.
+ (setq gnus-newsgroup-active
+ (gnus-copy-sequence
+ (gnus-active gnus-newsgroup-name)))
+ ;; You can change the summary buffer in some way with this hook.
+ (gnus-run-hooks 'gnus-select-group-hook)
+ ;; Set any local variables in the group parameters.
+ (gnus-summary-set-local-parameters gnus-newsgroup-name)
+ (gnus-update-format-specifications
+ nil 'summary 'summary-mode 'summary-dummy)
+ (gnus-update-summary-mark-positions)
+ ;; Do score processing.
+ (when gnus-use-scoring
+ (gnus-possibly-score-headers))
+ ;; Check whether to fill in the gaps in the threads.
+ (when gnus-build-sparse-threads
+ (gnus-build-sparse-threads))
+ ;; Find the initial limit.
+ (if gnus-show-threads
+ (if show-all
+ (let ((gnus-newsgroup-dormant nil))
+ (gnus-summary-initial-limit show-all))
+ (gnus-summary-initial-limit show-all))
+ ;; When untreaded, all articles are always shown.
+ (setq gnus-newsgroup-limit
+ (mapcar
+ (lambda (header) (mail-header-number header))
+ gnus-newsgroup-headers)))
+ ;; Generate the summary buffer.
+ (unless no-display
+ (gnus-summary-prepare))
+ (when gnus-use-trees
+ (gnus-tree-open group)
+ (setq gnus-summary-highlight-line-function
+ 'gnus-tree-highlight-article))
+ ;; If the summary buffer is empty, but there are some low-scored
+ ;; articles or some excluded dormants, we include these in the
+ ;; buffer.
+ (when (and (zerop (buffer-size))
+ (not no-display))
+ (cond (gnus-newsgroup-dormant
+ (gnus-summary-limit-include-dormant))
+ ((and gnus-newsgroup-scored show-all)
+ (gnus-summary-limit-include-expunged t))))
+ ;; Function `gnus-apply-kill-file' must be called in this hook.
+ (gnus-run-hooks 'gnus-apply-kill-hook)
+ (if (and (zerop (buffer-size))
+ (not no-display))
+ (progn
+ ;; This newsgroup is empty.
+ (gnus-summary-catchup-and-exit nil t)
+ (gnus-message 6 "No unread news")
+ (when kill-buffer
+ (gnus-kill-or-deaden-summary kill-buffer))
+ ;; Return nil from this function.
+ nil)
+ ;; Hide conversation thread subtrees. We cannot do this in
+ ;; gnus-summary-prepare-hook since kill processing may not
+ ;; work with hidden articles.
+ (and gnus-show-threads
+ gnus-thread-hide-subtree
+ (gnus-summary-hide-all-threads))
+ (when kill-buffer
+ (gnus-kill-or-deaden-summary kill-buffer))
+ ;; Show first unread article if requested.
+ (if (and (not no-article)
+ (not no-display)
+ gnus-newsgroup-unreads
+ gnus-auto-select-first)
+ (progn
+ (gnus-configure-windows 'summary)
+ (cond
+ ((eq gnus-auto-select-first 'best)
+ (gnus-summary-best-unread-article))
+ ((eq gnus-auto-select-first t)
+ (gnus-summary-first-unread-article))
+ ((gnus-functionp gnus-auto-select-first)
+ (funcall gnus-auto-select-first))))
+ ;; Don't select any articles, just move point to the first
+ ;; article in the group.
+ (goto-char (point-min))
+ (gnus-summary-position-point)
+ (gnus-configure-windows 'summary 'force)
+ (gnus-set-mode-line 'summary))
+ (when (get-buffer-window gnus-group-buffer t)
+ ;; Gotta use windows, because recenter does weird stuff if
+ ;; the current buffer ain't the displayed window.
+ (let ((owin (selected-window)))
+ (select-window (get-buffer-window gnus-group-buffer t))
+ (when (gnus-group-goto-group group)
+ (recenter))
+ (select-window owin)))
+ ;; Mark this buffer as "prepared".
+ (setq gnus-newsgroup-prepared t)
+ (gnus-run-hooks 'gnus-summary-prepared-hook)
+ (setq ad-return-value t)))))))
+
+;;; 5.8.2
+(defadvice gnus-activate-group (around tinygnus-debug dis)
+ "Output trace to tinygnus-:debug-buffer"
+ ;; (group &optional scan dont-check method)
+ ;; Check whether a group has been activated or not.
+ ;; If SCAN, request a scan of that group as well.
+ (tinygnus-debug-gnus-macro 'gnus-activate-group
+ (pr '(CALL-ARGS group &optional scan dont-check method)
+ (list group scan dont-check method))
+ (let ((method (or method (inline (gnus-find-method-for-group group))))
+ active)
+ (pr 'method method)
+ (setq
+ ad-return-value
+ (and (inline (gnus-check-server method))
+ ;; We escape all bugs and quit here to make it posxsible to
+ ;; continue if a group is so out-there that it reports bugs
+ ;; and stuff.
+ (progn
+ (and scan
+ (gnus-check-backend-function 'request-scan (car method))
+ (gnus-request-scan group method))
+ t)
+ (condition-case ()
+ (inline (gnus-request-group group dont-check method))
+ ;(error nil)
+ (quit nil))
+ (setq active (gnus-parse-active))
+ (unless active
+ (pr "(parse-active)NNTP buffer conatins no data"
+ nntp-server-buffer)
+ (pr 'gnus-parse-active active))
+ ;; If there are no articles in the group, the GROUP
+ ;; command may have responded with the `(0 . 0)'. We
+ ;; ignore this if we already have an active entry
+ ;; for the group.
+ (if (and (zerop (car active))
+ (zerop (cdr active))
+ (gnus-active group))
+ (gnus-active group)
+ (gnus-set-active group active)
+ ;; Return the new active info.
+ active))))))
+
+;;; --> nnagent-request-scan calls this too
+;;;
+;;; 5.8.2
+(defadvice nnml-request-group (around tinygnus-debug dis)
+ ;; (group &optional server dont-check)
+ "Output trace to tinygnus-:debug-buffer"
+ (tinygnus-debug-gnus-macro 'nnml-request-group
+ (pr '(CALL-ARGS group dont-check gnus-command-method)
+ (list group dont-check gnus-command-method))
+ (setq
+ ad-return-value
+ (let ((pathname-coding-system 'binary))
+ (cond ((not (nnml-possibly-change-directory group server))
+ (nnheader-report 'nnml "Invalid group (no such directory)"))
+ ((not (file-exists-p nnml-current-directory))
+ (nnheader-report 'nnml
+ "Directory %s does not exist"
+ nnml-current-directory))
+ ((not (file-directory-p nnml-current-directory))
+ (nnheader-report 'nnml
+ "%s is not a directory"
+ nnml-current-directory))
+ (dont-check (nnheader-report 'nnml "Group %s selected" group)
+ t)
+ (t (nnheader-re-read-dir nnml-current-directory)
+ (nnmail-activate 'nnml)
+ (let ((active (nth 1 (assoc group nnml-group-alist))))
+ (if (not active)
+ (nnheader-report 'nnml "No such group: %s" group)
+ (nnheader-report 'nnml "Selected group %s" group)
+ (nnheader-insert "211 %d %d %d %s
+" (max (1+ (- (cdr active) (car active))) 0) (car active) (cdr active) group)))))))))
+
+(defadvice nnml-possibly-change-directory (around tinygnus-debug dis)
+ ;; (group &optional server)
+ "Output trace to tinygnus-:debug-buffer"
+ (tinygnus-debug-gnus-macro 'nnml-possibly-change-directory
+ (pr '(CALL-ARGS group server) (list group server))
+ (when (and server
+ (not (nnml-server-opened server)))
+ (nnml-open-server server))
+ (setq
+ ad-return-value
+ (if (not group)
+ t
+ (let ((pathname (nnmail-group-pathname group nnml-directory))
+ (pathname-coding-system 'binary))
+ (pr 'nnmail-group-pathname pathname)
+ (pr 'nnml-current-directory nnml-current-directory)
+ (when (not (equal pathname nnml-current-directory))
+ (setq nnml-current-directory pathname
+ nnml-current-group group
+ nnml-article-file-alist nil))
+ (file-exists-p nnml-current-directory))))
+ (pr 'RETURN-VALUE ad-return-value)))
+
+;;; 5.8.2
+(defadvice gnus-request-group (around tinygnus-debug dis)
+ ;; (defun my-gnus-request-group (group &optional dont-check gnus-command-method)
+ ;; (group &optional dont-check gnus-command-method)
+ ;; "Request GROUP. If DONT-CHECK, no information is required."
+ "Output trace to tinygnus-:debug-buffer"
+ (tinygnus-debug-gnus-macro 'gnus-request-group
+ (pr '(CALL-ARGS group &optional dont-check gnus-command-method)
+ (list group dont-check gnus-command-method))
+ (let ((gnus-command-method
+ (or gnus-command-method (inline (gnus-find-method-for-group group)))))
+ (when (stringp gnus-command-method)
+ (setq gnus-command-method
+ (inline (gnus-server-to-method gnus-command-method)))
+ (pr 'gnus-command-method gnus-command-method))
+ (let* ((function (inline (gnus-get-function gnus-command-method
+ 'request-group)))
+ (group (gnus-group-real-name group))
+ (server (nth 1 gnus-command-method))
+ ret
+ stat
+ dir)
+ (pr 'FUNCALL function)
+ (pr 'FUNCALL-SYMBOL-FUNC (symbol-function function))
+ (pr 'GROUP group)
+ (pr 'SERVER server)
+ (pr 'DONT-CHECK dont-check)
+ (when (string-match "nnml-request-group"
+ (prin1-to-string (symbol-function function)))
+ (pr '(nnml-server-opened server) (nnml-server-opened server))
+ ;; FIXME: nnml-directory may be in server parameters
+ (setq dir (nnmail-group-pathname group nnml-directory))
+ (pr '(nnmail-group-pathname group nnml-directory) dir)
+ (pr 'nnml-directory nnml-directory)
+ (pr 'nnml-current-directory nnml-current-directory)
+ (setq stat (assoc group nnml-group-alist))
+ (pr '(assoc group nnml-group-alist) stat)
+ (unless stat
+ (pr "ERROR: Gnus doesn't know about ACTIVE file" "")
+ (pr 'nnml-group-alist nnml-group-alist)
+
+ (when (and (file-directory-p dir)
+ (or (file-exists-p (concat dir "active"))
+ (file-exists-p (concat dir ".agentview")))
+ (y-or-n-p "Group not in `nnml-group-alist'. Update? "))
+ (tinygnus-gnus-debug-update-nnml-group-alist group dir)))
+ (unless (string-match "nnml" group)
+ (pr "ERROR: group name doesn not contain NNML?"
+ "Gnus can't read group!!!")))
+ (setq ret
+ (funcall function group server dont-check))
+ (pr 'nnml-status-string nnml-status-string)
+ (pr 'RETURN-VALUE ret)
+ (setq ad-return-value ret)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-gnus-debug-investigate-problem (group)
+ "Debug why you can't select NNML/Agent NNTP group."
+ (interactive
+ (list
+ (completing-read
+ "TinyGnus group to debug: "
+ (ti::list-to-assoc-menu (list (gnus-group-group-name))))))
+ (let* ((method (gnus-find-method-for-group group))
+ (server (nth 1 method))
+ (buffer (get-buffer-create tinygnus-:debug-buffer))
+ info
+ info-method
+ elt
+ tmp1
+ tmp2)
+ ;; make shorter function name
+ (flet ((pr (x y)
+ (tinygnus-gnus-debug-insert-line x y)))
+ (with-current-buffer buffer
+ (tinygnus-gnus-debug-on)
+ (ti::pmax)
+ (insert (format "\nGNUS DEBUG SESSION (group: %s) %s\n\n"
+ group
+ (ti::date-standard-date 'minutes)))
+ (pr 'nnml-directory nnml-directory)
+ (pr 'gnus-agent-directory gnus-agent-directory)
+ (pr 'gnus-find-method-for-group method)
+ (pr 'request-group (gnus-get-function method 'request-group))
+ (pr 'gnus-group-real-name (gnus-group-real-name group))
+ (pr 'gnus-group-method (gnus-group-method group))
+ (pr 'gnus-group-real-prefix (gnus-group-real-prefix group))
+ (pr 'gnus-server-status (gnus-server-status method))
+ (pr 'gnus-server-opened (gnus-server-opened method))
+ (pr '(gnus-group-find-parameter nnml-directory)
+ (gnus-group-find-parameter nnml-directory))
+ (pr '(gnus-info-params (gnus-get-info group))
+ (gnus-info-params (gnus-get-info group)))
+ (pr '(assoc server gnus-server-alist)
+ (assoc server gnus-server-alist))
+ (pr 'gnus-group-name-to-method (gnus-group-name-to-method group))
+ (pr 'gnus-server-to-method (gnus-server-to-method gnus-command-method))
+ (pr '(gnus-active group) (gnus-active group))
+ (pr '(gnus-check-server method) (gnus-check-server method))
+ (pr 'gnus-agent-covered-methods gnus-agent-covered-methods)
+ (pr '(gnus-methods-using 'respool) (gnus-methods-using 'respool))
+ ;; ....................................... Active article list ...
+ (setq tmp1 (gnus-active group))
+ (setq tmp2 (gnus-activate-group group))
+ (pr '(gnus-active group) tmp1)
+ (pr '(gnus-activate-group group) tmp2)
+ (unless (or tmp1 tmp2)
+ (pr "ERROR: Gnus DOES NOT HAVE INFO ABOUT FILE RANGE. (active)"
+ ""))
+ ;; .................................................... server ...
+ (setq elt (assoc method gnus-opened-servers))
+ (pr 'gnus-opened-servers elt)
+ (pr '(gnus-get-function method 'open-server)
+ (gnus-get-function method 'open-server))
+ (pr '(gnus-request-group group nil method)
+ (gnus-request-group group nil method))
+ (setq info (gnus-get-info group))
+ (pr 'gnus-get-info info)
+ (pr 'nnml-directory nnml-directory)
+ (pr 'nnml-current-directory nnml-current-directory)
+ (setq info-method (gnus-info-method info))
+ (pr "(gnus-info-method info)" info-method)
+ (pr 'gnus-server-extend-method
+ (gnus-server-extend-method group info-method))
+ (pr 'gnus-group-entry (gnus-group-entry group))
+ ;; (gnus-activate-group group)
+ (tinygnus-gnus-debug-off)
+ (display-buffer (current-buffer))
+ (message "TinyGnus: Investigation ready. Check results from %s"
+ tinygnus-:debug-buffer)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-fix-nnml-groups ()
+ "Step throught every nnml group and make sure they have
+proper files created and Gnus knows about them via `nnml-group-alist'.
+
+Agent groups are also NNML groups, so this will also step through nntp
+backends when Gnus is unplugged."
+ (interactive)
+ (let* ((list (tinygnus-gnus-newsrc-alist
+ (function
+ (lambda (group)
+ (or (string-match "nnml" group)
+ (and (null gnus-plugged)
+ (eq (car (gnus-find-method-for-group group))
+ 'nntp)))))))
+ method
+ server
+ function
+ open-server
+ status
+ status2
+ real-name
+ dir
+ group)
+
+ (message "TinyGnus: NNML-DIRECTORY is %s" nnml-directory)
+ (message "TinyGnus: GNUS-AGENT-DIRECTORY is %s" gnus-agent-directory)
+ (dolist (elt list)
+ (setq group (car elt)
+ method (gnus-find-method-for-group group)
+ server (nth 1 method)
+ function (gnus-get-function method 'request-group)
+ real-name (gnus-group-real-name group))
+ (setq elt (assoc method gnus-opened-servers))
+ (setq open-server (gnus-get-function method 'open-server))
+ (when (eq (nth 1 elt) 'denied)
+ (message "TinyGnus: Group has denied server %s Trying to open %s ..."
+ group (prin1-to-string open-server))
+ (setq status (nth 1 method)
+ status2 (nthcdr 2 method))
+ (unless status
+ (message "TinyGnus: Open Server didn't succeed"))
+ (unless status2
+ (message "TinyGnus: status 2 error %s" (prin1-to-string status2))))
+ ;; see gnus-int.el gnus-request-group
+ (unless (funcall function real-name (nth 1 method) nil)
+ (message "TinyGnus: Group %s problem [%s] Trying to fix..."
+ group nnml-status-string)
+ (nnml-possibly-change-directory group server)
+ (setq dir (nnmail-group-pathname group nnml-directory))
+ (ti::d! group nnml-current-directory dir)
+ (if (not (file-directory-p dir))
+ (message "TinyGnus: Unable to fix %s, no directory %s" group dir)
+ (tinygnus-gnus-debug-update-nnml-group-alist group dir))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-gnus-debug-on (&optional verb)
+ "Turn on Gnus debug. See `tinygnus-:debug-buffer'. VERB.
+If you experience a problem during entering a group
+
+ cannot select group
+ couldn't open server
+
+Call this function and it will record the state of several Gnus functions
+and call parameters and gateher them to `tinygnus-:debug-buffer'. Examining
+the results may reveal where the problem is."
+ (interactive)
+ (ti::verb)
+ (let ((re "^tinygnus-debug"))
+ (if verb
+ (message
+ (substitute-command-keys
+ (concat
+ "TinyGnus: Gnus debug is now on (advices on). "
+ "Show debug \\[tinygnus-debug-show]."))))
+ (ad-enable-regexp re)
+ ;; (ad-update-regexp re)
+ (ad-activate-regexp re)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinygnus-gnus-debug-off (&optional verb)
+ "Turn off Gnus debug. See `tinygnus-:debug-buffer'. VERB."
+ (interactive)
+ (ti::verb)
+ (let ((re "^tinygnus-debug"))
+ (if verb
+ (message
+ (substitute-command-keys
+ (concat
+ "TinyGnus: Gnus debug is now off (advices off). "
+ "Show debug \\[tinygnus-debug-show]."))))
+ (ad-disable-regexp re)
+ (ad-update-regexp re)))
+
+;;}}}
+;;{{{ Advice
+
+;;; .......................................................... &advice ...
+
+;;; ----------------------------------------------------------------------
+;;; Dormant handling is hard coded in gnus, and the fastest way to
+;;; show them is include them in summary generation phase.
+;;; Called by gnus-sum.el::gnus-summary-initial-limit
+;;;
+;;; #Todo: 2000-01 puts gnus to infinite loop. Fix this.
+;;;
+(defadvice gnus-summary-limit-children (around tinygnus-show-dormants dis)
+ "Replace function if `tinygnus-:show-dormants' is t.
+Make dormants immediately visible in non-nntp groups."
+ (if (null tinygnus-:show-dormants)
+ ad-do-it
+ ;; Return 1 if this subthread is visible and 0 if it is not
+ (when (ad-get-arg 0) ;thread flag
+ (cond
+ ;; This part is copied from gnus-sum.el
+ ((and (not (string-match "nntp" gnus-newsgroup-name))
+ (let* ((children
+ (if (cdr (ad-get-arg 0))
+ (apply '+ (mapcar 'gnus-summary-limit-children
+ (cdr (ad-get-arg 0))))
+ 0))
+ (number (mail-header-number (car (ad-get-arg 0)))))
+ ;; In original gnus this test would suppress dormants.
+ (when (and (memq number gnus-newsgroup-dormant)
+ (zerop children))
+ (push number gnus-newsgroup-limit)
+ (setq ad-return-value 1)))))
+ (t
+ ad-do-it)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defadvice gnus-topic-read-group
+ (around tinygnus-fast-read-unread-articles act)
+ "Read only unread/newly arrived articles. If no new articles, read as usual.
+If given prefix arg 2 x \\[universal-argument] (NO-THREADS) then all threads
+with unread articles will be displayed.
+
+To put it simply: When you see new articles in Group, entering the
+group only shows those new articles. This makes reading group faster."
+ (let* ((fid "gnus-topic-read-group")
+ (arg (ad-get-arg 0))
+ ;; See also (gnus-group-group-name)
+ (groups (gnus-group-process-prefix nil))
+ (group (car groups))
+ unread-arts)
+ (unless fid ;; No-op. XEmacs byte compiler silencer
+ (setq fid nil))
+ ;; Parameter GROUP is not defined if you hit SPC on TOPIC
+ ;; to collapse or open it.
+ (cond
+ ((and group
+ (or (null arg) (equal arg '16))
+ (eq 1 (length groups))
+ (string-match "nnml" group)
+ (not (memq (car-safe (gnus-group-method group)) '(nntp)))
+ (let ((gnus-fetch-old-headers (if arg t nil)))
+ (setq unread-arts
+ (gnus-list-of-unread-articles group))))
+ (message "TinyGnus Advice: reading NEW articles.")
+ (sit-for 0.2)
+ (gnus-group-read-group nil t nil unread-arts))
+ (t
+ (message "TinyGnus Advice: Normal reading...")
+ ;; As usual, no new articles.
+ ad-do-it))))
+
+;;}}}
+;;{{{ 19.34 compressed .eld support
+
+;;; ..................................................... &compression ...
+;;; - sometimes I have _very_ limited quota and I woul wish gnus would allow
+;;; using compresses files, but it doesn't by default.
+;;; - These advices make Gnus use compressed startup files.
+;;; - The functins are copied directly from Gnus kit and needed modifications
+;;; have been made.
+;;;
+;;; See also
+;;;
+;;; gnus.el::gnus Find the current startup file name.
+;;; (setq gnus-current-startup-file (gnus-make-newsrc-file gnus-startup-file))
+
+;;; --++-- --++-- --++-- --++-- --++-- --++-- --++-- --+ &advice-start --
+(when (and nil
+ (string-match tinygnus-:gnus-version-for-advice gnus-version)
+ (stringp tinygnus-:z))
+
+ (defadvice gnus-check-first-time-used (around tinygnus act)
+ "Replace function."
+ (if (or (> (length gnus-newsrc-alist) 1)
+ (file-exists-p (concat gnus-startup-file (concat ".eld" tinygnus-:z)))
+ (file-exists-p gnus-startup-file)
+ (file-exists-p (concat gnus-startup-file ".el"))
+ (file-exists-p (concat gnus-startup-file ".eld")))
+ nil
+ (gnus-message 6 "First time user; subscribing you to default groups")
+ (unless (gnus-read-active-file-p)
+ (gnus-read-active-file))
+ (setq gnus-newsrc-last-checked-date (current-time-string))
+ (let ((groups gnus-default-subscribed-newsgroups)
+ group)
+ (if (eq groups t)
+ nil
+ (setq groups (or groups gnus-backup-default-subscribed-newsgroups))
+ (mapatoms
+ (lambda (sym)
+ (if (null (setq group (symbol-name sym)))
+ ()
+ (let ((do-sub (gnus-matches-options-n group)))
+ (cond
+ ((eq do-sub 'subscribe)
+ (gnus-sethash group group gnus-killed-hashtb)
+ (funcall gnus-subscribe-options-newsgroup-method group))
+ ((eq do-sub 'ignore)
+ nil)
+ (t
+ (setq gnus-killed-list (cons group gnus-killed-list)))))))
+ gnus-active-hashtb)
+ (while groups
+ (if (gnus-active (car groups))
+ (gnus-group-change-level
+ (car groups) gnus-level-default-subscribed gnus-level-killed))
+ (setq groups (cdr groups)))
+ (gnus-group-make-help-group)
+ (and gnus-novice-user
+ (gnus-message 7 "`A k' to list killed groups"))))))
+
+ (defun gnus-read-newsrc-file (&optional force)
+ "Replace function. Optionally FORCE."
+ (interactive)
+ ;;Make sure this is defined
+ (setq gnus-current-startup-file (gnus-make-newsrc-file gnus-startup-file))
+ (let ((variables gnus-variable-list))
+ (while variables
+ (set (car variables) nil)
+ (setq variables (cdr variables))))
+ (let* ((newsrc-file gnus-current-startup-file)
+ (quick-file (concat newsrc-file ".el")))
+ (save-excursion
+ ;; We always load the .newsrc.eld file. If always contains
+ ;; much information that can not be gotten from the .newsrc
+ ;; file (ticked articles, killed groups, foreign methods, etc.)
+ (gnus-read-newsrc-el-file quick-file)
+ (if (and (file-exists-p gnus-current-startup-file)
+ (or force
+ (and (file-newer-than-file-p newsrc-file quick-file)
+ (file-newer-than-file-p
+ newsrc-file (concat quick-file "d" tinygnus-:z)))
+ (not gnus-newsrc-alist)))
+ ;; We read the .newsrc file. Note that if there if a
+ ;; .newsrc.eld file exists, it has already been read, and
+ ;; the `gnus-newsrc-hashtb' has been created. While reading
+ ;; the .newsrc file, Gnus will only use the information it
+ ;; can find there for changing the data already read -
+ ;; ie. reading the .newsrc file will not trash the data
+ ;; already read (except for read articles).
+ (save-excursion
+ (gnus-message 5 "Reading %s..." newsrc-file)
+ (set-buffer (find-file-noselect newsrc-file))
+ (buffer-disable-undo (current-buffer))
+ (gnus-newsrc-to-gnus-format)
+ (kill-buffer (current-buffer))
+ (gnus-message 5 "Reading %s...done" newsrc-file)))
+ ;; Read any slave files.
+ (unless gnus-slave
+ (gnus-master-read-slave-newsrc))
+ ;; Convert old to new.
+ (gnus-convert-old-newsrc))))
+
+ (defadvice gnus-read-newsrc-el-file (around tinygnus act)
+ "Replace function."
+ (let ((ding-file (concat file "d" tinygnus-:z)))
+ ;; We always, always read the .eld file.
+ (gnus-message 5 "Reading %s..." ding-file)
+ (let (gnus-newsrc-assoc)
+ (condition-case nil
+ (load ding-file t t t)
+ (error
+ (gnus-error 1 "Error in %s" ding-file)))
+ (when gnus-newsrc-assoc
+ (setq gnus-newsrc-alist gnus-newsrc-assoc)))
+ (gnus-make-hashtable-from-newsrc-alist)
+ (when (file-newer-than-file-p file ding-file)
+ ;; Old format quick file
+ (gnus-message 5 "Reading %s..." file)
+ ;; The .el file is newer than the .eld file, so we read that one
+ ;; as well.
+ (gnus-read-old-newsrc-el-file file))))
+
+ (defadvice gnus-make-newsrc-file (around tinygnus act)
+ "Replace function."
+ (setq
+ ad-return-value
+ (let* ((file (expand-file-name file nil))
+ (real-file (concat file "-" (nth 1 gnus-select-method))))
+ (cond
+ ((file-exists-p (concat real-file ".el" tinygnus-:z))
+ (concat real-file ".el" tinygnus-:z))
+ ((file-exists-p (concat file tinygnus-:z))
+ (concat file tinygnus-:z))
+ ((or (file-exists-p real-file)
+ (file-exists-p (concat real-file ".el"))
+ (file-exists-p (concat real-file ".eld")))
+ real-file)
+ (t
+ file)))))
+
+ (defadvice gnus-save-newsrc-file (around tinygnus act)
+ "Add compressed file support."
+ ;; Note: We cannot save .newsrc file if all newsgroups are removed
+ ;; from the variable gnus-newsrc-alist.
+ (when (and (or gnus-newsrc-alist gnus-killed-list)
+ gnus-current-startup-file)
+ (save-excursion
+ (if (and (or gnus-use-dribble-file gnus-slave)
+ (not force)
+ (or (not gnus-dribble-buffer)
+ (not (buffer-name gnus-dribble-buffer))
+ (zerop (save-excursion
+ (set-buffer gnus-dribble-buffer)
+ (buffer-size)))))
+ (gnus-message 4 "(No changes need to be saved)")
+ (run-hooks 'gnus-save-newsrc-hook)
+ (if gnus-slave
+ (gnus-slave-save-newsrc)
+ ;; Save .newsrc.
+ (when gnus-save-newsrc-file
+ (gnus-message 5 "Saving %s..." gnus-current-startup-file)
+ (gnus-gnus-to-newsrc-format)
+ (gnus-message 5 "Saving %s...done" gnus-current-startup-file))
+ ;; Save .newsrc.eld.
+ (set-buffer (get-buffer-create " *Gnus-newsrc*"))
+ (make-local-variable 'version-control)
+ (setq version-control 'never)
+ (setq buffer-file-name
+ (concat gnus-current-startup-file ".eld" tinygnus-:z))
+ (setq default-directory (file-name-directory buffer-file-name))
+ (gnus-add-current-to-buffer-list)
+ (buffer-disable-undo (current-buffer))
+ (erase-buffer)
+ (gnus-message 5 "Saving %s.eld..." gnus-current-startup-file)
+ (gnus-gnus-to-quick-newsrc-format)
+ (run-hooks 'gnus-save-quick-newsrc-hook)
+ (save-buffer)
+ (kill-buffer (current-buffer))
+ (gnus-message
+ 5 "Saving %s.eld...done" gnus-current-startup-file))
+ (gnus-dribble-delete-file)
+ (gnus-group-set-mode-line)))))
+
+;;; --++-- --++-- --++-- --++-- --++-- --++-- --++-- --++- &advice-end --
+ ) ;; advice-end
+
+;;}}}
+
+(provide 'tinygnus)
+
+(tinygnus-install)
+(run-hooks 'tinygnus-:load-hook)
+
+;;; tinygnus.el ends here
--- /dev/null
+;;; tinyhotlist.el --- Hot-list of important buffers, files(ange-ftp), dired
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 1995-2007 Jari Aalto
+;; Keywords: tools
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program, call M-x tinyhotlist-version
+;; Look at the code with folding.el
+
+;; COPYRIGHT NOTICE
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;;; Install:
+
+;; ........................................................ &t-install ...
+;; Put this file on your Emacs-Lisp load path, add following into your
+;; ~/.emacs startup file. Rip code with tinylib.el/ti::package-rip-magic
+;;
+;; (add-hook 'tinyhotlist-:load-hook 'tinyhotlist-load-hotlist)
+;; (require 'tinyhotlist)
+;;
+;; or use autoload, preferred because your emacs starts up faster
+;;
+;; (autoload 'tinyhotlist-control "tinyhotlist" "" t)
+;; (autoload 'tinyhotlist-load-hotlist "tinyhotlist" "" t)
+;; (autoload 'tinyhotlist-save-hotlist "tinyhotlist" "" t)
+;;
+;; Suggested key bindings
+;;
+;; ;; for windowed system. In XEmacs, use event `button3'.
+;; (global-set-key [(control shift mouse-3)] 'tinyhotlist-control)
+;;
+;; ;; for non-windowed, close to C-x b , switch-to-buffer
+;; (global-set-key "\C-cb" 'tinyhotlist-control-kbd)
+;;
+;; Before you can use hot list, read the documentation of function
+;; `tinyhotlist-control'. Example setup is at the end of file.
+;;
+;; If you have any questions, use this function
+;;
+;; M-x tinyhotlist-submit-bug-report
+
+;;}}}
+;;{{{ Briefly
+
+;;; .................................................... &t-commentary ...
+
+;;; Commentary:
+
+;;}}}
+;;{{{ Documentation
+
+;; Preface, may 1995
+;;
+;; There is excellent utility 'msb.el', but when it comes to having
+;; most important files at hand, It needs some companion with it. An
+;; emacs session can easily have 20 C++ files, user may start news
+;; while the compile it going on and try some lisp code found from the
+;; gnu.emacs.help articles, load couple of emacs configuration files
+;; for editing and then realize that there is mail coming, because
+;; some biff utility tells so. User switches to mail reader and starts
+;; reading the latest messages... within short period of time emacs is
+;; full of buffers and to use MSB to navigate through them all may be
+;; get one frustrated: "Where was that buffer again, do I need to step
+;; 3 panes before I can see that file...?"
+;;
+;; The navigation is especially problem if user is working only with
+;; handful of source files actively, while he may still have 40+ files
+;; loaded.
+;;
+;; What would help the situation? A simple hot list for my most used
+;; files, where one can put and remove items very easily. No more
+;; searching like in msb.el.
+;;
+;; This package does not intend to replace `msb', it's superb in class
+;; of its own, but there may be also need for a hot list, because the
+;; most used files page in `msb' changes dynamically whenever buffers
+;; are changed. Hot list in the other hand stays the same from session
+;; to session.
+;;
+;; Overview of features
+;;
+;; o Provides pop-up menu where you can add and remove current buffer:
+;; "most important work file list". In non-windowed system,
+;; standard completion feature is used instead of pop-up menu.
+;; o Any persistent files can be kept in hot list, even ange-ftp files or
+;; dired buffers.
+;; o Hot list can be saved and read on startup.
+;; o This is not "last visited files" list, but persistent list of
+;; files. When you select item from hot list, the file is displayed
+;; (if it is in Emacs) or loaded (by using ange-ftp if necessary).
+;;
+;; How to use the hotlist
+;;
+;; When you load this package, it defines hot list cache to store the
+;; items. The list will be empty at first, but after you
+;; have added an entry to it, you can display the hot list. To add
+;; or remove entries from hot list, is explained in function:
+;;
+;; C-h f tinyhotlist-control
+;;
+;; If you use add and remove commands often, it might be useful to
+;; to define some custom key bindings. The alternative way is to use
+;; prefix arguments to functions `tinyhotlist-control'
+;;
+;; (global-set-key [(shift f3)] 'tinyhotlist-add)
+;; (global-set-key [(control f3)] 'tinyhotlist-remove)
+;;
+;; In non-windowed environment hot list is is managed through completion menu.
+;; Admittedly, this is not as nice as the pop-up menu.,
+;; To use keyboard, use function:
+;;
+;; tinyhotlist-control-kbd
+;;
+;; Here is an example of the displayed hot list in pop-up. The second
+;; string to the right is abbreviation name of the directory, e.g. `~ftp1'
+;; is a short name for /user@site.com:~user/project/this/. The `txt' is
+;; short name for $HOME/doc/txt/
+;;
+;; +-------------------+
+;; |hotlist |
+;; |===================|
+;; |*Backtrace* |
+;; |*VC-log* |
+;; |.emacs |
+;; |.procmailrc |
+;; |ChangeLog |
+;; |RMAIL |
+;; |file.txt txt |
+;; |other.txt txt |
+;; |remote.cc ~ftp1 |
+;; |remote.cc ~ftp2 |
+;; +-------------------+
+;;
+;; Note about the pop-up display: The font used in pop-up may not be
+;; proportionally spaced, like Courier, so the entries may therefore
+;; show as ragged. That is, the directory names are not nicely lined
+;; up.
+;;
+;; Shortening long filenames
+;;
+;; The typical menu item is quite long, because there is buffer name
+;; and filename part. The default rule shortens the home directory
+;; names to "" but if your file is elsewhere, you have to modify the
+;; `tinyhotlist-:abbreviate-file-name-table'. There is examples how to use it
+;; at the end of source file. Like:
+;;
+;; /user@site.com:~user/project/this/ --> ~ftp1
+;;
+;; If you make changes to this variable after the hot list has been
+;; made, the new abbreviations will take effect on at creation of new
+;; items. To rebuild everything from defaults (this destroys you
+;; previous content), call function `tinyhotlist-build-default-hotlist'.
+;;
+;; Hooks: saving hot list after each cache update
+;;
+;; The buffers are stored into variable `tinyhotlist-:cache' and there
+;; is two hooks that run after the entry is deleted or added to the
+;; cache. The hooks are `tinyhotlist-:add-hook' and
+;; `tinyhotlist-:remove-hook'. They contain default value
+;; `tinyhotlist-save-hotlist' which updates the cache on disk after
+;; each change. You can set these hooks to nil if you want to manually
+;; control when to save cache. (Maybe you load BASE cache every time
+;; and modify it during Emacs session, but you don't want to save
+;; this "session" hot list).
+;;
+;; (add-hook 'tinyhotlist-:load-hook 'my-tinyhotlist-load-hook)
+;;
+;; (defun my-tinyhotlist-load-hook ()
+;; "My hotlist settings"
+;; (setq tinyhotlist-save-hotlist nil)
+;; (setq tinyhotlist-:remove-hook nil))
+;;
+;; Saving and restoring the hot list
+;;
+;; When you're satisfied with the hot list, save it to file with command:
+;;
+;; M-x tinyhotlist-save-hotlist
+;;
+;; To automatically restore the hot list when package loads:
+;;
+;; (add-hook 'tinyhotlist-:load-hook 'tinyhotlist-load-hotlist)
+;;
+;; To save the _current_ hot list automatically when Emacs exists:
+;;
+;; (add-hook 'kill-emacs-hook 'tinyhotlist-save-hotlist)
+;;
+;; Example
+;;
+;; Here is complete example setup how you could configure this package.
+;;
+;; (autoload 'tinyhotlist-control "tinyhotlist" "" t)
+;; (ti::add-hooks 'tinyhotlist-:load-hook
+;; '(tinyhotlist-load-hotlist my-tinyhotlist-init))
+;;
+;; (defun my-tinyhotlist-init ()
+;; "Sets defaults for hotlist"
+;; (setq tinyhotlist-:default-function 'my-tinyhotlist-defaults)
+;; (global-set-key [(control shift mouse-3)] 'tinyhotlist-control))
+;;
+;; (defconst tinyhotlist-:abbreviate-file-name-table
+;; (list
+;; ;; Remember: the substitution order must be _BIGGEST_
+;; ;; substitution first.
+;; ;;
+;; ;; Shorten ange ftp references
+;; (list
+;; "/foo@example.com:/home/foo"
+;; "~foo")
+;;
+;; (list txt "~t")
+;; (list wtxt "~wt")
+;; (list elisp "") ;; and wont show this either
+;; (list h "")))) ;; don't display the home
+;;
+;; (defconst tinyhotlist-:default-regexp
+;; (concat
+;; "^RMAIL$\\|scratc\\|diff\\|buffer menu\\|diff\\|Messages"
+;;
+;; ;; Procmail
+;; "\\|procmailrc\\|pm-.*\\(hdr\\|log\\|rc\\|txt\\)"
+;;
+;; ;; text
+;; "\\|elisp.txt\\|ssjaaa.txt"
+;;
+;; ;; perl
+;; "\\|\\.pls"
+;;
+;; "\\|.mak"
+;;
+;; ;; emacs project files
+;; "\\|emacrs\\|funcs.ja.el\\|tinylibm.el\\|tinylib.el"
+;;
+;; ;; C++ project files
+;; "\\|wmpmea.*cc"
+;;
+;; ;; Gnus
+;; "\\|article\\|newsgroup\\|Summary\\|MIME-out"))
+;;
+;; ;; ^^^ ^^^ ^^^ ^^^ ^^^ ^^^ ^^^ ^^^ ^^^ ^^^ ^^^ ^^^ ^^^ window-system ^ ^
+;; )
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+;;{{{ setup: require
+
+(require 'tinylibm)
+
+(eval-when-compile (ti::package-use-dynamic-compilation))
+
+(ti::package-defgroup-tiny TinyHotlist tinyhotlist-: tools
+ "Hotlist of important buffers and files, easy add, easy remove")
+
+;;}}}
+;;{{{ setup: private
+;;; .......................................................... &v-bind ...
+
+(defvar tinyhotlist-:history-keymap nil
+ "Keymap for history.")
+
+;; completion keymap unused currently, #todo someday
+
+(if tinyhotlist-:history-keymap
+ nil
+ (setq tinyhotlist-:history-keymap (make-sparse-keymap))
+ (define-key tinyhotlist-:history-keymap [(up)] 'ignore)
+ (define-key tinyhotlist-:history-keymap [(down)] 'ignore))
+
+;;; ......................................................... &v-hooks ...
+
+(defcustom tinyhotlist-:load-hook '(tinyhotlist-load-hotlist)
+ "*Hook run when file is loaded."
+ :type 'hook
+ :group 'TinyHotlist)
+
+(defcustom tinyhotlist-:add-hook '(tinyhotlist-save-hotlist)
+ "*Hook run when new buffer is added with `tinyhotlist-add-internal'.
+Functions in hook are called with two arguments:
+
+ BUFFER ADD-STATUS
+
+Default value is `tinyhotlist-save-hotlist' which saves cache after every change."
+ :type 'hook
+ :group 'TinyHotlist)
+
+(defcustom tinyhotlist-:remove-hook '(tinyhotlist-save-hotlist)
+ "*Hook run when new buffer is added with `tinyhotlist-remove-internal'.
+Functions in hook are called with two arguments:
+
+ BUFFER REMOVE-STATUS
+
+Default value is `tinyhotlist-save-hotlist' which saves cache after every change."
+ :type 'hook
+ :group 'TinyHotlist)
+
+;;; ....................................................... &v-private ...
+
+(defvar tinyhotlist-:cache nil
+ "Hotlist cache.
+Format:
+ '((\"BUFFER-NAME[ DIRECTORY]\" . [FILE-NAME])
+ ...)
+
+The BUFFER-NAME is the actual name of the buffer. It may contains
+<2> in the name too indicatin second buffer with the same name.
+The DIRECTORY part is only included if buffer is readlly connected to file.
+the DIRECTORY contains leading space if the directory part is included
+
+ 'buffer' -- single entry
+ 'buffer2 ~/' -- buffer and filename.")
+
+(defvar tinyhotlist-:history nil
+ "History for completion.")
+
+(defcustom tinyhotlist-:hotlist-file
+ (ti::package-config-file-prefix "tinyhotlist.el")
+ "*Default hotlist configuration file. You can edit as you want.
+If you edit the order of this file, set `tinyhotlist-:cache-sort-flag' to nil."
+ :type 'file
+ :group 'TinyHotlist)
+
+(defcustom tinyhotlist-:cache-sort-flag t
+ "Non-nil means Sort the entries in hotlist after adding a buffer to it.
+If you want to edit by hand the order of the hotlist file
+`tinyhotlist-:hotlist-file', then set this variable to nil, and the raw
+order is preserved."
+ :type 'boolean
+ :group 'TinyHotlist)
+
+;;}}}
+;;{{{ setup: user config
+
+;;; ........................................................ &v-public ...
+
+(defcustom tinyhotlist-:list-max 40
+ "*Maximum members in hotlist."
+ :type 'integer
+ :group 'TinyHotlist)
+
+(defcustom tinyhotlist-:title " hotlist "
+ "*Title of menu."
+ :type 'string
+ :group 'TinyHotlist)
+
+;; handy if you want to call from non-mouse, e.g. pressing key.
+;; --> set event parameter to nil when calling func tinyhotlist-control
+
+(defcustom tinyhotlist-:x-coord 170
+ "*Default menu coordinate."
+ :type 'integer
+ :group 'TinyHotlist)
+
+(defcustom tinyhotlist-:y-coord 170
+ "*Default menu coordinate."
+ :type 'integer
+ :group 'TinyHotlist)
+
+(defcustom tinyhotlist-:use-x-popup t
+ "*If non-nil, don't use popups.
+If you prefer not to use popup-like dialog box for hotlist items,
+then set ths variable to nil. This variable is valid only if you're
+running in X-windowed system."
+ :type 'boolean
+ :group 'TinyHotlist)
+
+(defcustom tinyhotlist-:default-regexp nil
+ "*Regexp to match buffers when initialising hotlist menu.
+See `tinyhotlist-control'."
+ :type 'string
+ :group 'TinyHotlist)
+
+(defcustom tinyhotlist-:abbreviate-file-name-table
+ (list
+ (list
+ (or (and (getenv "HOME")
+ ;; The path names are seen as lowercase in Emacs in Win32
+ (if (ti::win32-p)
+ (downcase (getenv "HOME"))
+ (getenv "HOME")))
+ (error "TinyHotlist: no HOME env variable"))
+ "~"))
+ "How to substitute absolute path names. The PATH value is case sensitive.
+Changes in this variable will only affect the new buffers added to the
+hotlist. If you want to rebuild the whole hotlist using the
+`tinyhotlist-:default-regexp', call `tinyhotlist-build-default-hotlist'
+
+Format:
+ '((PATH SUBSTITUTE) (P S) ..)
+
+Example:
+
+ ;; Remember to put _longest_ substitutionmatches first.
+ ;;
+ '((\"/etc/daemons/interalarms/\" \"ALARM\")
+ (\"/users/foo/\" \"\")) ;; Don't show my home at all
+
+Please look at the many examples that are in the end of tinyhotlist.el"
+ :type '(repeat
+ (list
+ (string :tag "path")
+ (string :tag "alias")))
+
+ :group 'TinyHotlist)
+
+;;}}}
+
+;;{{{ version
+
+(eval-and-compile
+ (ti::macrof-version-bug-report
+ "tinyhotlist.el"
+ "tinyhotlist"
+ tinyhotlist-:version-id
+ "$Id: tinyhotlist.el,v 2.49 2007/05/01 17:20:43 jaalto Exp $"
+ '(tinyhotlist-:version-id
+ tinyhotlist-:list-max
+ tinyhotlist-:use-x-popup
+ tinyhotlist-:default-regexp
+ tinyhotlist-:abbreviate-file-name-table)))
+
+;;}}}
+
+;;{{{ menu handle
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyhotlist-find-buffer (item &optional no-confirm)
+ "Find buffer for corresponding menu ITEM.
+The buffer is loaded from disk if it does not exist in Emacs.
+NO-CONFIRM suppresses confirm of loading ange-ftp files."
+ (let* (buffer
+ file
+ elt
+ ptr)
+ (setq elt (assoc item tinyhotlist-:cache))
+ (setq buffer (car elt)
+ file (cdr elt))
+
+ (cond
+ (file
+ ;; Find ange-ftp dired buffer
+ (when (string-match "@.*:" file)
+ (dolist (buffer (buffer-list))
+ (with-current-buffer buffer
+ (when (and (eq major-mode 'dired-mode)
+ (string=
+ file
+ (symbol-value 'dired-directory)))
+ (setq ptr (current-buffer))
+ (return)))))
+ (setq ptr
+ (or ptr
+ (get-file-buffer file)
+
+ ;; This would call file-attributes, which will call
+ ;; ange ftp for remote buffers.
+ ;;
+ ;; ange-ftp-hook-function(file-attributes ...
+
+ (and (not (string-match "@.*:" file))
+ (find-buffer-visiting file))))
+ (if ptr
+ (switch-to-buffer ptr)
+ (cond
+ ((and (string-match "@.*:" file)
+ (y-or-n-p (format "Load %s " file)))
+ (find-file file))
+ ((not (file-exists-p file))
+ (message "TinyHotlist: file not found [%s]." (or file buffer))
+ (sleep-for 2))
+ (t
+ (find-file file)))))
+ ((setq ptr (get-buffer buffer))
+ ;; Temporary buffer, which is not a file, like *Messages*
+ (switch-to-buffer ptr))
+ (t
+ (message "TinyHotlist: Can't find buffer [%s]" buffer)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyhotlist-abbreviate-file-name (file &optional restore)
+ "Abbreviate FILE by looking at `tinyhotlist-:abbreviate-file-name-table'.
+If RESTORE is passed, the convert abbreviated FILE into absolute path
+using `tinyhotlist-:abbreviate-file-name-table'."
+ (let* (case-fold-search
+ str
+ substitute
+ match
+ replace)
+ (dolist (elt tinyhotlist-:abbreviate-file-name-table)
+ (setq str (nth 0 elt) substitute (nth 1 elt))
+ (setq match (if restore substitute str)
+ replace
+ (if restore
+ (file-name-as-directory str)
+ substitute))
+
+ (when (string-match (concat "^" (regexp-quote match)) file)
+ (setq file (ti::replace-match 0 replace file))
+ (return)))
+ file))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyhotlist-add-internal (buffer)
+ "Add BUFFER or list of buffers to hotlist. Arg must be STRING [list].
+
+Returns:
+ t or nil if added."
+ (let* (buffer-file
+ ptr
+ exist
+ ret)
+ (dolist (buffer (ti::list-make buffer))
+ ;; We have to check if it exists already...
+ ;; this is a bit inefficent way to check list, but because
+ ;; list is small, this is the shortest way.
+ (setq buffer-file
+ (and (setq ptr (get-buffer buffer))
+ (with-current-buffer ptr
+ (or (buffer-file-name) ;; 1) regular file
+ ;; 2) User may be in dired
+ ;; VC renames dired mode, so we can't just 'memq
+ ;; `major-mode'
+ (if (string-match "dired" (symbol-name major-mode))
+ (symbol-value 'dired-directory))))))
+ ;; ................................................ check buffer ...
+ ;; - If buffer has filename check the CDR of cache
+ ;; - if buffer has no filename, then check CAR of the cache.
+ (cond
+ (buffer-file
+ (setq exist
+ (member buffer-file (mapcar (function cdr) tinyhotlist-:cache))))
+ (t
+ (setq exist (ti::list-find tinyhotlist-:cache (regexp-quote buffer)))))
+ ;; ............................................. push to hotlist ...
+ (unless exist
+ (when buffer-file ;; Get the directory name
+ (let* ((abbrev (abbreviate-file-name
+ (tinyhotlist-abbreviate-file-name
+ (file-name-directory buffer-file))))
+ (total (+ (length buffer)
+ (length abbrev)))
+ elt)
+ (if (< total 80)
+ (setq elt (format "%-25s %s" buffer abbrev))
+ (setq elt (concat buffer " " abbrev)))
+ (push (cons elt (abbreviate-file-name buffer-file))
+ tinyhotlist-:cache)))))
+ ;; Keep it in sorted order.
+ (when tinyhotlist-:cache-sort-flag
+ (setq
+ tinyhotlist-:cache
+ (sort
+ tinyhotlist-:cache
+ (function
+ (lambda (a b)
+ (string-lessp (car b) (car a)))))))
+ (setq ret (not exist)) ;; buffer was added if didn't exist
+ (run-hook-with-args 'tinyhotlist-:add-hook buffer ret)
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyhotlist-remove-internal (arg type)
+ "Remove according to ARG and MODE a item from `tinyhotlist-:cache'.
+
+Input:
+
+ ARG Depends on mode.
+ TYPE what type the arg is: 'menu-item 'buffer 'file
+
+Return
+
+ nil t if removed."
+ (let* (list
+ func
+ ret)
+ (cond
+ ((eq type 'menu-item)
+ (when (and (stringp arg)
+ (setq arg (assoc arg tinyhotlist-:cache)))
+ (setq ret t)
+ (setq tinyhotlist-:cache (delete arg tinyhotlist-:cache))))
+ ((eq type 'file)
+ (setq func 'cdr))
+ ((eq type 'buffer)
+ (cond
+ ((get-buffer arg) ;Buffer is filename
+ (setq func 'cdr))
+ (t
+ (setq func 'car)))))
+ (when func
+ (dolist (elt tinyhotlist-:cache)
+ (if (string-match (regexp-quote arg) (or (funcall func elt) "" ))
+ (setq ret t)
+ (push elt list))
+ (setq tinyhotlist-:cache list))
+ (setq tinyhotlist-:cache list))
+ (run-hook-with-args 'tinyhotlist-:remove-hook arg ret)
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyhotlist-add-by-regexp (regexp &optional temp-buf)
+ "Add all buffers matchig REGEXP to hotlist.
+If optional TEMP-BUF prefix arg is non-nil the mach is made
+against temporary buffers too. Otherwise they are not counted."
+ (interactive "sAdd buffers matching: \nP")
+ (tinyhotlist-add-internal
+ (ti::dolist-buffer-list
+ (string-match regexp (buffer-name))
+ temp-buf)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyhotlist-kill (&optional default)
+ "Kill hotlist or initialise with defaults if DEFAULT flag is non-nil.
+References:
+ `tinyhotlist-:default-regexp'."
+ (interactive)
+ (setq tinyhotlist-:cache nil)
+ (if (and default (stringp tinyhotlist-:default-regexp))
+ (tinyhotlist-add-by-regexp tinyhotlist-:default-regexp)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyhotlist-set-defaults ()
+ "Initialise hotlist according to `tinyhotlist-:default-regexp'."
+ (tinyhotlist-kill 'init))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyhotlist-build-default-hotlist ()
+ "Delete existing hotlist and build with `tinyhotlist-:default-regexp'.
+See variable `tinyhotlist-:abbreviate-file-name-table'."
+ (interactive)
+ (setq tinyhotlist-:cache nil)
+ (tinyhotlist-set-defaults))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyhotlist-save-hotlist (&rest ARGS)
+ "Call `tinyhotlist-load-hotlist' with arg to save hotlist. ARGS are ignored."
+ (interactive)
+ (tinyhotlist-load-hotlist 'save))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyhotlist-load-hotlist (&optional save)
+ "Load or SAVE hotlist configuration from `tinyhotlist-:hotlist-file'.
+When the hotlist file is loaded, only valid entries from there
+are selected to `tinyhotlist-:cache': If File does not exist, it is dropped.
+
+Return:
+
+ nil t"
+ (interactive "P")
+ (let* ((file tinyhotlist-:hotlist-file)
+ buffer
+ list)
+ (cond
+ ;; ......................................................... load ...
+ ((null save)
+ (when (file-exists-p file)
+ (load-file file)
+ (dolist (elt tinyhotlist-:cache)
+ (setq buffer (car elt)
+ file (cdr elt))
+ ;; Drop away non-existing files.
+ ;; The Temp buffers *scratch* may not be in emacs, but
+ ;; they can be in hotlist.
+
+ (when (or (null file)
+ (and file
+ (or
+ ;; Let ange-ftp fies go through
+ (string-match "@" file)
+ ;; Check regular files.
+ (file-exists-p file))))
+ (push (cons buffer file) list)))
+ ;; Reverse must be used due to push.
+ (setq tinyhotlist-:cache (nreverse list))
+ t))
+ ;; ......................................................... save ...
+ (t
+ (let* ((file tinyhotlist-:hotlist-file)
+ (dir (file-name-directory file)))
+ (if (not (stringp dir))
+ (error (concat "TinyHotlist: `tinyhotlist-:hotlist-file'"
+ " must be absolute path [%s]")
+ file)
+ ;; Make sure that file can be saved to a directory
+ (or (file-directory-p dir)
+ (and (y-or-n-p (format "TinyHotlist: [SAVE] Create %s? " dir))
+ (make-directory dir t)))
+ (ti::write-file-variable-state
+ file
+ "Emacs TinyHotlist.el cache file."
+ '(tinyhotlist-:cache))))))))
+
+;;}}}
+;;{{{ X menu
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyhotlist-complete (list)
+ "Show LIST in completion menu.
+Return:
+ buffer or nil"
+ (let* ((menu (ti::list-to-assoc-menu list))
+ (def (car-safe tinyhotlist-:history))
+ ret)
+ (setq ret (completing-read "hot item: " menu nil t def 'tinyhotlist-:history))
+ (if (ti::nil-p ret) ;really selected ?
+ nil
+ ret)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyhotlist-show-menu (event &optional title)
+ "Pop the menu and select the buffer.
+If EVENT is nil, use default coordinates to display the menu and TITLE.
+
+Return:
+ menu item or nil."
+ (interactive "e")
+ (let* ((list (mapcar (function car) tinyhotlist-:cache))
+ (title (or title tinyhotlist-:title))
+ (x (cond
+ ((and tinyhotlist-:use-x-popup ;; permits use of popup
+ (ti::compat-window-system))
+ t)
+ (t
+ nil)))) ;; no X available...
+ (if x
+ (ti::compat-popup list event nil title)
+ (tinyhotlist-complete list))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyhotlist-control-kbd (&optional arg)
+ "Same as `tinyhotlist-control' with ARG, but you can call this from keyboard."
+ (interactive "P")
+ (tinyhotlist-control
+ (ti::compat-make-fake-event tinyhotlist-:x-coord tinyhotlist-:y-coord) arg))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyhotlist-control (event &optional arg)
+ "Control center of hotlist. Use mouse EVENT to position popup.
+
+Optional ARG can be:
+
+ nil show the hotlist
+ 0 kill all members from hotlist.
+ 9 kill all, but initalize with defaults.
+ nbr any number, add current active buffer to hotlist
+ - negative number, remove item from hotlist. E.g. \\[universal-argument] -
+ 1 x \\[universal-argument] remove current buffer from hotlist
+ 2 x \\[universal-argument] Save hotlist
+ 3 x \\[universal-argument] load hotlist."
+ (interactive "e\nP")
+ (let* ((buffer (buffer-name))
+ (menu (or tinyhotlist-:cache
+ ;; See if there is any buffers matching user's
+ ;; regexp to make the initial hotlist.
+ (and tinyhotlist-:default-regexp
+ (tinyhotlist-set-defaults)
+ tinyhotlist-:cache)))
+ ret)
+ (cond
+ ;; ...................................................... display ...
+ ((null arg)
+ (cond
+ ((null menu)
+ (message "TinyHotlist: Empty hotlist.")
+ (sleep-for 1))
+ (t
+ (when (setq ret (tinyhotlist-show-menu event))
+ (tinyhotlist-find-buffer ret)))))
+ ;; ................................................... remove/add ...
+ ((or (integerp arg)
+ (memq arg '(-)))
+ (cond
+ ((eq 0 arg)
+ (tinyhotlist-kill)
+ (message "TinyHotlist: Hotlist killed.")
+ (sleep-for 1))
+ ;; "Why number 9??" -- Because it's next to number 0
+ ((eq 9 arg)
+ (tinyhotlist-set-defaults)
+ (message "TinyHotlist: Hotlist killed/initalized.")
+ (sleep-for 1))
+ ((and (integerp arg)
+ (> arg 0))
+ (cond
+ ((tinyhotlist-add-internal buffer)
+ (message "TinyHotlist: Added to hotlist [%s]" buffer)
+ (sleep-for 1))
+ (t
+ (message "TinyHotlist: Already in hotlist."))))
+
+ (t ;Negative
+ (if (null menu)
+ (message "TinyHotlist: Empty hotlist.")
+ (when (setq ret (tinyhotlist-show-menu event "--Remove item--"))
+ (tinyhotlist-remove-internal ret 'menu-item)
+ (message "TinyHotlist: Removed. [%s]" ret)
+ (sleep-for 1))))))
+ ;; ............................................... remove current ...
+ ((equal '(4) arg)
+ (if (if (buffer-file-name)
+ (tinyhotlist-remove-internal (buffer-file-name) 'file )
+ (tinyhotlist-remove-internal buffer 'buffer))
+ (message "TinyHotlist: Removed [%s]" buffer)
+ (message "TinyHotlist: Nothing to remove, [%s] wasn't in hotlist."
+ buffer)))
+ ((equal '(16) arg)
+ (tinyhotlist-save-hotlist)
+ (message "TinyHotlist: saved")
+ (sit-for 1.5))
+ ((equal '(64) arg)
+ (if (tinyhotlist-load-hotlist)
+ (message "TinyHotlist: loaded")
+ (message "TinyHotlist: Can't load %s" tinyhotlist-:hotlist-file))
+ (sleep-for 2)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;
+;;;###autoload
+(defun tinyhotlist-add ()
+ "Add current buffer to hotlist."
+ (interactive)
+ (tinyhotlist-control nil 1))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;
+;;;###autoload
+(defun tinyhotlist-remove ()
+ "Remove current buffer from hotlist."
+ (interactive)
+ (tinyhotlist-control nil -1))
+
+;;}}}
+
+(provide 'tinyhotlist)
+(run-hooks 'tinyhotlist-:load-hook)
+
+;;; tinyhotlist.el ends here
--- /dev/null
+;;; tinyigrep.el --- Top level interface to igrep.el
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 1996-2007 Jari Aalto
+;; Keywords: tools
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program, call M-x tinyigrep-version
+;; Look at the code with folding.el
+
+;; COPYRIGHT NOTICE
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;;; Install:
+
+;; ....................................................... &t-install ...
+;; Put this file on your Emacs-Lisp load path, add following into your
+;; ~/.emacs startup file.
+;;
+;; (require 'tinyigrep)
+;;
+;; ** YOU NEED igrep.el before you can use this package
+;; ** See <http://groups.google.com/groups?group=gnu.emacs.sources>
+;;
+;; Or prefer autoload: your emacs loads this package only when you need it.
+;; Put your customizations to separate file emacs-rc-tinyigrep.el and add
+;; (provide 'emacs-rc-tinyigrep) to the end of the resource file.
+;;
+;; (global-set-key "\C-cG" 'tinyigrep-menu)
+;; (autoload 'tinyigrep-menu "tinyigrep" "" t)
+;;
+;; (defun my-tinyigrep-load-hook ()
+;; "My settings."
+;; (tinyigrep-install-default-databases)
+;; ;; Load your additional databases from separate file
+;; (require 'emacs-rc-tinygrep))
+;;
+;; (add-hook 'tinyigrep-:load-hook 'my-tinyigrep-load-hook)
+;;
+;; If you have any questions, suggestions, bug reports, use function
+;;
+;; M-x tinyigrep-submit-bug-report
+;;
+;; If you find any incorrect behavior, please immediately
+;;
+;; o M-x tinyigrep-debug-toggle
+;; o Clear debug buffer (kill-buffer tinyigrep-:debug)
+;; o Repeat the task
+;; o Send a bug report
+
+;;}}}
+
+;;{{{ Documentation
+
+;; ..................................................... &t-commentary ...
+
+;;; Commentary:
+
+;; Preface, Dec 1996
+;;
+;; Somewhere at summer 1996 Kevin Rodgers <kevinr@ihs.com> decided to
+;; put together all grep calls to one package named igrep.el: `agrep',
+;; `egrep', `fgrep' and `zgrep'. It also could search trees
+;; recursively.
+;;
+;; The package draw attention and many people picked up the package
+;; from the gnu.emacs.sources newsgroup. The default `M-x' `grep'
+;; command that came with emacs was a pale shadow compared to
+;; `igrep.el' package's possibilities and advanced features. The birth
+;; of tinyigrep.el was the need to integrate searches to some common
+;; directories or grouped files, like news articles, info pages,
+;; project directories, lisp sources, Emacs startup files. A package
+;; that would allow so called "databases" (directories to search).
+;; igrep.el interface seemed to offer great deal of flebility if you
+;; did not have locate(1) or glimpse(1) and their indexes up to date
+;; all the time.
+;;
+;; Description
+;;
+;; o Toplevel interface to `igrep.el': Easy command menu access.
+;; o You can toggle igrep options while you're in the
+;; echo-area menu.
+;; o Do directory searches easily: grep all your
+;; news files, your Emacs news files, your text files, your lisp
+;; files, grep all manual paths... just configure one variable.
+;; You can jump to matches from the *compile* buffer where
+;; the results will appear.
+;; o The default installation includes many default directories
+;; to search for: Perl .pod files, perl installation .pm files,
+;; Emacs lisp tree_: cl, vm, tm, semi, mc, gnus and Emacs Info
+;; tree files, Grep all Manual pages installed in your system,
+;; grep your ~/bin ... more.
+;;
+;; Do you need this package?
+;;
+;; If you use Emacs "grep" then I suggest you to move to *igrep.el*
+;; and evaluate tinyigrep.el as well. It simplifies your grep tasks
+;; much more. If you have several directories where you
+;; keep some persistent data where you want to do lookup from time to
+;; time, then you propably appreciate this package. The default setup
+;; already defines several search "databases" and all you need to
+;; do is to supply SEARCH-STRING and change options for search; like
+;; case sensitivity etc.
+;;
+;; Selecting igrep command from command menu
+;;
+;; When you call TinyIgrep, you get prompted for a database selection,
+;; which could be "lisp-cl", "Mail", "News" anything you defined. The
+;; igrep interface menu looks like this:
+;;
+;; igrep: i)grep g)uess l)ast time d)ired [c)ase r)ecur u)ser]
+;; ===================
+;; options on/off
+;;
+;; Pess key ? to see more help on the command line interface. You can
+;; change igrep.el options listed between brackets, e.g. key `c'
+;; toggles case sensitivity of the search by adding or removing the -i
+;; option for grep, `r' can be used to toggle recursive mode on or
+;; off, and `u' toggles user switches on and off. The user options are
+;; stored to history list `tinyigrep-:history-igrep-user-options' from
+;; where they can be recalled.
+;;
+;; List of predefined databases
+;;
+;; For your convenience, function `tinyigrep-install-default-databases'
+;; is run from `tinyigrep-:load-hook', which defines several databases
+;; Here is summary of *some* default databases that are defined, if
+;; you have function `tinyigrep-install-default-databases' in
+;; variable `tinyigrep-:load-hook'.
+;;
+;; Specials
+;;
+;; o `.' The dot-database: search current buffer's directory
+;;
+;; Home:
+;;
+;; o *home-bin-sh* Search ~/bin/ for *.sh *.awk
+;; o *home-bin-pl* Search ~/bin/ for Perl *.pl
+;;
+;; Operating system:
+;;
+;; o *man* Search manpages
+;; o *c-usr-include* Search C header *.h files in /usr/include
+;;
+;; Perl pages:
+;;
+;; o *perl-modules* Search Perl modules *.pm in @INC
+;; o *perl-pod* Search Perl installation *.pod manpages
+;;
+;; Emacs and Emacs lisp:
+;;
+;; o *lisp-home* Search ~/lisp or ~/elisp for *.el
+;; o *lisp-dot-files* Search all .emacs* or emacs-rc- files in `load-path'
+;; o *load-path* Search `load-path' *.el files
+;; o *lisp-emacs-distribution* Search Emacs Lisp installation root
+;; o *emacs-root* Search all of Emacs installation root
+;;
+;; Seach Emacs packages: (there are many more, these are only examples)
+;;
+;; o lisp-pcl-cvs
+;; o lisp-elib
+;; o lisp-cl
+;; o lisp-mc
+;; o lisp-irchat
+;; o lisp-bbdb
+;; o lisp-w3
+;; o lisp-vm
+;; o lisp-tiny
+;;
+;; In addition to the above, if you have created any of these files in
+;; the directories along the `load-path', you can search those
+;; directories recursively. Please create empty files "to mark"
+;; these directories for automatic scanning. In Unix, simply run
+;; `touch(1)' command to create a file.
+;;
+;; o *lisp-rc* database. If file `emacs-rc-flag.el' exists. Typically
+;; in ~/elisp/rc/ where you might keep all your Emacs startup
+;; settings. This directory may be under CVS, RCS version
+;; control. If you did not know, the term "rc" is historical
+;; and means "Resource file". It comes from Unix, where all
+;; startup files are referred as "Resource files".
+;; Traditionally Emacs only has one `$HOME/.emacs' but as
+;; gain experience and your Emacs configurations exlodes, it
+;; is wise to split the dot-emacs to more manageable parts.
+;;
+;; o *lisp-site-lisp* database. If file `site-lisp-flag.el' exists.
+;; Typically in /usr/local/share/site-lisp/ or under /opt
+;; hirarchy. This is the whole site wide lisp installation root
+;; directory. The search is recursive for this "flag database".
+;;
+;; o *lisp-site-lisp-emacs* database. If file
+;; `site-lisp-emacs-flag.el' exists. Here you keep Emacs specific
+;; files that do not work with XEmacs. Typically in
+;; /usr/local/share/site-lisp/emacs/ or under /opt/.
+;;
+;; o *lisp-site-lisp-xemacs* database. If file
+;; `site-lisp-xemacs-flag.el' exists. Here you keep XEmacs
+;; specific files that do not work with Emacs. Typically in
+;; /usr/local/share/site-lisp/xemacs/ or under /opt/.
+;;
+;; A Typical Emacs lisp package installation structure (site wide) might
+;; look like this. Create the appropriate dummy files as needed,
+;; like creating site-lisp-flag.el to directory /usr/share/site-lisp/
+;;
+;; ROOT ( e.g. /usr/local/share/site-lisp/ )
+;; |
+;; +-common/ for Both XEmacs and Emacs
+;; | |
+;; | +-packages/ Big packages
+;; +-emacs Emacs only packages
+;; +-net/ Net packages
+;; | |
+;; | +-cvs-packages/ CVS maintained packages from Net
+;; | +-users/ PAckages from Users around the Net
+;; +-xemacs/ XEmacs only packages
+;;
+;; If you want to define a short name for any of these defaults,
+;; add additional entry e.g. for "vm". The last parameter could
+;; be '(nil) which instead if ´nil' to enable recursive search.
+;;
+;; (tinyigrep-db-push-elt-lisp-package "vm" "vm.el" "grep" nil)
+;;
+;; Here is small piece of lisp code which adds multiple short names
+;; (defaults are lisp-*} to the search database:
+;;
+;; (require 'cl)
+;;
+;; (dolist (package '("vm" "gnus" "irchat" "semi-def" "mc" "tinylib"))
+;; (tinyigrep-db-push-elt-lisp-package
+;; package (concat package ".el") "egrep"))
+;; ;; end of code example
+;;
+;; Running custom grep search
+;;
+;; Sometimes there is need to search something in separate directory.
+;; and you need the full interface to the `grep'. This isavailable
+;; after the standard database menu which you can omit by hitting like
+;; this. First select d)data menu and you see prompt:
+;;
+;; TinyIgrep search database [RET=next choice]:
+;;
+;; Press RET key and you see full grep interface where you can fill
+;; in the search. Say, you have downloaded a mailing list archives
+;; for project xxx and you want to know if there is any discussion
+;; about your problem with `syslog' utility. First, complete the
+;; directory or individual files in the prompt. Separate entries by
+;; a apace. We suppose that archives are in bzip2 compressed format:
+;;
+;; Search file list [TAB]: ~/mailing-list/xxx/*bz2
+;; Grep program: bzgrep
+;; grep expression: syslog
+;;
+;; After that, the search should start. If you want to modify this
+;; search or run it again with different regexp, start again and
+;; recall the history entries with `M-p' (or cursor up).
+;;
+;; Special database for current file directory
+;;
+;; Normally you add databases to variable `tinyigrep-:database'.
+;; There is also a special database whose name is `.', which refers to
+;; files that are under current buffer's directory. E.g. say you
+;; are editing:
+;;
+;; /user/foo/txt/file.txt
+;;
+;; calling `tinyigrep-main' and selecting a special database `.' would
+;; give you a prompt to limit search for files under that directory.
+;; While at prompt, you can modify the file pattern:
+;;
+;; Search: /user/foo/txt/*.txt
+;;
+;; If you select `last' database, the file crieterias to search are
+;; resused and you only need to supply new search pattern (Use `M-p'
+;; and `M-n' to browse history).
+;;
+;; Suggestion
+;;
+;; You may find it useful to keep the igrep buffer in a special frame
+;; when working in windowed environment. See if you like this:
+;;
+;; (if window-system ;; Use variable `console-type' in XEmacs
+;; (setq special-display-buffer-names
+;; '("*compilation*" "*grep*" "*igrep*")))
+;;
+;; How to define your own search databases
+;;
+;; Suppose you want to search 1) emacs cl*el files 2) all your ~/Mail
+;; recursively and 3) your ~/News files. The sample database
+;; definitions would look like this:
+;;
+;; (require 'tinyigrep) ;; gives macros, see below
+;;
+;; (tinyigrep-db-push-elt
+;; (tinyigrep-db-lisp-elt
+;; "cl.el" ;; Find root based on this file
+;; "lisp-cl" ;; the name of search "database"
+;; "egrep" ;; Program to do the work (remember zgrep)
+;; ;; Grep only cl libraries
+;; '(list (concat dir "cl*el"))))
+;;
+;; ;; Notice '(nil) which turns on recursive search.
+;; ;;
+;; ;; database name
+;; ;; | list of files specs
+;; ;; | | recurse flag
+;; ;; | | |
+;; (tinyigrep-db-push-elt '("Mail" ("egrep" ("~/Mail/*") (nil) )))
+;;
+;; ;; This greps only ~/News/*, non-recursive
+;; ;;
+;; (tinyigrep-db-push-elt '("News" ("egrep" ("~/News/*") )))
+;;
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+;;{{{ setup: require
+
+;;; ......................................................... &require ...
+
+(require 'tinylibm)
+
+(eval-when-compile
+ ;; This is NOT used unless running native Win32 Emacs + Cygwin
+ (require 'advice))
+
+;; When tinyigrep.el is compiled, this strange error occurs:
+;; ** the function `igrep-read-args' is not known to be defined
+;;
+
+;; But that function is not used anywhere? The idea to suppress the
+;; message was to tell the byte compiler beforehand where that functions
+;; is and the `eval-and-compile' trick makes the unnecessary message go
+;; away.
+;;
+;; Interestingly, this error message is not displayed by XEmacs 19.14
+;; byte compiler. Maybe this is "used before defined" syndrome in
+;; igrep.el.
+
+(eval-and-compile
+
+ ;; From NTEmacs 20.x FAQ "igrep 2.82 needs to have the variable
+ ;; grep-null-device defined; add the following to your startup file"
+
+ (condition-case error
+ (require 'igrep)
+ (error
+ (error "\
+ ** tinyigrep.el: Hm, no igrep.el along `load-path'.
+ You can find it at <http://groups.google.com/groups?group=gnu.emacs.sources>
+ %s"
+ (prin1-to-string error))))
+
+ (unless (boundp 'igrep-null-device)
+ (if (boundp 'null-device)
+ (defvar igrep-null-device (symbol-value 'null-device))
+ ;; #todo: should this be call to `error'?
+ (message "\
+ ** tinyigrep.el: [WARN] `igrep-null-device' defined. Check igrep.el version.")))
+
+ ;; If trying to load 2.82 in Xemacs 21.2 beta; it cries that
+ ;; somebody (igrep) tried to require ange-ftp. Instruct users
+ ;; to get newer version.
+
+ (if (and (ti::xemacs-p)
+ (string< igrep-version "2.83"))
+ (message " ** TinyIgrep: [XEmacs check] you must have igrep.el 2.83+."))
+
+ (multiple-value-bind (major minor)
+ (if (string-match "^\\([0-9]+\\)\+.\\([0-9]+\\)" igrep-version)
+ (list (match-string 1 igrep-version)
+ (match-string 2 igrep-version)))
+ (if (or (< (string-to-int major) 2)
+ (and (string= major "2")
+ (< (string-to-int minor) 55)))
+ (error
+ "TinyIgrep: [Emacs check] You must have igrep 2.56+. You have now %s"
+ igrep-version)))
+
+ (autoload 'tinyperl-install "tinyperl" "" t)
+
+ ;; These are used only if tinyperl.el is available.
+ ;; Just introduce variables for byte compiler.
+
+ (defvar tinyperl-:pod-path)
+ (defvar tinyperl-:inc-path)
+ (autoload 'igrep-read-args "igrep"))
+
+(eval-when-compile
+ (ti::package-use-dynamic-compilation)
+ ;; Only used under Win32 Emacs/Cygwin
+ (require 'advice))
+
+(ti::package-defgroup-tiny TinyIgrep tinyigrep-: tools
+ "Top level interface to igrep.el")
+
+;;}}}
+;;{{{ setup: hooks
+
+;;; ......................................................... &v-hooks ...
+
+(defcustom tinyigrep-:load-hook
+ '(tinyigrep-install-default-databases)
+ "*Hook that is run when package is loaded."
+ :type 'hook
+ :group 'TinyIgrep)
+
+;;}}}
+;;{{{ setup: user config
+
+;;; ........................................................ &v-public ...
+;;; User configurable
+
+(defcustom tinyigrep-:grep-program
+ (cond
+ ((boundp 'grep-program)
+ grep-program)
+ ((and (ti::emacs-type-win32-p)
+ (cygwin-p))
+ ;; Cannot use `egrep' because itäs bash shell script and not
+ ;; a callable windows executable.
+ "grep")
+ (t
+ "egrep"))
+ "*Default grep program. Initialised from `grep-program' if available.")
+
+(defcustom tinyigrep-:grep-word-at-point nil
+ "*if non-nil, Grab word at point for searching.")
+
+(defcustom tinyigrep-:user-level 'basic
+ "*Interface level.
+'basic Suppose defautls for everything.
+'advanced Show additional features."
+ :type '(choice
+ (const basic)
+ (const advanced))
+ :group 'TinyIgrep)
+
+(defcustom tinyigrep-:special-database "."
+ "*Special database: grep files under file's directory.
+If user seelcts this database, then the current search is suggested
+by looking at the buffer's current directory and file extension.
+
+Eg. if you're in list buffer /dir1/dir2/foo.el, then the suggested
+files to search are
+
+ /dir1/dir2/*el"
+ :type 'string
+ :group 'TinyIgrep)
+
+(defcustom tinyigrep-:debug nil
+ "*If non-nil, Record program flow to debug buffer."
+ :type ' boolean
+ :group 'TinyIgrep)
+
+(defcustom tinyigrep-:flag-file-list
+ '(("lisp-site-lisp" "site-lisp-flag.el" 'rec)
+ ("lisp-site-lisp-net" "site-lisp-net-flag.el" 'rec)
+ ("lisp-site-lisp-net-cvs" "site-lisp-net-cvs-flag.el" 'rec)
+ ("lisp-site-lisp-net-packages" "site-lisp-net-packages-flag.el" 'rec)
+ ("lisp-site-lisp-net-users" "site-lisp-net-users-flag.el" 'rec)
+ ("lisp-site-lisp-common" "site-lisp-common-flag.el" 'rec)
+ ("lisp-site-lisp-emacs" "site-lisp-emacs-flag.el" 'rec)
+ ("lisp-site-lisp-xemacs" "site-lisp-xemacs-flag.el" 'rec)
+ ("lisp-rc" "emacs-rc-flag.el" 'rec))
+ "*List of lisp files that are searches to FLAG the directory.
+When the file is found, the database for that directory is created.
+The isea is that you have site-lisp structure, possibly under you
+~/elisp or /usr/share/site-lisp, where the files are grouped
+according to their characteristics. Here is one possible site-lisp
+organization chart:
+
+ site-lisp
+ |
+ +-common Files common to Emacs and XEmacs
+ |
+ +-emacs Fieles than only work in Emacs
+ +-xemacs Fieles than only work in XEmacs
+ +-net Packages available directly from internet
+ |
+ +-cvs-packages by CVS pserver directories (Gnus, Mailcrypt ..)
+ +-packages complete kits, like Tamp, Notes, etc (multiple files)
+ +-users by User, Emacs Lisp developers
+ |
+ +-firedman-noah
+ +-zakharevich-llya
+ ..
+
+If the entry is
+
+ '(\"lisp-site-lisp\" \"site-lisp-flag.el\" 'rec)
+
+then you would create file directly to the SITE-LISP ROOT,
+/usr/share/site-lisp/site-lisp-flag.el and TinyIgrep.el will flag that
+directory as searchable dir, effectively searching all of your lisp.
+
+Similarly, you can drop 'flags' to other directories, like database entry
+
+ '(\"lisp-site-lisp-net-users\" \"site-lisp-net-users-flag.el\" 'rec)
+
+Format:
+
+ '((DB-NAME lisp-flag-file-name recursive-search)
+ (DB-NAME lisp-flag-file-name recursive-search)
+ ..)."
+ :type '(list sexp)
+ :group 'TinyIgrep)
+
+(defcustom tinyigrep-:perl-pod-path nil ;Will be set later
+ "*Perl installation POD directory."
+ :type '(repeat directory)
+ :group 'TinyIgrep)
+
+(defcustom tinyigrep-:perl-inc-path nil ;Will be set later
+ "*Perl @INC path list."
+ :type '(repeat directory)
+ :group 'TinyIgrep)
+
+(defcustom tinyigrep-:man-path-root (ti::directory-unix-man-path-root)
+ "*Man path root in the system. usually /usr/man/ or /opt/local/man."
+ :type 'directory
+ :group 'TinyIgrep)
+
+(defcustom tinyigrep-:database nil
+ "*Igrep database for group of files.
+Rule: The directories _must_ have trailing slashes.
+
+There is one special entry named `tinyigrep-:special-database' which
+is treated differently.
+
+You can use following entry to tell that it should be skipped, the
+DB-NAME here is string \"nil\".
+
+ '(\"nil\")
+
+This is useful when you build the database in a variable and you test if
+certain directories exist. Like this, which builds dynamically one
+entry to the `tinyigrep-:database' at evaluation time.
+
+ (list
+ (if (not (file-exists-p \"/not/in/this/host\"))
+ \"nil\" \"my-path-db\")
+ (list
+ ...go and build the correct ENTRY))
+
+Note [igrep find fag]:
+
+ This optional argument is very important is you grep over many
+ directories and many files. It is impossible to tell in the program
+ if your defined criteas generate huge listing or not.
+
+ Defining 3rd argument as list, says that we should call `igrep-find' and
+ not igrep function to prevent \"Arg list too long\" error. This
+ variable reflects `igrep-find-use-xargs', and because nil is valid
+ value, you must express it in list format.
+
+ Valid values and their intepretation is presented below. You may gain
+ performance benefit with xargs since it will invoke fewer grep
+ processes. In the other hand the -exec choise gives you feeback for
+ every found file as it seaches them. In xargs case you have to wait
+ untill the whole list has been generated.
+
+ These values are same as in `igrep-find-use-xargs', only in list format:
+
+ '(gnu) find is called with ... -print0 | xargs -0 -e grep
+ '(not-nil) find is called with ... -print | xargs -e grep
+ '(nil) find is called with ... -exec grep -n -e grep
+
+Adding an entry to the database
+
+ There is a function that handles inserting entries to the database
+ for you. It will replace existing entry or add a new one. The argument
+ isa same as is described in Format below.
+
+ (tinyigrep-db-push-elt '(\"Elisp\" (\"egrep\" (\"~/elisp/*el\"))))
+
+Format:
+
+ '((DB-NAME
+ '(GREP-PROGRAM
+ (DIR DIR ..)
+ [(igrep-find flag)]))
+ ..)
+
+Alternatively the database entry can contain a lisp function that defines
+the actual entry to the variables. For example a call:
+
+ (tinyigrep-db-push-lazy-define \"test-db\" 'my-db-define-test-db)
+
+Would add a database entry in format:
+
+ '(\"test-db\" (my-db-define-test-db))
+
+And the function `my-db-define-test-db' is invoked when user requests
+\"test-db\" search. Tee function MUST DEFINE real entry with the same
+name: \"test-db\" by calling e.g. `tinyigrep-db-push-elt'. See
+source code of tinyigrep.el for examples of this 'deferred until called'
+lazy defining."
+ :type 'sexp
+ :group 'TinyIgrep)
+
+;;}}}
+;;{{{ setup: private
+
+;;; ....................................................... &v-private ...
+;;; Private variables
+
+(defvar tinyigrep-:man-path-sections
+ '("cat1.Z" "cat1m.Z"
+ "cat2.Z" "cat3.Z"
+ "cat4.Z" "cat5.Z"
+ "cat6.Z" "cat7.Z" "cat8.Z"
+ "man1" "man3" "man5" "man7" "man8")
+ "*Possible manual sections under `tinyigrep-:man-path-root'.
+You can list non existing section here; they are automatically ignored
+if they do not exist.")
+
+(defvar tinyigrep-:lisp-package-file-list
+ '(("elisp-apel" "poe.el")
+ ("elisp-bbdb" "bbdb.el")
+ ("elisp-edb" "db-file-io.el")
+ ("elisp-ede" "ede.el")
+ ("elisp-efs" "efs-auto.el")
+ ("elisp-eieo" "eieo.el")
+ ("elisp-elib" "elib-node.el")
+ ("elisp-erc" "erc.el") ; IRC client
+ ("elisp-eshell" "eshell.el")
+ ("elisp-flim" "FLIM-VERSION")
+ ("elisp-gnus" "gnus.el")
+ ("elisp-irchat" "irchat-main.el" ) ; IRC client
+ ("elisp-jde" "jde.el")
+ ("elisp-liece" "liece.el") ; IRC client
+ ("elisp-mailcrypt" "mailcrypt.el")
+ ("elisp-mel" "MEL-CFG")
+ ("elisp-notes-mode" "notes-mode.el")
+ ("elisp-psgml" "psgml-mode.el")
+ ("elisp-pcl-cvs" "pcl-cvs.el")
+ ("elisp-semi" "semi-def.el")
+ ("elisp-speedbar" "speedbar.el")
+ ("elisp-tiny" "tinylibm.el")
+ ("elisp-vm" "vm" '(nil))
+ ("elisp-w3" "w3")
+ ("elisp-xslide" "xslide.el"))
+ "*Lisp databases to search.
+Format:
+
+ '((DATABASE-NAME LISP-FILE-TO-SEARCH [RECURSIVE-OPTION])
+ ...)
+
+For example, to seach Gnus files, the entry looks like:
+
+ '((\"lisp-gnus\" \"gnus.el\") ...)
+
+Which means, that when gnus.el if found from path, that directory is
+used as a base for searches. If you supply a recursive option '(nil),
+then all directories below are searched as well.
+
+ '((\"lisp-gnus\" \"gnus.el\" '(nil)) ...)")
+
+(defvar tinyigrep-:databases-lazy-defined
+ '(("lisp-cl"
+ tinyigrep-install-database-setup-lisp-cl)
+ ("lisp-load-path"
+ tinyigrep-install-database-setup-lisp-load-path)
+ ("lisp-emacs-distribution"
+ tinyigrep-install-database-setup-lisp-cl)
+ ("perl-pod"
+ tinyigrep-install-database-setup-perl-pod)
+ ("perl-modules"
+ tinyigrep-install-database-setup-perl-modules))
+ "Databases whose definition is deferred until used.
+Format:
+
+ '((DATABASE DEFINE-FUNCTION) ...)
+
+In practise it means that for each element in list the
+following is called:
+
+ (tinyigrep-db-push-lazy-define DATABASE DEFINE-FUNCTION).")
+
+(defvar tinyigrep-:databases-lisp-texi-list
+ '(("texi-bbdb" "bbdb.el")
+ ("texi-edb" "db-file-io.el")
+ ("texi-ede" "ede.el")
+ ("texi-eieio" "eieio.el")
+ ("texi-elib" "elib-node.el")
+ ("texi-gnus" "gnus.el")
+ ("texi-irchat" "irchat.el")
+ ("texi-mailcrypt" "mailcrypt.el")
+ ("texi-pcl-cvs" "pcl-cvs.el")
+ ("texi-psgml" "psgml.el")
+ ("texi-w3" "w3.el"))
+ "Lisp *.texi file search databases.
+Many times a bigger lisp package comes with a manual under name
+package.texi, which you could grep easily. This may be faster than
+searching the accompanying info files (if they are even installed).
+
+Format:
+
+ '((DATABASE LISP-FILE-TO-SEARCH-WHERE-TEXI-COULD-BE-FOUND) ...)")
+
+(defconst tinyigrep-:igrep-previous-args nil
+ "List of variables used for calling igrep.")
+
+(defvar tinyigrep-:history-igrep nil
+ "History.")
+
+(defvar tinyigrep-:history-database nil
+ "History of previously used databases.")
+
+(defvar tinyigrep-:history-programs nil
+ "History of used programs.")
+
+(defvar tinyigrep-:history-igrep-user-options nil
+ "History.")
+
+(defvar tinyigrep-:last-database nil
+ "Last selected database.")
+
+(defvar tinyigrep-:debug-buffer "*tinyigrep-debug*"
+ "Debug data buffer.")
+
+;;}}}
+;;{{{ code: Cygwin support
+
+;;; ----------------------------------------------------------------------
+;;; Some code does not treat Cygwin environment properly, so you should do
+;;; use this macro.
+;;;
+(put 'ti::expand-file-name-cygwin-macro 'lisp-indent-function 1)
+(put 'ti::expand-file-name-cygwin-macro 'edebug-form-spec '(body))
+(defmacro ti::expand-file-name-cygwin-macro (check-form &rest body)
+ "Treat Cygwin path names specially and suppress `expand-file-name'.
+
+Input:
+
+ CHECK-FORM Additional check for to verify Cygwin or supply t if there
+ is nothing special to check.
+ BODY Forms to run."
+ (`
+ (let ((igrep-null-device igrep-null-device)
+ (CHECK (, check-form)))
+ (unwind-protect
+ (progn
+ (when (and CHECK
+ (ti::emacs-type-win32-p)
+ (ti::win32-cygwin-p))
+ (setq igrep-null-device "/dev/null")
+ (ti::advice-control '(expand-file-name
+ shell-quote-argument)
+ "^tinylib-cygwin" nil))
+ (,@ body))
+ (when (and CHECK
+ (ti::emacs-type-win32-p)
+ (ti::win32-cygwin-p))
+ (ti::advice-control '(expand-file-name
+ shell-quote-argument)
+ "^tinylib-cygwin" 'disable))))))
+
+;; Install only for Native Win32 Emacs + Cygwin tools
+
+(when (and (ti::emacs-type-win32-p)
+ (ti::win32-cygwin-p))
+
+ (defadvice shell-quote-argument (around tinylib-cygwin-fix dis)
+ "Use single quotes under Cygwin, Not win32 double quotes."
+ (setq ad-return-value (format "'%s'" (ad-get-arg 0))))
+
+ (defadvice expand-file-name (around tinylib-cygwin-fix dis)
+ ;; (expand-file-name NAME &optional DEFAULT-DIRECTORY)
+ ;;
+ ;; function `igrep' calls:
+ ;;
+ ;; (setq files
+ ;, (mapcar 'expand-file-name files)))
+ ;;
+ ;; Which returns incorrect DOS-filenames for Cygwin grep called from
+ ;; Win32 Emacs
+ ;;
+ ;; The same happens in Emacs 21.2 filecache.el
+ ;;
+ ;; (defun file-cache-add-directory-using-find (directory)
+ ;; (let ((dir (expand-file-name directory)))
+ ;; ...
+ ;; ... call `find' binary
+ ;;
+ "Change function during call to `igrep' under Native Win32 Emacs + Cygwin.
+The path is not expanded, but returned as is."
+ (let ((arg0 (ad-get-arg 0))
+ (arg1 (ad-get-arg 1)))
+ (if (and arg1
+ ;; Igrep calls `shell-quote-argument' which puts extra
+ ;; wuotes around text: \"path/filename\". Remove those
+ (string-match "[\"']\\(.*[^\"']\\)" arg1))
+ (setq arg1 (match-string 1 arg1)))
+ (setq ad-return-value
+ (if arg1
+ (format "%s%s" arg1 arg0)
+ arg0)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyigrep-cygwin-binary-p (prg)
+ "Fix `igrep' under Win32 Emacs and Cygwin."
+ (and (ti::win32-p)
+ (ti::emacs-type-win32-p)
+ (ti::win32-cygwin-p)
+ (string-match "grep\\|\\.sh$" prg)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyigrep-cygwin-fixes ()
+ "Under Native Win32 Emacs, use Cygwin executables, not Windows versions."
+ (when (and (ti::emacs-type-win32-p)
+ (ti::win32-cygwin-p))
+ ;; Depending on exec-path, the "find" may be windows version, fix
+ ;; it to cygwin version - the Real Find
+ (when (and (boundp 'igrep-find-program)
+ (string= igrep-find-program "find"))
+ (let ((bin (ti::executable-find "find" 'cygwin)))
+ (when bin
+ (message
+ (setq igrep-find-program bin)))))
+ ;; When igrep.el loads, there are many `defvar' calls to
+ ;; `shell-quote-args' which uses double-quotes under Native Win32. But
+ ;; for Cygwin single quotes are better. Change these:
+ ;;
+ ;; find -type f "!" -name "*~" "!" -name "*,v" "!" -name "s.*" -name "*el" ...
+ (when (and (boundp 'igrep-find-file-clause)
+ igrep-find-file-clause)
+ (setq igrep-find-file-clause
+ (subst-char-in-string ?\" ?' igrep-find-file-clause)))
+ (when (and (boundp 'igrep-find-prune-clause)
+ igrep-find-prune-clause)
+ (setq igrep-find-prune-clause
+ (subst-char-in-string ?\" ?' igrep-find-prune-clause)))))
+
+;;}}}
+;;{{{ code: low-level function and macros
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyigrep-expand-file-name-os (path)
+ "Expand PATH to correct OS. Under Cygwin, use Cygwin paths."
+ (unless (stringp path)
+ (error "TinyIgrep: argument PATH is not a string"))
+ (ti::file-name-for-correct-system path (if (ti::win32-cygwin-p)
+ 'cygwin)))
+
+;;; ----------------------------------------------------------------------
+;;; (tinyigrep-db-lazy-define-funcall (assoc "perl-pod" tinyigrep-:database))
+;;;
+(defun tinyigrep-db-lazy-define-funcall (elt)
+ "Examine database ELT and call embedded function to define database.
+This function activates only, if ELT is in format:
+
+ '(\"database-name\" (lisp-function))
+
+`lisp-function' is called and it should immediately define the
+real entries -- that is: it should replace \"database-name\"
+in `tinyigrep-:database'."
+ (let ((database (car elt))
+ (function (car-safe (nth 1 elt))))
+ (cond
+ ((functionp function)
+ (message "TinyIgrep: Initializing lazy defined database %s `%s'"
+ (car elt) (prin1-to-string function))
+ (funcall function)
+ ;; Did the function replace the entry?
+ (when (functionp
+ (car-safe (nth 1 (assoc database tinyigrep-:database))))
+ (error "TinyIgrep: function `%s' did not define database `%s'."
+ (prin1-to-string function) database)))
+ ((symbolp function)
+ (error "TinyIgrep: Can't define database. No callable function [%s]"
+ (prin1-to-string elt))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyigrep-db-push-lazy-define (database function)
+ "Add DATABASE name and FUNCTION to `tinyigrep-:database'.
+The FUNCTION si called when user selects DATABASE and it
+should call `tinyigrep-db-push-elt' to define the real
+search database entry.
+
+In other words: The FUNCTION is used as a placeholder
+and to forward declare a DATABASE which it will define
+at the point of calling."
+ (let* ((member (assoc database tinyigrep-:database)))
+ (if member
+ (setq tinyigrep-:database (delete member tinyigrep-:database)))
+ (push (list database (list function)) tinyigrep-:database)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyigrep-db-push-elt (elt)
+ "Replace existing ELT in the `tinyigrep-:database' or add new one.
+If you want to denote a directory, make sure the last character is slash.
+
+Examples:
+
+ ;; With recursion, see (nil) argument
+
+ (tinyigrep-db-push-elt '(\"my-perl\" (\"egrep\" (\"~/bin/perl/\") (nil) )))
+ (tinyigrep-db-push-elt '(\"my-bin\" (\"egrep\" (\"~/bin/\") (nil) )))
+
+ ;; Without recursion, filename spec mst be included: `*'
+
+ (tinyigrep-db-push-elt '(\"news-all\" (\"egrep\" (\"~/News/*\"))))
+ (tinyigrep-db-push-elt '(\"news-Incoming\" (\"egrep\" (\"~/Mail/Inc*\"))))
+
+ ;; Easy and free web server http://www.xitami.com/
+
+ (tinyigrep-db-push-elt
+ '(\"Xitami-root\"
+ (\"egrep\"
+ (\"d:/bin/server/xitami/*cfg\"
+ \"d:/bin/server/xitami/*txt\"
+ \"d:/bin/server/xitami/*aut\"))))"
+ (when (and elt (not (equal "nil" (car-safe elt))))
+ (let* ((member (assoc (car elt) tinyigrep-:database)))
+ (if member
+ (setq tinyigrep-:database (delete member tinyigrep-:database)))
+ (push elt tinyigrep-:database))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinyigrep-db-push-elt-lisp-package (name file &optional grep method)
+ "Push NAME into `tinyigrep-:database' if FILE found. Use GREP for search.
+This means, that if FILE exists, rthe directory where it was found
+is searched for *el files.
+
+Input:
+
+ NAME name of the database entry.
+ FILE file to find.
+ GREP program used to find. Default is `egrep'.
+ METHOD additional recursive grep method.
+
+Examples:
+
+ ;; Define shorter names. The default database names are prefixed with
+ ;; lisp- These don't need recursice search.
+
+ (dolist (package '(\"vm\" \"irchat\" \"semi-def\" \"mc\" \"tinylib\" \"bbdb\"))
+ (tinyigrep-db-push-elt-lisp-package package (concat package \".el\")))
+
+ ;; Recursively seached
+
+ (tinyigrep-db-push-elt-lisp-package \"gnus\" \"gnus.el\" \"egrep\" '(nil) )"
+ (tinyigrep-db-push-elt
+ (tinyigrep-db-lisp-elt
+ file name (or grep "egrep")
+ '(list (concat dir "*el")) method)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyigrep-db-push-elt-package (name package &optional recursive grep)
+ "Find PACKAGE and create NAME entry to database for RECURSIVE '(nil).
+
+Example:
+
+ (dolist (elt '(
+ (\"lisp-bbdb\" \"bbdb.el\")
+ (\"lisp-ede\" \"ede.el\")
+ (\"lisp-efs\" \"efs-auto.el\")
+ (\"lisp-eieo\" \"eieo.el\")))
+ (tinyigrep-db-push-elt-lisp-package
+ (nth 0 elt)
+ (nth 1 elt)
+ \"egrep\"
+ (nth 2 elt) ))"
+ (let* ((path (locate-library package)))
+ (when path
+ (setq path (file-name-directory path))
+ (tinyigrep-db-push-elt
+ (list
+ name
+ (list (or grep "grep")
+ (list (concat path "*el"))
+ (if recursive
+ '(nil))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyigrep-db-push-elt-package-texi
+ (name package &optional recursive grep)
+ "Find PACKAGE texi and create NAME entry to database for RECURSIVE '(nil).
+
+Examples:
+
+ (dolist (elt '((\"texi-bbdb\" . \"bbdb.el\")
+ (\"texi-ede\" . \"ede.el\")
+ (\"texi-eieio\" . \"eieio.el\")))
+ (tinyigrep-db-push-elt-package-texi (car elt) (cdr elt) nil \"egrep\"))"
+ (let ((root (locate-library package))
+ (choices '("texi/" "tex/" "")))
+ (catch 'done
+ (when root
+ (setq root (file-name-directory root))
+ (dolist (try (list root
+ (file-name-as-directory (ti::directory-up root))))
+ (dolist (dir choices)
+ (setq dir (concat try dir))
+ (when (and (file-directory-p dir)
+ (directory-files dir nil "\\.te?xi"))
+ (tinyigrep-db-push-elt
+ (list name (list grep (list (concat dir "*.texi*") ))))
+ (throw 'done dir))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro tinyigrep-countdown (message count &optional msg)
+ "Show (format MESSAGE COUNT MSG) and decrease COUNT."
+ (` (progn
+ (decf (, count))
+ (message (format (, message) (, count) (or (, msg) "") )))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyigrep-activate-perl-support ()
+ "Add support for Perl POD manual pages.
+The Perl support is consulted from package tinyperl.el.
+
+Return:
+ non-nil if `tinyigrep-:perl-pod-path' and
+ `tinyigrep-:perl-inc-path' were defined here."
+ ;; Ask from perl what paths are in @INC. That's what we want
+ ;; to search.
+ (when (or (executable-find "perl")
+ (executable-find "perl5"))
+ (message "TinyIgrep: Perl detected, consulting tinyperl.el...")
+ (cond
+ ((or (featurep 'tinyperl)
+ (load "tinyperl" 'noerr))
+ (unless tinyperl-:pod-path
+ (tinyperl-install))
+ (setq tinyigrep-:perl-pod-path tinyperl-:pod-path)
+ (setq tinyigrep-:perl-inc-path tinyperl-:inc-path))
+ (t
+ (message
+ "TinyIgrep: Sorry, tinyperl.el not found. Can't add Perl suport.")
+ nil))))
+
+;;}}}
+;;{{{ code: lazy defined databases
+
+;;; ----------------------------------------------------------------------
+;;; (assoc "perl-pod" tinyigrep-:database)
+;;;
+(defun tinyigrep-install-database-setup-perl-pod (&optional grep)
+ "Install Perl search databases."
+ (or grep
+ (setq grep tinyigrep-:grep-program))
+ (when (tinyigrep-activate-perl-support)
+ (message "TinyIgrep: activating database `perl-pod'")
+ (let* ((path tinyigrep-:perl-pod-path))
+ (when path
+ (tinyigrep-db-push-elt
+ (list "perl-pod"
+ (list grep
+ (list (format
+ "%s*pod"
+ (file-name-as-directory path))))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyigrep-install-database-setup-perl-modules (&optional grep)
+ "Install Perl search databases."
+ (or grep
+ (setq grep tinyigrep-:grep-program))
+ (when (tinyigrep-activate-perl-support)
+ (message "TinyIgrep: activating database `perl-modules'")
+ (let* ((path tinyigrep-:perl-inc-path))
+ (tinyigrep-db-push-elt
+ (list "perl-modules"
+ (list grep
+ (mapcar
+ (function
+ (lambda (x)
+ (format "%s*pm" x)))
+ path)
+ '(nil)))))))
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyigrep-install-database-setup-lisp-rc-files (&optional grep)
+ "Emacs Lisp *-rc-* file search database."
+ (or grep
+ (setq grep tinyigrep-:grep-program))
+ (let* (list)
+ (message "TinyIgrep: activating database `lisp-rc-files'")
+ (dolist (path load-path)
+ (when (and (stringp path)
+ (file-directory-p path))
+ (dolist (file (directory-files path))
+ (when (string-match "-rc-" file)
+ (push (concat (file-name-as-directory path)
+ "*-rc-*el")
+ list)
+ (return)))))
+ (when list
+ (tinyigrep-db-push-elt (list "lisp-rc-files" (list grep list))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyigrep-install-database-setup-lisp-cl (&optional grep)
+ "Install cl*.el search databases."
+ (or grep
+ (setq grep tinyigrep-:grep-program))
+ ;; Find the Emacs lisp root directory dynamically
+ (let* ((path-cl (locate-library "cl.el"))
+ root)
+ (when path-cl
+ (setq path-cl (file-name-directory path-cl)
+ root path-cl)
+ ;; Emacs 20.7 cl.el is one directory down from root
+ ;; in emacs-20.6/lisp/emacs-lisp/cl.el, but we want the root
+ (when (string-match ".*[0-9]/lisp/" path-cl)
+ (setq root (match-string 0 path-cl)))
+
+ (tinyigrep-db-push-elt
+ (list
+ "lisp-emacs-distribution"
+ (list grep
+ (list (concat root "*el"))
+ '(nil))))
+
+ (tinyigrep-db-push-elt
+ (list
+ "lisp-cl"
+ (list grep
+ (list (concat path-cl "cl*el"))
+ '(nil)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyigrep-install-database-setup-lisp-load-path (&optional grep)
+ "Install Emacs Lisp `load-path' search database."
+ (or grep
+ (setq grep tinyigrep-:grep-program))
+ (message "TinyIgrep: activating database `lisp-load-path'")
+ (let ((root-list (ti::directory-unique-roots load-path)))
+ (when root-list
+ (let ((database
+ (list grep
+ (delq nil
+ (mapcar
+ (function
+ (lambda (x)
+ (when (and (stringp x)
+ (file-directory-p x))
+ (concat (file-name-as-directory x) "*.el"))))
+ root-list))
+ '(nil))))
+ (tinyigrep-db-push-elt (list "lisp-load-path" database))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyigrep-install-database-lisp-packages-lazy (&optional grep)
+ "Define lisp package databases. This utilizes deferred lazy loading.
+References:
+ `tinyigrep-:lisp-package-file-list'."
+ (or grep
+ (setq grep tinyigrep-:grep-program))
+ (let* ((base "tinyigrep-install-database-setup-lisp-package-")
+ (list tinyigrep-:lisp-package-file-list)
+ (count (length list))
+ def
+ sym)
+ (dolist (elt list)
+ (multiple-value-bind (db lisp-file recursive) elt
+ (setq sym (intern (format "%s%s" base db)))
+ (setq def
+ (` (defun (, sym) (&optional grep)
+ "Define lisp package database"
+ (or grep
+ (setq grep tinyigrep-:grep-program))
+ (tinyigrep-db-push-elt-lisp-package
+ (, db)
+ (, lisp-file)
+ grep
+ (, recursive) ))))
+ (tinyigrep-countdown
+ (concat
+ "TinyIgrep: Wait, initialising `tinyigrep-:lisp-package-file-list'"
+ "lazy...")
+ count (format "[%s]" db) )
+ ;; Create functions on-the-fly
+ (eval def)
+ (tinyigrep-db-push-lazy-define db sym)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyigrep-install-database-lisp-flag-files-lazy (&optional grep)
+ "Define lisp search databases. This utilizes deferred lazy loading.
+References:
+ `tinyigrep-:flag-file-list'."
+ (or grep
+ (setq grep tinyigrep-:grep-program))
+ (let* ((base "tinyigrep-install-database-setup-lisp-flag-")
+ ;; Create these files with touch(1) to the lisp
+ ;; root directories
+ (list tinyigrep-:lisp-package-file-list)
+ (count (length list))
+ def
+ sym)
+ (dolist (elt list)
+ (multiple-value-bind (db lisp-file recursive) elt
+ (setq sym (intern (format "%s%s" base db)))
+ (setq def
+ (` (defun (, sym) (&optional grep)
+ "Define lisp package database"
+ (or grep
+ (setq grep tinyigrep-:grep-program))
+ (tinyigrep-db-push-elt-package
+ (, db)
+ (, lisp-file)
+ (, recursive) ))))
+ (tinyigrep-countdown
+ (concat
+ "TinyIgrep: Wait, initialising "
+ "`tinyigrep-:lisp-package-file-list' lazy...")
+ count (format "[%s]" db) )
+ ;; Create functions on-the-fly
+ (eval def)
+ (tinyigrep-db-push-lazy-define db sym)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyigrep-install-database-lisp-texi-lazy (&optional grep)
+ "Define lisp *.texi search databases. This utilizes deferred lazy loading.
+References:
+ `tinyigrep-:databases-lisp-texi-list'."
+ (or grep
+ (setq grep tinyigrep-:grep-program))
+ (let* ((base "tinyigrep-install-database-setup-lisp-texi-")
+ ;; Create these files with touch(1) to the lisp
+ ;; root directories
+ (list tinyigrep-:databases-lisp-texi-list)
+ (count (length list))
+ def
+ sym)
+ (dolist (elt list)
+ (multiple-value-bind (db lisp-file) ;; ... recursive)
+ elt
+ (setq sym (intern (format "%s%s" base db)))
+ (setq def
+ (` (defun (, sym) (&optional grep)
+ "Define lisp package database"
+ (or grep
+ (setq grep tinyigrep-:grep-program))
+ (tinyigrep-db-push-elt-package-texi
+ (, db)
+ (, lisp-file)
+ nil
+ grep ))))
+ (tinyigrep-countdown
+ (concat
+ "TinyIgrep: Wait, initialising "
+ "`tinyigrep-:lisp-texi-database-list' lazy...")
+ count (format "[%s]" db) )
+ ;; Create functions on-the-fly
+ (eval def)
+ (tinyigrep-db-push-lazy-define db sym)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyigrep-install-database-lazy ()
+ "Install lazy defined databases in `tinyigrep-:databases-lazy-defined'."
+ (let* ((list tinyigrep-:databases-lazy-defined)
+ (count (length list)))
+ (dolist (elt list)
+ (multiple-value-bind (db function) elt
+ (tinyigrep-countdown
+ "TinyIgrep: Wait, initialising default lazy database..."
+ count (format "[%s]" db))
+ (tinyigrep-db-push-lazy-define db function)))))
+
+;;}}}
+;;{{{ code: default database
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyigrep-install-default-databases (&optional grep)
+ "Install default Emacs, Info, Perl: Man entries to `tinyigrep-:database'.
+GREP is program to used for grepping. Default is `egrep'."
+ (interactive)
+ (let* ((count 25)
+ (msg "TinyIgrep: Wait, initialising default databases... %d %s"))
+
+ (tinyigrep-install-database-lazy)
+ (tinyigrep-install-database-lisp-packages-lazy)
+ (tinyigrep-install-database-lisp-flag-files-lazy)
+ (tinyigrep-install-database-lisp-texi-lazy)
+ (or grep
+ (setq grep tinyigrep-:grep-program))
+ (tinyigrep-countdown msg count "[start]" )
+ ;; .................................................... ¤t-dir ...
+ ;; Make sure this entry is included.
+ ;; Copy this exactly like below, you may only change
+ ;; the GREP program name. It greps from the current file directory,
+ ;; where buffer is.
+ (tinyigrep-db-push-elt
+ (list tinyigrep-:special-database (list grep '(nil))))
+ ;; ...................................................... &man-pages ...
+ (tinyigrep-countdown msg count "[man pages]" )
+ (when (and tinyigrep-:man-path-root
+ (file-exists-p tinyigrep-:man-path-root))
+ (list
+ "man"
+ (list
+ "zgrep"
+ (union
+
+ (mapcar ;; These are system's man paths
+ (function
+ (lambda (x)
+ (setq x (concat (file-name-as-directory
+ tinyigrep-:man-path-root) x))
+ (when (and (stringp x)
+ (file-directory-p x))
+ (concat (file-name-as-directory x) "*"))))
+ tinyigrep-:man-path-sections)
+ (delq nil
+ (mapcar
+ (function
+ (lambda (x)
+ (when (and (stringp x)
+ (file-directory-p x))
+ (concat (expand-file-name x) "*" ))))
+ '( ;; Add also extra man paths
+ "~/man/"
+ "/usr/local/man/"
+ "/usr/contrib/man/"))))
+ ;; Must be recursive
+ '(non-nil))))
+ ;; ........................................................... &home ...
+ ;; shell programs
+ (tinyigrep-countdown msg count "[home bin]" )
+ (when (file-directory-p "~/bin")
+ (tinyigrep-db-push-elt (list "home-bin-sh"
+ (list grep
+ (list
+ "~/bin/*sh" "~/bin/*awk"))))
+ (tinyigrep-db-push-elt (list "home-bin-perl"
+ (list grep
+ (list
+ "~/bin/*.pl"
+ "~/bin/*.pm")))))
+ (tinyigrep-countdown msg count "[home Mail]" )
+
+ (when (file-directory-p "~/Mail")
+ (tinyigrep-db-push-elt
+ (list "home-Mail"
+ (list grep (list "~/Mail/" '(nil))))))
+
+ (tinyigrep-countdown msg count "[home News]" )
+
+ (when (file-directory-p "~/News")
+ (tinyigrep-db-push-elt
+ (list "home-News"
+ (list grep (list "~/News/" '(nil))))))
+ ;; .................................................... &usr-include ...
+ (tinyigrep-countdown msg count "[usr include]" )
+ (tinyigrep-db-push-elt
+ (list
+ (if (file-exists-p "/usr/include/")
+ "c-usr-include" "nil")
+ (list
+ grep
+ (list
+ "/usr/include/")
+ '(nil))))
+ ;; .......................................................... &elisp ...
+ ;; Private home lisp directory
+ (tinyigrep-countdown msg count "[lisp HOME files]" )
+ (let (path-list)
+ (dolist (path '("~/elisp"
+ "~/lisp"
+ "~/.xemacs"
+ "~/.emacs.d"
+ "~/.emacs"))
+ (if (file-directory-p path)
+ (push path path-list)))
+ (when path-list
+ (tinyigrep-db-push-elt
+ (list "lisp-home"
+ (list grep path-list '(nil) )))))
+ ;; ................................................. &elisp-rc-files ...
+ ;; find directories that contain files starting with .emacs*
+ ;; These are Emacs initialisation or setup files.
+ (tinyigrep-countdown msg count "[lisp dot files]")
+ (let* (list)
+ (dolist (path load-path)
+ (when (stringp path)
+ (push (concat (file-name-as-directory path)
+ ".*")
+ list)))
+ (tinyigrep-db-push-elt
+ (list "lisp-dot-files" (list grep list))))
+ ;; ............................................. &emacs-distribution ...
+ (tinyigrep-countdown msg count "[emacs all current]" )
+ (let* ((root (ti::emacs-install-root)))
+ (when root
+ (tinyigrep-db-push-elt
+ (list "ti::emacs-install-root-current"
+ (list
+ grep
+ (list (concat (ti::emacs-install-root) "/*"))
+ '(nil))))
+ (tinyigrep-countdown msg count "[emacs all others/up dir]" )
+ ;; See if thre are more Emacs version installed in the same
+ ;; level and add search to install database as well
+ (setq root (file-name-as-directory (ti::directory-up root)))
+ (let* ((dirs (ti::directory-subdirs root))
+ name)
+ (dolist (path dirs)
+ (when (string-match
+ "^\\([Xx]?[Ee]macs-\\)[0-9]+\\.[0-9.]+$"
+ path)
+ (setq name (concat "ti::emacs-install-root-" path))
+ (tinyigrep-db-push-elt
+ (list name
+ (list
+ grep
+ (list (concat root path "/*"))
+ '(nil)))))))))
+ ;; ........................................................ Cygwin ...
+ (tinyigrep-countdown msg count "[Cygwin]" )
+ (let ((root (ti::win32-cygwin-p))
+ (dir "/usr/doc"))
+ (when root
+ (if (ti::emacs-type-win32-p)
+ (setq dir (concat root dir)))
+ (when (file-directory-p dir)
+ (tinyigrep-db-push-elt
+ (list "cygwin-doc"
+ (list grep
+ (list
+ (concat dir "/*")
+ '(nil))))))))
+ ;; ............................................................ MAIL ...
+ (tinyigrep-countdown msg count "[Mail]" )
+ (when (file-directory-p "~/Mail/")
+ (tinyigrep-db-push-elt (list "Mail" (list grep '("~/Mail/*") '(nil)))))
+ (tinyigrep-countdown msg count)
+ (tinyigrep-countdown msg count "[News]" )
+ (when (file-directory-p "~/News/")
+ (tinyigrep-db-push-elt (list "News" (list grep '("~/News/*") '(nil)))))
+ (tinyigrep-countdown msg count)
+ ;; ................................................. &elisp-packages ...
+ (tinyigrep-countdown msg count "[lisp ediff]" )
+ (let* ((path (locate-library "ediff.el")))
+ (when path
+ (setq path (file-name-directory path))
+ (tinyigrep-db-push-elt
+ (list "lisp-ediff"
+ (list grep (list (concat path "ediff*el")) nil )))))
+ (tinyigrep-countdown msg count "[lisp packages]" )
+ (tinyigrep-install-database-lisp-packages-lazy)
+ ;; If you have SEMI, you propably have installed it so that there is
+ ;; ROOT directory under which you have put SEMI, APEL, FLIM, CHAO
+ ;;
+ ;; elisp
+ ;; semi-mime-root
+ ;; |
+ ;; --- flim
+ ;; --- apel
+ ;; --- mel
+ ;; --- semi-1.9.2
+ ;; (tinyigrep-countdown msg count "[lisp SEMI]" )
+ ;;
+ ;; (let* ((path (locate-library "semi-def.el")))
+ ;; (when path
+ ;; (setq path (if path (ti::directory-up (file-name-directory path))))
+ ;; (tinyigrep-db-push-elt
+ ;; (list "lisp-semi-root"
+ ;; (list grep (list (concat path "*el")) '(nil) )))))
+ ;; ..................................................... &emacs-info ...
+ (tinyigrep-countdown msg count "[info elisp]" )
+ (tinyigrep-db-push-elt
+ (list
+ "info-elisp"
+ (list grep
+ (mapcar
+ (function
+ (lambda (x)
+ (when (and (stringp x)
+ (file-directory-p x))
+ (concat (file-name-as-directory x) "*elisp*"))))
+ (ti::compat-Info-directory-list)))))
+ (tinyigrep-countdown msg count "[info emacs]" )
+ (tinyigrep-db-push-elt
+ (list
+ "info-emacs"
+ (list grep
+ (mapcar
+ (function
+ (lambda (x)
+ (when (and (stringp x)
+ (file-directory-p x))
+ (concat (file-name-as-directory x) "*emacs*"))))
+ (ti::compat-Info-directory-list)))))
+ (tinyigrep-countdown msg count "[info all]" )
+ (tinyigrep-db-push-elt
+ (list
+ "info-all"
+ (list grep
+ (mapcar
+ (function
+ (lambda (x)
+ (when (and (stringp x)
+ (file-directory-p x))
+ (concat (file-name-as-directory x) "*info*"))))
+ (ti::compat-Info-directory-list)))))
+ (tinyigrep-countdown msg count "[info Gnus]" )
+ (tinyigrep-db-push-elt
+ (list
+ "info-gnus"
+ (list "zgrep" ;; unser linux the files are in compressed form
+ (mapcar
+ (function
+ (lambda (x)
+ (when (and (stringp x)
+ (file-directory-p x))
+ (concat (file-name-as-directory x) "*gnus*"))))
+ (ti::compat-Info-directory-list)))))
+ (message "TinyIgrep: Wait, initialising default databases...done")))
+
+;;}}}
+;;{{{ version
+
+;;; ....................................................... &v-version ...
+
+(eval-and-compile
+
+;;;###autoload (autoload 'tinyigrep-version "tinyigrep "Package Description." t)
+
+ (ti::macrof-version-bug-report
+ "tinyigrep.el"
+ "tinyigrep"
+ tinyigrep-:version-id
+ "$Id: tinyigrep.el,v 2.89 2007/05/07 10:50:07 jaalto Exp $"
+ '(tinyigrep-:version-id
+ tinyigrep-:debug
+ igrep-version
+ tinyigrep-:load-hook
+ tinyigrep-:igrep-previous-args
+ tinyigrep-:history-igrep
+ tinyigrep-:history-database
+ tinyigrep-:special-database
+ tinyigrep-:database)
+ '(tinyigrep-:debug-buffer)))
+
+;;;### (autoload 'tinyigrep-debug-toggle "tinyigrep" t t)
+
+(eval-and-compile (ti::macrof-debug-standard "tinyigrep" ":-"))
+
+;;}}}
+;;{{{ Install
+
+(defvar tinyigrep-:menu
+ '((format
+ "\
+%s%sigrep: i)grep d)ata l)ast D)ir v)er - c)ase r)ecur u)ser [%s]"
+ (if (eval (tinyigrep-recursive-var)) "R " "")
+ (if igrep-options (concat igrep-options " ") "")
+ (if (stringp tinyigrep-:last-database)
+ tinyigrep-:last-database
+ ""))
+ ((?i . ( (call-interactively 'igrep)))
+ (?D . ( (call-interactively 'dired-do-igrep)))
+ (?d . ( (call-interactively 'tinyigrep-main)))
+ (?l . ( (call-interactively 'tinyigrep-as-last-time)))
+ (?c . (t
+ (progn
+ (if (string= "-i" (or igrep-options ""))
+ (setq igrep-options nil)
+ (setq igrep-options "-i")))))
+ (?u . (t
+ (let (opt)
+ (setq
+ opt
+ (read-from-minibuffer
+ "Set igrep options: "
+ nil nil tinyigrep-:history-igrep-user-options))
+
+ ;; Should I check something here before doing the assignment?
+ (setq igrep-options opt))))
+ (?r . (t (let ((sym (tinyigrep-recursive-var)))
+ ;; toggle value
+ (if (eval sym)
+ (set sym nil)
+ (set sym t)))))
+ (?v . ( (progn (tinyigrep-version))))))
+ "TinyIgrep echo area menu.
+The complete package manual is available at M-x tinyigrep-version
+
+Commands:
+
+i = Run `igrep'. This is the standard grep interface that Emacs
+ has had for ages. Gives you a command line prompt where you
+ can write the command and parameters.
+
+d = use databases. You can select from predefined
+ databases that were set up at package load time. It is possible
+ to define your own custom search directories and give it a
+ search \"name\". See more with M-x tinyigrep-version.
+
+ If you supply a `tinyigrep-:special-database', defualt is dot(.),
+ you can grep files under current buffer's file directory.
+
+l = Use same database for searching as last time. The name of the last
+ database is rightmost string that us displayd after brackets [].
+
+D = Run `dired-do-grep' which see.
+
+v = Run `tinyigrep-version' which will print the package's manual.
+
+Options:
+
+c = Toggle case sensitive option `-i' in grep searches.
+u = User option. Prompt for custom grep options.
+r = Toggle recursive option `igrep-find'.")
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyigrep-menu (&optional arg)
+ "Igrep command menu."
+ (interactive "P")
+ (ti::menu-menu 'tinyigrep-:menu arg))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinyigrep-check-files (files)
+ "Check that FILES can be grepped."
+ (when files
+ (dolist (elt (ti::list-make files))
+ (if (ti::file-name-remote-p elt)
+ (error "TinyIgrep: Remote file name is not supported: %s" elt)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyigrep-db-lisp-elt (file name prg list &optional method)
+ "Return tigr entry if FILE was found.
+
+Input:
+
+ FILE package.el or Directory. This variable is evaluated.
+ NAME the database completions name
+ PRG grep program to use
+ LIST files definitions and directories to grep
+ METHOD additional recursive grep method
+
+You can refer to variable `dir' if path was found.
+
+Example:
+
+ (igr-push-elt
+ (tinyigrep-db-lisp-elt
+ \"bbdb.el\" \"bbdb\" \"zgrep\"
+ '(list (concat dir \"*\"))))
+
+This will dynamically find the directory where bbdb.el is stored and
+assign local variable `dir' to it (which you see used here).
+If bbdb.el is not found, then this return valid 'null' entry."
+ (let* ((some (eval file))
+ (path (when (stringp some)
+ (if (file-directory-p some)
+ some
+ (locate-library some))))
+ (dir (if path (file-name-directory path))))
+ (if (null dir)
+ (list "nil")
+ (list name (list prg (eval list) method)))))
+
+;;}}}
+;;{{{ Igrep
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyigrep-fix-program-path (program)
+ "Fix PROGRAM path according to environment.
+Under Win32, Emacs cannot call Cygwin shell scripts.
+Find out the full path for PROGRAM."
+ (when (and (stringp program)
+ ;; egrep.exe is in Win32. Do not check.
+ (not (string-match "^grep$" program))
+ ;; There is cygwin XEmacs, howabout native xemacs? #todo:
+ (ti::emacs-p)
+ (ti::win32-cygwin-p 'use-cache))
+ (let (bin)
+ ;; Do we have a cached value?
+ (unless (setq bin (get 'tinyigrep-fix-program-path program))
+ ;; Find out path for program
+ (setq bin (executable-find program))
+ (unless bin
+ (setq bin (ti::file-get-load-path program exec-path)))
+ (when bin
+ (setq program (ti::file-name-forward-slashes bin))
+ ;; SAve value, since lookups are expensive.
+ (put 'tinyigrep-fix-program-path bin program)))))
+ program)
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyigrep-recursive-var ()
+ "Return igrep variable name."
+ (if (boundp 'igrep-recursively)
+ 'igrep-recursively
+ ;; Newer, 2.55
+ 'igrep-find))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyigrep-fix-word (word)
+ "Set WORD to '' if it contain only repeated chars.
+Fix other things too."
+ ;; Be a bit nice to user; if he sits on repeated line like
+ ;; '------------------------' there is no point of
+ ;; offerering that as initial string.
+ (if (and (> (length word) 5)
+ (string=
+ (make-string (length word)
+ (string-to-char (substring word 0 1)))
+ word))
+ (setq word ""))
+ ;; Remove grabbed parenthesis and symbol(') ticks
+ (when (stringp word)
+ (setq word (replace-regexp-in-string "[?!`()'\"\r\n]" "" word)))
+ (ti::remove-properties word))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyigrep-igrep-call (prg pattern files &optional use-find)
+ "Call igrep.el with PRG PATTERN and FILES and recursive USE-FIND."
+ (let ((fid "tinyigrep-igrep-call:"))
+ ;; ti::with-unix-shell-environment
+ ;; (call-process
+ ;; "h:/unix-root/u/bin/bash.exe"
+ ;; nil
+ ;; (current-buffer)
+ ;; "-c"
+ ;; "h:/unix-root/u/bin/zgrep"
+ ;; "--help"))
+ (unless fid ;; No-op. XEmacs byte compiler silencer
+ (setq fid nil))
+ (tinyigrep-debug fid "Calling IGREP"
+ 'default-directory default-directory
+ 'prg prg
+ 'pattern pattern
+ 'files files)
+
+ (ti::expand-file-name-cygwin-macro
+ (tinyigrep-cygwin-binary-p prg)
+ (ti::with-unix-shell-environment
+ (if (ti::listp use-find)
+ (let ((igrep-find-use-xargs (car use-find)))
+ (igrep-find prg pattern files))
+ (igrep prg pattern files))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyigrep-as-last-time (pattern arg-list)
+ "Call `igrep' like last time, with same args. Allow editing.
+The word to be grepped and the passed args can be changed.
+PATTERN is new search patter and ARG-LIST is original argument list."
+ (interactive
+ (let* ((fid "tinyigrep-as-last-time: ")
+ (args tinyigrep-:igrep-previous-args)
+ (list (mapcar 'prin1-to-string args))
+ (alist (ti::list-to-assoc-menu list))
+ (word (tinyigrep-fix-word (or (ti::buffer-read-space-word) "")))
+ (level-basic (eq tinyigrep-:user-level 'basic))
+ dir
+ sel
+ elt)
+ (unless fid ;; No-op. XEmacs byte compiler silencer
+ (setq fid nil))
+
+ (tinyigrep-debug fid "interactive in:" args word)
+
+ (if (null args)
+ (error
+ (concat "TinyIgrep: Sorry, no saved call arguments "
+ "in memory. Call search first.")))
+ (setq word
+ (read-from-minibuffer
+ "Igrep pattern: "
+ (ti::string-left word 40)
+ nil nil
+ 'tinyigrep-:history-igrep))
+
+ (if level-basic
+ (setq elt (car args))
+ (setq sel ;Previous args, allow changing
+ (completing-read
+ "select: "
+ alist
+ nil
+ nil
+ (car list)
+ 'list))
+ ;; Read possibly modified entry
+ (setq elt (read sel)))
+ (tinyigrep-debug fid "interactive out: " word elt)
+ (list word elt)))
+ ;; ................................................. interactive-end ...
+ (let* ((default-directory default-directory)
+ (igrep-program igrep-program) ;we may change these
+ use-find
+ files)
+ (tinyigrep-debug fid "in: " pattern arg-list)
+ (if (not (ti::listp arg-list))
+ (error "Tinyigrep: No previous database call arguments saved."))
+ (setq default-directory (nth 0 arg-list)
+ igrep-program (nth 1 arg-list)
+ ;; 2 is the pattern we don't care now
+ files (nth 3 arg-list)
+ use-find (nth 4 arg-list))
+ ;; (ti::d!! 'dir default-directory 'args arg-list)
+ (tinyigrep-igrep-call igrep-program pattern files use-find)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyigrep-determine-grep-program (file-list)
+ "Guess proper grep program for FILE-LIST."
+ (when file-list
+ (let ((prg "egrep"))
+ (dolist (file file-list)
+ (cond
+ ((string-match "z2$" file)
+ (setq prg "bzgrep")
+ (return))
+ ((string-match "gz$" file)
+ (setq prg "zgrep")
+ (return))))
+ prg)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyigrep-main-read-args ()
+ "Ask args to igrep.
+If you press RETURN when this function asks for database, then you
+should give directory and file list shell regexp what to match.
+
+References:
+ `tinyigrep-:database'"
+ (let* ((fid "tinyigrep-main-read-args:")
+ (table tinyigrep-:database)
+ (file (buffer-file-name))
+ (extension (and file (file-name-extension file)))
+ ;; Remove entries named "nil", do not offer them when
+ ;; completing the DB name
+ (car-list (delete
+ nil
+ (delete "nil" (mapcar 'car table))))
+ (table-completions (ti::list-to-assoc-menu car-list))
+ (word (and tinyigrep-:grep-word-at-point
+ (tinyigrep-fix-word
+ (or (ti::buffer-read-space-word) ""))))
+ (bfn (or (buffer-file-name) ""))
+ (ext (cond
+ ((string-match "\\.[Cch][ch]?$" bfn)
+ "*[ch]")
+ ((string-match "\\.java$" bfn)
+ "*.java")
+ ((string-match "\\.el$" bfn)
+ (concat
+ (char-to-string
+ (aref (file-name-nondirectory bfn) 0)) ;first char
+ "*el"))
+ (t
+ (or (and extension (concat "*." extension))
+ (and file (ti::list-find auto-mode-alist file))
+ "*"))))
+;;; (info (ti::string-match "^[^-]+" 0
+;;; (symbol-name
+;;; (or (ti::id-info 'symbol) major-mode))))
+
+ (program-completions
+ (ti::list-to-assoc-menu
+ '("bzgrep"
+ "zgrep"
+ "egrep"
+ "grep")))
+ completion-ignore-case ; Be case sensitive
+ use-find
+ prg
+ pattern
+ files
+ ans
+ db-elt
+ elt
+ ret)
+ (unless fid ;; XEmacs byte cimpiler silencer
+ (setq fid nil))
+ (tinyigrep-debug fid "in:" bfn ext word car-list)
+ (setq tinyigrep-:last-database "nil")
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... ... db ...
+ (or
+ (progn
+ (setq ans (completing-read
+ "TinyIgrep search database [RET=next choice]: "
+ table-completions
+ nil ;; PREDICATE
+ 'match
+ nil
+ 'tinyigrep-:history-database))
+ (tinyigrep-debug fid "selected DB answer" ans)
+ ;; Did we get a valid database ?
+ (unless (or (ti::nil-p ans)
+ (null (setq db-elt (assoc ans table))))
+ (setq tinyigrep-:last-database ans)
+
+ ;; In case the element is a lisp function, let that define the
+ ;; database. (Lazy-define)
+ (tinyigrep-db-lazy-define-funcall db-elt)
+ ;; Now the entry has been defined.
+ (setq elt (nth 1 (assoc ans tinyigrep-:database)))
+ (setq prg (nth 0 elt)
+ files (delq nil (nth 1 elt))
+ use-find (and (> (length elt) 2)
+ ;; If there is 3rd element, get it
+ (nth 2 elt)))
+ (if (null files)
+ (error "Tinyigrep: Odd? No files to search"))
+ (tinyigrep-debug fid "prog db ans selected:"
+ files prg "use find" use-find)
+ ;; progn ret val
+
+ t))
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... ... ask ...
+ (progn
+ ;; Read each directory and file to grep
+ (let ((dir (abbreviate-file-name default-directory))
+ grep-prg)
+ (if (> (length dir) 40)
+ (setq dir (concat "(...)" (ti::string-right dir 40))))
+ (setq files (ti::file-read-file-list
+ (format "%s Search files or patterns [TAB]: " dir)))
+ (tinyigrep-debug fid "prog asked files:" files)
+ (if (null files)
+ (error "Tinyigrep: No files to search"))
+ (setq grep-prg (tinyigrep-determine-grep-program files))
+ (setq prg
+ (completing-read
+ "Grep program: "
+ program-completions
+ nil
+ nil
+ grep-prg
+ 'tinyigrep-:history-programs)))))
+
+ ;; -----------------------------------------------------------------
+ ;; What did we get from user?
+ ;; -----------------------------------------------------------------
+ (setq ret t)
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... special / db . .
+ (cond
+ ((string= ans tinyigrep-:special-database)
+ (or (setq files
+ (let ((ans (read-from-minibuffer
+ "TinyIgrep file pattern(s): ")))
+ (mapcar '(lambda (x)
+ (format "%s%s"
+ (file-name-as-directory
+ default-directory)
+ x))
+ (split-string ans))))
+ (error "TinyIgrep: No files for `%s'" ans))
+ (setq pattern
+ (read-from-minibuffer
+ "grep expression: "
+ word nil nil
+ 'tinyigrep-:history-igrep))
+ (tinyigrep-debug fid "cond special db files:" pattern files))
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... ... rest ..
+ (t
+ (setq pattern (read-from-minibuffer
+ "grep expression: "
+ (and word
+ (ti::string-left word 40)) ;limit length
+ nil
+ nil
+ 'tinyigrep-:history-igrep))
+ (setq file (delq nil files))
+ (setq files (and files
+ (mapcar 'tinyigrep-expand-file-name-os files)))))
+ (tinyigrep-debug fid "out:" default-directory
+ "-" prg pattern files ret use-find)
+ (setq prg (tinyigrep-fix-program-path prg))
+ (tinyigrep-check-files files)
+ (list
+ (ti::remove-properties prg)
+ (ti::remove-properties pattern)
+ files
+ ret
+ use-find)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyigrep-main (&optional prg pattern files do-it use-find)
+ "Front-end to igrep.
+Try to guess what directories to search according to buffer content.
+
+If you give empty prompt (do not select any database completion),
+then you can specify all arguments.
+
+The grep is never case sensitive.
+
+Input:
+
+ PRG PATTERN FILES DO-IT USE-FIND"
+ (interactive (tinyigrep-main-read-args))
+
+ (tinyigrep-debug "tinyigrep-main in:" default-directory "-"
+ prg pattern files do-it use-find)
+
+ (let* ((fid "tinyigrep-main")
+ (default-directory default-directory))
+ (unless fid ;; XEmacs byte cimpiler silencer
+ (setq fid nil))
+ (when do-it
+ ;; CD to the first directory. If it exists.
+ ;; If it doesn't, call-process in igrep will tell it to user.
+ (let* ((dir (file-name-directory (car files))))
+ (when (and dir
+ (setq dir (ti::file-name-for-correct-system dir 'emacs))
+ (file-directory-p dir))
+ (setq default-directory dir)))
+ ;; Strip away the path from first file
+ ;; (setcar files (file-name-nondirectory (car files)))
+ (push (list
+ default-directory
+ prg
+ pattern
+ files
+ use-find)
+ tinyigrep-:igrep-previous-args)
+
+ ;; (save-some-buffers)
+ (tinyigrep-igrep-call prg pattern files use-find)
+ do-it)))
+
+;;}}}
+
+(tinyigrep-cygwin-fixes)
+
+(provide 'tinyigrep)
+(run-hooks 'tinyigrep-:load-hook)
+
+;;; tinyigrep.el ends here
--- /dev/null
+;;; tinyindent.el --- Like indented-text-mode, but minor-mode.
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 1994-2007 Jari Aalto
+;; Keywords: tools
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program, call M-x tinyindent-version.
+;; Look at the code with folding.el
+
+;; COPYRIGHT NOTICE
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Installation
+
+;; ....................................................... &t-install ...
+;; Put this file on your Emacs-Lisp load path, add following into
+;; ~/.emacs startup file:
+;;
+;; (require 'tinyindent)
+;;
+;; OR use this; your .emacs loads quicker
+;;
+;; (autoload 'tinyindent-mode "tinyindent" "" t)
+;; (autoload 'tinyindent-tt-mode "tinyindent" "" t)
+;;
+;; Suggested keybindings, you're going to use them a lot..
+;;
+;; (global-set-key [C-tab] 'tinyindent-tt-mode) ;; this is toggle
+;;
+;; ;;; the first one is for some PC machines (XCeed emulated X)
+;; (global-set-key [S-kp-tab] 'tinyindent-mode)
+;; (global-set-key [S-backtab] 'tinyindent-mode) ;; this is on/off mode
+;;
+;; For some PC:s in nonWindowed, this is same as S-tab
+;; --> check out with C-h l
+;;
+;;
+;; (define-key esc-map "OI" 'tinyindent-mode)
+;;
+;; If you have any questions, use this function
+;;
+;; M-x tinyindent-submit-bug-report
+
+;;}}}
+;;{{{ Documentation
+
+;; ..................................................... &t-commentary ...
+
+;;; Commentary:
+
+;; Preface, sep 1994
+;;
+;; The original auto-indent-mode from autoindent.el was very short
+;; and limited, so I thought I extend it a little...here is the
+;; result. Thank you Alan for giving me a push to extend your code
+;; into new directions. When I spoke with Alan and he gave me free
+;; hands, because he hadn't used the .el for quite a long time.
+;;
+;; I wasn't satisfied with the indent-relative function, so
+;; I coded a preprocessor for it. Now the cursor won't jump
+;; all over the line if the previous one was empty. Just
+;; try original M-x indent-relative when there is empty line above
+;; and you'll see what I mean.
+;;
+;; And where this module really shines: Has it ever been easier to line
+;; up variables according to '=' or in within lisp 'let*', or writing
+;; mail messages while this mode is turned on...
+;;
+;; Overview of features
+;;
+;; o General block editing or indentation MINOR mode. Replacement for
+;; `indented-text-mode'.
+;; o Takes over the TAB and BACKSPACE key.
+;; o Looks back to guess right indentation. and uses relative indent
+;; when not at BOL.
+;; o Special indentation is suggested if cursor is at BOL and
+;; user defined regexp is matched in line above. (like adding
+;; multiple c++ comments)
+;; o Extra tinyindent-tt-mode for writing descriptions within comments. This
+;; allows user to choose when to use HARD tab or SOFT tab = relative
+;; to the text above. TAB TAB inserts hard tab, TAB SPC inserts soft
+;; tab.
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+;;{{{ setup: require
+
+;;; ......................................................... &require ...
+
+(require 'tinylibm)
+(eval-when-compile (ti::package-use-dynamic-compilation))
+
+(ti::package-defgroup-tiny TinyIndent tinyindent-: tools
+ "like `indented-text-mode', but minor-mode.
+ Overview of features
+
+ o General block editing or indentation MINOR mode. Replacement for
+ `indented-text-mode'.
+ o Takes over the TAB and BACKSPACE key.
+ o Looks back to guess right indentation. and uses relative indent
+ when not at BOL.
+ o Special indentation is suggested if cursor is at BOL and
+ user defined regexp is matched in line above. (like adding
+ multiple c++ comments)
+ o Extra tinyindent-tt-mode for writing descriptions within comments. This
+ allows user to choose when to use HARD tab or SOFT tab = relative
+ to the text above. TAB TAB inserts hard tab, TAB SPC inserts soft
+ tab.")
+
+;;}}}
+;;{{{ setup: all
+
+;;; .......................................................... &v-bind ...
+
+(defvar tinyindent-:mode-map nil
+ "Minor keymap, only for TAB key. Copy of `current-local-map'.")
+
+(defvar tinyindent-:mode-prefix-map nil
+ "Prefix minor keymap, only for TAB key.")
+
+;;; ......................................................... &v-hooks ...
+
+(defcustom tinyindent-:mode-load-hook nil
+ "*Hook run when file is loaded."
+ :type 'hook
+ :group 'TinyIndent)
+
+(defcustom tinyindent-:mode-hook nil
+ "*Hook run when function `tinyindent-mode' turned on."
+ :type 'hook
+ :group 'TinyIndent)
+
+(defcustom tinyindent-:mode-define-keys-hook 'tinyindent-mode-map-define-keys
+ "*Hook to define keys for mode."
+ :type 'hook
+ :group 'TinyIndent)
+
+;;; .......................................................... &v-mode ...
+
+(defvar tinyindent-mode nil
+ "If set, indicates that auto-indent mode is active.
+This variable isautomatically set by invoking \\[tinyindent-mode].")
+(make-variable-buffer-local 'tinyindent-mode)
+
+(defvar tinyindent-tt-mode nil
+ "Hard tab submode.")
+(make-variable-buffer-local 'tinyindent-tt-mode)
+
+;;; ....................................................... &v-private ...
+
+(defvar tinyindent-:RET nil
+ "Global return value used, when multiple values are neede.
+Shouldn't interest regular user.")
+(make-variable-buffer-local 'tinyindent-:RET)
+
+(defvar tinyindent-:cp 0 "Internal. Current point.")
+(make-variable-buffer-local 'tinyindent-:cp)
+
+(defvar tinyindent-:cl 0 "Internal. Current line.")
+(make-variable-buffer-local 'tinyindent-:cl)
+
+;;; ........................................................ &v-public ...
+;;; User configurable
+
+;; - The BOL is special, because when you write code, the crucial
+;; point is line start: you decide indentation or cursor positioning with
+;; that first keystroke.
+
+(defcustom tinyindent-:bol t
+ "*Flag that determines if beg. of line should be treated differently."
+ :type 'boolean
+ :group 'TinyIndent)
+
+(defcustom tinyindent-:special-regexp
+ (concat
+ "^[ \t]*\\(//\\|\#\\|!\\|REM\\)[ \t]*"
+ ;; don't put ;;+, since someone may draw ;;;;;;;;;;...
+ "\\|^[ \t]*;;:?;?[ \t]*")
+ "*Special indent at the beginning of line.
+Sometimes single indent isn't enough. For example it would be convenient
+to write long C++ comments by hitting the TAB on the next line. Original
+RE handles considers these as special cases.
+! .Xdefauls or X-related files
+# Perl, awk, shell
+// C++
+;;; Lisp
+REM Oracle Sqlplus, SQL files in general"
+ :type 'string
+ :group 'TinyIndent)
+
+(defcustom tinyindent-:mode-str-orig " Tii"
+ "*String to be displayed in mode line."
+ :type 'string
+ :group 'TinyIndent)
+
+(defcustom tinyindent-:tt-mode-str-orig " TiiT"
+ "*String to be displayed in mode line."
+ :type 'string
+ :group 'TinyIndent)
+
+;; This is not a user variable
+
+(defvar tinyindent-:mode-name tinyindent-:mode-str-orig
+ "Current minor mode status displayed. Changed dynamically.")
+(make-variable-buffer-local ' tinyindent-:mode-name)
+
+;;; ......................................................... &version ...
+
+;;;###autoload (autoload 'tinyindent-version "tinyindent" "Display commentary." t)
+
+(eval-and-compile
+ (ti::macrof-version-bug-report
+ "tinyindent.el"
+ "tinyindent"
+ tinyindent-:version-id
+ "$Id: tinyindent.el,v 2.42 2007/05/01 17:20:44 jaalto Exp $"
+ '(tinyindent-:version-id
+ tinyindent-:mode-map
+ tinyindent-:mode-prefix-map
+ tinyindent-:mode-load-hook
+ tinyindent-:mode-hook
+ tinyindent-:mode-define-keys-hook
+ tinyindent-:special-regexp
+ tinyindent-:mode-str-orig
+ tinyindent-:mode-str)))
+
+;;}}}
+
+;;; ########################################################### &Funcs ###
+
+;;{{{ code: misc
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyindent-mode-map-define-keys ()
+ "Defines keybindings to `tinyindent-:mode-map'."
+
+ (define-key tinyindent-:mode-map "\t" 'tinyindent-tab-key)
+
+ ;; e.g. lisp-mode uses backward-delete-char-untabify which is
+ ;; uncomfortable in editing.
+ ;;
+ ;; The 2nd bind works in X env only
+
+ (define-key tinyindent-:mode-map "\177" 'delete-backward-char))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;### (autoload 'tinyindent-install-mode "tinyindent" t t)
+(ti::macrof-minor-mode-install
+ tinyindent-install-mode
+ tinyindent-mode
+ tinyindent-:mode-map
+ tinyindent-:mode-prefix-map
+ tinyindent-:mode-name
+ tinyindent-:mode-define-keys-hook)
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyindent-confirm (msg)
+ "Confirms action with MSG.
+RET/SPC = ok. The real character pressed is available
+thru global variable `tinyindent-:RET'."
+ (setq tinyindent-:RET (ti::read-char-safe msg))
+ (if (and (characterp tinyindent-:RET)
+ (or (char= tinyindent-:RET ?\C-m)
+ (char= tinyindent-:RET ?\ ))) ; RET/SPC
+ t
+ nil))
+
+;;}}}
+;;{{{ engine
+
+;;; .......................................................... &engine ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyindent-special-handle ()
+ "Handle some special lines -- like `gin-mode', but simpler.
+Supposes that point is at the beginning of investigated line.
+Moves point 1 line forward af ter done.
+
+Returns:
+ filling pattern to use at front of line or nil"
+ ;; Look for some special lines, like C++
+ (let* ((s-re tinyindent-:special-regexp)
+ fill
+ line)
+ (when (looking-at s-re)
+ ;; back to original line
+ ;;
+ (forward-line 1) ;otherwise visible to user when asking
+ (when (tinyindent-confirm "indent special? ")
+ (setq line
+ (save-excursion
+ (goto-char (- (point) 1))
+ (ti::read-current-line)))
+ (string-match s-re line)
+ (setq fill
+ (substring line (match-beginning 0) (match-end 0)))))
+ fill))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyindent-tab-key ()
+ "Handle tab key.
+Check if TinyMail is present and call Header completions in header area,
+in BODY use relative indent."
+ (interactive)
+ (or (and (featurep 'tinymail)
+ (ti::mail-mail-p)
+ (< (point) (ti::mail-hmax))
+ (ti::funcall 'timi-complete-key))
+ (tinyindent-relative)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyindent-relative ()
+ "Almost like `indent-relative', but handles some special cases.
+- if the above line if NOT empty, then we indent relatively automatically
+- if above line IS empty, then ask if normal TAB/relative indent.
+
+References:
+ `tinyindent-:special-regexp'"
+ (interactive)
+ (let* ((bolp-flag tinyindent-:bol)
+ (p (point))
+ (cur-col (current-column))
+ (imode t)
+ (SPC (char-to-int ?\ ))
+
+ prev-empty
+ prev-col
+ bp ep ;BEG END point
+ fill
+ line
+ ch
+ skip)
+
+ (catch 'cancel
+ (save-excursion
+ (save-excursion
+ (setq bp (line-beginning-position))
+ (setq ep (line-end-position))
+ (forward-line -1)
+ (setq prev-empty (looking-at "[ \t]*$"))
+ (end-of-line)
+ (setq prev-col (current-column)))
+
+ ;; make sure these are NOT nil
+
+ (if (null tinyindent-:cp) (setq tinyindent-:cp 0))
+ (if (null tinyindent-:cl) (setq tinyindent-:cl 0))
+
+ ;; Count lines has A BUG! , If I'm at the beg of line
+ ;; or 1 char forward it gives different values!
+
+ (setq line (count-lines 1 p))
+
+ (if (or (eq p bp) (eobp))
+ (setq line (1+ line))) ;BEG of line error
+
+ ;; - the user has answered to question, we are on the same line
+ ;; - if he is at the beginning, then ALWAYS ask (forced ask)
+
+ (if prev-empty
+ (if (and ;already asked ?
+ (>= tinyindent-:cp bp)
+ (<= tinyindent-:cp ep))
+ (setq skip 1))
+ (if (null (bolp))
+ (setq skip 2)) ;BOL ?
+ (if (< prev-col cur-col)
+ ;; previous line is shorter
+ (setq skip 3)))
+
+;;; (ti::d! skip "POINT" p " " tinyindent-:cl line " bp ep " bp ep tinyindent-:cp)
+
+ (if skip
+ (throw 'cancel t)) ;we were on this line already
+
+ (setq tinyindent-:cl line) ;update line number
+ (setq tinyindent-:cp p) ;current point position
+
+ ;;^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ ;; The real engine
+
+ (setq tinyindent-:RET nil)
+ (cond
+ ((bobp)
+ (tab-to-tab-stop))
+ ((bolp)
+ (forward-line -1) ;Check previous line
+ (if (setq fill (tinyindent-special-handle))
+ (progn
+ (throw 'cancel t))
+ (forward-line 1)
+ (when tinyindent-tt-mode
+ (if (null bolp-flag)
+ (setq imode t)
+ (setq imode (tinyindent-confirm "indent relative?")))))
+ ;; this was pressed
+ (setq ch tinyindent-:RET)))))
+
+ ;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ catch end ^^^
+ (if fill
+ (insert fill) ;see save-excursion, fill is set
+ (cond
+ (tinyindent-tt-mode
+ (setq ch (or ch (ti::read-char-safe)))
+ (cond
+ ((not (characterp ch)))
+ ((eq ch SPC)
+ (indent-relative))
+ ((char= ch ?\t)
+ (tab-to-tab-stop)
+ ;; tab stop already does this
+ (setq ch nil))
+ (t
+ (indent-relative))))
+ (t
+ (cond
+ (imode
+ (indent-relative) ;other char follows
+ (if (eq ch SPC) ;kill space, because it means YES
+ (setq ch nil)))
+ (t
+ (tab-to-tab-stop) ;use hard tab
+ ;; kill the TAB char
+ (setq ch nil)))))
+
+ ;; (ti::d! imode ch (ti::print-p ch)))
+ ;; the TAB char automatically moves to tab-to-tab-stop
+ ;; if it's inserted
+
+ (if (and (characterp ch)
+ (ti::print-p ch)
+ (not (eq ch SPC)))
+ ;; this is already handled
+ ;; add the character, don't loose it
+ (insert ch)))))
+
+;;}}}
+;;{{{ modes
+
+;;; ........................................................... &modes ...
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyindent-tt-mode (&optional arg)
+ "Toggle variable `tinyindent-tt-mode' with ARG. See description in `tinyindent-mode'."
+ (interactive "P")
+ (ti::bool-toggle tinyindent-tt-mode arg) ;toggle mode variable
+ (cond
+ (tinyindent-tt-mode
+
+ (unless tinyindent-mode ;turn on the major mode tinyindent-mode
+ (tinyindent-mode) ;turn it on
+ (setq tinyindent-tt-mode t))
+
+ (setq tinyindent-:mode-name tinyindent-:tt-mode-str-orig))
+ (t
+ (setq tinyindent-:mode-name tinyindent-:mode-str-orig)))
+ (ti::compat-modeline-update))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyindent-mode (&optional arg)
+ "Toggle relative indentation mode with ARG.
+
+Indentation is determined according to previous lines. Special
+indent happens only at the beginning of line, where user is asked if
+he wants to have relative or \"hard\" indentation.
+
+Abount function `tinyindent-tt-mode'
+
+This isn't really mode. It just turns one flag on in `tinyindent-mode', so that
+it behaves a little differently. If the `tinyindent-mode' is not running, it
+wiil be turned on. turning off `tinyindent-tt-mode' _does_not_ end `tinyindent-mode'.
+
+Sometimes you want to control between 'hard' tab and 'soft' tab, ie.
+relative indent. This mode causes second character to be read after
+tab key is hit. The following happens:
+
+TAB TAB inserts hard tab
+TAB SPC indent relative without inserting space char.
+TAB x indents relative and inserting character x
+
+\\{tinyindent-:mode-map}"
+ (interactive "P")
+
+ (if (null (assq 'tinyindent-mode minor-mode-alist))
+ (tinyindent-install-mode))
+
+ (ti::bool-toggle tinyindent-mode arg) ;toggle mode variable
+
+ (cond
+ (tinyindent-mode
+ (unless tinyindent-tt-mode
+ (setq tinyindent-:mode-name
+ tinyindent-:mode-str-orig))
+ (run-hooks 'tinyindent-:mode-hook))
+ (t
+ (setq tinyindent-tt-mode nil)))
+ (ti::compat-modeline-update))
+
+;;}}}
+
+(add-hook 'tinyindent-:mode-define-keys-hook 'tinyindent-mode-map-define-keys)
+(provide 'tinyindent)
+(run-hooks 'tinyindent-:mode-load-hook)
+
+;;; tinyindent.el ends here
--- /dev/null
+;;; tinyirc.el --- IRC related utilities for Emacs
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 2003-2007 Jari Aalto
+;; Keywords: tools
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+
+;; COPYRIGHT NOTICE
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;;; Install:
+
+;; ....................................................... &t-install ...
+;;
+;; Requirements:
+;;
+;; o Only paste services that use de facto
+;; <http://sourceforge.net/projects/pastebot> servers
+;; are supported.
+;; o Perl must have been installed
+;; o External program pbotutil.pl must have been installed
+;; See `tinyirc-:pastebot-program-url'.
+;;
+;; Put this file on your Emacs-Lisp load path, add following into
+;; ~/.emacs startup file.
+;;
+;; (require 'tinyirc)
+;; (global-set-key "\C-cps" 'tinyirc-pastebot-send-region)
+;; (global-set-key "\C-cpr" 'tinyirc-pastebot-receive-url)
+;;
+;; ** NOTE: Read "Pastebot Preliminary settings" before using
+;; ** NOTE: Win32 NTEmacs users, read "Pastebot Win32 notes"
+;;
+;; Or prefer autoload: your emacs loads this package only when you need it.
+;;
+;; (autoload 'tinyirc-pastebot-send-region "tinyirc" "" t)
+;; (autoload 'tinyirc-pastebot-receive-url "tinyirc" "" t)
+;;
+;; (global-set-key "\C-cps" 'tinyirc-pastebot-send-region)
+;; (global-set-key "\C-cpr" 'tinyirc-pastebot-receive-url)
+;;
+;; Then you can try callling the initial setup. Thi needs to be done
+;; only once to verify your setup.
+;;
+;; M-x load-library RET tinyirc.el RET
+;; M-x tinyirc-pastebot-install-perl-util-pastebot RET
+;; M-x tinyirc-pastebot-install-example-servers RET
+;;
+;; If you have any questions, have suggestions or bug reports send mail
+;; to maintainer.
+
+;;}}}
+;;{{{ Documentation
+
+;; ..................................................... &t-commentary ...
+
+;;; Commentary:
+
+;; Preface, Aug 2003
+;;
+;; IRC is very poplar method of getting together with all sorts of
+;; activities. For programmers, IRC is like 'all united' where
+;; you get invaluable help from people that happen to be online. No need
+;; to scratch your head alone; let's scratch together in a friendly
+;; programming channel.
+;;
+;; Most of the channels do not permit flooding - that is -
+;; copy/pasting many lines (of code) at once. If person does that, the
+;; (ro)bot watching the activities of the channel will kick person out
+;; of the channel faster than he can blink his eye. So don't try
+;; pasting long material to the channel. Usually the channel's topic,
+;; which is displayed on entering the channel, includes the etiquette
+;; how to present your problem to the audiance. in previous times it
+;; has been a custom to use separate #flood channel (which you must
+;; join):
+;;
+;; /join #flood
+;;
+;; and then announce to people "Hey, I've posted the code to #flood,
+;; go and check". But someone may not be watching the channel's
+;; messages at the time of announcement and when he finally joins the
+;; #flood, he's too late. He cannot see the code. The catch is that
+;; every interested person has be be in the channel #flood *first*
+;; before anyone pastes a message there. Participants cannot see old
+;; messages but only the lines after his joined to the #flood channel.
+;;
+;; An then someone came with a nifty idea: use PasteBot services for
+;; permanet storage (with line numbers). It would be nice if the
+;; the PasteBot messages could be managed directly from Emacs with
+;; couple of key bindings. So, this package was born. The basic idea
+;; to exchange information (like examples, bug reports) is:
+;;
+;; You => send message => +------------------------+
+;; <= message URL | PasteBot server |
+;; | stores the message and |
+;; | assigns a unique ID |
+;; | to it. It returns the |
+;; | storage URL back |
+;; +------------------------+
+;;
+;; Now, you publish the URL (to anyone interested), e.g in a IRC
+;; channel. Interested people can go and check it, at any time:
+;;
+;; Rush of Crowd => See it! +------------------------+
+;; | PasteBot displays the |
+;; | stored message |
+;; | |
+;; | It won't fade away, |
+;; | like text in IRC |
+;; | |
+;; | SEMI-PERMANENT STORAGE |
+;; +------------------------+
+;;
+;; _NOTE;_ Although the PasteBot services are mostly used in
+;; IRC channels to exchange information, they can also be used
+;; to exchange e.g. debug information with any parties involved.
+;;
+;; Description
+;;
+;; o Send text region to PasteBot servers.
+;; o Receive messages from PasteBot servers using URL or
+;; message ID.
+;;
+;; Sending Pastebot messages
+;;
+;; There is simple interface: draw region and call `M-x'
+;; `tinyirc-pastebot-send-region', which you should assign to a key
+;; for easier access. But you can't use that quite yet, because you
+;; have to configure your environment first. Read "preliminary
+;; settings" topic and test your interface before calling that function.
+;;
+;; ;; If this is occupied, select other free key
+;; (global-set-key "\C-cps" 'tinyirc-pastebot-send-region)
+;;
+;; The response from the send command is recorded into separate buffer
+;; *IRC* *pastebot* *sent* and the lines in the buffer look like:
+;;
+;; 2003-08-07 16:06 test foo <URL> <MESSAGE>
+;; 2003-08-07 17:21 test foo <URL> <MESSAGE>
+;; | | | |
+;; | | | Summary line (Subject/Errors)
+;; | | Where message can be read
+;; | Your id used for sending the message
+;; The service (channel) where message was sent
+;;
+;; For adavanced users: few variables are available in case you make
+;; changes to the perl script. See `tinyirc-:pastebot-program' and
+;; `tinyirc-:pastebot-config-directory'.
+;;
+;; Sending to channels that are not supported
+;;
+;; The pastebot servers do not support all IRC channels per se.
+;; E.g. they mey limit posts to #perl, #sendmail etc. In case you
+;; participate in other channels, you can still use the pastebot
+;; service. Just use some free channel like "flood" or "test" for
+;; all your posts. Announce the returned URL to the channel
+;; your're being joined in. Use IRC command `/me' to submit your
+;; IRC message:
+;;
+;; /me [pastebot] <MESSAGE> htpp//....
+;;
+;; Receiving pastebot messages
+;;
+;; Receiving messages announced in the IRC channel is even easier
+;; than sending (less typing into prompts). Call `M-x'
+;; `tinyirc-pastebot-receive-url' and copy the URL announced in the
+;; channel. A possible key binding for this could be:
+;;
+;; ;; If this is occupied, select a any free key
+;; (global-set-key "\C-cpr" 'tinyirc-pastebot-receive-url)
+;;
+;; The receive buffer output looks something like this when used
+;; couple of times. Notice the added line numbers (001:) in the
+;; first message, which can be toggled on or off with `mouse-3'.
+;;
+;; 2003-08-07 18:04 http://dragon.cbi.tamucc.edu:8080/72
+;; 001: test message
+;; 002: another line
+;; 003: more lines
+;; 004: and more
+;; 2003-08-07 18:14 http://dragon.cbi.tamucc.edu:8080/72
+;; warning: error fetching http://dragon.cbi.tamucc.edu:8080/72: 500 Can't connect to dragon.cbi.tamucc.edu:8080 (connect: timeout)
+;; 2003-08-07 18:32 http://dragon.cbi.tamucc.edu:8080/74
+;; #/!usr/bin/perl
+;; use strict;
+;; use English;
+;; ...
+;; 2003-08-08 15:29 http://dragon.cbi.tamucc.edu:8080/74
+;; #/!usr/bin/perl
+;; use strict;
+;; use English;
+;; ...
+;;
+;; Pastebot mode (PBot)
+;;
+;; The buffers *pastebot* *received* and *pastebot*
+;; *sent* are put into `tinyirc-pastebot-mode', whose mode name is
+;; derived from variable `tinyirc-:mode-name'. Within these buffer it
+;; is possible to receive or view the received messages easily.
+;; Following default key bindings are set, when
+;; `tinyirc-:pastebot-mode-define-keys-hook' is run if
+;; `tinyirc-pastebot-mode-map' is nil when mode is turned on for the
+;; first time:
+;;
+;; mouse-3 tinyirc-pastebot-mode-command-receive
+;; Control mouse-3 tinyirc-pastebot-mode-command-line-number-toggle
+;; C-p tinyirc-pastebot-message-timestamp-backward
+;; C-n tinyirc-pastebot-message-timestamp-forward
+;; C-c C-r tinyirc-pastebot-mode-command-receive
+;; C-c C-w tinyirc-pastebot-mode-command-write-file
+;; C-c C-l tinyirc-pastebot-mode-command-line-numbers-toggle
+;;
+;; The line number toggle function is handy when checking at references
+;; "see line NN", or "Try what variable that code prints at line NN".
+;; The mode calls hook `tinyirc-:pastebot-mode-hook' where user
+;; can add more customizations.
+;;
+;; Pastebot preliminary settings
+;;
+;; You can use the PasteBot services directly from their web
+;; pages. There should be a form to where to submit a message.
+;; Couple of services at the time of writing existed:
+;;
+;; http://dragon.cbi.tamucc.edu:8080
+;; http://sial.org/pbot/
+;; http://pastebin.ca/
+;; http://paste.lisp.org/
+;; http://nopaste.snit.ch/
+;; http://channels.debian.net/paste/
+;;
+;; At the page, there is a button [channel] which defines what
+;; channels support pastebot announcements. In order to use the
+;; service from Emacs, you need a command line program that
+;; handles the send request. The Perl client `pbotutil' can be
+;; found from address `tinyirc-:pastebot-program-url'. A
+;; configuration file must include the details about available
+;; pastebot servers and their supported channels. _Note:_ There
+;; is command `M-x' `tinyirc-pastebot-install-example-servers'
+;; which writes the example file.
+;;
+;; Use command line prompt first to test that the interface works
+;; by sending message simple file to *none* service, which
+;; can be used for testing purposes:
+;;
+;; $ pbotutil.pl -s none -u $USER -m test put test.txt
+;; |
+;; Select a service from configuration file
+;;
+;; $ pbotutil.pl get <URL>
+;;
+;; If everything worked ok, you should see program print an URL where
+;; the message was stored. Visit the page to verify that message is
+;; available. When these preliminary tests indicate that the interface
+;; works, you're ready to use the Emacs interface.
+;;
+;; Making your PasteBot send log available
+;;
+;; If you can run a web server and want to publish your posts, you
+;; could configure it to show ´tinyirc-:pastebot-buffer-file-name' all
+;; the time (it's nil by default). For Apache the needed line in
+;; /etc/apache/httpd.conf would look something line:
+;;
+;; Alias /pastebot-log /home/you/tmp/pastebot
+;;
+;; and Emacs setting:
+;;
+;; ;; Browsers can view ".txt" files directly.
+;; (setq tinyirc-:pastebot-buffer-file-name-sent
+;; "~/tmp/pastebot/pastebot.txt")
+;;
+;; After these (and `apachectl' `restart') all your posts could be
+;; recalled by looking at the list from address:
+;;
+;; http://www.example.com/pastebot-log
+;;
+;; If you want more challenges, it is possible to start up your own
+;; PasteBot service. For more information see "Related software" later.
+;;
+;; Pastebot Win32 notes
+;;
+;; NTEmacs and Cygwin Emacs - two different choices
+;;
+;; Emacs and XEmacs have two release flavors under Windows platform.
+;; For GNU Emacs, you can download and run "Native Win32 NTEmacs" or
+;; use "Cygwin Win32 Emacs" which is included in Cygwin available
+;; at <http://www.cygwin.com>. Usually these two are simply referred
+;; to as `NTEmacs' and `Cygwin' `Emacs'. Most of the Win32 users use
+;; the NTEmacs version. People from Unix/Linux background usually
+;; prefer the Cygwin Emacs, becaue it's more like the "real thing" and
+;; integrates better to features that are not available to NTEmacs.
+;; Usually things work better under Cygwin Emacs than NTEmacs,
+;; because real Emacs supposes many of the Unix utilities to be
+;; around. In Cygwin there are `diff' program, `find' program etc.
+;;
+;; NTEmacs
+;;
+;; There is command `M-x'
+;; `tinyirc-pastebot-install-example-servers' which you can try. If
+;; it fails, follow these steps described below.
+;;
+;; If you use NTEmcs, read this section carefully. The client
+;; *pbotutil.pl* is a _perl_ program, so Perl must be installed.
+;; See Native Win32 Perl at <http://www.activestate.com> or
+;; better, install Cygwin, which includes all. Client
+;; *pbotutil.pl* is an application which expects to see
+;; configuration directory named `$HOME/.pbotutil'. Yes, the directory
+;; indeed starts with a dot.
+;;
+;; Windows does not define environment variable named `HOME', so
+;; it must be created to system registry. In W2k you create the
+;; variable from Start => Setings => Control Panel => System icon
+;; Advanced [tab] + Environment variable [button] => System variable.
+;; The `HOME' is location that is considered to be the work directory.
+;; If you have never heard of `$HOME' (the "variable"), refer to
+;; NTEmacs FAQ at
+;; <http://www.gnu.org/software/emacs/windows/ntemacs.html>. At
+;; this page, see link pointing to *Installing* *Emacs*. There
+;; you can find more information on setting the `$HOME' variable.
+;;
+;; Next, create the dot-directory `$HOME/.pbotutil' which
+;; _cannot_ be made using the standard Windows file manager (explorer).
+;; It is not possible to request from menu *File* => *New* =>
+;; *Folder* with a name that starts with a dot. That's a Windows
+;; bug. But it is possible to create dot-directories directly from Emacs.
+;; Start *dired* and point it to your $HOME:
+;;
+;; C-x d $HOME or this is the same: C-x d ~
+;;
+;; From dired buffer, press command `+' to create directory *.pbotutil*
+;; and it should soon appear in the *dired* buffer. You're now ready
+;; to use perl script *pbotutil.pl* (See above "Preliminary setup")
+;; which searches its configuration file from that location.
+;;
+;; Cygwin symlink notes (= Windows shotrcuts)
+;;
+;; _NOTE:_ Never edit any file which is a Windows shortcut or a Cygwin
+;; symbolic link under NTEmacs. NTEmcs (as of writing; 21.3) cannot by
+;; default follow any windows shortcuts or Cygwin's symbolic links.
+;; Just use Cygwin Emacs for Cygwin's symbolic link files.
+;;
+;; There exist packages for NTEmacs to help it to understand links,
+;; but those packages are recommended only for advanced Emacs users.
+;; If you're interested, contact these people for additional packages:
+;;
+;; w32-symlinks by F.J.Wright@qmul.ac.uk
+;; follow-lnk.el by christoph.conrad@gmx.de
+;;
+;; Related software
+;;
+;; o Perl client: http://bboett.free.fr/webPaste.html
+;; o The server software is available at
+;; <http://freshmeat.net/projects/pastebot/>
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+;;{{{ setup: require
+
+;;; ......................................................... &require ...
+
+(require 'cl)
+
+(eval-when-compile
+ (setq byte-compile-dynamic t))
+
+(eval-and-compile
+ ;; predeclare - Byte compiler silencer.
+ (defvar font-lock-keywords))
+
+;;}}}
+;;{{{ setup: hooks
+
+;;; ..................................................... &v-variables ...
+
+(defcustom tinyirc-:load-hook nil
+ "*Hook that is run when package is loaded."
+ :type 'hook
+ :group 'TinyIrc)
+
+(defcustom tinyirc-:pastebot-hook-sent
+ '(tinyirc-pastebot-font-lock-mode-sent)
+ "*Hook that is run at the end of `tinyirc-pastebot-message-record'"
+ :type 'hook
+ :group 'TinyIrc)
+
+(defcustom tinyirc-:pastebot-hook-received
+ '(tinyirc-pastebot-font-lock-mode-received)
+ "*Hook that is run at the end of `tinyirc-pastebot-receive-message'."
+ :type 'hook
+ :group 'TinyIrc)
+
+(defcustom tinyirc-:pastebot-mode-hook nil
+ "*Hook run after the `tinydesk-receive-mode' is turned on.
+This happend when message log is written either to buffer
+`tinyirc-:pastebot-buffer-name-received' or
+`tinyirc-:pastebot-buffer-name-sent'."
+ :type 'hook
+ :group 'TinyIrc)
+
+(defcustom tinyirc-:pastebot-mode-define-keys-hook
+ '(tinyirc-pastebot-default-mode-bindings)
+ "*Hook run only if `tinyirc-pastebot-mode-map' is nil. This is checked at
+package load and when `tinyirc-pastebot-mode' is called."
+ :type 'hook
+ :group 'TinyIrc)
+
+;;}}}
+;;{{{ setup: User variables
+
+(defcustom tinyirc-:pastebot-program nil
+ "*Perl program to send messages to PasteBot servers."
+ :type 'filename
+ :group 'TinyIrc)
+
+;; Try to configure the variable
+(unless tinyirc-:pastebot-program
+ (setq tinyirc-:pastebot-program
+ (let* ((name "pbotutil.pl")
+ (bin (executable-find name)))
+ (if bin
+ bin
+ (message
+ (concat
+ "TinyIrc: [ERROR] Please configure "
+ "`tinyirc-:pastebot-program '. Not in PATH `%s'")
+ name)
+ nil))))
+
+(defcustom tinyirc-:pastebot-send-file
+ (let ((file "pastebot-submit.txt")
+ dir)
+ (dolist (d '("~/tmp/"
+ "~/"
+ "c:/"))
+ (when (file-directory-p d)
+ (setq dir d)
+ (return)))
+ (unless dir
+ (error (concat "TinyIrc: Can't find suitable directory. "
+ "Set `tinyirc-:pastebot-send-file'.")))
+ (format "%s%s" dir file))
+ "*Perl program to send messages to PasteBot servers."
+ :type 'filename
+ :group 'TinyIrc)
+
+(defcustom tinyirc-:pastebot-config-directory
+ (let* ((dir "~/.pbotutil"))
+ (unless (file-directory-p dir)
+ (message
+ (concat
+ "TinyIrc: [ERROR] Please configure "
+ "`tinyirc-:pastebot-config-directory'. No directory `%s'")
+ dir))
+ dir)
+ "*Configuration directory of `tinyirc-:pastebot-program'. If you change
+this variable, you need to change the Perl program itseld too."
+ :type 'directory
+ :group 'TinyIrc)
+
+;; "~/tmp/pastebot.txt"
+(defcustom tinyirc-:pastebot-buffer-file-name-sent nil
+ "Name of file buffer where the results are saved after each send. If nil,
+no file is saved. Refer to manual \\[finder-commentary] `tinyirc' for more
+information"
+ :type 'filename
+ :group 'TinyIrc)
+
+(defcustom tinyirc-:pastebot-font-lock-keywords-sent
+ (list
+ ;; Service name used to send the message
+ (list
+ "^.*:[0-9][0-9][ \t]+\\([^ \t]+\\)"
+ 1 'font-lock-reference-face)
+ ;; The Message
+ (list
+ "http:/[^ \t]+[ \t]+\\(.+\\)"
+ 1 'font-lock-type-face))
+ "*Font lock keywords."
+ :type 'sexp
+ :group 'TinyIrc)
+
+(defcustom tinyirc-:pastebot-font-lock-keywords-received
+ (list
+ ;; The id line (receive time)
+ (list
+ "^[0-9][0-9].*:[0-9][0-9].*http://.*"
+ 0 'font-lock-reference-face)
+ ;; Errors
+ (list
+ "Can't connect"
+ 0 'font-lock-type-face))
+ "*Font lock keywords."
+ :type 'sexp
+ :group 'TinyIrc)
+
+(defcustom tinyirc-:mode-name "PBot"
+ "*Name of major mode `tinyirc-pastebot-mode'."
+ :type 'string
+ :group 'TinyIrc)
+
+;;}}}
+;;{{{ setup: private variables
+
+;;; ....................................................... &v-private ...
+;;; Private variables
+
+(defvar tinyirc-:pastebot-program-url
+ "http://sial.org/code/perl/scripts/pbotutil.pl"
+ "Download location of the pastebot perl interface.
+See also manual <http://sial.org/code/perl/scripts/pbotutil.pl.html>.")
+
+(defvar tinyirc-:pastebot-message-format-function
+ 'tinyirc-pastebot-message-format
+ "Function to format the message arguments: SERVICE USER MSG and URL.")
+
+(defvar tinyirc-:pastebot-buffer-name-sent "*pastebot sent*"
+ "Log buffer of sent pastebot messages. If nil, no log is recorded.")
+
+(defvar tinyirc-:pastebot-buffer-name-received "*pastebot received*"
+ "log buffer of received pastebot messages.")
+
+(defvar tinyirc-:pastebot-history-user nil
+ "History of used pastebot user names.")
+
+(defvar tinyirc-:pastebot-history-services nil
+ "History of used pastebot services.")
+
+(defvar tinyirc-:pastebot-service-list nil
+ "List of available services according to `servers' file.
+If this variable is not set, it is populated from
+`tinyirc-:pastebot-config-directory' and file `servers'.
+
+The content of the `servers' file is read only once, so if it
+modified, function `tinyirc-pastebot-service-list-set'.")
+
+(defvar tinyirc-:pastebot-service-list-time-stamp nil
+ "Time of reading from `tinyirc-:pastebot-config-directory'.")
+
+(defvar tinyirc-pastebot-mode-map nil
+ "Local keymap for STATE files loaded by edit.")
+
+(defvar tinyirc-:error-buffer "*TinyIrc error*"
+ "Error buffer.")
+
+(defvar tinyirc-:http-buffer "*TinyIrc http*"
+ "Error buffer.")
+
+(defvar tinyirc-:pastebot-config-default-content
+ (format "\
+# %s configuration file for SERVERS
+# for program %s
+
+# irc.freenode.net
+name debian
+url http://channels.debian.net/paste/
+channel #debian
+
+# irc.freenode.net
+name flood
+url http://channels.debian.net/paste/
+channel #flood
+
+# irc.freenode.net
+name perl
+url http://dragon.cbi.tamucc.edu:8080/
+channel #perl
+
+# irc.freenode.net (backup)
+name perl2
+url http://sial.org/pbot
+channel #perl
+
+# Perl channel backup
+name perl2
+url http://nopaste.snit.ch:8000/
+channel #perl-help
+
+# Use 'test' or 'none' service for channels that do not have
+# particular support for PasteBot. Simply announce
+# the url in the #channel with command:
+#
+# /me [pastebot] <URL>
+
+name none
+url http://sial.org/pbot
+channel #none
+
+name nopaste
+url http://rafb.net/paste/
+channel #none
+
+name test
+url http://dragon.cbi.tamucc.edu:8080/
+channel ''
+
+name test2
+url http://sial.org:8888/
+channel ''
+
+name pastebin
+url http://pastebin.ca/
+channel ''
+
+# End of file
+"
+ tinyirc-:pastebot-config-directory
+ tinyirc-:pastebot-program)
+ "Default content for `tinyirc-pastebot-install-example-servers'.
+See also `tinyirc-:pastebot-config-directory'.")
+
+;;}}}
+
+;;; ########################################################### &Funcs ###
+
+;;{{{ General functions
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinyirc-time-string ()
+ "Return ISO 8601 time YYYY-MM-DD HH:MM."
+ (format-time-string "%Y-%m-%d %H:%M"))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyirc-word-at-point ()
+ "Return word separated by whitespace."
+ (save-excursion
+ (unless (string-match
+ "[ \t\r\n]" (char-to-string (following-char)))
+ (skip-chars-backward "^ \t\r\n")
+ (let ((point (point)))
+ (skip-chars-forward "^ \t\r\n")
+ (buffer-substring point (point))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyirc-append-to-buffer (string)
+ "Add STRING to the end of current buffer."
+ ;; Make room for new message if point is ar wrong place.
+ (goto-char (point-max))
+ (beginning-of-line)
+ (unless (or (eobp)
+ (looking-at "^[\r\n]"))
+ (open-line 1)
+ (forward-line 1))
+ (insert string))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinyirc-line-number-p ()
+ "Return non-nil if line contains a line number.
+Match 1 contains line numer, 2 contains rest of the line."
+ (save-excursion
+ (beginning-of-line)
+ (looking-at "^\\([0-9][0-9][0-9]: \\)\\(.*\\)")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyird-line-number-add-region (beg end)
+ "Add line numbers to region BEG END. Point is moved."
+ (let* ((i 1))
+ (goto-char beg)
+ (beginning-of-line)
+ (catch 'stop
+ (while (and (not (eobp))
+ (< (point) end))
+ ;; Abort if there is already a line number
+ (when (tinyirc-line-number-p)
+ (throw 'stop 'abort))
+ (insert (format "%03d: " i))
+ (forward-line 1)
+ (incf i)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyird-line-number-delete-region (beg end)
+ "Delete line numbers to region BEG END. Point is moved."
+ (goto-char beg)
+ (beginning-of-line)
+ (let (line)
+ (while (and (not (eobp))
+ (< (point) end))
+ (when (tinyirc-line-number-p)
+ (setq line (match-string 2))
+ (delete-region (line-beginning-position)
+ (line-end-position))
+ (insert line))
+ (forward-line 1))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyirc-path (path)
+ "Return path using forward slashes and without using trailing slash."
+ (setq path (file-name-as-directory
+ (replace-regexp-in-string "[\\]" "/" path)))
+ (if (string-match "^.+[^\\/]" path)
+ (match-string 0 path)
+ path))
+
+;;}}}
+;;{{{ Pastebot: Library
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyirc-pastebot-font-lock-mode-select (mode &optional off)
+ "MODE is 'sent or 'received. Turn on or OFF font lock."
+ (let ((kwds (if (eq mode 'sent)
+ tinyirc-:pastebot-font-lock-keywords-sent
+ tinyirc-:pastebot-font-lock-keywords-received)))
+ (cond
+ (off
+ (setq font-lock-keywords nil)
+ (font-lock-mode -11))
+ (t
+ (font-lock-mode 1)
+ (setq font-lock-keywords kwds)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyirc-pastebot-font-lock-mode-sent (&optional off)
+ "Turn on or OFF font lock."
+ (tinyirc-pastebot-font-lock-mode-select 'sent off))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyirc-pastebot-font-lock-mode-received (&optional off)
+ "Turn on or OFF font lock."
+ (tinyirc-pastebot-font-lock-mode-select 'received off))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyirc-pastebot-message-record (msg)
+ "Record sent MSG to `tinyirc-:pastebot-buffer-name-sent'.
+Buffer is saved if `tinyirc-:pastebot-buffer-file-name' is set.
+
+References:
+ `tinyirc-:pastebot-hook-sent'."
+ (let* ((buffer tinyirc-:pastebot-buffer-name-sent)
+ (save-file tinyirc-:pastebot-buffer-file-name-sent)
+ (save-dir (and save-file
+ (file-name-directory save-file))))
+ (when buffer
+ (get-buffer-create buffer)
+ (display-buffer buffer)
+ (with-current-buffer buffer
+ (when (and (not buffer-file-name)
+ save-file)
+ (if (file-directory-p save-dir)
+ (setq buffer-file-name save-file)
+ (message
+ (concat "TinyIrc: [ERROR] "
+ "tinyirc-:pastebot-buffer-file-name-sent' "
+ "no such dir ``%s'")
+ save-file)))
+ ;; Make room for new message if point is ar wrong place.
+ (tinyirc-append-to-buffer msg)
+;;; (shrink-window-if-larger-than-buffer
+;;; (get-buffer-window buffer))
+ (when buffer-file-name
+ (save-buffer))
+ (run-hooks 'tinyirc-:pastebot-hook-sent)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyirc-pastebot-message-format (service user msg url)
+ "Format message using SERVICE USER MSG URL with timestamp."
+ (let* ((time (tinyirc-time-string))
+ (eol (if (string-match "\n$" msg)
+ ""
+ "\n")))
+ (format "%s %s %s %s %s%s" time service user url msg eol)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyirc-pastebot-program-1 ()
+ "Return location of `tinyirc-:pastebot-program'."
+ (let* ((prg (if (stringp tinyirc-:pastebot-program)
+ tinyirc-:pastebot-program
+ (error
+ "TinyIrc: `tinyirc-:pastebot-program' not defined.")))
+ (saved-abs (get 'tinyirc-pastebot-program 'absolute))
+ (saved-orig (get 'tinyirc-pastebot-program 'original))
+ (path (cond
+ ((and saved-abs
+ (file-exists-p saved-abs)
+ ;; Program has not changed since
+ (string= prg saved-orig))
+ ;; `executable-find' is heavy; use cached file.
+ saved-abs)
+ ((and prg
+ (file-exists-p prg))
+ (expand-file-name prg))
+ (t
+ (executable-find prg)))))
+ (put 'tinyirc-pastebot-program 'original prg)
+ (put 'tinyirc-pastebot-program 'absolute path)
+ path))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyirc-pastebot-program ()
+ "Return location of `tinyirc-:pastebot-program'. Die on error."
+ (let ((path (tinyirc-pastebot-program-1)))
+ (unless path
+ (error
+ (format
+ (concat "TinyIrc: `tinyirc-:pastebot-program' %s not found in PATH. "
+ "Download it at %s")
+ tinyirc-:pastebot-program
+ tinyirc-:pastebot-program-url)))
+ (unless (file-exists-p path)
+ (error "TinyIrc: `tinyirc-:pastebot-program' %s does not exist."
+ tinyirc-:pastebot-program))
+ path))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyirc-pastebot-service-file-name ()
+ "Return configuration filename."
+ (let* ((dir tinyirc-:pastebot-config-directory)
+ (file (concat (file-name-as-directory dir)
+ "servers")))
+ (unless (file-directory-p dir)
+ (error "Cannot read `tinyirc-:pastebot-config-directory' %s"
+ tinyirc-:pastebot-config-directory))
+ file))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyirc-pastebot-service-file-name-changed-p ()
+ "Check if configuration file has chnages since last reading."
+ (let ((time tinyirc-:pastebot-service-list-time-stamp))
+ (when time
+ (let* ((file (tinyirc-pastebot-service-file-name))
+ (modtime (format-time-string
+ "%Y-%m-%d %H:%M"
+ (nth 5 (file-attributes file)))))
+ (string< time modtime)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyirc-pastebot-service-list-from-file ()
+ "Read `tinyirc-:pastebot-config-directory' and parse `servers' file."
+ (let* ((file (tinyirc-pastebot-service-file-name))
+ list)
+ (with-temp-buffer
+ (insert-file-contents-literally file)
+ (goto-char (point-min))
+ (while (re-search-forward
+ "^[ \t]*name[ \t]+\\([^ \t\r\n\f]+\\)"
+ nil t)
+ (push (match-string 1) list)))
+ list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyirc-pastebot-service-list-set ()
+ "Set `tinyirc-:pastebot-service-list' from file.
+See `tinyirc-:pastebot-config-directory'."
+ (setq tinyirc-:pastebot-service-list-time-stamp
+ (format-time-string "%Y-%m-%d %H:%M")
+ tinyirc-:pastebot-service-list
+ (tinyirc-pastebot-service-list-from-file)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyirc-pastebot-service-list ()
+ "Return `tinyirc-:pastebot-service-list' or read configuration."
+ (if (tinyirc-pastebot-service-file-name-changed-p)
+ ;; Need update. User has chnages it on disk while we had read
+ ;; and cached it earlier.
+ (tinyirc-pastebot-service-list-set)
+ (or tinyirc-:pastebot-service-list
+ (tinyirc-pastebot-service-list-set))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyirc-pastebot-receive-call-process-id (service id)
+ "Receive message from pastebot SERVICE by ID number. Return content.
+Valid SERVICE is one that is defined in dire$ctory
+`tinyirc-:pastebot-config-directory' and file `servers'."
+ (let ((prg (tinyirc-pastebot-program)))
+ (if (integerp id)
+ (setq id (int-to-string id)))
+ (with-temp-buffer
+ (message "TinyIrc: pastebot receiving ID %s from %s ..." id service)
+ (call-process "perl"
+ nil
+ (current-buffer)
+ nil
+ prg
+ "-s"
+ service
+ "get"
+ id)
+ (message "TinyIrc: pastebot receiving ID %s from %s ...done." id service)
+ ;; Drop trailing newline from URL.
+ (buffer-string))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyirc-pastebot-receive-call-process-url (url)
+ "Receive message from pastebot by URL . Return content."
+ (let ((prg (tinyirc-pastebot-program)))
+ (with-temp-buffer
+ (message "TinyIrc: pastebot receiving URL %s ..." url)
+ (call-process "perl"
+ nil
+ (current-buffer)
+ nil
+ prg
+ "get"
+ url)
+ (message "TinyIrc: pastebot receiving URL %s ...done." url)
+ ;; Drop trailing newline from URL.
+ (buffer-string))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyirc-pastebot-send-call-process (file service user msg)
+ "Call `tinyirc-:pastebot-program' with perl and send argumens.
+See program for definition of FILE SERVICE USER MSG.
+
+Return program's message without trailing newline. If command succeed,
+the return value is URL where message is available. In case of error, the
+return value is program's error message."
+ (let ((prg (tinyirc-pastebot-program)))
+ (with-temp-buffer
+ (setq file (expand-file-name file))
+ (message "TinyIrc: pastebot sending %s ..." file)
+ (call-process "perl"
+ nil
+ (current-buffer)
+ nil
+ prg
+ "-s"
+ service
+ "-u"
+ user
+ "-m"
+ msg
+ "put"
+ file)
+ (message "TinyIrc: pastebot sending %s ...done." file)
+ ;; Drop trailing newline from URL.
+ (buffer-substring (point-min)
+ (max (point-min)
+ (1- (point-max)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyirc-pastebot-send-main (file service &optional msg user)
+ "Send FILE to SERVICE using optional MSG and USER.
+USER defaults to variable `user-login-name', environment variable USER
+or string `anon'."
+ (let* ((function tinyirc-:pastebot-message-format-function)
+ url)
+ (or user
+ (setq user (or (and (boundp 'user-login-name) ;; Emacs only variable
+ (symbol-value 'user-login-name))
+ (getenv "USER")
+ "anon")))
+ (or msg
+ (setq msg "No message"))
+ (setq url (tinyirc-pastebot-send-call-process
+ file service user msg))
+ (setq msg
+ (if function
+ (funcall function service user msg url)
+ (tinyirc-pastebot-message-format service user msg url)))
+ (tinyirc-pastebot-message-record msg)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyirc-pastebot-receive-message (url msg)
+ "Write URL's MSG to `tinyirc-:pastebot-buffer-name-received'."
+ (let* ((time (tinyirc-time-string))
+ (buffer (get-buffer-create
+ tinyirc-:pastebot-buffer-name-received)))
+ ;; Make sure there is final newline
+ (unless (string-match "\n$" msg)
+ (setq msg (concat msg "\n")))
+ (display-buffer buffer)
+ (with-current-buffer buffer
+ (tinyirc-append-to-buffer
+ (format "%s %s\n%s" time url msg))
+ (run-hooks 'tinyirc-:pastebot-hook-received))))
+
+;;}}}
+;;{{{ Pastebot: Mode
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinyirc-pastebot-message-timestamp-regexp ()
+ "Return timestamp regexp."
+ "^[0-9][0-9][0-9][0-9]-[0-9][0-9]-[0-9][0-9] +[0-9][0-9]:[0-9][0-9] +")
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinyirc-pastebot-message-timestamp-p ()
+ "Return t if line contains a timestamp."
+ (string-match
+ (tinyirc-pastebot-message-timestamp-regexp)
+ (buffer-substring (line-beginning-position)
+ (line-end-position))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinyirc-pastebot-message-timestamp-backward ()
+ "Move to previous timestamp. Return nin-nil if moved.
+Point is after timestamp."
+ (re-search-backward
+ (tinyirc-pastebot-message-timestamp-regexp) nil t))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinyirc-pastebot-message-timestamp-forward ()
+ "Move to previous timestamp. Return nin-nil if moved.
+Point is at the beginning of line."
+ (re-search-forward
+ (tinyirc-pastebot-message-timestamp-regexp) nil t))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyirc-pastebot-message-timestamp-move-to-url ()
+ "At timestap line, go to URL at line. Return non-nl if moved."
+ (let (point)
+ (save-excursion
+ (beginning-of-line)
+ (when (looking-at (tinyirc-pastebot-message-timestamp-regexp))
+ (setq point (match-end 0))))
+ (when point
+ (goto-char point))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyirc-pastebot-url-at-point ()
+ "Return HTTP url at point if any."
+ (let* ((word (tinyirc-word-at-point)))
+ (when (and word
+ (string-match "http://" word))
+ word)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyirc-pastebot-message-region ()
+ "Determine retrieved message's region. Return list '(beg end).
+The region searched starts with a time stamp and ends in another timestamp
+or `eobp'."
+ (let (point
+ ok)
+ (save-excursion
+ (cond
+ ((tinyirc-pastebot-message-timestamp-p)
+ (forward-line 1)
+ (setq ok t))
+ ((tinyirc-pastebot-message-timestamp-forward)
+ (setq ok t)))
+ (when (and ok
+ (not (or (tinyirc-pastebot-message-timestamp-p)
+ (eobp))))
+ (setq point (point))
+ (cond
+ ((tinyirc-pastebot-message-timestamp-forward)
+ (beginning-of-line))
+ (t
+ (goto-char (point-max))))
+ (list point (point))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyirc-pastebot-message-string ()
+ "Return received message at point."
+ (multiple-value-bind (beg end)
+ (tinyirc-pastebot-message-region)
+ (when (and beg end)
+ (buffer-substring beg end))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyirc-pastebot-mode-command-write-file (beg end file)
+ "Write message at BEG END to a FILE."
+ (interactive
+ (let (file)
+ (multiple-value-bind (beg end)
+ (tinyirc-pastebot-message-region)
+ (unless beg
+ (error "TinyIrc: Can't find timestamp at point %d"
+ (point)))
+ (setq file
+ (read-file-name "Save message to file: "))
+ (unless (string-match "[^ \t\r\n\f]" file)
+ (setq file "--abort-this"))
+ (list
+ beg
+ end
+ file))))
+ (when (and file
+ (not (string-match "--abort-this" file)))
+ (write-region beg end file)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyirc-pastebot-mode-command-receive (url &optional arg)
+ "Receive messages.
+In buffer tinyirc-:pastebot-buffer-name-sent', receive
+message using current line's URL. With Prefix argument, receive
+arbitrary user supplied URL.
+
+In buffer `tinyirc-:pastebot-buffer-name-received' this function
+automatically asks what URL to receive."
+ (interactive
+ (let* (url)
+ (cond
+ ((string= (buffer-name)
+ tinyirc-:pastebot-buffer-name-sent)
+ (cond
+ (current-prefix-arg
+ (setq url
+ (read-string "Pastebot receive URL: "
+ (thing-at-point 'url))))
+ (t
+ (save-excursion
+ (when (tinyirc-pastebot-message-timestamp-move-to-url)
+ (setq url (thing-at-point 'url))
+ (when (and url
+ (not (y-or-n-p
+ (format
+ "Receive %s "
+ url))))
+ (setq url nil)))))))
+ ((string= (buffer-name)
+ tinyirc-:pastebot-buffer-name-received)
+ (setq url
+ (read-string "Pastebot receive URL: "
+ (tinyirc-pastebot-url-at-point)))))
+ (list url
+ current-prefix-arg)))
+ (when url
+ (tinyirc-pastebot-receive-url url)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyirc-pastebot-mode-command-line-number-toggle ()
+ "Add or remove line numbers to the message at point (or forward)."
+ (interactive)
+ (if (not (tinyirc-pastebot-message-timestamp-p))
+ (message "TinyIrc: Move to a timestamp first.")
+ (multiple-value-bind (beg end)
+ (tinyirc-pastebot-message-region)
+ (if (not (and beg end))
+ (message "TinyIrc: Cannot find message's region.")
+ (let* ((number-p (save-excursion
+ (goto-char beg)
+ (tinyirc-line-number-p))))
+ (save-excursion
+ (if number-p
+ (tinyird-line-number-delete-region beg end)
+ (tinyird-line-number-add-region beg end))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyirc-pastebot-default-mode-bindings ()
+ "Define default key bindings to `tinyirc-pastebot-mode-map'."
+
+ (cond
+ ((string-match "XEmacs" (emacs-version))
+ (define-key tinyirc-pastebot-mode-map [(mouse3up)]
+ 'tinyirc-pastebot-mode-command-receive)
+ (define-key tinyirc-pastebot-mode-map [(control mouse3up)]
+ 'tinyirc-pastebot-mode-command-line-number-toggle))
+ (t ;; Emacs
+ (define-key tinyirc-pastebot-mode-map [(mouse-3)]
+ 'tinyirc-pastebot-mode-command-receive)
+ (define-key tinyirc-pastebot-mode-map [(control mouse-3)]
+ 'tinyirc-pastebot-mode-command-line-number-toggle)))
+
+ (define-key tinyirc-pastebot-mode-map "\C-p"
+ 'tinyirc-pastebot-message-timestamp-backward)
+
+ (define-key tinyirc-pastebot-mode-map "\C-n"
+ 'tinyirc-pastebot-message-timestamp-forward)
+
+ (define-key tinyirc-pastebot-mode-map "\C-c\C-r"
+ 'tinyirc-pastebot-mode-command-receive)
+
+ (define-key tinyirc-pastebot-mode-map "\C-c\C-w"
+ 'tinyirc-pastebot-mode-command-write-file)
+
+ (define-key tinyirc-pastebot-mode-map "\C-c\C-l"
+ 'tinyirc-pastebot-mode-command-line-numbers-toggle))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinyirc-mode-map-activate ()
+ "Use local \\{tinyirc-pastebot-mode-map} on this buffer."
+ (use-local-map tinyirc-pastebot-mode-map))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinyirc-mode-map-define-keys ()
+ "Run `tinyirc-:pastebot-mode-define-keys-hook'.
+But only if `tinyirc-pastebot-mode-map' is nil."
+ (unless tinyirc-pastebot-mode-map
+ (setq tinyirc-pastebot-mode-map (make-sparse-keymap))
+ (run-hooks 'tinyirc-:pastebot-mode-define-keys-hook)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autolaod
+(defun tinyirc-pastebot-mode ()
+ "Major mode for handlling PasteBot server messages: sending, receiving and
+formatting. For more information run \\[finder-commentary] RET tinyirc.el
+RET.
+
+Mode description:
+
+\\{tinyirc-pastebot-mode-map}"
+ (interactive)
+ (tinyirc-mode-map-define-keys)
+ (tinyirc-mode-map-activate) ;turn on the map
+ (setq mode-name tinyirc-:mode-name)
+ (setq major-mode 'tinyirc-pastebot-mode) ;; for C-h m
+ (when (interactive-p)
+ (message
+ (substitute-command-keys
+ (concat
+ "Receive URL at line \\[tinyirc-pastebot-mode-command-receive] "
+ "Line num \\[tinyirc-pastebot-mode-command-line-numbers-toggle] ")))
+ (sleep-for 1))
+ (run-hooks 'tinyirc-:pastebot-mode-hook))
+
+;;}}}
+;;{{{ Pastebot: User functions
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyirc-http-get (url buffer &optional verbose timeout)
+ "Send URL and output result to BUFFER with VERBOSE optional TIMEOUT."
+ (let ((port 80)
+ connection
+ path
+ host)
+ (or timeout
+ (setq timeout 60))
+ (cond
+ ((stringp buffer)
+ (setq buffer (or (get-buffer buffer)
+ (get-buffer-create buffer))))
+ ((and (not (null buffer))
+ (bufferp buffer)))
+ (t
+ (error "BUFFER arg [%s] is incorrect" buffer)))
+ (if (not (string-match "^http://\\([^/]+\\)\\(/.*\\)" url))
+ (error "Must be _http_ request '%s'" url)
+ (setq host (match-string 1 url)
+ path (match-string 2 url)))
+ (with-current-buffer buffer
+ (erase-buffer))
+ (condition-case error
+ (progn
+ (if verbose
+ (message "TinyIrc: opening %s:%s" host port))
+ (setq
+ connection
+ (open-network-stream "*http*" buffer host port))
+ (if verbose
+ (message "TinyIrc: sending %s:%s + %s" host port path))
+ (process-send-string
+ connection
+ (concat "GET "
+ path
+ " HTTP/1.0\r\n\r\n"))
+ (while (and (eq 'open (process-status connection))
+ (accept-process-output connection timeout))))
+ (error
+ (error (cdr error))))
+ (if verbose
+ (message "TinyIrc: clossing %s:%s" host port))
+ (if connection
+ (delete-process connection))
+ buffer))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyirc-pastebot-install-perl-util-pastebot ()
+ "Install `tinyirc-:pastebot-program-url'."
+ (interactive)
+ (let ((perl (executable-find "perl"))
+ (http-buffer tinyirc-:http-buffer)
+ (name tinyirc-:error-buffer)
+ (url tinyirc-:pastebot-program-url)
+ (filename (file-name-nondirectory tinyirc-:pastebot-program-url))
+ (program tinyirc-:pastebot-program)
+ buffer)
+ (unless perl
+ (with-current-buffer (or buffer
+ (get-buffer-create name))
+ (insert (format "\
+INSTALL PROBLEM: Perl
+
+ The `tinyirc-:pastebot-program' [%s] need Perl command interpreter to run.
+ Perl doesn't seem to be installed. Please update environment variable
+ PATH if you do have Perl, but it's merely missing from there."
+ tinyirc-:pastebot-program))
+ (if (file-directory-p "c:/")
+ (insert "\
+
+ If you haven't installed Perl language yet, get it from
+ <http://cygwin.com> by downloading the setup.exe from top right
+ and running the install program. Make sure you mark the checkbox
+ for Perl from list of installable program list."))))
+ (setq program nil)
+ (when (not (stringp program))
+ (let ((buffer (tinyirc-http-get
+ url
+ (get-buffer-create http-buffer)
+ 'verbose)))
+ (with-current-buffer buffer
+ (goto-char (point-min))
+ (replace-regexp "\r" "" nil (point-min) (point-max))
+ (re-search-forward "^\n")
+ (let (dir
+ saveto)
+ (setq dir (completing-read
+ (format
+ "Save %s to dir (must be along PATH): " filename)
+ (mapcar (function
+ (lambda (x)
+ (cons x 1)))
+ (split-string (getenv "PATH") path-separator))
+ nil
+ 'match))
+ (setq saveto
+ (expand-file-name
+ (concat (file-name-as-directory dir) filename)))
+ (write-region (point) (point-max) saveto)
+ (message "TinyIrc: saved %s" saveto)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyirc-pastebot-install-example-servers ()
+ "Install the Pastebot `servers' example configuration file. This function
+tries to veriry the setup and suggest corrective actions how to get the
+PasteBot interface working. Once the installation look valid, this function
+should report an success status.
+
+References:
+ `tinyirc-:pastebot-config-default-content'
+ `tinyirc-:pastebot-program'
+ `tinyirc-:pastebot-program-url'"
+ (interactive)
+ (let* ((config-default-content tinyirc-:pastebot-config-default-content))
+ (let* ( ;; (win32 (file-directory-p "c:/"))
+ ;; (cygwin (string-match "cygwin" "emacs-version"))
+ (dir (tinyirc-path tinyirc-:pastebot-config-directory))
+ ;; Watch out for Cygwin made symlink under Native
+ ;; Win32 NTEmacs. We must not
+ (link (concat dir ".lnk"))
+ (config (format "%s/servers" dir)))
+ (when (and (file-directory-p "c:/")
+ (file-exists-p link))
+ (error "TinyIrc: [install] Cygwin conflict. File [%s] exists. \
+That file might be a Windows shortcut, a symlink, made under Cygwin.
+In that case, you cannot use PasteBot interfcase
+both from NTEmacs and Cygwin Emacs, because NTEmacs
+cannot by default follow Cygwin symlinks.
+
+In case you aren't using Cygwin, please remove that Windows shortcut link
+and create real directory instead."
+ link))
+ (if (file-directory-p dir)
+ (message "TinyIrc: [install] Good, you have %s" dir)
+ (message "TinyIrc: [install] Making directory %s" dir)
+ (make-directory dir))
+ (if (file-exists-p config)
+ (message "TinyIrc: [install] Good, you have %s" config)
+ (message "TinyIrc: [install] Writing configuration file %s ..."
+ config)
+ (with-temp-buffer
+ (insert config-default-content)
+ (write-region (point-min) (point-max) config))
+ (message "TinyIrc: [install] Writing configuration file %s ...done."
+ config))
+ (let ((prg (tinyirc-pastebot-program-1)))
+ (if prg
+ (message "TinyIrc: [install] Good, you have program %s" prg)
+ (error (concat
+ "TinyIrc: [install] FATAL you do not have program %s, "
+ "visit %s and install it along PATH")
+ tinyirc-:pastebot-program
+ tinyirc-:pastebot-program-url)))
+ (message
+ (concat
+ "TinyIrc: [install] Check passed. "
+ "Your PasteBot interface should be functonal provided that "
+ "configuration file %s 1) contains needed entries and "
+ "2) it has no syntax errors."
+ "This function did not check its content. ")
+ config))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyirc-pastebot-receive-url (url)
+ "Retrieve URL from PasteBot service."
+ (interactive
+ (list
+ (read-string "Pastebot receive URL: "
+ (tinyirc-pastebot-url-at-point))))
+ (when (or (not (stringp url))
+ (not (string-match "http://" url)))
+ (error "TinyIrc: invalid URL %s" url))
+ (tinyirc-pastebot-receive-message
+ url
+ (tinyirc-pastebot-receive-call-process-url url)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyirc-pastebot-send-region (service user msg beg end)
+ "Send code to SERVICE using Perl script pastebot.pl.
+identify as USER with MSG. Send text in region BEG and END.
+
+See http://sial.org/code/perl/scripts/pbotutil.pl.html
+You also have to define databases for SERVICE selections, see script's
+manual page for details.
+
+References:
+ `tinyirc-:pastebot-send-file'."
+ (interactive
+ (let* ( ;; Make assoc list
+ (list (mapcar (function
+ (lambda (x)
+ (cons x 1)))
+ (tinyirc-pastebot-service-list)))
+ (file tinyirc-:pastebot-send-file))
+ (unless list
+ (error (concat "Tinyirc: Cannot get completions."
+ "Check pastebot `servers' file.")))
+ (list
+ (completing-read "Send to PasteBot service: "
+ list
+ nil
+ ;; Because user may have updated the
+ ;; configuration file and we don't know about it
+ (not 'requir-match)
+ (if tinyirc-:pastebot-history-services
+ (car tinyirc-:pastebot-history-services))
+ 'tinyirc-:pastebot-history-services)
+ (read-string "Pastebot user: "
+ (if tinyirc-:pastebot-history-user
+ (car tinyirc-:pastebot-history-user)
+ (or user-login-name
+ (getenv "USER")))
+ 'tinyirc-:pastebot-history-user)
+ (read-string "Pastebot message: ")
+ (region-beginning)
+ (region-end))))
+ (let ((file (or tinyirc-:pastebot-send-file
+ (error "TinyIrc: `tinyirc-:pastebot-send-file' not set."))))
+ (unless (and beg end)
+ (error "Pastebot: region not defined"))
+ (write-region beg end file)
+ (tinyirc-pastebot-send-main file service msg user)))
+
+;;}}}
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyirc-install (&optional uninstall)
+ "Install or UNINSTALL package."
+ ;; (interactive "p")
+ (tinyirc-mode-map-define-keys))
+
+(tinyirc-install)
+(provide 'tinyirc)
+(run-hooks 'tinyirc-:load-hook)
+
+;;; End of tinyirc.el
--- /dev/null
+;;; tinylib-ad.el --- Library of adviced functions. Backward compatibility
+
+;;{{{ Id
+
+;; Copyright (C) 1999-2007 Jari Aalto
+;; Keywords: extensions
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program, call M-x tinylib-ad-version
+
+;; COPYRIGHT NOTICE
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;; ........................................................ &t-install ...
+;; Put this file on your Emacs-Lisp load path, add following into your
+;; ~/.emacs startup file
+;;
+;; (require 'tinylibm) ;; Yes, there is no mistake. You require the "m"
+
+;;}}}
+;;{{{ Documentation
+
+;; ..................................................... &t-commentary ...
+
+;;; Commentary:
+
+;; Preface, 1999
+;;
+;; This is lisp function library, package itself does nothing.
+;; It modifies existing Emacs functions with advice.el in order
+;; to provide backward compatibility for functions that have changed.
+;; E.g. Emacs 20.4 introduced new parameter NOERR to `require' command.
+;;
+;; There is another way, load this library first and continue using
+;; your current Emacs version. This package will redefine functions
+;; only when needed, so it should be quite safe.
+;;
+;; Usage
+;;
+;; You must not autoload this package; but always include
+;;
+;; (require 'tinylibm)
+;;
+;; You don't need any other require commands: all other library
+;; functions get defined as well by using autoload. Repeat: you don't
+;; have to put these in your packages:
+;;
+;; (require 'tinylib) ;; leave this out
+;; (require 'tinyliby) ;; not needed either.
+;; (require 'tinylib-ad) ;; not needed either.
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+(require 'tinylibb)
+
+(eval-when-compile
+ (require 'advice))
+
+(when (and (ti::emacs-p)
+ (not (ti::emacs-p "20.2")))
+ (defadvice shell-command (after tiny act)
+ "The OUTPUT-BUFFER does not work in old releases. Fix it."
+ (let* ((buffer (ad-get-arg 1)))
+ (when (and buffer
+ (get-buffer buffer)
+ (get-buffer shell-command-output-buffer))
+ (with-current-buffer buffer
+ (erase-buffer)
+ (insert-buffer shell-command-output-buffer)
+ (ti::kill-buffer-safe shell-command-output-buffer))))))
+
+;; Emacs 20.1 inroduced new argument (buffer-size &optional BUFFER)
+(unless (string-match "buffer"
+ (or (ti::function-args-p 'buffer-size) ""))
+ (defadvice buffer-size
+ (around tinylib-ad (feature &optional buffer) act)
+ "Emacs compatibility: optional parameter BUFFER."
+ (if buffer
+ (with-current-buffer buffer
+ ad-do-it)
+ ad-do-it)))
+
+;; Emacs 21.1
+;; (define-key-after KEYMAP KEY DEFINITION &optional AFTER)
+;; Emacs 20.7
+;; (define-key-after KEYMAP KEY DEFINITION AFTER)
+
+(when (and (fboundp 'define-key-after)
+ (string-match "optional"
+ (or (ti::function-args-p 'define-key-after) "")))
+ (defadvice define-key-after
+ (around tinylib-ad (keymap key definition &optional after) act)
+ "Emacs compatibility: parameter AFTER is now optional."
+ ad-do-it))
+
+;; 20.4 introduced new arg NOERR
+;; (require FEATURE &optional FILE-NAME NOERROR)
+
+(unless (string-match "noerr"
+ (or (ti::function-args-p 'require) ""))
+ (defadvice require
+ (around tinylib-ad (feature &optional file-name noerror) act)
+ "Emacs compatibility: Added parameter NOERR."
+ (let* ((noerr (ad-get-arg 2)))
+ (if noerr
+ (or (featurep feature)
+ (load (or file-name (symbol-name feature)) 'noerr 'nomsg))
+ ad-do-it))))
+
+;; Emacs includes more arguments
+
+(when (and (fboundp 'read-char-exclusive)
+ (not (string-match "prompt"
+ (or (ti::function-args-p 'read-char-exclusive) ""))))
+ (defadvice read-char-exclusive
+ (around tinylib-ad (&optional prompt inherit-input-method) act)
+ "Emacs compatibility. Added parameters PROMPT INHERIT-INPUT-METHOD,
+but INHERIT-INPUT-METHOD is not supported."
+ (message prompt)
+ (setq ad-return-value (read-char-exclusive))))
+
+;; Older versions of `executable-find' did not search ".exe" or ".com" ...
+;; extensions. This was true for XEmacs 21.2 also. In Emacs 20.4 it's ok.
+;;
+;; We instantiate this advice if it can't pass the test.
+
+(when (and (ti::win32-p)
+ ;; Try and see if executable-find adds extension .com and
+ ;; .exe, if these fail, then fix it.
+ (let ((exec-path exec-path))
+ (push "c:/windows" exec-path)
+ (push "c:/winnt" exec-path)
+ (null (or (executable-find "command")
+ (executable-find "cmd")))))
+ (defadvice executable-find (around tinylib-ad act)
+ "Replace function. In win32, try also extension .com .exe .bat ..."
+ (let ((command (ad-get-arg 0))
+ ret)
+ (dolist (ext '(".exe" ".com" ".bat" ".cmd" ".btm" ""))
+ (if (setq ret (ti::file-get-load-path
+ (concat command ext) exec-path))
+ (return ret)))
+ (setq ad-return-value ret))))
+
+;;{{{ Version
+
+;;; ......................................................... &version ...
+
+(defconst tinylib-ad-version
+ (substring "$Revision: 2.45 $" 11 15)
+ "Latest version number.")
+
+(defconst tinylib-ad-version-id
+ "$Id: tinylib-ad.el,v 2.45 2007/05/01 17:20:44 jaalto Exp $"
+ "Latest modification time and version number.")
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylib-ad-version (&optional arg)
+ "Show version information. ARG will instruct to print message to echo area."
+ (interactive "P")
+ (ti::package-version-info "tinylib-ad.el" arg))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylib-ad-submit-bug-report ()
+ "Submit bug report."
+ (interactive)
+ (ti::package-submit-bug-report
+ "tinylib-ad.el"
+ tinylib-ad-version-id
+ '(tinylib-ad-version-id)))
+
+;;}}}
+
+(provide 'tinylib-ad)
+
+;;; tinylib-ad.el ends here
--- /dev/null
+;;; tinylib.el --- Library of general functions
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 1995-2007 Jari Aalto
+;; Keywords: extensions
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program, call M-x tinylib-version
+;; Look at the code with folding.el
+
+;; COPYRIGHT NOTICE
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;;; Install:
+
+;; ........................................................ &t-install ...
+;; Put this file to the package that you're developing. This file is
+;; is mostly for developers.
+;;
+;; (require 'tinylibm) ;; No mistake here, you load `m' library
+;;
+;; If you have any questions or feedback, use this function
+;;
+;; M-x tinylib-submit-feedback
+
+;;}}}
+;;{{{ Documentation
+
+;; ..................................................... &t-commentary ...
+
+;;; Commentary:
+
+;; Preface, 1995
+;;
+;; This is library, so the package itself does nothing,
+;; there may be some interactive functions.
+;; There is a issue of Emacs and XEmacs differences multiplied with
+;; different OS platforms, like Cygwin and native Win32. In order to
+;; reuse the code in modules and to keep up with the Emacs/XEmacs
+;; interface and different releases, the general function can be found
+;; from these libraries.
+;;
+;; Defining a minor mode
+;;
+;; This library provides Emacs/XEmacs comatible minor mode
+;; since 1995. There is one macro that defines all minor mode
+;; variables and function.
+;;
+;; (eval-and-compile ;; So that defvars and defuns are seen
+;; (ti::macrof-minor-mode-wizard
+;; ;;
+;; ;; 1. prefix for variables and functions
+;; ;; 2. Modeline name
+;; ;; 3. prefix key for mode.
+;; ;; 4. Menu bar name
+;; ;; 5. <forget this>
+;; ;;
+;; "xxx-" " xxxModeline" "\C-cx" "xxxMenubar" nil
+;;
+;; "XXX minor mode. Does fancy things." ;; mode description
+;; Defined keys:
+;; \\{xxx-mode-map}
+;; "
+;;
+;; "XXX help" ;; message displayed when user calls mode
+;; nil ;; Forms When minor mode is called
+;;
+;; ;; This is used by easy-menu.el and defines menu items.
+;; (list
+;; xxx-mode-easymenu-name
+;; ["Eval whole buffer" xxx-eval-current-buffer t]
+;; ..)
+;;
+;; ;; this block defines keys to the mode. The mode minor map is
+;; ;; locally bound to 'map' symbol.
+;; (progn
+;; (define-key map "-" 'xxx-eval-current-buffer)
+;; (define-key map "=" 'xxx-calculate))))
+;;
+;; Defining minor mode step by step
+;;
+;; If you want to take more personal control over the minor mode
+;; creation, here I explain step by step what macros you need to include
+;; in your package to get minor mode created, This takes only
+;; half an hour and you have basic minor mode ready. Put all
+;; following calls near top of your file. We suppose we're
+;; creating XXX-mode.
+;;
+;; _[1]_ First, define standard variables for minor mode.
+;;
+;; (ti::macrov-minor-mode "xxxModeline" "\C-cx" "xxxMenubar")
+;;
+;; After that user has following varibles for customization. (for
+;; complete list of created variables, see the macro's description)
+;;
+;; ;; Don't like default key combo C-c x
+;; (setq xxx-mode-prefix-key "\C-cm")
+;;
+;; ;; The default mode string was too long, use shorter.
+;; (setq xxx-mode-name "xxx")
+;;
+;; ;; When mode runs, I want to do this.
+;; (add-hook 'xxx-mode-hook 'my-xxx-settings)
+;;
+;; ;; I want to add additional keys
+;; (add-hook 'xxx-mode-define-keys-hook 'my-xxx-keys)
+;;
+;; _[2]_ Next we need installation function, which installs our minor
+;; mode so that emacs is aware of it. The minor mode functions,
+;; xxx-mode, will call xxx-mode-define-keys-hook which takes care of
+;; defining keys to key maps and creating menus with easy-menu.el. The
+;; separate installation function is used, because it takes care of
+;; emacs specific things and if called with additional argument, it
+;; also knows how to remove the mode gracefully.
+;;
+;; (ti::macrof-minor-mode-install
+;; xxx-install-mode
+;; xxx-mode
+;; xxx-mode-map
+;; xxx-mode-name
+;; xxx-mode-define-keys-hook)
+;;
+;; _[3]_ Do we have additional files attached to the end of package?
+;; If yes, then we need pgp-tar unpack function too.
+;;
+;; (ti::macrof-install-pgp-tar "xxx-install-files" "xxx.el")
+;;
+;; _[4]_ Finally the user callable minor mode function is created.
+;;
+;; (ti::macrof-minor-mode
+;; xxx-mode
+;; "XXX minor mode. Does fancy things."
+;; Defined keys:
+;; \\{xxx-:mode-map}
+;; "
+;; xxx-install-mode
+;; xxx-mode
+;; xxx-mode-name
+;; xxx-mode-prefix-key
+;; xxx-mode-easymenu
+;; nil ;Yes, print turn on/off message
+;; "XXX help"
+;; xxx-mode-hook)
+;;
+;; That's it. when you execute all these statements you have basic core
+;; for emacs minor mode. The only things missing is the actual
+;; functions that the minor mode commands uses and the function that
+;; defines keys and menus for the minor mode. You probably want to
+;; start from the function that defines keys and menus. Here is ready
+;; macro for that too.
+;;
+;; (add-hook' xxx-mode-define-keys-hook 'xxx-mode-define-keys)
+;;
+;; (ti::macrof-define-keys
+;; "xxx-mode-define-keys"
+;; 'xxx-:mode-prefix-map
+;; 'xxx-:mode-prefix-key
+;;
+;; 'xxx-:easymenu
+;; 'xxx-:easymenu-name
+;; "Programming help menu."
+;; (list
+;; xxx-:easymenu-name
+;; ["Eval whole buffer" xxx-eval-current-buffer t]
+;; ..)
+;; '(progn
+;; (define-key map "-" 'xxx-eval-current-buffer)
+;; (define-key map "=" 'xxx-calculate)
+;; ..))
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+;;{{{ require
+
+;;; ......................................................... &require ...
+
+(require 'tinylibm) ;macro package
+
+(eval-when-compile
+ (ti::package-use-dynamic-compilation)
+ (when (and (ti::xemacs-p)
+ (byte-compiling-files-p))
+ (message "\n\
+ ** tinylib.el: [Note] It is safe to ignore Emacs dependant ange-ftp function
+ compilation errors.")))
+
+(eval-and-compile
+
+ (defvar generated-autoload-file) ;; See autoload.el
+ (defvar flyspell-mode)
+
+ (autoload 'vc-name "vc-hooks")
+ (autoload 'vc-file-getprop "vc-hooks")
+
+ ;; Can't autoload timer, because various calls in this lib are behind
+ ;; ti::funcall --> Bytecompiler doesn't see them.
+
+ (ti::package-package-require-timer) ;XEmacs and Emacs differencies
+
+ (cond
+ ((ti::xemacs-p)
+
+ ;; Ange-ftp function used in this package won't work in XEmacs.
+ ;; The ange functions used for backgroung ftp downloads
+ ;; and low level calling calling of ange functions. Currently used in
+ ;; one pacakge: tinydired.el, which let's you donwload/upload
+ ;; files at the background.
+
+ (require 'efs-auto nil 'noerr)
+ (autoload 'read-passwd "passwd" "" t))
+
+ ((ti::emacs-p)
+ (defvar ange-ftp-process-result nil)
+ (defvar ange-ftp-ascii-hash-mark-size 1024)
+ (defvar ange-ftp-binary-hash-mark-size 1024)
+ (defvar ange-ftp-process-busy nil)
+ (autoload 'ange-ftp-process-handle-line "ange-ftp")
+ (autoload 'ange-ftp-get-process "ange-ftp")
+ (autoload 'ange-ftp-ftp-name "ange-ftp")
+ (autoload 'ange-ftp-real-file-name-as-directory "ange-ftp")
+ (autoload 'ange-ftp-expand-dir "ange-ftp")
+ (autoload 'ange-ftp-ftp-process-buffer "ange-ftp")
+ (autoload 'ange-ftp-set-binary-mode "ange-ftp")
+ (autoload 'ange-ftp-send-cmd "ange-ftp")
+ (autoload 'ange-ftp-cd "ange-ftp")
+ (autoload 'ange-ftp-raw-send-cmd "ange-ftp"))))
+
+;;}}}
+;;{{{ setup: -- variables
+
+;;; ....................................................... &v-private ...
+
+(defconst ti::var-syntax-info
+ '((?\ "Whitespace")
+ (?- "Whitespace")
+ (?w "Word")
+ (?_ "Symbol, variables and commands")
+ (?. "Punctuation, separate symbols from one another")
+ (?( "Open parenthesis")
+ (?) "Close parenthesis")
+ (?\" "String quote, string as a single token")
+ (?\\ "Escape")
+ (?/ "Character quote, only the character immediately following.")
+ (?$ "Paired delimiter, like string quote, chars between are not suppressed")
+ (?< "Comment starter")
+ (?> "Comment ender")
+ (?@ "Inherit from standard syntax table"))
+ "Short syntax definition table ((CLASS . DESC) ..).")
+
+;;; ........................................................ &v-public ...
+;;; User configurable
+
+(defvar ti::var-x-coord 170
+ "*Default X menu coordinate.")
+
+(defvar ti::var-y-coord 170
+ "*Default X menu coordinate.")
+
+;; Make this invisible by default, note leading space.
+(defvar ti::var-passwd-buffer " *passwd-entries*"
+ "*Contents of password file.")
+
+;;}}}
+;;{{{ setup: -- version
+
+;;; ....................................................... &v-version ...
+;;; These are not library funcs, so they have normal 'tinylib-' prefix
+
+(defconst tinylib-version
+ (substring "$Revision: 2.107 $" 11 15)
+ "Latest version number.")
+
+(defconst tinylib-version-id
+ "$Id: tinylib.el,v 2.107 2007/05/07 10:50:07 jaalto Exp $"
+ "Latest modification time and version number.")
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylib-version (&optional arg)
+ "Show version information. ARG will instruct to print message to echo area."
+ (interactive "P")
+ (ti::package-version-info "tinylib.el" arg))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylib-submit-feedback ()
+ "Submit suggestions, error corrections, impressions, anything..."
+ (interactive)
+ (ti::package-submit-feedback "tinylib.el"))
+
+;;}}}
+
+;;; ########################################################### &funcs ###
+
+;;{{{ defsubst
+
+;;; ........................................................ &defsubst ...
+;;; inlined functions, they must be introduced before used
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::string-trim-blanks (string &optional middle)
+ "Strip leading, trailing and middle spaces.
+Input:
+
+ MIDDLE if non-nil, trim blanks in the middle too and convert
+ tabs to spaces."
+ (when (stringp string)
+ ;; Strip leading and trailing
+ (if (string-match "^[ \t\f\r\n]*\\(.+[^ \t\f\r\n]\\)" string)
+ (setq string (match-string 1 string)))
+ (when middle
+ ;; middle spaces
+ (setq string (replace-regexp-in-string "[\t\r\n]" " " string))
+ (setq string (replace-regexp-in-string " +" " " string)))
+ string))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;; (ti::string-verify-ends "Z" "\\." "." 'beg)
+;;; (ti::string-verify-ends "dir" "/")
+;;;
+(defun ti::string-verify-ends (str re &optional add-str beg)
+ "Make sure STR match RE and add ADD-STR string to it when necessary.
+if ADD-STR is not given, adds RE to the string.
+
+Default is to check end of string, Optionally BEG of string.
+The RE may not include anchors.
+
+Examples:
+ making sure directory has ending slash
+ (ti::string-verify-ends \"dir\" \"/\") --> \"dir/\"
+
+ Making sure, time is zero based:
+ (ti::string-verify-ends \"7\" \"0\" nil 'beg) --> \"07\"
+
+ This does not give you the rsult you assume!
+ because the second parameter, \" \", is regexp that is tried.
+ This function can't know that there is only \" \" space at front,
+ since the regexp dind't match.
+
+ (ti::string-verify-ends \" padd\" \" \" nil 'beg)
+ --> \" padd\"
+
+Return:
+ str possibly modified"
+ (let* ((RE (if beg
+ (concat "\\`" re)
+ (concat re "\\'")))
+ (add (or add-str re))) ;which one to add.
+ (if (string-match RE str)
+ str
+ (if beg
+ (concat add str)
+ (concat str add)))))
+
+;;; ----------------------------------------------------------------------
+;;; - Originally there was own function for this; but now
+;;; it uses general func verify...
+;;; - The main purpose of this function is that when you cat words
+;;; together, you can be sure they have COUNT spaces.
+;;; - kinda sprintf...
+;;;
+(defsubst ti::string-add-space (str &optional end count)
+ "Add space to the beginning of STR if there isn't one.
+Optionally adds to the END. COUNT is by default 1
+
+If string length is 0, do nothing."
+ (let* ((count (or count 1))
+ (padd (make-string count ?\ )))
+ (ti::string-verify-ends str padd padd (not end))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::string-remove-whitespace (string)
+ "Squeezes empty spaces around beginning and end of STRING.
+If STRING is not stringp, then returns STRING as is."
+ (when string
+ (replace-regexp-in-string
+ "^[ \t\r\n]+" ""
+ (replace-regexp-in-string
+ "[ \t\r\n]+\\'" "" string))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::string-mangle (string)
+ "Mangle STRING ie. make STRING unreadable.
+Same mangling is performed for the same STRING. Mangling can't be reversed."
+ (let* ((ch-list (coerce string 'list))
+
+ ;; (coerce list 'string) to get list of ints to string
+
+ (abc "zaybxcwdveuftgshriqjpkolnm0918273645ZAYBXCWDVEUFTGSHRIQJPKOLNM")
+ (len (length abc))
+ (ret "")
+ x)
+ (dolist (ch ch-list)
+ (setq x (% (char-to-int ch) len))
+ (setq ret (concat ret (substring abc x (1+ x)))))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;; #todo: Use replace-regexp-in-string
+;;;
+(defsubst ti::string-regexp-delete (re str &optional level)
+ "Remove all that match RE from STR at subexpression LEVEL."
+ (while (string-match re str)
+ (setq str (ti::replace-match (or level 0) nil str)))
+ str)
+
+;;}}}
+;;{{{ Conversions
+
+;;; ##################################################### &Conversions ###
+
+;;; ----------------------------------------------------------------------
+;;; Try
+;;; (setq str "%s")
+;;; (message str) ;; suppose you don't know what's in there
+;;;
+;;; and you get error... use (message (ti::string-format-percent str))
+;;;
+(defun ti::string-format-percent (str)
+ "Convert STR to message string, doubling diffucult charactes, like % and \\."
+ (let* ((len (length str))
+ (i 0)
+ (ret str)
+ ch-string
+ extra
+ ch)
+ (cond
+ ((string-match "[%\\]" str) ;only now do
+ (setq ret "")
+ (while (< i len)
+ (setq ch (aref str i)
+ ch-string (char-to-string ch)
+ extra "")
+ (if (char= ch ?%)
+ (setq extra ch-string))
+ (setq ret (concat ret ch-string extra))
+ (incf i))))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::string-url-to-ange-ftp (str)
+ "Converts URL STR into ange ftp address.
+
+Eg:
+ ftp://some.site
+ ftp://some.site/pub/users/foo/emacs/some.el
+ ftp://some.site:/pub/users/foo/emacs/some.el
+ ftp://ftp@some.site/pub/users/foo/emacs/some.el
+ ftp://ftp@some.site:/pub/users/foo/emacs/some.el
+
+ -->
+ /ftp@some.site:/
+ /ftp@some.site:/pub/users/foo/emacs/some.el
+
+Return:
+ string
+ nil"
+ (let* (ref
+ idx
+ login
+ host
+ dir
+ ret)
+ (cond
+ ( ;;
+ (string-match "ftp:/\\(/.*@\\)\\([^/]+:\\)\\(/.*\\)" str)
+ (setq login (match-string 1 str) ;; case 3
+ host (match-string 2 str)
+ dir (match-string 3 str)
+ ret (concat login host dir)))
+ ( ;;
+ (and (string-match "ftp:/\\(/.*@\\)\\(.*\\)" str)
+ (setq login (match-string 1 str) ;; case 4
+ ref (match-string 2 str)))
+ (setq idx (ti::string-index ref ?/ ))
+ (setq host (or host (substring ref 0 idx)))
+ (setq dir (substring ref idx))
+ (setq ret (concat (or login "/ftp@") host ":" dir)))
+ ( ;; ftp://some.site/pub/users/foo/emacs/some.el
+ (and (string-match "ftp://\\([^@/]+\\)\\(:?/.*\\)" str)
+ (setq host (match-string 1 str)
+ dir (match-string 2 str)))
+ (setq ret (concat
+ "/ftp@" host
+ (if (ti::string-index dir ?:) "" ":") ;add colon if needed
+ dir)))
+
+ ( ;; ftp://some.site
+ (and (string-match "ftp://\\([^@:]+\\)$" str)
+ (setq host (match-string 1 str)))
+ (setq ret (concat "/ftp@" host ":/"))))
+
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;; #todo: there seems to be c-backslash-region
+;;;
+(defun ti::buffer-backslash-fix-paragraph
+ (&optional target-column stop-func verb)
+ "Fix \\ lines in current paragraph.
+The first \\ Tells what the target column is. If there is no \\ anywhere
+in the paragraph, this function does nothing.
+
+Input:
+
+ TARGET-COLUMN position backslashes to this column, if possible.
+ if \\[universal-argument] or negative number,
+ remove backslashes.
+ STOP-FUNC If this function returns non-nil, then stop adding
+ backslashes. It is called prior the line is handled.
+ VERB Verbose messages.
+
+Example 1:
+
+ This is \\
+ Here is another ;; Note missing \\
+ and \\ ;; Note, extra \\, should not be there
+
+ Will be formatted as:
+
+ This is \\ ;; Target column, when TARGET-COLUMN is nil
+ Here is another \\ ;; Because the target-cool couldn't be set.
+ end
+
+Example 2:
+
+ This is ;; Ignored, no \\
+ Here is another \\ ;; Target starts here
+ And still..
+ end
+
+ Will be formatted as:
+
+ This is
+ Here is another \\
+ And still.. \\ ;; Added
+ end
+
+Example 3:
+
+All the lines in this procmail example are together, but it would be wrong
+to add final \\ to the end of ')'. The STOP-FUNC can make sure about that.
+
+{
+ :0 h # this is procmail code
+ * condition
+ | ( formail -rt \\
+ MORE-OPTIONS | \\
+ $SENDMAIL -t)
+}"
+ (interactive "*P")
+ (let* ((point (point))
+ (cs (or comment-start "[ \t]*"))
+ (stop-re (format "^\\(%s\\)?[ \t]*$" cs)) ;Paragraph end
+ (kill-it (or (ti::listp target-column)
+ (and (integerp target-column)
+ (< target-column 0))))
+
+ indent-tabs-mode ;No tabs allowed
+ beg
+ col-target
+ col-now
+ col-word
+ ad-it)
+ (ti::verb)
+ ;; ............................................... paragraph start ...
+ (beginning-of-line)
+ (while (and (not (eobp))
+ (not (looking-at stop-re)))
+ (forward-line -1))
+ ;; .................................... forward to first backslash ...
+ ;; Skip comment lines and emtuy line forward.
+ (while (and (not (eobp))
+ (looking-at stop-re))
+ (forward-line 1))
+ (when (eq major-mode 'makefile-mode)
+ (if (looking-at ".*:") ;; Go path the TARGET: RULE
+ (forward-line 1)))
+ ;; ... ... ... ... ... ... ... ... ... ... .. &starting target-col ...
+ (save-excursion ;Find the starting \\
+ (beginning-of-line)
+ (while (and (not (eobp))
+ (not (looking-at ".*[\\][ \t]*$"))
+ (not (looking-at stop-re)))
+ (forward-line 1))
+ (setq beg (point)))
+ (goto-char beg) ;We landed here
+ (cond
+ ((not (looking-at ".*[\\]"))
+ (message "\
+Fix backslash: Nothing to do; no \ mark at the paragraph beginning."))
+ (t
+ (goto-char (match-end 0))
+ (backward-char 1)
+ (setq col-target (or (and
+ ;; User gave this value
+ (integerp target-column)
+ (>= target-column 0)
+ target-column)
+ (current-column))) ;; use column from code them
+ (when kill-it
+ (delete-char 1)
+ (delete-horizontal-space))
+ ;; there was old starting \\, but not in the right column. Fix it,
+ ;; but only if it was far left.
+ ;;
+ ;; txt txt \ ;; this line is too far right
+ ;; T \ ;; The target column user wanted was T
+ (when (and (null kill-it)
+ (not (eq (current-column) col-target)))
+ (delete-region (point) (line-end-position))
+ (move-to-column col-target)
+ (when (or (null stop-func)
+ (and stop-func
+ (null (funcall stop-func))))
+ (insert "\\")))
+ (unless (looking-at "$") ;Remove garbage
+ (delete-region (point) (line-end-position)))
+ (beginning-of-line)
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... .. loop-lines . .
+ ;; Empty line terminates
+ (while (and
+ (not (eobp))
+ (not (looking-at stop-re))
+ (or (null stop-func)
+ (and stop-func
+ (null (funcall stop-func)))))
+ (save-excursion ;Peek next line
+ (forward-line 1)
+ (setq ad-it (not (looking-at stop-re))))
+ ;; ... ... ... ... ... ... ... ... ... ... ... fix backslashes ...
+ (cond
+ (kill-it
+ (when (looking-at ".*[\\]")
+ (goto-char (match-end 0)) (backward-char 1)
+ (delete-char 1)
+ (delete-horizontal-space)))
+ ((looking-at ".*[\\]")
+ (goto-char (match-end 0)) (backward-char 1)
+ (setq col-now (current-column))
+ ;; Where is the word start?
+ (skip-chars-backward " \t\\")
+ (untabify (point) (line-end-position))
+ (setq col-word (current-column))
+ (cond
+ ((and (eq col-now col-target)
+ (null ad-it))
+ ;; remove Extra \\
+ (move-to-column col-now)
+ (delete-char 1)
+ (delete-horizontal-space))
+ ((not (eq col-now col-target))
+ ;; This \
+ ;; GFile.here \ < This is further right
+ (cond
+ ((> col-word col-target)) ;Do nothing, can't "line up"
+ (t
+ (move-to-column (min col-target col-now))
+ (delete-region (point) (line-end-position))
+ (when ad-it
+ (ti::buffer-move-to-col col-target)
+ (insert "\\")))))))
+ ;; ... ... ... ... ... ... ... ... ... ... .. no-continuation ..
+ (ad-it ;No previous "\" and next line exist
+ (end-of-line)
+ (delete-horizontal-space) ;Clear the EOL
+ ;; Only if there is no text, T is target, but next line has
+ ;; longer line.
+ ;;
+ ;; T
+ ;; This rule here \
+ (if (<= (current-column) col-target)
+ (ti::buffer-move-to-col col-target))
+ (insert "\\")))
+ (forward-line 1))))
+ (goto-char point) ;Restore user position
+ (when verb
+ (cond
+ (kill-it
+ (message "Fix backslash: backslashes removed."))
+ (col-target
+ (message
+ "Fix backslash: backslashes in column %d" col-target))))))
+
+;;; ----------------------------------------------------------------------
+;;; - in many C/C++ styles the variables are names so that they start
+;;; with lowercase letters and following ones are catenated + first char
+;;; in upcase.
+;;; - Function names may start with uppercase.
+;;;
+;;;
+(defun ti::buffer-upcase-words-to-variable-names (beg end &optional case-fold)
+ "Does following conversion by searhing caps only words in region.
+
+ THE_COLUMN_NAME --> theColumnName
+
+Input:
+
+ BEG END region bounds
+ CASE-FOLD the value of `case-fold-search'. nil means that the
+ upcase \"words\" are counted only. Non-nil accepts
+ seearching mixed case words."
+ (interactive "*r\nP")
+ (let* ((case-fold-search case-fold) ;; case is significant..
+ (ptable (syntax-table)) ;; previous
+ (table (make-syntax-table))
+ f1
+ f2)
+ (save-restriction
+ (unwind-protect
+ (progn
+ (narrow-to-region beg end)
+ (ti::pmin)
+ ;; let's make sure the _ is not in a word class, put it
+ ;; into some other class for now.
+
+ (modify-syntax-entry ?_ "_" table)
+ (set-syntax-table table)
+ (while (re-search-forward "[A-Z][A-Z_]+" nil t)
+ (setq beg (match-beginning 0)
+ end (match-end 0))
+ (save-excursion
+ (setq f1 (looking-at "[ \t]\\|$"))
+ (goto-char (1- beg))
+ (setq f2 (looking-at "[ \t]\\|$")))
+ (cond
+ ((and f1 f2)
+ ;; make first word "lowercase only"
+ (goto-char beg)
+ (downcase-word 1)
+ ;; handle next words, until space/eol/eob is seen
+ (while (and (not (eobp))
+ (not (looking-at "[ \t]\\|$")))
+
+ ;; Remove that underescore
+ ;; Capit. command moves forward while doing
+
+ (and (looking-at "_")
+ (delete-char 1))
+ (capitalize-word 1)))))
+ ;; ... ... ... ... ... ... ... ... ... ... ... .. unwind end . .
+ ;; Now, make sure the old table is restored,
+ ;; the unwind protects against Ctrl-g
+ (set-syntax-table ptable))))
+ ;; let-defun end
+ nil))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::string-nth-from-number (nbr)
+ "Return string representing NBR position: st, nd, th.
+
+Input:
+ string or number in digit form.
+
+Return:
+ \"st\", \"nd\", \"th\""
+ (if (stringp nbr)
+ (setq nbr (string-to-int nbr)))
+ (cond
+ ((eq nbr 1) "st")
+ ((eq nbr 2) "nd")
+ ((eq nbr 3) "rd")
+ ((> nbr 3) "th")
+ (t
+ (error "invalid ARG" nbr))))
+
+;;; ----------------------------------------------------------------------
+;;; #todo
+;;; - Did 19.29+ change the current-time function? Oh my...say no?
+;;; --> should handle it if the format changed.
+;;;
+(defun ti::date-time-elements (&optional zero-form time-string)
+ "Return list of elements derived from `current-time'.
+This is old function, you should use newer `format-time-string'.
+
+Input:
+
+ ZERO-FORM make sure numbers have preceeding zeroes. Like 7 --> 07
+ TIME-STRING user supplied time string in `current-time' format.
+
+Return list form: \( dd mm ...\)
+
+ 0 dd nbr, day if zero-form: ti::string-value
+ 1 mm nbr, month if zero-form: ti::string-value
+ 2 yy 2nbr, year
+ 3 tt 2nbr, hh:mm
+ 4 wd 3str, week day, string like 'Mon'
+ 5 m str, month, full string
+ 6 yyyy 4str, whole year"
+ (interactive)
+ (let (time m mm dd yy tt wd yyyy)
+ (setq time (or time-string
+ (current-time-string))) ;"Wed Oct 14 22:21:05 1987"
+ (setq wd (substring time 0 3))
+ (setq m (substring time 4 7))
+ (setq mm (or (ti::date-month-to-number m) 0))
+ ;; we remove trailing space "2 " --> 2 --> "2"
+ (setq dd (string-to-int (substring time 8 10)))
+ (setq tt (substring time -13 -8))
+ (setq yy (substring time -2 nil))
+ (setq yyyy (substring time -4 nil))
+ (cond
+ (zero-form ;convert "7" --> "07"
+ (setq dd (int-to-string dd))
+ (setq mm (int-to-string mm))
+ (if (not (eq (length dd) 2))
+ (setq dd (concat "0" dd)))
+ (if (not (eq (length mm) 2))
+ (setq mm (concat "0" mm)))))
+ (list dd mm yy tt wd m yyyy)))
+
+;;; ----------------------------------------------------------------------
+;;; - This is mainly used, if you read the regexp from the buffer:
+;;; obviously you can't just pick it from there:
+;;;
+;;; "find this\t+"
+;;; ^^
+;;; and use it in re-search-XXX commands. See function ti::buffer-get-re
+;;; which does the conversion automatically by calling these functions.
+;;;
+(defun ti::string-char-to-escape-char (item)
+ "Converts ITEM to escape sequence \"t\" --> \"\\t\".
+
+Input:
+
+ item integer, character, or single string
+
+Return:
+
+ nil if cannot identify ITEM.
+ string escape char"
+ (let* (el ret
+ (table
+ '(("a" . 7)
+ ("b" . 8)
+ ("f" . 12)
+ ("n" . 10)
+ ("r" . 13)
+ ("t" . 9)
+ ("v" . 11))))
+ (if (integerp item)
+ (setq item (char-to-string item)))
+ (if (setq el (assoc item table))
+ (setq ret (char-to-string (cdr el))))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::string-plain-string-to-regexp (str)
+ "Convert slashes in STR \\\ --> \.
+If you read from buffer two some special characters, it can't be
+used like that right a way for regexp. E.g. in buffer \\\\ two slashes mean
+one slash actually when assigned to string to form the regexp."
+ (let* ((ret "")
+ (i 0)
+ (len (length str))
+ (look-ch ?\\)
+ (prev-ch ?d) ;just some dummy
+ (count 0)
+ chs
+ ch)
+ (while (< i len)
+ (setq ch (aref str i)
+ chs (char-to-string ch))
+ (if (eq ch look-ch) ;add counter when EQ
+ (incf count))
+ (cond
+ ((eq count 2) ;two successive ?
+ (if (eq prev-ch look-ch)
+ (setq count 0) ;delete second
+ (setq ret (concat ret chs))
+ (setq count 0)))
+ ((eq count 1)
+ (if (eq ch look-ch)
+ ;; Right now it was found
+ (setq ret (concat ret chs))
+ ;; - Count is still 9, but we aren't looking at double \\ ?
+ ;; --> there is \t sequence
+ ;; - we revove last char and put our sequence instead
+ (setq ret (concat
+ (substring ret 0 (1- (length ret)))
+ (ti::string-char-to-escape-char chs)))
+ (setq count 0)))
+ (t
+ (setq ret (concat ret chs))))
+ (setq prev-ch ch )
+ (incf i))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;; arc.mode.el -- This is from 19.28 distrib.
+;;;
+(defun ti::file-access-mode-to-string (mode)
+ "Turn an integer MODE, 0700 (i.e., 448) into a mode string like -rwx------."
+ (let ((str (make-string 10 ?-)))
+ (or (zerop (logand 16384 mode)) (aset str 0 ?d))
+ (or (zerop (logand 8192 mode)) (aset str 0 ?c)) ; completeness
+ (or (zerop (logand 256 mode)) (aset str 1 ?r))
+ (or (zerop (logand 128 mode)) (aset str 2 ?w))
+ (or (zerop (logand 64 mode)) (aset str 3 ?x))
+ (or (zerop (logand 32 mode)) (aset str 4 ?r))
+ (or (zerop (logand 16 mode)) (aset str 5 ?w))
+ (or (zerop (logand 8 mode)) (aset str 6 ?x))
+ (or (zerop (logand 4 mode)) (aset str 7 ?r))
+ (or (zerop (logand 2 mode)) (aset str 8 ?w))
+ (or (zerop (logand 1 mode)) (aset str 9 ?x))
+ (or (zerop (logand 1024 mode)) (aset str 3 (if (zerop (logand 64 mode))
+ ?S ?s)))
+ (or (zerop (logand 2048 mode)) (aset str 6 (if (zerop (logand 8 mode))
+ ?S ?s)))
+ str))
+
+;;; ----------------------------------------------------------------------
+;;; See also convert-standard-filename which e.g. changes forward slashes
+;;; to backward slashes under win32.
+;;;
+(defun ti::file-name-for-correct-system (path system)
+ "Convert PATH to correct system: 'emacs, 'dos or 'cygwin.
+
+Input:
+
+PATH Path name. This must already be in expanded form.
+ Use Emacs function `expand-file-name' as needed.
+
+SYSTEM 'cygwin => convert to cygwin path notation
+ 'dos => convert to DOS notation.
+ 'emacs => convert to notation which current Emacs uses.
+ If running Win32 native Emacs, convert to DOS.
+ If running Cygwin Emacs, convert to cygwin.
+
+Notes:
+
+ In native Win32 Emacs, the choice 'emacs work correctly only if package
+ cygwin-mount.el is active. The cygwin path are handled by it."
+ (when (stringp path)
+ (when (string-match "~\\|\\.\\." path) ;; Need absolute path
+ (setq path (expand-file-name path)))
+ (cond
+ ((eq system 'emacs)
+ (setq path (w32-expand-file-name-for-emacs path))
+ (let ((func 'cygwin-mount-substitute-longest-mount-name))
+ (when (and (ti::emacs-type-win32-p)
+ path
+ (and (string-match "^/" path))
+ (fboundp func))
+ ;; Need to convert Cygwin => DOS path
+ (setq path (funcall func path)))))
+ ((eq system 'cygwin)
+ (setq path (w32-expand-file-name-for-cygwin path)))
+ ((eq system 'dos)
+ (if (string-match "^/cygdrive/" path)
+ (setq path (w32-cygwin-path-to-dos path))))))
+ path)
+
+;;}}}
+
+;;{{{ Version control, RCS delta files
+
+;;; ....................................................... &rcs-delta ...
+;;; In general, do not use these function, but use the top-level ones
+;;; that deal with filenames or buffers.
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::vc-rcs-delta-get-revisions (&optional buffer)
+ "Parse all revision numbers from delta file BUFFER.
+
+Return:
+ '(version version ..)"
+ (let* (list)
+ (save-excursion
+ (if buffer
+ (set-buffer buffer))
+ (ti::pmin)
+ (while (re-search-forward "^[0-9.]+[0-9]+$" nil t)
+ (push (match-string 0) list)))
+ ;; preserve order
+ (nreverse list)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::vc-rcs-delta-get-file (file buffer)
+ "Read delta FILE to temporary BUFFER.
+The delta file is truncated to header info only.
+
+Input:
+
+ FILE RCS file
+ BUFFER Existing buffer where to put delta.
+
+Errors:
+
+ VC Generates error if file is not vc registered.
+
+Return:
+
+ buffer Possibly newly created buffer."
+ (let* ((rcs-name (vc-name file))) ;; CVS returns entries.
+ (if (or rcs-name
+ (error "Not an RCS file. %s" file))
+ (with-current-buffer buffer
+ (erase-buffer)
+ (if (fboundp 'vc-insert-file) ;19.30
+ (ti::funcall 'vc-insert-file rcs-name "^desc")
+ (insert-file-contents rcs-name)
+ (buffer-disable-undo)
+ (set-buffer-modified-p nil)
+ (auto-save-mode nil)
+ (if (re-search-forward "^desc" nil t)
+ (delete-region (point) (point-max))))))
+ buffer))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::vc-rcs-delta-lock-status (&optional user-name)
+ "Return lock status by reading the delta buffer.
+If USER-NAME is non-nil return locks only for that user.
+
+Return:
+ ((USER . (VER VER ..)) (U . (V V)) ..)
+ nil"
+ (let (user
+ ver
+ ret)
+ (save-excursion
+ (ti::pmin)
+ ;; locks
+ ;; jaalto:1.13; strict;
+ ;; comment @; @;
+ (when (re-search-forward "^locks" nil t)
+ (forward-line 1)
+ (while (re-search-forward
+ "^[ \t]+\\([^:]+\\):\\([^;\n\r]+\\)"
+ nil t)
+ (setq user (ti::remove-properties (match-string 1))
+ ver (ti::remove-properties (match-string 2)))
+ (if (or (null user-name)
+ (ti::string-match-case (regexp-quote user-name) user))
+ (cond
+ ((assoc user ret) ;already a user in list
+ (ti::assoc-append-inside 'assoc user ret ver))
+ (t
+ (if (null ret)
+ (setq ret (list (cons user (list ver))))
+ (push (cons user (list ver)) ret ))))))
+ (forward-line 1)))
+ (nreverse ret)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::vc-rcs-delta-lock-status-user (user)
+ "Return list of locks for USER.
+This is toplevel function to `ti::vc-rcs-delta-lock-status'.
+Please use it directly if you want other users information too.
+If you only need *one* users information, use this function, because
+it hides the lock data structure.
+
+Return:
+ (VER VER ..) ,list of version strings.
+ nil"
+ ;; this always parses the buffer.
+ (cdr-safe (assoc user (ti::vc-rcs-delta-lock-status))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::vc-rcs-delta-highest-version ()
+ "Return the highest version from delta buffer."
+ (interactive)
+ (save-excursion
+ (ti::pmin)
+ (if (re-search-forward "head[ \t]+\\([.0-9]+\\)" nil t)
+ (match-string 1))))
+
+;;}}}
+;;{{{ Version control, general
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::vc-dir-p (file-or-dir)
+ "Check if FILE-OR-DIR looks like version controlled.
+Return type: 'rcs, 'cvs, 'monotone, 'subversion 'git' 'bzr' 'hg' or 'arch.
+Note, the return value is LIST."
+ (let ((dir (cond
+ ((file-directory-p file-or-dir)
+ file-or-dir)
+ ((or (file-name-directory file-or-dir)
+ (let ((buffer (or (get-buffer file-or-dir)
+ (get-file-buffer file-or-dir)
+ (find-buffer-visiting file-or-dir))))
+ (and buffer
+ (file-name-directory
+ (buffer-file-name buffer))))))))
+ (check '(("CVS/Entries" cvs)
+ (".svn" subversion)
+ ;; #todo: Correct these
+ (".git" git)
+ (".hg" hg)
+ (".bzr" bzr)
+ ("MT" monotone)
+ ("arch" arch)))
+ ret)
+ (setq dir (file-name-as-directory dir))
+ (dolist (elt check)
+ (multiple-value-bind (try type) elt
+ (setq try (concat dir try))
+ (if (or (file-exists-p try)
+ (file-directory-p try))
+ (push type ret))))
+ ret))
+
+;;}}}
+;;{{{ Version control, string, RCS information
+;;; ............................................................. &rcs ...
+;;; Refer to GNU RCS ident(1) how to construct valid identifiers.
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::vc-rcs-read-val (str)
+ "Cleans the RCS identifiers from the STR and return the value."
+ (let* ((re ".*[$][^ \t]+: \\(.*\\) [$]"))
+ (if (and (stringp str)
+ (string-match re str))
+ (match-string 1 str)
+ nil)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::vc-rcs-look-id (str)
+ "Return the RCS identifier in STR."
+ (let* ((re ".*[$]\\([^ \t]+\\): .* [$]"))
+ (if (string-match re str)
+ (match-string 1 str)
+ nil)))
+
+;;}}}
+;;{{{ Version control, CVS
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::vc-cvs-to-cvs-dir (file)
+ "Return CVS directory for file."
+ (concat (file-name-directory file) "CVS"))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::vc-cvs-to-cvs-dir-p (file)
+ "Check if there is CVS directory for file. Return CVS path if CVS exist."
+ (let* ((path (ti::vc-cvs-to-cvs-dir file)))
+ (when (file-directory-p path)
+ path)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::vc-cvs-to-cvs-file (file cvs-file)
+ "Use FILE or directory and return CVS/CVS-FILE, like `Root'.
+If CVS-FILE does not exist, return nil."
+ (let* ((path (ti::vc-cvs-to-cvs-dir file))
+ (root (and path (concat path "/" cvs-file))))
+ (when (and root
+ (file-exists-p root))
+ root)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::vc-cvs-to-cvs-file-content (file cvs-file)
+ "Use FILE or directory name as base and return contents of CVS-FILE as string."
+ (let* ((file (ti::vc-cvs-to-cvs-file file cvs-file)))
+ (when file
+ (with-temp-buffer
+ (insert-file-contents file)
+ (buffer-string)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::vc-cvs-file-exists-p (file)
+ "Return cvs-entry if FILE is in VCS controlled.
+Look into CVS/Entries and return line from it if file was CVS controlled."
+ (let* ((cvs-dir (ti::vc-cvs-to-cvs-dir-p file))
+ cvs-file)
+ (when (and cvs-dir
+ (file-directory-p cvs-dir)
+ (setq cvs-file (concat cvs-dir "/Entries"))
+ (file-exists-p cvs-file))
+ (with-temp-buffer
+ ;; CVS/Entries contain information on files in repository
+ (ti::find-file-literally cvs-file (current-buffer))
+ ;; /tinylib.el/1.1.1.1/Thu Dec 24 04:34:10 1998//
+ (if (re-search-forward
+ (concat "^/" (regexp-quote (file-name-nondirectory file)))
+ nil t)
+ (ti::read-current-line))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::vc-cvs-entry-split (line)
+ "Split cvs /Entries LINE into pieces.
+/add-log.el/1.1.1.2.2.4/Wed Jan 05 11:25:14 2000//Tb20_4
+D/calendar////"
+ (when line
+ (split-string line "/")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::vc-cvs-entry-type (line)
+ "Return type 'dir or 'file for cvs /Entries LINE"
+ (when line
+ (cond
+ ((string-match "^D/" line) 'dir)
+ ((string-match "^/" line) 'file) )))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::vc-cvs-entry-split-info (info what)
+ "Request information on the CVS Entries line INFO.
+Input:
+
+ INFO list returned by `ti::vc-cvs-entry-split'
+ WHAT list of returned values: 'file 'revision 'time 'rest."
+ (let* (ret)
+ (dolist (type (ti::list-make what))
+ (push (cond
+ ((eq type 'file) (nth 0 info))
+ ((eq type 'revision) (nth 1 info))
+ ((eq type 'time) (nth 2 info))
+ ((eq type 'rest) (nth 4 info))
+ ((error "Invalid WHAT arg %s" type)))
+ ret))
+ ;; preserve order.
+ (nreverse ret)))
+
+;;}}}
+;;{{{ Version control, RCS
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::vc-rcs-file-p (file)
+ "Return t if FILE STRING is in RCS controlled form.
+That is, if FILE has ,v at the end."
+ (and (> (length file) 2)
+ (string= (substring file -2) ",v")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::vc-rcs-make-filename (file &optional vc-subdir)
+ "Constructs RCS controlled FILE name. VC-SUBDIR is by default RCS/.
+FILE --> PATH/vc-subdir/FILE,v"
+ (let* (ret
+ fn
+ dir)
+ (cond
+ ((ti::vc-rcs-file-p file)
+ (setq ret file))
+ (t
+ (setq dir (or (file-name-nondirectory file) "./"))
+ (setq fn (file-name-directory file))
+ (setq ret (concat dir (or vc-subdir "RCS/") fn ",v"))))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::vc-rcs-file-exists-p (file)
+ "Return t if equivalent RCS FILE can be found.
+If the following condition is met, then such file exists:
+ ~/dir1/dir2/file.cc --> ~/dir1/dir2/RCS/file.cc,v"
+ (let* ((rcs (ti::vc-rcs-make-filename file)))
+ (file-exists-p rcs)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::vc-rcs-normal-file (rcs-file)
+ "Return normal file when version controlled RCS-FILE is given."
+ (let* (( case-fold-search nil))
+ (when (ti::vc-rcs-file-p rcs-file)
+ (setq rcs-file (replace-regexp-in-string "RCS/" "" rcs-file))
+ (setq rcs-file (replace-regexp-in-string ",v" "" rcs-file)))
+ rcs-file))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::vc-rcs-sort-same-level-list (list)
+ "Sort RCS revision LIST, which are at same level.
+Ie. when only the last version number changes:
+1.1 1.2 1.3, or 1.2.1.1 1.2.1.3 1.2.1.10"
+ (let* ((max 0)
+ ptr
+ new-list
+ len
+ ret
+ padd
+ str)
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... .. greatest ...
+ (dolist (nbr list) ;find greatest. 1.xx
+ (setq max (max (length nbr) max)))
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... ... .. padd ...
+ (setq ptr list)
+ (dolist (elt ptr) ;padd 1.1 --> 1.01
+ (setq len (length elt))
+ (unless (eq len max)
+ (setq padd (make-string (- max len) ?0))
+ (if (not (string-match "[0-9]+$" elt))
+ (setq elt nil) ;Invalid entry
+ (setq str (match-string 0 elt) )
+ (setq elt (ti::replace-match 0 (concat padd str) elt))))
+ (if elt
+ (push elt new-list)))
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... ... .. sort ...
+ (setq new-list (sort new-list 'string<))
+ ;; Check if the values are doubled, and only then fix the list.
+ ;; Hmm, if this happens, then the error is not in the 'sort'
+ ;; but somewhere else.
+;;; (cond
+;;; ((and new-list (string= (nth 0 new-list)
+;;; (nth 1 new-list)))
+;;; (setq new-list (ti::list-remove-successive new-list 'string=))
+;;; ))
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... remove padd ...
+ (setq ptr new-list)
+ (dolist (elt ptr) ;fix 1.01 > 1.1
+ (when (string-match "\\.\\(0+\\)[1-9][0-9]*$" elt)
+ (setq elt (ti::replace-match 1 "" elt)))
+ (push elt ret))
+ (nreverse ret)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::vc-rcs-files-in-dir (&optional dir re)
+ "Return all RCS controlled files in directory DIR.
+It doesn't matter if the directory points to RCS itself or
+one level up. Thus the two DIR parameters are identical:
+
+ /mydir/ takes longer to execute.
+ /mydir/RCS/
+
+The DIR parameter can hold filename, but only the directory portion
+is used. If no directory portion exists \"./\" will be used.
+
+Filenames returned do not have any \",v\" extensions or directories.
+
+Optional RE tells to return files matching RE only.
+
+Return:
+ list (file file ..)"
+ (let* ((re (or re ".")) ;default to match all
+ d
+ fn
+ fnn
+ list
+ ret)
+ (if (null (file-directory-p dir))
+ (error "Not a directory"))
+ (setq d (or (and dir
+ (or (file-name-directory (expand-file-name dir))
+ "./"))
+ "./"))
+ (cond
+ ((ti::string-match-case "RCS/?" d)
+ (setq list (directory-files d nil re))
+ (dolist (elt list)
+ (set fn (replace-regexp-in-string ",v$" "" elt))
+ (push fn ret)))
+ (t
+ (setq list (directory-files d nil re))
+ (dolist (fn list)
+ (setq fnn (concat d fn)) ;with directory
+ (if (and (not (file-directory-p fnn))
+ (ti::vc-rcs-file-exists-p (concat d fn)))
+ (push fn ret)))))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;; - The vc. does not return the _version_ latest.
+;;; See vc-hook/ vc-fetch-properties
+;;;
+(defsubst ti::vc-rcs-head-version (file)
+ "Get latest version, the head, for FILE.
+No errors generates although file is not in RCS tree.
+
+Return:
+ string version string
+ nil not an rcs file"
+ (with-temp-buffer
+ ;; May not be RCS file
+ (ignore-errors (ti::vc-rcs-delta-get-file file (current-buffer)))
+ (ti::vc-rcs-delta-highest-version)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::vc-rcs-guess-buffer-version (file &optional user)
+ "Try to guess right version number for buffer visiting FILE.
+If file is locked, look at delta log to find out version, otherwise call
+`ti::vc-rcs-buffer-version' and consult vc if needed.
+
+Input:
+
+ FILE file name
+ USER rcs user name, defaults to (user-login-name)
+
+Return:
+
+ string
+ nil"
+ (let* ((user (or user (user-login-name)))
+ list
+ ver)
+ (when (not buffer-read-only) ;It's Checked Out
+ ;; Never trust the ID string in the buffer, always look
+ ;; at delta file --> this may be checked out with -k and
+ ;; then RCS strings are not updated.
+ (with-temp-buffer
+ (ti::vc-rcs-delta-get-file file (current-buffer))
+ ;; We're interested in current user's locks only
+ (setq list (ti::vc-rcs-delta-lock-status user))))
+ (cond
+ ((and list
+ (eq 1 (length list))
+ (setq list (cdr (car list)))
+ (eq 1 (length list)))
+ ;; Okay, only 1 version locked, then we're safe
+ (setq ver (car list)))
+ (t
+ (setq ver
+ (or (save-excursion
+ (set-buffer (get-file-buffer file))
+ (ti::vc-rcs-buffer-version))
+ (vc-file-getprop file 'vc-workfile-version)
+ nil))))
+ ver))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::vc-rcs-buffer-version (&optional buffer)
+ "Return version number for optional BUFFER.
+Supposes that RCS string 'Revision' 'Id' or 'Log' exist.
+If they do not exist, then see if VC is loaded and look at the modeline.
+
+Please use `ti::vc-rcs-guess-buffer-version' and not this function."
+ (let* (rev
+ tmp)
+ (save-excursion
+ (if buffer
+ (set-buffer buffer))
+ (ti::widen-safe
+ (ti::pmin)
+ (cond
+ ((setq tmp (ti::vc-rcs-str-find "Revision"))
+ (setq rev (ti::vc-rcs-read-val tmp)))
+ ((ti::vc-rcs-str-find "Log" )
+ (forward-line)
+ (setq rev (ti::buffer-match ".*Revision +\\([0-9.]+\\)" 1)))
+ ((setq tmp (ti::vc-rcs-str-find "Id" 'value))
+ (setq rev (nth 1 (split-string tmp " ")))))))
+ ;; See if VC is installed and ask from it then.
+ (if (and (null rev)
+ (fboundp 'vc-mode-line))
+ (setq rev (ti::string-match "[^.0-9]*\\([.0-9]+\\)" 1
+ (or (symbol-value 'vc-mode) ""))))
+ rev))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::vc-rcs-rlog-get-revisions ()
+ "REad all revision numbers from rcs rlog buffer.
+The line searched looks like:
+
+ revision 1.10 locked by: loginName;
+ revision 1.9
+
+Return:
+
+ list revision numbers
+ nil"
+ (let* ((re "^revision[ \t]+\\([.0-9]+\\)$")
+ ver
+ list)
+ (save-excursion
+ (ti::pmin)
+ (while (re-search-forward re nil t)
+ (if (setq ver (match-string 1))
+ (push ver list))))
+ (nreverse list)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::vc-rcs-all-versions (file)
+ "Return string list of all version numbers for FILE."
+ (with-temp-buffer
+ (ti::vc-rcs-delta-get-file file (current-buffer))
+ (ti::vc-rcs-delta-get-revisions)))
+
+;;; ----------------------------------------------------------------------
+;;; For big files this is real slow, since building up lists and
+;;; sort the revisions is hard
+;;;
+(defun ti::vc-rcs-previous-version (version v-list)
+ "Return previous version for FILE.
+Do not call this function Often, since it may be quite time consuming.
+
+Input:
+
+ VERSION ,lever as string, e.g. \"1.5\"
+ V-LIST ,all version numbers for file, order not significant.
+
+Return:
+
+ RCS tree previous version
+ 1.5 1.4
+ 1.4 1.3
+ 1.3 1,2
+ 1.3.1.1 1.3
+ 1.3.1.2 1.3.1.1
+ 1.2 1.1
+ 1.1 nil"
+ (let* (branch-list
+ list
+ tmp
+ ret)
+ (setq branch-list (ti::vc-rcs-get-all-branches version v-list))
+ (cond
+ ((null branch-list)
+ ;; record the error to *Message* buffer
+ (message "Tinylib: [rcs] This level does not have version? %s" version))
+ ;; after 1.1.1.1 we go up one level, to 1.1
+ ((setq ret (ti::string-match"\\([.0-9]*\\).1.1$" 1 version)))
+ (t
+ (setq list branch-list tmp nil)
+ (dolist (elt list)
+ (if (not (string= elt version))
+ (setq tmp elt)
+ (setq ret tmp)
+ (return)))))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::vc-rcs-get-all-branches (rev rev-list)
+ "Return sorted braches, lowest first, at same revion level.
+
+Input:
+
+ REV version number string
+ REV-LIST list of version numbver string
+
+Example:
+
+ if version is 1.2, return all 1.x branches
+ if version is 1.2.1.1, return all 1.2.1.x branches"
+ (let* (list
+ val)
+ (if (null val) ;Quiet XEmacs 19.14 ByteComp
+ (setq val (ti::string-match ".*\\." 0 rev))) ;remove last number
+ (setq
+ list
+ (ti::list-find rev-list
+ rev
+ ;; - The count thing just makes sure we get
+ ;; 1.1 and 1.2 , not 1.1.1.1
+ ;; - match makes sure that the start of the string is same
+ ;; 1. --> 1.2 1.3 1.4
+ (function
+ (lambda (arg elt)
+ (and (eq (count-char-in-string ?. arg)
+ (count-char-in-string ?. elt))
+ (string-match val elt))))
+ 'all-matches))
+ (when list
+ ;; Simple (setq list (sort list 'string<)) won't do the job,
+ ;; since it claims 1.10 is before 1.9
+ ;;
+ ;; 1.1
+ ;; 1.10 ;; see ?
+ ;; 1.2
+ ;; 1.9
+ (setq list (ti::vc-rcs-sort-same-level-list list)))
+ list))
+
+;;}}}
+;;{{{ Version control, buffer's RCS strings, other
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::vc-version-string-p (version)
+ "Test if VERSION looks like version number N.N, N.N.N etc."
+ (and (stringp version)
+ (string-match "^[0-9]+\\.[0-9]+\\(\\.[0-9]+\\)*$" version)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::vc-version-simple-p (version)
+ "test if VERSION is simple N.N; N.N.N would be complex."
+ (and (stringp version)
+ (eq 1 (count-char-in-string ?. version))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::vc-version-lessp (a b &optional zero-treat)
+ "Return t if A is later version than B.
+This function can only check only three levels; up till: NN.NN.NN.
+
+Examples:
+
+ 2 > 1.1
+ 1.11 > 1.3
+ 1.3.1 > 1.1
+
+Input
+
+ A Version string one
+ B Version string two
+ ZERO-TREAT If non-nil, consider version numbers starting with 0.NN
+ never than 2.1. In this case it is assumed
+ that zero based versions are latest development releases."
+ (flet ((version (str regexp)
+ (if (string-match regexp str)
+ (string-to-number (match-string 1 str))
+ 0)))
+ (let* ((a1 (version a "^\\([0-9]+\\)"))
+ (a2 (version a "^[0-9]+\\.\\([0-9]+\\)"))
+ (a3 (version a "^[0-9]+\\.[0-9]+\\.\\([0-9]+\\)"))
+ (b1 (version b "^\\([0-9]+\\)"))
+ (b2 (version b "^[0-9]+\\.\\([0-9]+\\)"))
+ (b3 (version b "^[0-9]+\\.[0-9]+\\.\\([0-9]+\\)")))
+ (or (and zero-treat
+ (and (= a1 0)
+ (> b1 0)))
+ (> a1 b1)
+ (and (= a1 b1)
+ (> a2 b2))
+ (and (= a1 b1)
+ (= a2 b2)
+ (> a3 b3))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::vc-rcs-str-find (str &optional mode)
+ "Try to find rcs string STR starting from the point forward.
+
+Return:
+
+ By default whole string is returned.
+ If MODE is non-nil, the value of rcs identifier is returned."
+
+ ;; RCS keywords are like this:
+ ;;
+ ;; $ Revision:
+
+ (let* ((re (concat "[$]" str ":[^$]+[$]"))
+ ret)
+ (if (null (re-search-forward re nil t))
+ nil
+ (setq ret (match-string 0))
+ (if (null mode)
+ ret
+ (ti::vc-rcs-read-val ret)))))
+
+;;; ----------------------------------------------------------------------
+;;; - In fact this should be macro, defsubst
+;;;
+(defsubst ti::vc-rcs-str-find-buffer (str &optional mode)
+ "Try to find rcs string STR starting from `point-min'.
+Return:
+
+ By default whole string is returned.
+ If MODE is non-nil, the value of rcs identifier is returned.
+
+Example call:
+
+ (ti::vc-rcs-str-find-buffer \"Id\" 'value)"
+ (save-excursion
+ (ti::widen-safe
+ (ti::pmin)
+ (ti::vc-rcs-str-find str mode))))
+
+;;}}}
+
+;;{{{ Date
+
+;;; ............................................................ &date ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::date-standard-rfc-regexp (&optional type time)
+ "Return RFC date matching regexp: Feb 9 16:50:01.
+Input:
+
+ TYPE \"mon\" .. \"mon-date-hh-mm-ss\" What elements to inlcude.
+ TIME if not set, use `current-time'.
+
+Note it makes no sense to request \"mon-mm\", because the return
+value si cumulated. Do not leave out directived from the middle, but
+tag in order:
+
+ mon
+ mon-date
+ mon-date-hh
+ mon-date-hh-mm
+ mon-date-hh-mm-ss."
+ (or time
+ (setq time (current-time)))
+ (let* ((mon (format-time-string "%b" time))
+ (dd (ti::string-trim-blanks
+ (format-time-string "%e" time)))
+ (hh (format-time-string "%H" time))
+ (mm (format-time-string "%M" time))
+ (ss (format-time-string "%S" time))
+ ret)
+ (cond
+ ((not (stringp type))
+ nil)
+ (t
+ (when (string-match "mon" type)
+ (setq ret (concat (or ret "") mon)))
+ (when (string-match "date" type)
+ (setq ret (concat (or ret) " +" dd)))
+ (when (string-match "hh" type)
+ (setq ret (concat (or ret) " +" hh)))
+ (when (string-match "mm" type)
+ (setq ret (concat (or ret) ":" mm)))
+ (when (string-match "ss" type)
+ (setq ret (concat (or ret) ":" ss)))))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;; #defalias (defalias 'time-now 'ti::date-standard-date)
+;;;
+
+(when (fboundp 'format-time-string) ;19.29+
+ (defun ti::date-standard-date (&optional type time)
+ "Return time RFC 'Nov 07 1995 20:49' or in SHORT
+Input:
+ TYPE return YYYY-MM-DD instead (ISO 8601).
+ if 'minutes, return YYYY-MM-DD HH:MM.
+ TIME-STRING User supplied string in format `current-time-string'."
+ (cond
+ ((eq 'minutes type)
+ (format-time-string "%Y-%m-%d %H:%M" (or time (current-time))))
+ (type
+ (format-time-string "%Y-%m-%d" (or time (current-time))))
+ (t
+ (format-time-string "%b %d %Y %H:%M"
+ (or time (current-time)))))))
+
+;;; ---
+(unless (fboundp 'format-time-string)
+ (defun ti::date-standard-date (&optional type time)
+ "Return Time 'Nov 10th 1995 20:49'.
+Input:
+ TYPE return YYYY-MM-DD ISO 8601.
+ if 'minutes, return YYYY-MM-DD HH:MM.
+ TIME User supplied time in format `current-time'."
+ (interactive "P")
+ (let* ((list (ti::date-time-elements nil (current-time-string
+ (or time (current-time)))))
+ nbr)
+ (cond
+ (type
+ (setq nbr (cdr (assoc (nth 5 list) (ti::month-mm-alist))))
+ (concat
+ (nth 6 list) "-"
+ (int-to-string nbr)
+ "-"
+ (int-to-string (nth 0 list))
+ (if (not (eq type 'minutes))
+ ""
+ (concat " " (nth 3 list)))))
+ (t
+ (concat (nth 5 list) " "
+ (int-to-string (nth 0 list))
+ (ti::string-nth-from-number (nth 0 list)) " "
+ (nth 6 list) " "
+ (nth 3 list)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::date-month-to-number (arg &optional mode)
+ "Return month number for string or vice versa.
+
+When MODE is nil
+
+ Accepts Jan or January with any case --> Return nbr or nil
+
+When MODE is non-nil
+
+ Accepts nbr or str-nbr --> return str or nil"
+ ;; (interactive)
+ (let ((alist
+ '(("jan" . 1) ("feb" . 2) ("mar" . 3) ("apr" . 4)
+ ("may" . 5) ("jun" . 6) ("jul" . 7) ("aug" . 8)
+ ("sep" . 9) ("oct" . 10) ("nov" . 11) ("dec" . 12)))
+ len
+ idx
+ el
+ ret
+ str)
+ (cond
+ ((eq nil mode)
+ (setq len (length arg))
+ (if (> len 3) (setq arg (substring str 0 3))) ; cut to 3 chars
+ (setq idx (downcase arg))
+ (if (setq el (assoc idx alist))
+ (setq ret (cdr el))))
+ (t
+ (if (stringp arg) (setq arg (string-to-int arg)))
+ (setq idx arg)
+ (if (setq el (rassq idx alist))
+ (setq ret (car el)))))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::date-time-difference (a b &optional float)
+ "Calculate difference beween times A and B optionally in FLOAT seconds.
+The input must be in form of '(current-time)'
+The returned value is difference in seconds.
+E.g. if you want to calculate days; you'd do
+\(/ (ti::date-time-difference a b) 86400) ;; 60sec * 60min * 24h"
+ (if float
+ (progn
+ (multiple-value-bind (s0 s1 s2) a
+ (setq a (+ (* (float (ash 1 16)) s0)
+ (float s1) (* 0.0000001 s2))))
+ (multiple-value-bind (s0 s1 s2) b
+ (setq b (+ (* (float (ash 1 16)) s0)
+ (float s1) (* 0.0000001 s2))))
+ (- a b))
+ (let ((hi (- (car a) (car b)))
+ (lo (- (car (cdr a)) (car (cdr b)))))
+ (+ (lsh hi 16) lo))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::date-time-diff-days (std1 std2)
+ "Return approximation of time difference in days.
+STD1 and STD2 are two standard times in short format YYYY-MM-DD.
+In calculation each month is supposed to have 30 days and a year 356 days."
+ (let ((re "\\([0-9][0-9][0-9][0-9]\\)-\\([0-9]+\\)-\\([0-9]+\\)")
+ y1 m1 d1
+ y2 m2 d2
+ ret)
+ (string-match re std1)
+ (setq y1 (string-to-int (match-string 1 std1))
+ m1 (string-to-int (match-string 2 std1))
+ d1 (string-to-int (match-string 3 std1)))
+ (string-match re std2)
+ (setq y2 (string-to-int (match-string 1 std2))
+ m2 (string-to-int (match-string 2 std2))
+ d2 (string-to-int (match-string 3 std2)))
+ (if (>= (- d2 d1) 0) ;day2 is smaller
+ (setq ret (- d2 d1))
+ (setq ret (- (+ 30 d2) d1))
+ (decf m2))
+ (incf ret (* 30 (- m2 m1)))
+ (incf ret (* 356 (- y2 y1)))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;; Try this: (ti::date-parse-date "Wed, 21 Jul 93 09:26:30 EST")
+;;;
+(defun ti::date-parse-date (str)
+ "Try to parse date field.
+
+Return:
+
+ list ,(dd mm yy tt wd m yy tz)
+ \"\" in fields which weren't identified.
+
+ list members:
+ 0 YYYY year 4 numbers
+ 1 mm month number
+ 2 dd day number
+ 3 tt hh:mm nbr:nbr
+ 4 wd week day string e.g. \"Mon\"
+ 5 m month string e.g. \"Jun\"
+ 7 tz time zone e.g. [+-]nnnn, where n = number"
+ (let* (wd
+ dd
+ mm
+ m
+ yyyy
+ tt
+ tz
+
+ (rAaa "\\([A-Z][a-z][a-z]\\)")
+ (rd "\\([0-9][0-9]?\\)") ;; typical day nbr
+ (rd4 "\\([0-9][0-9][0-9][0-9]\\)") ;; typical year nbr (regexp day)
+ (rt "\\([0-9]+:[0-9:]+\\)") ;; time
+ ;; UTC+2 GMT+2
+ (rz "\\([+-][0-9]+\\|[A-Z][A-Z][A-Z]+[^ \t\n]*\\)?") ;; timezone
+ (re-yyyy
+ (concat rd4 " +" rt)) ;; 1994 08:52:25
+ (re-yy
+ (concat rd " +" rt)) ;; 94 08:52:25
+ (re-wd
+ (concat rAaa ",? +" rd " +" rAaa)) ;; weekday: Mon, 24 Oct
+ (re-dd
+ (concat rd ",? +" rAaa " +")) ;; 24 Oct
+ ;; (current-time-string) Wed Oct 14 22:21:05 1987
+ (re-wd-4y
+ (concat re-wd " +" re-yyyy " *" rz )) ;; Mon, 24 Oct 1994 08:52:25 +0200
+ (re-wd-2y
+ (concat re-wd " +" re-yy " *" rz )) ;; Mon, 24 Oct 94 08:52:25 +0200
+ (re-dd-yyyy ;
+ (concat re-dd re-yyyy " *" rz)) ; 24 Oct 1994 00:28:04 GMT
+ (re-dd-yy
+ ;; 24 Oct 94 00:28:04 GMT
+ (concat re-dd re-yy " *" rz)))
+ ;; Tue, 1 Nov 1994 8:52:36 +0300 (EET)
+ (cond
+ ((or (string-match re-wd-4y str)
+ (string-match re-wd-2y str))
+ (setq wd (match-string 1 str)
+ dd (match-string 2 str)
+ m (match-string 3 str)
+ yyyy (match-string 4 str)
+ tt (match-string 5 str)
+ tz (match-string 6 str)))
+ ;; 24 Oct 1994 00:28:04 GMT
+ ((or (string-match re-dd-yyyy str)
+ (string-match re-dd-yy str))
+ (setq dd (match-string 1 str)
+ m (match-string 2 str)
+ yyyy (match-string 3 str)
+ tt (match-string 4 str)
+ tz (match-string 5 str))))
+ (when (and yyyy (eq (length yyyy) 2))
+ (setq yyyy (concat
+ (if (string-match "^[789]" yyyy) "19" "20")
+ yyyy)))
+ (when m
+ (setq mm (format "%02d" (ti::date-month-to-number m))))
+ (when dd
+ (setq dd (format "%02d" (string-to-int dd))))
+ (list yyyy mm dd tt wd m tz)))
+
+;;}}}
+;;{{{ string(s), chars
+
+;;; ########################################################## &string ###
+
+;;; ----------------------------------------------------------------------
+;;; #defalias (defalias 'string-repeat 'ti::string-repeat)
+;;;
+(defun ti::string-repeat (count char-or-string)
+ "Repeat COUNT times CHAR-OR-STRING."
+ (let* ((i 0)
+ ret)
+ (if (characterp char-or-string) ;; XEmacs compatibility needed
+ (setq char-or-string (char-to-string char-or-string)))
+
+ (if (integerp char-or-string)
+ (setq ret (make-string count char-or-string))
+ (setq ret "")
+ (while (< i count)
+ (setq ret (concat ret char-or-string))
+ (incf i)))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::string-syntax-info (char &optional verb)
+ "Return brief syntax definition string for CHAR. VERB."
+ (interactive "cShow syntax of char: ")
+ (let* ((syntax (char-syntax char ))
+ (elt (assq syntax ti::var-syntax-info))
+ (verb (or verb (interactive-p)))
+ ret)
+ (setq ret
+ (concat
+ (char-to-string syntax)
+ " "
+ (if elt (nth 1 elt) "")))
+ (if verb
+ (message ret))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::string-syntax-kill-double-quote ()
+ "Kill double quote string syntax class for current buffer.
+This is usually useful when you turn on `font-lock' in current
+buffer where there won't be equal amount of \" and ' pairs.
+Your highlighting will then work as expected after syntaxes are killed."
+ (interactive)
+ (let ((table (make-syntax-table)))
+ (modify-syntax-entry ?\" "_" table)
+ (set-syntax-table table)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::string-tabify (string &optional mode)
+ "Tabify STRING, or if MODE is non-nil, untabify."
+ (let* ((indent-tabs-mode t)) ;makes sure tabs are used.
+ (with-temp-buffer
+ (insert string)
+ (if (null mode)
+ (tabify (point-min) (point-max))
+ (untabify (point-min) (point-max)))
+ (buffer-string))))
+
+;;; ----------------------------------------------------------------------
+;;; - This is slightly different than the next one. Use the one you need.
+;;;
+(defun ti::string-match-string-subs (level-list &optional string terminate)
+ "Return matcg list according to subexpression list LEVEL-LIST.
+
+Supposes that you have already done the matching. If STRING is not
+given, the buffer will be used for reading.
+
+If optional TERMINATE is non-nil, terminates if any of the matches return
+nil. In this case the return list will be empty signifying that all matches
+weren't satisfied.
+
+Input:
+ level-list list e.g. '(1 0 2)
+ string str e.g. \"testThis\"
+
+Return:
+ ( \"str\" nil \"str\" .. )
+ nil ,see TERMINATE"
+ (let* (ret
+ str)
+ (dolist (level level-list)
+ (setq str (match-string level string))
+ (if (and terminate (null str))
+ (progn
+ (setq ret nil) ;that's it then...
+ (return))
+ (push str ret)))
+ (nreverse ret)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::string-match-string-list (match-list level-list string &optional terminate)
+ "Return match list list according to subexpressions.
+
+Input:
+
+ MATCH-LIST list e.g. '(\"\\(re1\\)\" \"re2\" \"\\(cash\\(re3\\)\\)\"
+ LEVEL-LIST list e.g. '(1 0 2)
+ STRING str e.g. \"re1 re2 cashre3\"
+ TERMINATE any e.g. nil, 'terminate
+
+Supposes that you have already done the matching.
+
+If the match wasn't found in current level, it assign nil to the
+corresponding position in return list
+
+If optional TERMINATE is non-nil, terminates if any of the matches return
+nil. In this case the return list will be empty signifying that all matches
+weren't satisfied.
+
+Return:
+ ( \"str\" nil \"str\" .. )
+ nil ,see TERMINATE"
+ (let* (ret
+ str)
+ (if (not (eq (length match-list)
+ (length level-list)))
+ (error "List length mismatch."))
+ (while level-list
+ (setq str (ti::string-match (car match-list) (car level-list) string))
+ (if (and terminate (null str))
+ (setq ret nil level-list nil) ;that's it then...
+ (ti::nconc ret str))
+ (pop level-list)
+ (pop match-list))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::string-case-replace (model str &optional symmetry rest-case)
+ "Use MODEL and change case of characters in STR.
+Preserve case if SYMMETRY is non-nil.
+
+E.g. If your input is:
+
+ model: BARMAN
+ str : Foomanager
+
+and the symmetry is non-nil, you get
+
+ output: FOOMANager
+
+If the model is too short the variable REST-CASE instructs what to do
+
+ nil --> the rest of the STR will be added \"as is\"
+ 'follow --> the rest of the STR are in the same case as last
+ char in MODEL
+ 'lower --> insert rest as lowercase
+ 'upper --> insert rest as uppercase"
+ (let* ((i 0)
+ (part "")
+ case-fold-search ;case is important
+ last
+ len
+ ret
+ ch
+ ch-model)
+ (if (null symmetry)
+ str ;don't care
+ (setq len (min (length str) (length model))
+ ret "")
+ ;; ............................................ MODEL characters ...
+ (while (< i len)
+ (setq ch-model (char-to-string (aref model i))
+ ch (char-to-string (aref str i)))
+ (cond
+ ((string-match "[a-z]" ch-model)
+ (setq ch (downcase ch) last 'downcase))
+ ((string-match "[A-Z]" ch-model)
+ (setq ch (upcase ch) last 'upcase))
+ (t
+ ;; MODEL has punctuation, choose previous case
+ (if (eq last 'upcase)
+ (setq ch (upcase ch))
+ (setq ch (downcase ch)))))
+ (setq ret (concat ret ch))
+ (incf i))
+ ;; ............................................. REST characters ...
+ ;; if MODEL is too short, then determine what to do to the rest
+ ;; of the characters theat are left.
+ (when (< (length model) (length str)) ;Need to guess REST model?
+ (setq part (substring str len))
+ (cond
+ ((eq rest-case 'follow)
+ (setq ch (char-to-string (aref model (1- len)))) ;read last char
+ (cond
+ ((string-match "[a-z]" ch)
+ (setq part (downcase part)))
+ ((string-match "[A-Z]" ch)
+ (setq part (upcase part)))
+ (t
+ ;; kast char was punctuation, choose last type
+ (if (eq last 'upcase)
+ (setq part (upcase part))
+ (setq part (downcase part))))))
+ ((equal rest-case 'upper)
+ (setq part (upcase part)))
+ ((equal rest-case 'lower)
+ (setq part (downcase part)))))
+ (setq ret (concat ret part))
+ ret)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::string-index (str char &optional reverse)
+ "Check STR and first CHAR position 0..nbr.
+If REVERSE is non-nil, start searching at the end of string."
+ (let ((len (length str))
+ (i -1))
+ (cond
+ (reverse
+ (while (and (>= (decf len) 0)
+ (/= (aref str len) char))) ;check character in string
+ (if (>= len 0)
+ len
+ nil))
+ (t
+ (while (and (< (incf i) len)
+ (/= (aref str i) char)))
+ (if (< i len)
+ i
+ nil)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::string-index-substring (str char &optional include right seek-end)
+ "Return left hand substring from STR maching CHAR.
+
+Input:
+
+ INCLUDE The CHAR itself is included too.
+ RIGHT Return right hand portion.
+ SEEK-END Search from the end.
+
+Example:
+
+ ;; To get only the file part, you'd say
+
+ (setq string \"user@site:~/bin/myfile\")
+ (ti::string-index-substring string ?: nil 'right)
+
+ ;; To get last item, separated by |
+
+ (setq string \"aa|bb|cc|dd\")
+ (ti::string-index-substring string ?| nil 'right 'seek-end)
+
+Input:
+
+ str string
+ char character to look in string
+ include flag, should char be included too?
+ right return right side of string
+ seek-end start looking the position from the end instead
+
+Return:
+
+ str if ch found
+ nil no ch found, or impossible condition. Like if input STR is \":\"
+ and don't want to include ?: character."
+
+ (let (idx
+ ret)
+ ;; common mistakes, prevent it immediately, because
+ ;; looking the cause in debuffer may be a bit hairy, due to
+ ;; breakout only in ti::string-index
+
+ (if (not (and str char))
+ (error "parameter error %s %s" str char))
+ (if (null (setq idx (ti::string-index str char seek-end)))
+ nil
+ (cond
+ (right
+ (setq ret (substring str
+ (if include
+ idx
+ (1+ idx)))))
+ (t
+;;; (ti::d! str include idx)
+ (setq ret (substring str
+ 0
+ (if include ;; the second parameter
+ (1+ idx )
+ idx))))))
+ (if (ti::nil-p ret) ;do not return empty strings
+ nil
+ ret)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::string-replace-one-space (str)
+ "Convers all spaces/tabs in STR into one space."
+ ;; #todo: Would using a temporary buffer + untabify + replace-regexps
+ ;; be faster?
+ (let* ((out "")
+ beg
+ end)
+ (while (and (> (length str) 0)
+ (string-match "[ \t]+\\|$" str))
+ (setq beg (match-beginning 0) end (match-end 0))
+ ;; Take only 1 space (1+ ..
+ ;;
+ ;; no more spaces ? , the "$" matched ...
+ (if (eq beg (length str))
+ (progn
+ ;; is the rest of it spaces ?
+ (if (string-match "[ \t]+$" str) nil
+ (setq out (concat out str)))
+ (setq str "")) ;found empty space
+ (setq out (concat out (substring str 0 (1+ beg))))
+ (setq str (substring str end))))
+ out))
+
+;;; ----------------------------------------------------------------------
+;;; 17 Aug 1995, gnu.emacs.help, kevinr@ihs.com (Kevin Rodgers)
+;;; - Slightly modified by jaalto
+;;;
+(defun ti::string-listify (string &optional sep)
+ "Look STRING and search SEP [whitespace] and return list of substrings."
+ (let ((start 0)
+ (sep (or sep "[^ \f\t\n\r\v]+"))
+ list)
+ (while (string-match sep string start)
+ (setq list
+ (cons (substring string (match-beginning 0) (match-end 0))
+ list))
+ (setq start (match-end 0)))
+ (nreverse list)))
+
+;;}}}
+;;{{{ buffer: line, information, dired
+
+;;; ........................................................ &ange-ftp ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::dired-buffer (dir)
+ "Return dired buffer for DIR if any."
+ (setq dir (file-name-as-directory dir)) ;; Dired uses trailing slash
+ (dolist (buffer (buffer-list))
+ (when (with-current-buffer buffer
+ (and (eq major-mode 'dired-mode)
+ (string= dired-directory dir)))
+ (return buffer))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::buffer-get-ange-buffer-list (&optional regexp)
+ "Return list of ange-ftp buffers matching optional REGEXP."
+ (ti::dolist-buffer-list
+ (and (string-match "internal.*ange" (symbol-name major-mode))
+ (string-match (or regexp "^[*]ftp") (buffer-name)))
+ 'temp-buffers))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::buffer-find-ange-buffer (user host)
+ "Find ange ftp buffer with login USER running under HOST.
+
+Return:
+
+ buffer"
+ (car-safe ;may be nil list
+ (ti::buffer-get-ange-buffer-list
+ (concat "^[*]ftp +" user "@" host "[*]"))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::buffer-find-ange-to-dired-buffer ()
+ "Find associated dired buffer for current ange-ftp buffer.
+
+Return:
+
+ list list of possible buffers
+ nil"
+ (let* ( ;; Check that we're in ange buffer "*ftp ..."
+ (name (ti::string-match "^[*]ftp +\\(.*\\)[*]" 1 (buffer-name))))
+ (when name
+ (ti::dolist-buffer-list
+ (and (eq major-mode 'dired-mode)
+ (string-match
+ name (or (symbol-value 'dired-directory) "")))))))
+
+;;; ........................................................ &uuencode ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::buffer-uu-area (&optional data-buffer buffer)
+ "Find uuencoded region forward.
+
+Input:
+
+ DATA-BUFFER Where to look, defaults to `current-buffer'.
+ BUFFER If non-nil, put uuencode data here.
+
+Return:
+
+ (beg . end) list, the uu data area
+ nil no uu after point found"
+ (let* ((case-fold-search nil) ;must use case sensitive
+ (beg-re "begin[ \t]+[0-9]+[ \t]+.")
+ (end-re "end[ \t]*$")
+ beg end
+ bol
+ leading)
+ (save-excursion
+ (set-buffer (or data-buffer (current-buffer)))
+ (and (re-search-forward beg-re nil t)
+ (setq bol (line-beginning-position))
+ (setq beg (match-beginning 0))
+ (re-search-forward end-re nil t)
+ (setq end (line-end-position))))
+ (when (and beg end buffer)
+ ;; First get the data
+ (with-current-buffer buffer
+ (erase-buffer)
+ (insert-buffer-substring data-buffer bol end)
+ ;; Remove possible leadings so that you can extract NEWS
+ ;; citated UUdata too
+ ;;
+ ;; > begin 0 cobol.el.gz
+ ;; > M'XL("!?:;S```V-O8F]L+F5L`*P\:W/;1I*?Q;H?,4'MK@A%8"0GL9PH&Z\B
+ (if (< (- beg bol) 1) ;no leading characters.
+ nil
+ (setq leading (concat "^" (make-string (- beg bol) ?.)))
+ (ti::pmin)
+ (ti::buffer-replace-regexp leading 0 ""))
+ (ti::pmax)
+ (insert "\n")))
+ (if (and beg end)
+ (cons beg end))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::buffer-uu-line-p (&optional string)
+ "Determines if current line is UUencoded. Optionally check STRING.
+The line is considered as an uu line if it has no lowercase chars and has
+length more than 50 chars. Any leading spaces and tabs are skipped to find
+the UU start [applies to buffer reading only].
+
+Return length of line if it's UU, nil if not."
+ ;; (interactive)
+ (let* ((case-fold-search nil) ;case is important
+ (at-least 50)
+ line
+ len
+ ret)
+ (cond
+ ((setq line (or string (ti::buffer-read-if-solid)))
+ (setq len (length line))
+ (if (and (not (string-match "[a-z]" line)) ;--> not UU line
+ (> len at-least)) ;must be longer than xx chars
+ (setq ret len))))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::buffer-area-bounds (beg end)
+ "Search area bounds delimited by _strings_ BEG and END.
+First searches backward, them forward.
+
+Return:
+ (beg-point . end-point)
+ nil"
+ (condition-case nil
+ (let (p pp)
+ (save-excursion
+ (search-backward beg)
+ (setq p (point))
+ (search-forward end)
+ (setq pp (point)))
+ (if (< (point) pp) (cons p pp) nil))
+ (search-failed
+ nil)))
+
+;;}}}
+
+;;; ########################################################## &Buffer ###
+
+;;{{{ buffer: reading lines, chars
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::buffer-parse-grep-line ()
+ "Parse grep(1) formatted line. FILE:LINE:<content>.
+Return:
+ '(file line content)."
+ (let* (file
+ line
+ rest)
+ (save-excursion
+ (beginning-of-line)
+ (cond
+ ((looking-at "^[ \t]*\\([^:\r\n]+\\):\\([0-9]+\\):\\(.*\\)")
+ ;; file:nbr:<rest>
+ (setq file (match-string 1)
+ line (match-string 2)
+ rest (match-string 3)))
+ ((looking-at "^[ \t]*\\([a-zA-Z]:[^:\r\n]+\\):\\([0-9]+\\):\\(.*\\)")
+ ;; d:/home/path/file.txt
+ (setq file (match-string 1)
+ line (match-string 2)
+ rest (match-string 3))))
+ (when line
+ (if (string-match "^[0-9]+$" line)
+ (setq line (string-to-int line))
+ (setq line nil)))
+ (when file
+ (list file line rest)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::buffer-parse-grep-line2 ()
+ "Parse 'file nbr' format. Return '(file line)."
+ (save-excursion
+ (beginning-of-line)
+ (when
+ (or (looking-at "^[ \t]*\\([^ \t\n:]+\\)[ \t]+\\([0-9]+\\)[ \t:]+")
+ (looking-at (concat ".*line[ \t,\n]+\\([0-9]+\\)[ \t,\n]+"
+ "file[ \t,\n]+\\([^ \t\n:)]+\\)")))
+ (list
+ (match-string 1)
+ (match-string 2)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::buffer-parse-line-main ()
+ "Find directory from the previous 'cd' command.
+Look current line first and if it has no directory part,
+search backward.
+
+Line formats recognized are:
+
+ FILE:LINE: results
+ FILE LINE results
+
+ Or the format can be following, where tokens can span multiple lines
+
+ line LINE, file LINE results
+
+Note:
+
+ You should probably call `ti::file-name-for-correct-system' to convert
+ the filename to current Emacs and OS. (Like reading Cygwin paths under
+ native NT Emacs)
+
+Return:
+
+ (file line) information
+ nil not valid line"
+ (let* ( ;; (drive "\\([a-zA-Z]:\\)?")
+ (cd-re1 ".*cd +\\(.*\\)")
+ (cd-re2 "^cd +\\(.*\\)")
+ path
+ elt
+ line
+ ret
+ file)
+ ;; ................................................ grep-format ...
+ (when (setq elt (or (ti::buffer-parse-grep-line)
+ (ti::buffer-parse-grep-line2)))
+ (setq file (nth 0 elt)
+ line (nth 1 elt))
+ ;; ..................................................... Paths ...
+ (cond ;Unix, Dos paths
+ ((save-excursion
+ (and (null (string-match (concat "^/\\|^[a-z]:[\\/]") file))
+ (or (looking-at cd-re1)
+ (re-search-backward cd-re2 nil t)))
+ (setq path (match-string 1))))
+ (buffer-file-name ;Another condition
+ ;; If we loaded erorr log file from the same directory: try it
+ ;;
+ ;; weblint file.html > file.err
+ ;;
+ ;; --> then load file.err into emacs and start jumping to errors.
+ (setq path (file-name-directory buffer-file-name))))
+ ;; ./dir/file --> dir/file
+ (if (and (stringp file)
+ (string-match "^\\.[/\\]" file))
+ (setq file (ti::replace-match 0 nil file)))
+ (setq ret (list (if path
+ (ti::file-make-path path file)
+ file)
+ line)))
+
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::buffer-join-region (beg end)
+ "Join the region BEG END into a single line."
+ (interactive "*r")
+ (save-excursion
+ (goto-char end)
+ (while (> (point) beg)
+ (delete-indentation)))
+ (beginning-of-line))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::buffer-read-if-solid ()
+ "Read from current point all the non-whitespace characters.
+Ignores leading and trailing whitespace."
+ (let* ((eol (line-end-position))
+ beg
+ ret)
+ (save-excursion
+ (if (looking-at "[ \t]")
+ (skip-syntax-forward " " eol))
+ (setq beg (point))
+ (unless (eolp)
+ (skip-chars-forward "^ \t" eol)
+ (if (eq (point) beg) ;not moved
+ (end-of-line)) ;no trailing spaces
+ (unless (eq (point) beg)
+ (setq ret (buffer-substring beg (point))))))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::buffer-read-whitespace (&optional point)
+ "Gets whitespace following the point or optional at POINT.
+Return:
+ '' if no whitespace
+ str whitespace string"
+ (let* ((re-w "[ \t]+") ;whitespace
+ mp ;maximum point, end of line
+ op)
+ (save-excursion
+ (if (null point)
+ (setq op (point))
+ (setq op point)
+ (goto-char point))
+ (setq mp (line-end-position))
+ (if (or (null (looking-at re-w)) ;not sitting on whitespace
+ (null (re-search-forward re-w mp t)))
+ ""
+ (buffer-substring op (point))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::buffer-read-paragraph ()
+ "Read paragraph at point."
+ (save-excursion
+ (beginning-of-line)
+ (when (looking-at ".*[^ \t]")
+ (backward-paragraph)
+ (let* ((beg (point)))
+ (forward-paragraph)
+ (buffer-substring beg (point))))))
+
+;;; ----------------------------------------------------------------------
+;;; - if you use outline or folding, please open the buffer first
+;;; otw lines cannot be read correcly [the \n is missing if file
+;;; has closed folds]
+;;;
+(defun ti::buffer-read-line (&optional len skip)
+ "Read whole line from buffer.
+Input:
+
+ LEN Only read LEN characters.
+ If LEN is more than line has characters then return whole line.
+ SKIP Ignores SKIP count characters from beginning of line.
+ If there is not that many to skip, return full line."
+ (let* ((line (ti::read-current-line))
+ (len-full (length line)))
+ (if (null skip) nil
+ (cond
+ ((and len (> len skip))
+ (setq line (substring line skip)))
+ ((eq len skip) (setq line ""))))
+ (if (and len (< len len-full))
+ (substring line 0 len)
+ line)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::buffer-grep-lines (re &optional beg end inc-prop)
+ "Greps lines matching RE from buffer.
+
+Optionals:
+
+ BEG default is `point-min'
+ END default is `point-max'
+ INC-PROP do not remove properties while reading lines.
+
+Return:
+
+ nil or \(str str str ..\)"
+ (let* ((beg (or beg (point-min))) ;point begin
+ (end (or end (point-max))) ;point end
+ list
+ line)
+ (save-excursion
+ (goto-char beg)
+ (while (re-search-forward re end t)
+ (setq line (ti::read-current-line))
+ (if (null inc-prop)
+ (setq line (ti::remove-properties line)))
+ (ti::nconc list line)
+ (forward-line 1)))
+ list))
+
+;;}}}
+;;{{{ buffer: matching, reading words, chars
+
+;;; ....................................................... &b-reading ...
+
+;;; ----------------------------------------------------------------------
+;;; The bad thing is that it is impossible slow, so
+;;; use it only when time is not critical (not in loops)
+;;;
+(defun ti::buffer-looking-back-at (re)
+ "Return t if text immediately before point match RE.
+This function modifies the match data that `match-beginning',
+`match-end' and `match-data' access; save and restore the match
+data if you want to preserve them.
+
+Note:
+ Use only if you need this badly. It's impossible slow."
+ (let ((beg (point))
+ ret)
+ (while (and (null ret)
+ (re-search-backward re nil t))
+ (setq ret (eq (match-end 0) beg)))
+ (goto-char beg)
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::buffer-read-char (&optional direction distance)
+ "Read character towards the DIRECTION from current point.
+nil = forward, non-nil backward. DISTANCE 0/nil means reading from
+current position.
+
+Return:
+
+ nbr read char value
+ nil if the position is not within `point-min-marker' and
+ `point-max-marker'."
+ (let* ((beg (point-min-marker))
+ (end (point-max-marker))
+ (pos (or distance 0))
+ (dest (if direction
+ (- (point) (1+ pos))
+ (+ (point) pos)))
+ (read (if (or (< dest beg) (> dest end))
+ nil
+ t)))
+ (if (null read)
+ nil ;allowed to read ?
+ (char-after dest))))
+
+;;; ----------------------------------------------------------------------
+;;; - You can define the "word" syntax here without changing syntax entries.
+;;; - If you want to get word according to current mode's syntax table,
+;;; use following instead
+;;;
+;;; (require 'thingatpt) ;19.29
+;;; (word-at-point)
+;;;
+(defun ti::buffer-read-word (&optional charset strict)
+ "Return word specified by optional CHARSET after point.
+If optional STRICT is non-nil, requires that point is sitting on
+CHARSET before continuing. If there is no CHARSET under point,
+search forward for word.
+
+Limitations:
+
+ Cannot read word that starts at beginning of buffer
+
+Return:
+ str word or nil."
+ (let* ((charset (or charset "-a-zA-Z0-9_"))
+ (not (concat "^" charset)))
+ (save-excursion
+ (if (or (null strict)
+ (and strict (looking-at charset)))
+ (buffer-substring
+ (progn
+ (skip-chars-forward not)
+ (skip-chars-backward charset)
+ (point))
+ (progn
+ (skip-chars-forward charset)
+ (point)))))))
+
+;;; ----------------------------------------------------------------------
+;;; - This is totally different from the other word reading funcs,
+;;; it gives you the word separated by spaces. For more finer control see,
+;;; CHARSET in ti::buffer-read-word
+;;;
+(defun ti::buffer-read-space-word ()
+ "Return word separated by spaces or bol/eol.
+If sitting on space or tab, read next word forward. If sitting in the
+middle of word, find the word beginning until bol, and start reading from
+that point. Point is moved to the beginning of word.
+
+Return:
+ str
+ nil empty line"
+ (let* ((bol (line-beginning-position))
+ p) ;point
+ (cond
+ ((or (bobp)
+ (equal (char-syntax (preceding-char)) ?\ ))
+ ;; At the beginning of word, first char
+ nil)
+ ((looking-at "[^ \t\n]")
+ (setq p (point))
+ (skip-chars-backward "^ \t\n" bol)
+ ;; (skip-syntax-backward " " bol)
+ (if (eq p (point)) ;jump not done.
+ (beginning-of-line))) ;text starts at bol
+ ((looking-at "[ \t\n]")
+ (skip-chars-forward " \t\n"))
+ ((save-excursion ;is the line end of buffer
+ (end-of-line) ;--> e.g. in minibuffer
+ (eobp))
+ (beginning-of-line)))
+ (ti::buffer-read-if-solid)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::buffer-read-syntax-word (syntax &optional mode)
+ "Read block of characters from current point.
+Blocks are separated by SYNTAX Normally the block is read
+from current point forward.
+
+Input:
+ SYNTAX class like \"w\" for words.
+ MODE 'back read backward
+ 'word read full word, skip syntax forward, then backward.
+
+Return:
+
+ str
+ nil current point does not contain SYNTAX class char."
+ (let* ((beg (point))
+ end
+ ret)
+ (save-excursion
+ (cond
+ ((eq mode 'back)
+ (setq end (point))
+ (skip-syntax-backward syntax)
+ (setq beg (point)))
+ ((eq mode 'word)
+ (skip-syntax-forward syntax) (setq end (point))
+ (skip-syntax-backward syntax) (setq beg (point)))
+ (t
+ (skip-syntax-forward syntax)
+ (setq end (point)))))
+ (if (not (eq beg end))
+ (setq ret (buffer-substring beg end)))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;; #not fully tested
+;;; - Why did I do this after all ?
+;;; - This won't work if cursor it at SPACE and BOL and user wants
+;;; word BACK
+;;;
+;;;
+(defun ti::buffer-read-nth-word (&optional count mode back charset)
+ "Read COUNT nth word in line.
+
+Input:
+
+ COUNT defaults to 0 ,current word according to MODE.
+ MODE nil count from the bol/eol.
+ 'end count from the bol/eol, stop at eol/bol
+ 'this start counting from this position
+ 'thisEnd start counting from this position, stop at eol/bol
+ BACK read backward. Affects the mode parameter.
+ CHARSET use charset as \"word\", otw defaults to mode's
+ word syntax.
+
+Examples:
+
+ (ti::buffer-read-nth-word) ,return first word in line
+ (ti::buffer-read-nth-word 5 'end) ,return 5th word, but stop at eol
+
+ ;; return 5th word, counting backwards stopping at bol. Read the word
+ ;; with charset a-zA-z.
+
+ (ti::buffer-read-nth-word 5 'end 'back \"a-zA-Z\")
+
+Caveats:
+
+ You get different results, if point is already sitting at word, or
+ if it's sitting at whitespace, when using 'this modes.
+ Try yourself with `forward-word' command.
+
+ REMEMBER THAT WORD IS MODE DEPENDENT (syntax tables)
+
+Return:
+
+ str word
+ nil nth word does not exist."
+ (let* ((next-func (if back 'backward-word 'forward-word))
+ (prev-func (if back 'forward-word 'backward-word))
+ (next-skip (if back 'skip-chars-backward 'skip-chars-forward))
+ (cmp-func (if back '< '>))
+ (count (or count 0))
+ limit
+ ret)
+ (save-excursion
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... set limits ...
+ (if (memq mode '(end nil)) ;starting position
+ (if back (line-end-position) (line-beginning-position)))
+ (if (memq mode '(end thisEnd)) ;setting the limit value
+ (setq limit (if back (line-beginning-position) (line-end-position))))
+ (if (eq 0 count)
+ ;; Skip over spaces, stay put ...
+ (if (ti::char-in-list-case (following-char) '(?\t ?\ ))
+ (funcall next-skip " \t"))
+ (funcall next-func count)
+ (if (ti::char-in-list-case (following-char) '(?\t ?\ ))
+ (funcall prev-func 1)))
+ (if (and limit
+ (funcall cmp-func (point) limit))
+ nil ;limit exceeded
+ (cond
+ (charset
+ (setq ret (ti::buffer-read-word charset)))
+ (t
+ (require 'thingatpt)
+ ;; silence Bytecomp.
+ (setq ret (ti::funcall 'word-at-point)))))
+ ret)))
+
+;;}}}
+;;{{{ buffer: replacing, modifying lines
+
+;;; ..................................................... &b-replacing ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::buffer-replace-keywords-with-table (keys)
+ "Function to replace string a with string b.
+A and b are stored in a structure and b may be the result of a
+computation in itself. In other words, say we have a list of dotted
+pairs like this
+
+ ((\"$$AUTHORNAME$$\" . \"Charles R Martin\")
+ (\"$$TIMESTAMP$$\" . (current-time-string))
+
+then the function skips through the buffer doing replace-string
+$$AUTHORNAME$$ 'Charles R Martin' followed by replace-string
+$$TIMESTAMP$$ (results of 'current-time-string')."
+ (interactive
+ (list (symbol-value
+ (intern
+ (completing-read "Replace keywords using table: "
+ obarray
+ (lambda (e)
+ (and (boundp e)
+ (listp (symbol-value e)))))))))
+ (mapcar (lambda (x)
+ (save-excursion
+ (goto-char (point-min))
+ (while (search-forward (car x) nil t)
+ (replace-match (eval (cdr x))))))
+ keys))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::buffer-replace-region-with (beg end string &optional keep-point)
+ "Replace region BEG END with STRING.
+Point is after the inserted string or if KEEP-POINT is non-nil
+then point is at BEG."
+ ;; Prevent accidental delete
+ (if (not (stringp string))
+ (error "Input error."))
+ ;; mimic "r" tag region, do not kill that extra char.
+ (delete-region beg end)
+ (goto-char beg)
+ (insert string)
+ (if keep-point
+ (goto-char beg)))
+
+;;; ----------------------------------------------------------------------
+;;; The basic code for this was borrowed from zap-to-char in simple.el
+;;; (define-key esc-map "Z" 'zap-to-regexp) ; originally 'zap-to-char
+;;;
+(defun ti::buffer-zap-to-regexp (arg regexp)
+ "Kill up to and including ARG'th occurrence of REGEXP.
+Goes backward if ARG is negative; error if REGEXP not found."
+ (interactive "p\nsZap to regexp: ")
+ (kill-region
+ (point)
+ (progn
+ (search-forward-regexp regexp nil nil arg)
+ ;; This line makes zap-to-regexp behave like
+ ;; d/ and d? in vi (ie with forward deletion
+ ;; the regexp is left intact). Is this
+ ;; really the right thing? zap-to-char
+ ;; dropped this behavior. Was there a good
+ ;; reason? I like this behavior since I use
+ ;; vi frequently enough to get some benefit
+ ;; from the orthogonality.
+ (if (>= arg 0) (search-backward-regexp regexp 1))
+ ;; p.s. Yes I know the '=' doesn't really do
+ ;; much.
+ (point))))
+
+;;; ----------------------------------------------------------------------
+;;; #defalias (defalias 'leave-nth-word 'ti::buffer-leave-nth-word)
+;;; - This is great function if you have some column output generated
+;;; by SQL call or shell call, and you just want THOSE words left...
+;;;
+;;;
+(defun ti::buffer-leave-nth-word (beg end &optional nbr strict)
+ "Delete all between BEG and END except nth word NBR.
+Default word nbr is 1, ie. the first word in the line.
+The word is considered as space separated entity.
+
+REMEMBER that word is mode dependent !
+
+Input:
+
+ NBR which word top leave on line, range 1..x
+ STRICT if non-nil then if word NBR is not found delete whole line"
+ (interactive "*r\nP")
+ (let* ((nbr (or nbr 1))
+ word)
+ (save-restriction
+ (narrow-to-region beg end) (ti::pmin)
+ (while (not (eobp))
+ (beginning-of-line)
+ (setq word (ti::buffer-read-nth-word nbr 'end))
+;;; (ti::d! word)
+ (cond
+ (word
+ (delete-region (line-beginning-position) (line-end-position))
+ (insert word)
+ (forward-line 1))
+ ((and (null word) strict)
+ (ti::buffer-kill-line)) ;already does fwd-line
+ (t
+ (forward-line 1)))))))
+
+;;; ----------------------------------------------------------------------
+;;; - Easiest would have been using zap-to-char, but
+;;; it's not same in 18.xx and 19.xx
+;;; #todo: detect 19.xx and use zap, it's much quicker
+;;;
+;;;
+(defun ti::buffer-kill-line (&optional delete count)
+ "Kill line and move next line up.
+If cursor is sitting at the end of buffer, nothing happens.
+
+Input:
+
+ DELETE use `delete-region', which doesn't manipulate `kill-ring',
+ thus the execution is faster.
+ COUNT how many lines to wipe.
+
+Portable:
+
+ Between any emacs versions 18.xx - 19.xx
+
+Errors:
+
+ Never signalled.
+
+Return:
+
+ t line killed
+ nil sitting at eob, cannot kill line"
+ (interactive "*P")
+ (let* ((null-line-re "^$")
+ (count (or count 1))
+ (i 0))
+
+ ;; emacs kill-line is little awkward, because if you're at the
+ ;; end of buffer it signals an error...
+
+ (while (< i count)
+ (incf i)
+ (cond
+ ((eobp) ;nothing to kill
+ nil)
+ ((and (null (eobp)) (looking-at null-line-re))
+ (if delete
+ (delete-char 1)
+ (kill-line))
+ t)
+ (t ;shift line up
+ (beginning-of-line)
+ (if delete
+ (delete-region (point) (line-end-position))
+ (kill-line))
+ (if (null (eobp))
+ (if delete
+ (delete-char 1)
+ (kill-line)))
+ t)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::buffer-strip-control-m () ;;#todo: Emacs function?
+ "Remove control-M characters from buffer."
+ (with-buffer-modified
+ (save-excursion
+ (ti::pmin)
+ (while (re-search-forward "\r+$" nil t)
+ (replace-match "" t t)))))
+
+;;; ----------------------------------------------------------------------
+;;; #defalias (defalias 'u2d 'ti::buffer-lf-to-crlf)
+;;;
+(defun ti::buffer-lf-to-crlf (&optional arg force)
+ "Simple Unix to Dos converter. If ARG is non-nil --> Dos to Unix.
+Strips or inserts ^M (return) marker _only_ at the end of line.
+
+If optional FORCE is given, ignores possible write protection.
+
+Example:
+ (if (ti::file-dos-p)
+ (ti::buffer-lf-to-crlf 'Dos2unix 'doReadOnly))"
+ (interactive "P")
+ (let* ((stat buffer-read-only))
+ (cond
+ ((or (not stat)
+ (prog1 force (setq buffer-read-only nil))) ;turn it off
+ ;; - We use unwind, because the buffer read only status must be
+ ;; restored. User may get anxious and press C-g for large buffers...
+ ;; - I wonder if we can clear the buffer-modified flag too?
+ ;; we leave it untouched for now...
+ (unwind-protect
+ (save-excursion
+ (goto-char (point-min)) ; start at the be.g. of file
+ (if arg
+ ;; ..................................... Dos --> unix ...
+ (progn
+ (while (search-forward "\015\n" nil t)
+ (replace-match "\n"))
+ (ti::pmax)
+ (beginning-of-line)
+ ;; Maybe last line does not have newline?
+ (when (looking-at ".*\015$")
+ (end-of-line)
+ (delete-backward-char 1)))
+ ;; ....................................... unix --> dos ...
+ (end-of-line)
+ (if (not (char= (preceding-char) ?\015))
+ (insert "\015"))
+ (while (not (eobp))
+ (forward-line)
+ (end-of-line)
+ (if (not (char= (preceding-char) ?\015))
+ (insert "\015")))))
+ ;; restore value
+ (setq buffer-read-only stat))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::buffer-arrow-control (buffer &optional mode str pos)
+ "Controls showing the arrow glyph.
+
+Input:
+ BUFFER Where to put the arrow, must be visible.
+ MODE 'show show the arrow with optional STRING
+ 'hide remove the arrow. If STR is given, change the value
+ of `overlay-arrow-position'. This is usually for restoring
+ the original content.
+ 'move move to current bol position or to POS. STR argument is
+ ignored.
+ any same as 'hide
+
+ STR arrow string to use, defaults to \"=>\"
+ POS any position, converted to beginning of line
+ [Emacs docs say the arrow must be at bol]"
+ (cond
+ ;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ show ^^^
+ ((or (eq mode 'show)
+ (eq mode 'move))
+ ;; We do not touch the arrow definition, if 'move is the mode
+ (if (eq mode 'show)
+ (setq overlay-arrow-string
+ (if (stringp str) str "=>")))
+ (or overlay-arrow-position
+ (setq overlay-arrow-position (make-marker)))
+ (set-marker overlay-arrow-position
+ (if pos
+ (progn
+ (goto-char pos)
+ (line-beginning-position))
+ (line-beginning-position))
+ buffer))
+ ;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ hide ^^^
+ (t
+ (if overlay-arrow-position ;Kill the marker
+ (set-marker overlay-arrow-position nil))
+ (if (stringp str)
+ (setq overlay-arrow-string str)))))
+ ;; - Here should be some kind of buffer refresh, since
+ ;; the markes isn't hidden, if you're using read-char,
+ ;; instead of read-from-minibuffer. See [tinyreply.el] for hack.
+ ;; - Anybody knows how to refresh the view, please MAIL ME!!
+;;; Not working, I thought moving the cursor would refresh arrow state
+;;; (save-excursion
+;;; (select-window (get-buffer-window buffer))
+;;; (set-buffer buffer)
+;;; (goto-char (line-beginning-position)))
+
+;;; ----------------------------------------------------------------------
+;;; #defalias (defalias 'nl 'ti::buffer-insert-line-numbers), see unix nl(1)
+;;;
+;;; -- or is this better ?
+;;; #defalias (defalias 'insert-lines-numbers 'ti::buffer-insert-line-numbers)
+;;;
+(defun ti::buffer-insert-line-numbers (beg end &optional line grow format)
+ "Insert line numbers to buffer.
+Mark the region where to insert the line numbers.
+
+The default line format is '%02d:%s' for values lower that 100.
+For bigger values the format is dynamical (digit len derived from
+start value)
+
+Input:
+
+ BEG END point area bounds
+ LINE nbr starting line number. 1 is default
+ GROW nbr grow count. 1 is default
+ FORMAT str how line is formatted, see above
+
+Return:
+
+ --"
+ ;; We input number as string so that user may press return
+ ;;
+ (interactive "*r\nsStart line[1]: \nsInterval[1]: ")
+ (let* (
+ ;; convert strings to sensible value
+ (count (cond
+ ((integerp line) ;; calling lisp
+ line)
+ (t ;; interactive
+ (if (eq 0 (length line))
+ 1
+ (string-to-int line)))))
+ (factor (cond
+ ((integerp grow)
+ grow)
+ (t
+ (if (eq 0 (length grow))
+ 1
+ (string-to-int grow)))))
+ (digits (ti::digit-length count))
+ ;; Select "02d" when numbers < 100
+ ;; Otw, select "digits" len.
+ (fmt (or format
+ (concat
+ "%0"
+ (int-to-string
+ (if (or (= digits 1) (eq digits 2))
+ 2 digits))
+ "d:%s")))
+ line)
+ (save-restriction
+ (narrow-to-region beg end)
+ (ti::pmin)
+ (while (not (eobp))
+ (setq line (ti::read-current-line))
+ (if (not (string-equal "" line))
+ (delete-region (point) (line-end-position)))
+
+ (insert (format fmt count line))
+ (setq count (+ count factor))
+;;; (ti::d! count)
+ (forward-line 1)))))
+
+;;; ----------------------------------------------------------------------
+;;; - There must be removing function too.. :-)
+;;; #defalias (defalias 'remove-line-numbers 'ti::buffer-remove-line-numbers)
+;;;
+(defsubst ti::buffer-remove-line-numbers (beg end &optional re level)
+ "Remove line numbers from region BEG END.
+The Default line numbers are sticked to the left and have form
+
+ xxx: text txt txt
+
+where xxx represent some numbers.
+
+You can supply optional RE and regexp LEVEL that should be
+removed. E.g. in normal, above case the
+
+ RE = \"^[0-9]+:\"
+ LEVEL = 0 ,match whole regexp"
+ (interactive "*r")
+ (ti::buffer-replace-regexp
+ (or re "^[0-9]+:")
+ (or level 0)
+ ""
+ nil
+ beg
+ end))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::buffer-randomize-lines (beg end)
+ "Scramble all the lines in region BEG END.
+If region contains less than 2 lines, lines are left untouched."
+ (interactive "*r")
+ (catch 'cancel
+ (save-restriction
+ (narrow-to-region beg end)
+ ;; Exit when there is not enough lines in region
+ (if (< (- (point-max) (point-min)) 3)
+ (throw 'cancel t))
+ ;; Prefix lines with a random number and a space
+ (goto-char (point-min))
+ (while (not (eobp))
+ (insert (int-to-string (random 32000)) " ")
+ (forward-line 1))
+ ;; Sort lines according to first field (random number)
+ (sort-numeric-fields 1 (point-min) (point-max))
+ (goto-char (point-min)) ;Remove the prefix fields
+ (while (not (eobp))
+ (delete-region (point) (progn (forward-word 1) (+ (point) 1)))
+ (forward-line 1)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::buffer-make-dup-line (&optional count)
+ "Copy the current line COUNT times (default is 1) below the current line."
+ (interactive "*p")
+ (setq count (or count 1))
+ (save-excursion
+ (beginning-of-line)
+ (let ((line (buffer-substring
+ (point)
+ (progn (forward-line 1) (point)))))
+ (while (> count 0)
+ (insert line)
+ (setq count (1- count))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::buffer-inc-string-nbr (re inc-val increment &optional level)
+ "Search string and increment integers.
+
+Input:
+
+ RE regexp to match integer. Subexpr 1 assumed in interactive call
+ INC-VAL start value.
+ INCREMENT Step how much to increment every time.
+ LEVEL Subexpression in regexp to match the integer portion.
+
+E.g. I you have just paste same variable on the lines multiple times
+
+ tablevar10[10]
+ tablevar10[10]
+ tablevar10[10]
+ tablevar10[10]
+ tablevar10[10]
+
+And now you want to make them unique:
+
+ tablevar01[10]
+ tablevar02[10]
+ tablevar03[10]
+ tablevar04[10]
+ tablevar05[10]
+
+You just give RE \"r\\([0-9]+\\)\" and start value 1, increment 1"
+ (interactive "sRE: \nnstart value: \nnIncrement: ")
+ (let* ((level (or level 1))
+ len
+ beg
+ end
+ fmt)
+ (while (re-search-forward re nil t) ;search whole buffer
+ (when (match-end level)
+ (setq beg (match-beginning level)
+ end (match-end level)
+ len (- end beg)
+ fmt (concat "%0" (int-to-string len) "d"))
+ (delete-region beg end)
+ (goto-char beg)
+ (insert (format fmt inc-val))
+ (incf inc-val increment)))))
+
+;;; ----------------------------------------------------------------------
+;;; - Here is slightly different version. this increments every number
+;;; whereas the previous would increment only SUBMATCH by STEP
+;;;
+;;; - E.g. copying the first line produces:
+;;;
+;;; assign pi0_vld = (opc_i0 === alu0);
+;;; assign pi1_vld = (opc_i1 === alu1);
+;;;
+(defun ti::buffer-copy-line-and-inc-numbers (&optional increment)
+ "Copy line, preserving cursor column, and INCREMENT any numbers found.
+Prefix ARG is the increment value. Defaults to 1."
+ (interactive "p")
+ (let* ((col (current-column))
+ (line (ti::read-current-line))
+ (increment (if (integerp increment) increment 1))
+ len out
+ mark
+ num)
+ (end-of-line)
+ ;; We have to use markers, because the line is modified.
+ (setq mark (point-marker))
+ (beginning-of-line)
+ (while (re-search-forward "[0-9]+" (marker-position mark) 1)
+ (setq len (length (match-string 0)))
+ (setq num (string-to-int (match-string 0)))
+ ;; E.g. 0001 --> 0002
+ (setq out (format (concat "%0" (int-to-string len) "d")
+ (+ increment num)))
+ (replace-match out))
+ (beginning-of-line)
+ (insert line "\n")
+ (move-to-column col t)
+ ;; kill marker
+ (setq mark nil)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::buffer-copy-word (n)
+ "Copy N words above the current line.
+If there is no words above the line, then do nothing."
+ (interactive "p")
+ (let ((column (current-column))
+ copy)
+ (save-excursion
+ (beginning-of-line)
+ (if (bobp)
+ nil
+ (forward-line -1)
+ (move-to-column column t)
+ (setq copy (buffer-substring
+ (point)
+ (min (save-excursion (end-of-line) (point))
+ (save-excursion (forward-word n) (point)))))))
+ (if copy
+ (insert copy))))
+
+;;; ----------------------------------------------------------------------
+;;; #defalias (defalias 'double-space-region 'ti::buffer-newlines-to-region)
+;;;
+(defun ti::buffer-add-newlines-to-region (beg end &optional arg)
+ "Insert to to the end of each line in region BEG END ARG newlines.
+Default is to inser one which makes lines make double spaced."
+ (interactive "*r\np")
+ (save-restriction
+ (narrow-to-region beg end)
+ (ti::pmin)
+ (while (search-forward "\n" nil t)
+ (replace-match
+ (concat "\n" (make-string arg ?\n))
+ nil t))))
+
+;;; ----------------------------------------------------------------------
+;;; - STRICT parameter can be used from lisp call
+;;; #defalias (defalias 'remove-blank-lines 'ti::buffer-cnv-empty-lines)
+;;;
+(defun ti::buffer-cnv-empty-lines (beg end &optional nbr strict)
+ "Convert empty lines in region BEG END to zero empty lines.
+Optionally leaves NBR empty lines. If STRICT is non-nil, all lines
+must have NBR amount of empty lines, no more or less.
+
+Point is not preserved."
+ (interactive "*r\nP")
+ (let* ((empty-line-re "^[ \t]+$\\|\n")
+ (nbr (or nbr 0)) ;default is to leave no empty lines
+ pb pe ;points beg, end
+ count
+ do-it)
+ (save-restriction
+ (narrow-to-region beg end)
+ (ti::pmin)
+ (while (not (eobp))
+ (if (null (looking-at empty-line-re))
+ (forward-line 1)
+ (setq pb (point)) (skip-chars-forward " \t\n")
+ (beginning-of-line) (setq pe (point))
+ ;; There is a bug in count-lines, that's why we
+ ;; use line-end-position,
+ ;; not 'pe' to count the lines in region
+ (setq count (count-lines pb (line-end-position)))
+ (setq do-it nil)
+ ;; ...................................................... cond ...
+ (cond
+ ((null strict)
+ (if (> nbr count)
+ nil ;not that many lines here
+ (setq do-it t)))
+ (t
+ (setq do-it t)))
+ ;; .................................................... action ...
+ (cond
+ ((null do-it)
+ (forward-line 1)) ;skip
+ ((> count 0)
+ (delete-region pb pe)
+ (setq count nbr)
+ (while (> count 0) ;leave that many
+ (decf count) (insert "\n"))
+ (if (> count 1)
+ (beginning-of-line)
+ ;; nothing done, next line
+ (forward-line)))))))))
+
+;;; ----------------------------------------------------------------------
+;;; #defalias (defalias 'delete-duplicate-lines 'ti::buffer-del-dup-lines)
+;;;
+;;; - Letting shell to do the job is the fastest, cleanest
+;;; way. Sometimes lisp just isn't the right tool...
+;;;
+;;; A. Want to do it fast?
+;;; Camel book has ready code for this. Pg 228
+;;; $ perl -ne 'print unless $seen{$_}++' file.in > file.out
+;;;
+;;; B. How about running a shell command over the region/buffer
+;;; with command "uniq"? This filters successive lines.
+;;; C-x h , ESC-| uniq RET
+;;;
+;;;
+(defun ti::buffer-del-dup-lines(beg end &optional len white-lines)
+ "Deletes duplicate lines in buffer. Optionally compares first LEN
+characters to determine line equality.
+
+Input:
+
+ BEG,END area bounds
+ LEN portion of line: chars to compare
+ WHITE if non-nil, don't touch whitespace only lines.
+
+Requirements:
+
+ Call shell with small PERL program. Make sure PERL is along the path.
+"
+ (interactive "*r\nP")
+ (let* (cmd)
+ (save-restriction
+ (narrow-to-region beg end)
+ (ti::pmin)
+ (setq
+ cmd
+ (concat
+ "perl -ne '"
+ (if len
+ (concat "$line = substring($_,0, "
+ (int-to-string len)
+ ");")
+ "$line = $_;")
+
+ (if white-lines
+ "/^\\s*$/ && do{print; next;};")
+ "print unless $seen{$line}++;"
+ "'"))
+ (shell-command-on-region
+ (point-min)
+ (point-max)
+ ;; replace flag
+ cmd
+ t))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::buffer-delete-until-non-empty-line (&optional backward point)
+ "Delete all lines starting from current point.
+Stop on [be]obp or non-empty line. Optionally delete BACKWARD
+and start at POINT or current position.
+
+Moves point to the beginning of non-empty line."
+ (interactive "P")
+ (let* (end)
+ (when point
+ (goto-char point))
+ (beginning-of-line)
+ (setq point (point))
+ (cond
+ (backward
+ (while (and (not (bobp))
+ (looking-at "^[ \t]*$"))
+ (setq end (point))
+ (forward-line -1)))
+ (t
+ (while (and (not (eobp))
+ (looking-at "^[ \t]*$"))
+ (forward-line 1)
+ (setq end (point)))))
+ (if end
+ (delete-region point end))))
+
+;;; ----------------------------------------------------------------------
+;;; - The delete-region, according to emacs C-developers,
+;;; is _lighting_ fast way to do deletions in emacs.
+;;;
+(defun ti::buffer-trim-blanks (beg end)
+ "Delete trailing blanks in region BEG END."
+ (interactive "*r")
+ (save-restriction
+ (save-excursion
+ (narrow-to-region beg end)
+ ;; _much slower would be: (replace-regexp "[ \t]+$" "")
+ (goto-char (point-min))
+ (while (not (eobp))
+ (end-of-line)
+ (delete-horizontal-space)
+ (forward-line 1))))
+ nil) ;for possible hook
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::buffer-replace-regexp (re level str &optional back beg end)
+ "Like `replace-regexp' but for Lisp programs.
+Lisp info page says in \"Node: Style Tip\", that lisp programs shouldn't
+use `replace-regexp', so here is identical function that doesn't touch
+the mark. The point is left after last match.
+
+Input:
+
+ RE regexp
+ LEVEL subexpression
+ STR string used in replacing.
+ BACK replace backward
+ BEG END region. If both BEG and END is given, the
+ BACK parameter is ignored."
+ (let* ((func (if back 're-search-backward 're-search-forward))
+ bp
+ ep)
+ (if (not (integerp level)) ;common error
+ (error "Level is not integer."))
+ (cond
+ ((and beg end)
+ (setq bp beg ep end func 're-search-forward))
+ ((and back end)
+ (setq bp (point) ep (point-min)))
+ ((and back beg)
+ (setq bp beg ep (point-min)))
+ ((and (not back) beg)
+ (setq bp beg ep (point-max)))
+ ((and (not back) end)
+ (setq bp (point) ep end))
+ (t ;fall thru case
+ (setq bp (point) ep (point-max))))
+ (save-restriction
+ (narrow-to-region bp ep)
+ (ti::pmin)
+ (while (and (funcall func re nil t)
+ (not (eobp)))
+ (if (null (match-end level)) nil ;not matched
+ (ti::replace-match level)
+ ;; point is at the end of STR inserted
+ (insert str))))))
+
+;;}}}
+;;{{{ buffer: misc
+
+;;; ..................................................... &buffer-misc ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::buffer-diff-type-p ()
+ "Check the diff type in buffer.
+Assumes that whole buffer contains diff. Searches for traces.
+Lines must be left flushed.
+
+ *** /tmp/T.11 Fri Oct 20 12:22:51 1995
+ --- /tmp/T.1 Fri Oct 20 12:24:29 1995
+ ***************
+
+Normal diff shows:
+
+ 20,21d19
+ < clrFamily;
+ < clrInfo;
+
+Gnu diff -n (or --rcs, Output an RCS format diff)
+
+ d696 1
+ a696 1
+ (tdi-goto-kbd 'verb)
+ d704 2
+ a705 2
+
+Gnu diff -u (unified diff)
+
+ @@ -17,6 +17,8 @@
+ bAnsTime[16+1];
+ clearCode;
+ endChargeTime[16+1];
+ +clrFamily;
+ +clrInfo;
+ statClrTime[16+1];
+ clearPart;
+ aDirNbrType;
+
+Returns:
+ cons cell
+ (TYPE . POS) ,POS is the diff start position
+ nil ,no diff found
+
+ TYPE can be
+ 'context ,context diff -c
+ 'gnu-n ,gnu diff -n
+ 'gnu-u ,gnu diff -u
+ 'normal ,normal diff
+
+ POS
+ character position where the first diff was found"
+ (let* ((re-c1 "^[ \t]*[*][*][*] [0-9]") ;context diff regexps
+
+ ;; The normal diff line is following, but PGP breaks it.
+ ;; That's why we have those ? ? in thge regexp
+ ;; --- 1.2.1.1
+ ;; - --- 1.2.1.1
+ ;;
+ (re-c2 "^-? ?--- .")
+ (re-c3 (concat "^" (regexp-quote "***************")))
+ (re-n1 "^[0-9]+[dca][0-9]+$\\|^[0-9]+,[0-9]+[dca][0-9]")
+ (re-n2 "^[<>]")
+ ;; Gnu types
+ (re-gn1 "^[dac][0-9]+ [0-9]+$")
+ (re-gu1 "^@@ [-+][0-9]+,[0-9]+[ \t]+[-+]+")
+ type
+ pos
+ ret)
+ (save-excursion
+ (ti::pmin)
+ (cond
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... context ..
+ ((and (re-search-forward re-c1 nil t)
+ (setq pos (line-beginning-position))
+ (or (save-excursion
+ (and (progn
+ (forward-line 1)
+ (looking-at re-c2))
+ (progn
+ (forward-line 1)
+ (looking-at re-c3))))
+ (save-excursion
+ (forward-line -1)
+ (looking-at re-c3))))
+ (setq type 'context))
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... . normal ..
+ ((and (re-search-forward re-n1 nil t)
+ (setq pos (line-beginning-position))
+ (progn
+ (forward-line 1)
+ (looking-at re-n2)))
+ (setq type 'normal))
+ ((re-search-forward re-gu1 nil t)
+ ;; There is filename information above the diff start.
+ ;; --- file.xx
+ ;; +++ file.xx
+ ;;
+ (forward-line -2)
+ (setq pos (point))
+ (setq type 'gnu-u))
+ ((and (re-search-forward re-gn1 nil t) ;require two same lines
+ (setq pos (line-beginning-position))
+ (progn
+ (forward-line 1)
+ (looking-at re-gn1)))
+ (setq type 'gnu-n)))
+ (if (and type pos)
+ (setq ret (cons type pos)))
+ ret)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::buffer-outline-widen ()
+ "Open folded/outlined buffer if some of the modes is active.
+You have to call this function if you want to do something for
+the whole buffer."
+ (interactive)
+
+ ;; Unfold the buffer, so that we can see all.
+ ;; We must also preserve point
+
+ (ti::save-with-marker-macro
+ (and (boundp 'folding-mode)
+ ;; No autoloads allowed, this makes sure the fboundp
+ ;; is converted to real function. The ti::funcall command
+ ;; cannot use autoload function.
+ (progn (require 'folding) t)
+ (if (symbol-value 'folding-mode) ;ByteComp silencer
+ (ti::save-line-column-macro nil nil
+ ;; ByteComp silencer
+ (ti::funcall 'folding-open-buffer))))
+ (and (eq major-mode 'outline-mode)
+ (fboundp 'show-all)
+ (progn (require 'outline) t)
+ (ti::save-line-column-macro nil nil
+ (ti::funcall 'show-all)))
+ (and (boundp 'outline-minor-mode)
+ (fboundp 'show-all)
+ (progn (require 'outline) t)
+ (ti::save-line-column-macro nil nil
+ (ti::funcall 'show-all)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::buffer-buffer-list-files (&optional re str)
+ "Return all files loaded into Emacs.
+
+If optional RE and STR are given, then a file name substitution
+takes place:
+
+ args RE = \"/usr43/users/john/\" STR = \"~/\"
+ buffer file \"/usr43/users/john/t.txt\"
+ substituted \"~/t.txt\"
+
+Example:
+
+ (ti::buffer-buffer-list-files \"/usr43/users/john\" \"~\")
+
+Return:
+
+ (filename ..) list of filenames"
+ (let* (list
+ file)
+ (dolist (elt (buffer-list))
+ (setq file (buffer-file-name elt))
+ (when (stringp file) ;might be nil if buffer has no file
+ (if (and re str
+ (string-match re file))
+ (setq file (ti::replace-match 0 str file)))
+ (push file list)))
+ list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::buffer-count-words (beg end)
+ "Count words in region BEG END."
+ (interactive "r")
+ (let ((msg (count-matches "\\w*" beg end)))
+ (when (and msg
+ (string-match "\\([0-9]+\\)" msg))
+ (string-to-int msg))))
+
+;;; ----------------------------------------------------------------------
+;;; - This is quite a handy function when you're programming e.g.
+;;; in C++ and want to know how many chars are in the string.
+;;;
+(defun ti::buffer-count-chars-in-delimited-area (arg &optional verb)
+ "Counts characters within quotes. ARG C - u to search single quotes.
+Other argument invokes asking the beginning delimiter: if you give
+\"(\" the end delimiter is automatically set to \")\".
+This function is mainly for interactive use. VERB.
+
+Return:
+ nbr count of characters
+ nil begin or end delimiter was not found"
+ (interactive "P")
+ (let* ((alist '(( ?\( ?\) )
+ ( ?\{ ?\} )
+ ( ?\[ ?\] )
+ ( ?\` ?\' )
+ ( ?\< ?\> )))
+ (verb (or verb (interactive-p)))
+ beg-ch
+ end-ch
+ beg-re
+ end-re
+ re
+ elt
+ point
+ ret)
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... . preliminaries ...
+ (setq
+ re (cond
+ ((equal arg nil)
+ "\"")
+ ((equal arg '(4))
+ "'")
+ (t
+ (message "Begin delimiter char: ")
+ (setq beg-ch (read-char))
+ (setq end-ch
+ (if (setq elt (assq beg-ch alist))
+ (nth 1 elt)
+ ;; Can't find match for it, so use same char
+ ;; for both delimiters
+ beg-ch))
+ nil)))
+ (if re ;now, what we got?
+ (setq beg-re (regexp-quote re) end-re beg-re)
+ (setq beg-re (regexp-quote (char-to-string beg-ch))
+ end-re (regexp-quote (char-to-string end-ch))))
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... ... . do it ...
+ (save-excursion
+ (if (null (re-search-forward end-re nil t))
+ (and verb
+ (message (concat "Can't find end mark: " end-re)))
+ (setq point (point))
+ ;; the re-search-forward leaves point after the char,
+ ;; we have to go small step back before we change the direction.
+ (forward-char -1)
+ (if (null (re-search-backward beg-re nil t))
+ (and verb
+ (message (concat "Can't find beginning mark: " beg-re)))
+ ;; the -2 excludes the markers itself.
+ ;;
+ (setq ret (- (length
+ (buffer-substring point (point)))
+ 2))
+ (and verb
+ (message (concat (int-to-string ret) " characters."))))))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::buffer-word-move (set &optional back)
+ "Move to next word defined in SET, optionally BACK.
+SET must be string, that can be turned into regexp and that can
+be used with skip-chars functions.
+
+E.g. \"-[]$%@#&*\":;{}()<>/\\ \t\n\""
+ (interactive)
+ (let* ((nset (concat "^" set)) ;not-set
+ (set-re (concat "[" (regexp-quote set) "]"))
+ (char (char-to-string
+ (if back
+ (preceding-char)
+ (following-char))))
+ (point (point)))
+ (cond
+ (back
+ (if (string-match set-re char)
+ (progn
+ (skip-chars-backward set)
+ (skip-chars-backward nset))
+ ;; If we're over word already, this moves. But if we're
+ ;; at the beginning of word this doesn't move.
+ ;;
+ (skip-chars-backward nset)
+ (when (eq (point) point)
+ (skip-chars-backward set)
+ (skip-chars-backward nset))))
+ (t
+ (if (string-match set-re char)
+ (progn
+ (skip-chars-forward set)
+ (skip-chars-forward nset))
+ (skip-chars-forward nset)
+ (skip-chars-forward set))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::buffer-find-duplicate-same-word (&optional back)
+ "Find consecutive occurrences of same word, optionally search BACK."
+ (interactive "P")
+ (let* ((func (if back 're-search-back 're-search-forward)))
+ (if (funcall func "\\(\\<\\w*\\>\\)[ \t\n]*\\1" nil t)
+ (isearch-highlight (match-beginning 0) (match-end 0))
+ nil)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::buffer-move-paragraph-to-column (beg end col)
+ "Move text BEG END to column position COL.
+
+The indent is done in the following way:
+o untabify region
+o Search first non-whitespace line starting from the beginning
+ of region.
+o count how much the line is indented: remove that indentation
+ from all the rest of the lines.
+o Now when lines have no indet; reindent to COL
+
+The procedure described preserves the actual paragraph style, so that
+if text inside paragraph is more indented that the previous line the
+relative indent is preserved.
+
+ txt txt txt txt txt txt
+ txt txt txt txt txt txt
+ inner indent txt txt txt
+ inner indent txt txt txt
+ txt txt txt txt txt txt
+ txt txt txt txt txt txt
+
+Input:
+
+ beg always calculates to bol
+ end always calculates to eol"
+ (interactive "*r\np")
+ (let (min
+ marker
+ len)
+ (goto-char (min beg end)) ;Setting MIN
+ (setq min (line-beginning-position))
+ (goto-char (max beg end)) ;setting MAX
+ (end-of-line)
+ (setq marker (point-marker)) ;Because untabify moves end
+ (untabify min (marker-position marker))
+ ;; Is there non whitespace line?
+ (goto-char min)
+ (cond
+ ((re-search-forward "^[^ \n]" (marker-position marker) t)
+ ;; non whitespace line found.
+ ;; Do nothing -- indent directly
+ nil)
+ ((re-search-forward "^\\( +\\)[^ \n]" (marker-position marker) t)
+ ;; Remove this indentation.
+ (when (> (setq len (length (or (match-string 1) ""))) 0)
+ (indent-rigidly min (marker-position marker) (- 0 len) ))))
+ ;; Now reindent the region
+ (indent-rigidly min (marker-position marker) col) ;new
+ ;; Kill marker
+ (setq marker nil)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::buffer-move-to-col (col)
+ "Doesn't care about line length. Insert spaces to get to COL.
+Convert tabs to spaces to get to exact COL."
+ (interactive "Nto col: ")
+ (move-to-column col t)
+ (if (not (eq (current-column) col))
+ (while (< (current-column) col)
+ (insert " "))))
+
+ ;;;;; Experimental
+ ;;;(defun space-to-column (target)
+ ;;; "Insert spaces as necessary to move pt to TARGET column."
+ ;;; (interactive "p")
+ ;;; (let ((cur (current-column)))
+ ;;; (if (< cur target)
+ ;;; (insert (make-string (- target cur) ? )))))
+
+;;}}}
+;;{{{ buffer: selective display
+
+;;; ................................................... &misc-packages ...
+
+;;; ----------------------------------------------------------------------
+;;; - Separating the "effective display" is easy with this...
+;;;
+;;;
+(defun ti::buffer-selective-display-copy-to (beg end buffer &optional verb)
+ "Copy region BEG END selective display to BUFFER. VERB.
+E.g. folding.el and outline based modes use selective display."
+ (interactive
+ (progn
+ (if (not (region-active-p))
+ (error "Region not selected."))
+ (list
+ (region-beginning)
+ (region-end)
+ (read-from-minibuffer "To buffer: " "*selective display*"))))
+ (let* ((bp (get-buffer-create buffer)) ;barfs if invalid...
+ (bp (ti::temp-buffer bp 'clear)) ;ok, use it
+ line)
+ (ti::verb)
+ (save-excursion
+ (save-restriction
+ (narrow-to-region beg end)
+ (ti::pmin)
+ (while (not (eobp))
+ ;; - Reset for normal lines.
+ ;; - Or reads until \r. I.e. the hidden part is not read
+ (setq line (or (and (looking-at ".*\r")
+ (concat
+ (ti::buffer-match "\\([^\r]+\\)+\r" 1)
+ "..."))
+ (ti::read-current-line)))
+
+ (setq line (concat line "\n"))
+ (forward-line 1)
+ (ti::append-to-buffer bp line))))
+ (if verb
+ (pop-to-buffer bp))))
+
+;;; ----------------------------------------------------------------------
+;;; - Print folding.el and outline based buffer with this...
+;;;
+(defun ti::buffer-selective-display-print (beg end)
+ "Print selective display region BEG END."
+ (interactive "r")
+ (let* ((buffer (generate-new-buffer "*print*")))
+ (unwind-protect
+ (progn
+ (ti::buffer-selective-display-copy-to beg end buffer)
+ (with-current-buffer buffer (print-buffer)))
+ (kill-buffer buffer))))
+
+;;}}}
+;;{{{ Window, frames
+
+;;; .......................................................... &window ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::window-frame-list (&optional all exclude-current win)
+ "Return only frames that are non-dedicated.
+Input:
+ ALL if non-nil, return all frames.
+ EXCLUDE-CURRENT if non-nil, exclude current active frame.
+ WIN Use this is as a current window when searching
+ current frame."
+ (let* ((oframe (if win
+ (window-frame win)
+ (selected-frame)))
+ flist
+ ret)
+ (if exclude-current
+ (setq flist (delete oframe (frame-list)))
+ (setq flist (frame-list)))
+ (dolist (frame flist)
+ (select-frame frame)
+ (if (or all (not (window-dedicated-p (selected-window))))
+ (ti::nconc ret frame)))
+ (if (framep oframe)
+ (select-frame oframe)) ;Return back to original
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::window-list (&optional buffers)
+ "Gather all visible windows or BUFFERS visible in current frame."
+ (let* ((s (selected-window)) ;start window
+ (loop t)
+ (w s) ;current cycle
+ l
+ ww)
+
+ (if buffers ;Start list
+ (setq l (list (window-buffer s)))
+ (setq l (list s)))
+
+ (while loop
+ (setq ww (next-window w))
+ (setq w ww) ;change
+ (other-window 1) ;move fwd
+ (if (eq ww s) ;back to beginning ?
+ (setq loop nil)
+
+ (if buffers ;list of buffers instead
+ (setq ww (window-buffer ww)))
+ (setq l (cons ww l))))
+ (nreverse l)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::window-single-p ()
+ "Check if there is only one window in current frame."
+ ;; No need to run `length' when `nth' suffices.
+ (let* ((win (selected-window))
+ (next (next-window)))
+ ;; Same window?
+ (eq win next)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::window-get-buffer-window-other-frame (buffer)
+ "Return (frame . win). If BUFFER is visible..
+in some other frame window than in the current frame."
+ (let* (win
+ ret)
+ (dolist (frame
+ (delete (selected-frame) (frame-list)))
+ ;; maybe in other frame...
+ (when (setq win (get-buffer-window buffer frame))
+ (setq ret (cons frame win))
+ (return)))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;; - don't know good way how to generalize this to return either top/bottom
+;;; window. I guess we just copy this and make small changes...
+;;; - Does anyone have good suggestions to do therwise?
+;;;
+(defun ti::window-find-bottom (win-list)
+ "Find bottom window from WIN-LIST.
+Any non-visible window in list is skipped.
+If there are adjacent windows, return all of them.
+
+ -------------
+ | | <- top window
+ -------------
+ | | | | < three splitted windows at the bottom
+ | A| B | C |
+ -------------
+
+Return:
+ list single or many windows. In any order."
+ (let* (data
+ top
+ top-cmp
+ bot
+ bot-cmp
+ win-val
+ init)
+ (dolist (win win-list)
+ (setq data (window-edges win))
+ (if (null init) ;init vars
+ (setq init t ;initalized ok
+ win-val (list win) ;win comes from 'window-loop'
+ top (nth 1 data)
+ bot (nth 3 data)))
+
+ (setq top-cmp (nth 1 data)
+ bot-cmp (nth 3 data))
+ (cond
+ ((> bot-cmp bot) ;this is more lower
+ (setq win-val (list win)
+ top top-cmp
+ bot bot-cmp))
+ ((or (eq bot-cmp bot) ;hmm, same horizontal top row..
+ (eq top-cmp top)) ;split sideways...
+ (push win win-val))
+ ((or (eq bot-cmp bot) ; .........
+ (> top-cmp top)) ; .... .
+ ; ......... < pick lowest in left
+ (setq win-val (list win)
+ top top-cmp
+ bot bot-cmp))))
+ win-val))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::window-match-buffers (buffer-name-list)
+ "Check all windows that match BUFFER-LIST.
+
+Input:
+
+ BUFFER-NAME-LIST ,strings, list of buffer names.
+
+Return:
+
+ '((BUFFER-NAME WIN-PTR WIN-PTR ..)
+ (BUFFER-NAME ..)
+ ..)"
+ (let* (alist
+ buffer
+ ptr
+ p)
+ (dolist (win (ti::window-list))
+ ;; last walue will tell the BOTTOM
+ (setq buffer (buffer-name (window-buffer win)))
+ ;; Create alist
+ ;; '((BUFFER-NAME WIN-PTR WIN-PTR ..)
+ ;; (BUFFER-NAME ..))
+ (cond
+ ((member buffer buffer-name-list) ;does it interest us ?
+ (cond
+ ((not (setq ptr (assoc buffer alist))) ;; create initial element
+ (push (list buffer win) alist))
+ (t ;; add element
+ (setq p (cdr ptr)) ;drop 1st element away
+ (ti::nconc p win) ;add new element
+ ;; replace with new list
+ (setcdr ptr p))))))
+ (nreverse alist)))
+
+;;}}}
+;;{{{ Key maps, translations
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::keymap-single-key-definition-p (key-def)
+ "Check if KEY-DEF is a single key definition.
+E.g. If you want to check if prefix key is composed only from
+one key: \"a\" \"?\\C-a\" or even [(?a)].
+
+ (ti::keymap-single-key-definition-p [ a ] ) --> a
+ (ti::keymap-single-key-definition-p [(a)] ) --> a
+ (ti::keymap-single-key-definition-p \"a\" ) --> a
+ (ti::keymap-single-key-definition-p \"\\C-a\" ) --> C-a
+
+ (ti::keymap-single-key-definition-p [(a) (b)] ) --> nil
+ (ti::keymap-single-key-definition-p [(meta a)]) --> nil
+ (ti::keymap-single-key-definition-p \"ab\" ) --> nil
+ (ti::keymap-single-key-definition-p \"?C-ab\" ) --> nil
+
+Return:
+
+ If single key. Return it, either as character or symbol."
+ (let* ((key (cond
+ ((and (stringp key-def) ;; "\C-a" or "a"
+ (eq 1 (length key-def)))
+ (string-to-char key-def))
+ ((and (vectorp key-def) ;; [(ELT)] or [ELT]
+ (eq 1 (length key-def))
+ (eq 1 (length (elt key-def 0))))
+ (let* ((ELT (elt key-def 0))
+ (item (if (listp ELT) ;; was [(ELT)]
+ (car ELT)
+ ELT)) ;; otherwise [ELT]
+ ;; At this point; convert to string
+ (ch (cond
+ ((symbolp item) ;; mouse-1 ot the like
+ item)
+ ((characterp item) ;; was it ?a ==> [(?a)]
+ item)
+ ((and (stringp item)
+ (eq 1 (length item)))
+ (string-to-char item)))))
+ ch)))))
+ key))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::keymap-define-key-backspace ()
+ "Move C-h to Backspace if this is non-windowed Emacs.
+Key C-x C-? replaces original C-x C-h.
+Key C-c h replaces original C-h call
+"
+ (interactive)
+ (let* (;;; (DELETE "\C-h")
+ (BACKSPACE "\177"))
+ (unless (ti::compat-window-system)
+ (defvar key-translation-map (make-sparse-keymap))
+ ;; If it's nil then something is wrong. Fix it.
+ (unless key-translation-map
+ (setq key-translation-map (make-sparse-keymap)))
+ ;; This keymap works like `function-key-map', but comes after that,
+ ;; and applies even for keys that have ordinary bindings.
+ (define-key key-translation-map "\177" "\C-h")
+ (define-key key-translation-map "\C-h" "\177")
+ (global-set-key BACKSPACE 'backward-delete-char)
+ (flet ((key-warning
+ (key def)
+ (message "tinylib: Warning, key already occupied: %s %s"
+ key def)))
+ ;; (ti::define-key-if-free global-map
+ ;; "\C-x\C-?" 'help-for-help 'key-warning)
+ (ti::define-key-if-free global-map
+ "\C-ch" 'help-command 'key-warning)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::keymap-function-bind-info (function-sym &optional map)
+ "Return binding information for FUNCTION-SYM from MAP as string or nil."
+ (let* ((gm (current-global-map))
+ global-bindings
+ local-bindings
+ bind-info)
+ (setq global-bindings (where-is-internal function-sym)
+ local-bindings
+ (prog2
+ ;; We have to set this to nil because where-is-internal
+ ;; searches global map too. We don't want that to happen
+ ;;
+ (use-global-map (make-keymap))
+ (where-is-internal
+ function-sym
+ (or map (current-local-map)))
+ (use-global-map gm)))
+ (setq
+ bind-info
+ (if (or global-bindings local-bindings)
+ (format "%s%s%s"
+ (if global-bindings
+ (format "global %s"
+ (mapcar 'key-description
+ global-bindings))
+ "")
+ (if (and global-bindings local-bindings)
+ " and "
+ "")
+ (if local-bindings
+ (format "local to %s"
+ (mapcar 'key-description
+ local-bindings))
+ ""))))
+ bind-info))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;; because of the nature of minor modes, changes in the maps
+;;; are not reflected unless, the minor mode is installed again
+;;;
+;;; The following removes minor keymap, if it exists,
+;;; and reinstalls it with new added bindings.
+;;;
+(defun ti::keymap-reinstall-minor-mode (mode-name-symbol)
+ "Reinstall minor mode MODE-NAME-SYMBOL.
+This is needed if you have made changes to minor modes keymaps.
+They don't take in effect until you reinstall the minor mode.
+
+Return:
+ t minor mode found and reinstalled
+ nil no susch minor mode."
+ (let* (sym
+ mode-string
+ elt
+ map-sym
+ map)
+ (when (setq elt (assq mode-name-symbol minor-mode-alist))
+ (setq mode-string (nth 1 elt))
+ (setq elt (assq mode-name-symbol minor-mode-map-alist))
+
+ (unless elt
+ (error "No map for minor mode %s" mode-name-symbol))
+ (setq sym (concat
+ (symbol-name mode-name-symbol)
+ "-map"))
+ (setq map-sym (intern-soft sym))
+ (if (or (null map-sym)
+ (not (keymapp (setq map (eval map-sym)))))
+ (error "The keymap was not found %s" map-sym))
+ (ti::keymap-add-minor-mode mode-name-symbol nil nil 'remove)
+ (ti::keymap-add-minor-mode mode-name-symbol mode-string map))))
+
+;;; ----------------------------------------------------------------------
+;;; - Why doesn't emacs offer this simple interface by default ?
+;;;
+(defun ti::keymap-add-minor-mode
+ (mode-func-sym mode-name-sym mode-map &optional remove)
+ "Add the minor mode into Emacs. If mode exists, do nothing.
+
+Input:
+
+ MODE-FUNC-SYM function symbol, mode to turn on
+ MODE-NAME-SYM variable symbol to hold mode name string
+ MODE-MAP keymap
+ REMOVE OPTIONALLY removes mode with mode-name-sym
+
+Examples:
+
+ ;; to add mode
+ (ti::keymap-add-minor-mode 'foo-mode 'foo-mode-name foo-mode-map)
+
+ ;; to remove mode
+ (ti::keymap-add-minor-mode 'foo-mode nil nil 'remove)"
+
+ (let* (elt)
+ (cond
+ ((null remove)
+ (or (assq mode-func-sym minor-mode-map-alist)
+ (setq minor-mode-map-alist
+ (cons (cons mode-func-sym mode-map)
+ minor-mode-map-alist)))
+ ;; Update minor-mode-alist
+ (or (assq mode-func-sym minor-mode-alist)
+ (setq minor-mode-alist
+ (cons (list mode-func-sym mode-name-sym)
+ minor-mode-alist))))
+ (t
+ (and (setq elt (assq mode-func-sym minor-mode-map-alist))
+ (setq minor-mode-map-alist (delq elt minor-mode-map-alist)))
+
+ (and (setq elt (assq mode-func-sym minor-mode-alist))
+ (setq minor-mode-alist (delq elt minor-mode-alist)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::keymap-bind-control (map-symbol get-set prop key)
+ "Get or set the stored property binding in map.
+This is a good function to use if you modify the original
+bindings in the map. You can then call the original
+function behind the binding in your modified function.
+
+Input:
+
+ MAP-SYMBOL map name
+ GET-SET operation.
+ 'get = return previous property value (key definition)
+ 'set = copy definition once.
+ 'sett = (force) copy definition even if already copied.
+ The 'set copies the key definition behind the propert
+ PROP only if there is no previous value. 'sett
+ replaces the content of PROPERTY.
+ PROP property name
+ KEY string -- key binding.
+
+Examples:
+
+ (ti::keymap-bind-control 'mail-mode-map 'set 'my \"\\C-c\\C-c\")
+ --> mail-send-and-exit, saved to property 'my
+
+ (ti::keymap-bind-control 'mail-mode-map 'set 'my \"\\C-c\\C-c\")
+ --> nil, property 'my Was already set
+
+ (ti::keymap-bind-control 'mail-mode-map 'get 'my \"\\C-c\\C-c\")
+ --> mail-send-and-exit, get the saved property 'my.
+
+Live example:
+
+ ;; - first save original, then use our function. Use property
+ ;; 'my, because The C-c C-c can already be occupied by
+ ;; some other package...
+ ;; - it calls the original afterwards
+
+ (ti::keymap-bind-control 'mail-mode-map 'set 'my \"\\C-c\\C-c\")
+ (define-key mail-mode-map \"\\C-c\\C-c\" 'my-mail-func-CcCc)
+
+ (defun my-mail-func-CcCc (arg)
+ ...
+ (funcall ;; Call the original.
+ (ti::keymap-bind-control 'mail-mode-map 'get 'my \"\C-c\C-c\")
+ arg)
+ ;; Function ends here.)"
+ (let* (map
+ map-key
+ sym
+ val
+ func)
+ (unless (boundp map-symbol)
+ (error "No variable bound %s" map))
+ (setq map (eval map-symbol))
+ (unless (keymapp map)
+ (error "Not a keymap %s" map-symbol))
+ (if (or (ti::nil-p key) ;must be valid string
+ (not (stringp key)))
+ (error "Invalid KEY %s" key))
+ (setq map-key (concat (symbol-name map-symbol) key))
+ (setq func (lookup-key map key))
+ (when func ;does function exist?
+ (setq sym (intern map-key)
+ val (get sym prop))
+ (cond
+ ((eq get-set 'get)
+ val)
+ ((and (eq get-set 'set)
+ (null val)) ;set only if PROP not exist
+ (put sym prop func))
+ ((eq get-set 'sett) ;replace value
+ (put sym prop func))))))
+
+;;; ----------------------------------------------------------------------
+;;; - What is an translate table?
+;;; - Well; it says "if you press this key I give you this character back"
+;;; - It is used for remapping the keys, but beware! In X envinronment,
+;;; where you can paste data between emacs, the translation gives
+;;; unpleasant results. Try pasting the _normal_ \ char from other
+;;; window to emacs that uses transltion presented in example below.
+;;; --> you get the | character pasted into Emacs
+;;;
+(defun ti::keymap-translate-table (&optional arg)
+ "Make new translate table.
+
+Input ARG
+
+ 'use Start using the new table if the
+ `keyboard-translate-table' if nil. Otherwise does nothing.
+ 'use-new replace current table with fresh one
+ nil return new, default translate table.
+
+Examples:
+
+ Switch these keys. Let's assume the \\ key is on top after this,
+ since it is used more often in emacs.
+
+ (ti::keymap-translate-table 'use)
+ (aset keyboard-translate-table ?\\| ?\\\\ )
+ (aset keyboard-translate-table ?\\\\ ?\\| )
+
+Return:
+
+ new translate table"
+ (let ((index 0)
+ (xlat-table (make-string 128 0)))
+ (while (< index 128) ;Generate the identity map.
+ (aset xlat-table index index)
+ (setq index (1+ index) ))
+ (cond
+ ((eq arg 'use-new)
+ (setq keyboard-translate-table xlat-table))
+ ((eq arg 'use)
+ (and (null keyboard-translate-table)
+ (setq keyboard-translate-table xlat-table)))
+ (t))
+ xlat-table))
+
+;;; ----------------------------------------------------------------------
+;;; - For preventing Emacs to beep and disabling the normal keys
+;;; (for mail, gnus, ... )
+;;;
+(defun ti::keymap-put-abc-map (map &optional func)
+ "Put function `ignore' to abc key MAP, optionally put FUNC."
+ (let* ((i 0)
+ (func (or func 'ignore))
+ low
+ up)
+ (while (< i 27 )
+ ;; Set lowercase/upcase keys to nil
+ (setq low (char-to-string (+ 65 i))
+ up (char-to-string (+ 97 i)))
+ (define-key map low func)
+ (define-key map up func)
+ (incf i))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::keymap-put-map (map &optional func)
+ "Put function `ignore' to a0 > x <128 key MAP, optionally put FUNC."
+ (let* ((i 20)
+ (func (or func 'ignore)))
+ (while (< i 128 )
+ (define-key map (char-to-string i) func)
+ (incf i))))
+
+;;; ----------------------------------------------------------------------
+;;; - Mapping keysto functions easily.
+;;;
+(defun ti::keymap-mapkeys (map-key-fun args)
+ "Maps MAP-KEY-FUN to list of keys in ARGS.
+
+Example:
+ (mapkeys
+ 'global-set-key
+ '([f1] 'hilit-rehighlight-buffer
+ [f2] 'eval-defun
+ [f3] 'repeat-complex-command))"
+ (let (key
+ func
+ (i 0)
+ (len (length args)))
+ (if (eq 0 (% len 2)) nil
+ (error "args not paired"))
+ (while (< i len )
+ (setq key (nth i args) func (nth (1+ i) args) i (+ 2 i) )
+ (funcall map-key-fun key func))))
+
+;;}}}
+;;{{{ (T)ext properties, faces
+
+;;; ........................................................... &faces ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::buffer-text-properties-wipe (&optional beg end)
+ "Remove all, ie. literally all, text properten between BEG and END.
+BEG AND end defaults to whole buffer.
+Doesn't care about read only status of buffer."
+ (interactive "r")
+ (let (buffer-read-only
+ (inhibit-read-only t)) ;allow read-only prop wipe out
+ (set-text-properties
+ (or beg (point-min))
+ (or end (point-max))
+ nil)))
+
+;;; ----------------------------------------------------------------------
+;;; - During setting a different color to a face,
+;;; the color may be occupied and emacs halts with message
+;;;
+;;; (error "X server cannot allocate color" "DarkSeaGreen3")
+;;;
+;;; - This function allows you to give several "try" choices,
+;;;
+(defun ti::set-face-try-list (list face &optional attribute)
+ "Try to assign color to face.
+The input is list of color names which are tried one by one.
+First one that succeeds is assigned. If color is occupied, tries
+next one. Doesn't signal any errors.
+
+Input:
+
+ LIST (\"color1\" \"color2\" ..) or single color string
+ FACE symbol. E.g. 'region
+ ATTRIBUTE symbol. Choices are 'fg and 'bg. Default is 'fg
+
+Return:
+
+ color color that was assigned
+ nil all tries failed"
+ (let* (status)
+ (or attribute
+ (setq attribute 'fg))
+ (dolist (color (ti::list-make list))
+ (when (condition-case nil
+ (progn
+ (cond
+ ((eq attribute 'fg)
+ (set-face-foreground face color))
+ (t
+ (set-face-background face color)))
+ (setq status color)
+ t)
+ (error
+ ;; cannot set
+ nil))
+ ;; succesfull; stop the loop
+ (return)))
+ status))
+
+;;}}}
+
+;;{{{ misc: movement
+
+;;; ############################################################ &Misc ###
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::buffer-forward-line (&optional count)
+ "Move vertically lines down. If COUNT is negative, then up.
+
+`forward-line' moves point always to the beginning
+of next line, and the elisp manual says not to use `next-line' in
+programs.
+
+This function behaves exactly as `next-line'. If the next line is shorter
+it moves to the end of line."
+ ;; (interactive "P")
+ (let* ((col (current-column)))
+ (and (null count) (setq count 1)) ;No arg given
+ (forward-line count)
+ (move-to-column col)))
+
+;;}}}
+;;{{{ buffer: line handling , addings strings
+
+;;; ......................................................... &m-lines ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::buffer-looking-at-one-space ()
+ "Return non-nil if point is in the middle on one whitespcae.
+This is a position where there is only one tab or one space or point is
+followed by one newline. Similarly if point is at `point-min' and there is
+only one whitepace, or at `point-max' is preceded by one whitespace."
+ (let* ((char-backward (if (not (bobp))
+ (preceding-char)))
+ (char-forward (if (not (eobp))
+ (following-char))))
+ ;; Point-!-Here
+ (cond
+ ((and (null char-backward)
+ (null char-forward))
+ ;; BOBPEOBP ie. empty buffer.
+ nil)
+ ((and char-backward
+ char-forward)
+ ;; char-!-char
+ (and (not (string-match "[ \t\f\r\n]"
+ (char-to-string char-backward)))
+ (string-match "[ \t\f\r\n]"
+ (char-to-string char-forward))
+ ;; What is the next character?
+ (save-excursion
+ (forward-char 1)
+ (not (string-match "[ \t\f\r\n]"
+ (char-to-string (following-char)))))))
+ (t
+ ;; BOBP-!-char
+ ;; char-!-EOBP
+ (string-match "[ \t\f\r\n]"
+ (char-to-string
+ (if (eobp)
+ char-backward
+ char-forward)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::buffer-surround-with-char (char)
+ "Insert two same CHAR around a string near point.
+String is delimited by whitespace, although the function will do
+the right thing at beginning or end of a line, or of the buffer.
+If the char is one of a matching pair, do the right thing.
+Also makes a great gift."
+ (interactive "cSurround with char: ")
+ ;; hmm, ought to be able to do this with syntax tables?
+ (let
+ ((begchar char)
+ (endchar char))
+ (cond
+ ((or (char= char ?{) (char= char ?}))
+ (setq begchar ?{)
+ (setq endchar ?}))
+ ((or (char= char ?\() (char= char ?\)))
+ (setq begchar ?\()
+ (setq endchar ?\)))
+ ((or (char= char ?<) (char= char ?>))
+ (setq begchar ?<)
+ (setq endchar ?>))
+ ((or (char= char ?`) (char= char ?'))
+ (setq begchar ?`)
+ (setq endchar ?'))
+ ((or (char= char ?[) (char= char ?]))
+ (setq begchar ?[)
+ (setq endchar ?])))
+ (re-search-backward "^\\|\\s-" (point-min))
+ (if (not (bolp))
+ (re-search-forward "\\s-")
+ (if (looking-at "\\s-") (re-search-forward "\\s-")))
+ (insert-char begchar 1)
+ (let ((opoint (point)))
+ (if (re-search-forward "\\s-\\|\n" (point-max) t)
+ (forward-char -1)
+ (goto-char (point-max)))
+ (insert-char endchar 1)
+ (if (eq (point) (+ opoint 1))
+ (forward-char -1)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::buffer-fill-region-spaces (beg end &optional column)
+ "Fill region BEG END with spaces until COLUMN or 80.
+In picture mode paste/copying rectangles,
+it easiest if the area has spaces in every row up till
+column \"80\".
+
+To return to 'ragged' text, use function `ti::buffer-trim-blanks'
+
+Input:
+ BEG beginning of area, always line beginning
+ END end of area, always line end.
+ COLUMN the fill column. Defaults to 79, because 80 would
+ add annoying \\ marks at the end of line."
+ (interactive "*r\nP")
+ (let* ((column (or column 79))
+ (spaces (make-string (+ 2 column) ?\ ))
+ line
+ len
+ add)
+ (save-restriction
+ (narrow-to-region beg end)
+ (untabify (point-min) (point-max)) ;very important !!
+ (ti::pmin)
+ (while (not (eobp))
+ (setq line (ti::read-current-line)
+ len (length line)
+ add (- column len))
+ (if (<= add 0)
+ nil ;we can't touch this
+ (end-of-line)
+ (insert (substring spaces 1 add)))
+ (forward-line 1)))))
+
+;;; ----------------------------------------------------------------------
+;;; - This nice and elegant solution to get quotes around the words,
+;;; but someday it should be generalized to put ANYTHING around the word.
+;;;
+(defun ti::buffer-quote-words-in-region (beg end)
+ "This function quotes words in selected region BEG END."
+ (interactive "r")
+ (goto-char beg)
+ (while (< (point) end)
+ (kill-word 1)
+ (insert (prin1-to-string (current-kill 0)))
+ (setq end (+ end 2))
+ (forward-word 1)
+ (forward-word -1)))
+
+;;; ----------------------------------------------------------------------
+;;; - E.g. if you want to decide "fast filling", you could check if any line
+;; is longer that fill-column.
+;;;
+(defun ti::buffer-find-longer-line (beg end len)
+ "Check BEG END if there exist line longer than LEN.
+
+Return:
+ point beginning of line
+ nil"
+ (let* (pos)
+ (save-excursion
+ (goto-char (min beg end))
+ (while (and (null pos)
+ (not(eobp))
+ (< (point) (max beg end)))
+ (end-of-line)
+ (if (<= (current-column) len)
+ nil
+ (beginning-of-line) (setq pos (point)) )
+ (forward-line 1)))
+ pos))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::buffer-scramble-region (beg end &optional char)
+ "Scrables text BEG END with char so that it's not readable any more.
+Preserves words by substituting every [a-zA-Z] with optional CHAR."
+ (interactive "r")
+ (let* ((ch (if char ;pick the scramble char
+ (char-to-string char)
+ "o")))
+ (save-excursion
+ (save-restriction ;preserve prev narrowing
+ (narrow-to-region beg end)
+ (ti::pmin)
+ (ti::buffer-replace-regexp "[a-zA-Z]" 0 ch)))))
+
+;;; ----------------------------------------------------------------------
+;;; - This function requires user input when RE-LOOK is given
+;;; - This is aimed for lisp programs
+;;;
+(defun ti::buffer-add-string-region (beg end str &optional re-look)
+ "Add to region BEG END STR and optionally to lines matching RE-LOOK.
+You might use this as intend-region by adding more spaces to any
+vertical position, but most likely this is best function for
+commenting arbitrary blocks of code.
+
+1) set mark to _exact_column_ where to add string
+2) move cursor to destination line, column does not matter.
+
+If you want to add string to specific lines only, supply
+rex when you are asked for 'look for rex'. Remember that this
+rex will be used from that mark column to the end of line, so whole line
+is not looked. Here is one example:
+
+ *mark here
+ ;;; triple comment
+ ; single comment
+
+ ;;; another triplet
+ *cursor here
+
+ ;;#; triple comment
+ ; single comment
+
+ ;;#; another triplet
+ ^^^^^^^^^^^^^^^^^^^^ --> the REX match area, note not incl. leading!
+
+Note that the single ';' isn't matched, because the mark's column position
+is further away.
+
+References:
+
+ Emacs 19.28 has almost similar function. Look
+ `string-rectangle'. It does not overwrite existing text."
+ (interactive "r\nsString to region :\nsLook for re :")
+ (let* (col
+ look)
+ (if (ti::nil-p re-look) ;reset
+ (setq re-look nil))
+ (if (ti::nil-p str)
+ nil ;pass, nothing given
+ (save-excursion
+ ;; Get true boundaries.
+ ;;
+ (goto-char (min beg end)) (setq col (current-column))
+ (setq beg (line-beginning-position))
+ (goto-char (max beg end)) (setq end (line-end-position))
+ (save-restriction
+ (narrow-to-region beg end) (ti::pmin)
+ (while (not (eobp))
+ (move-to-column col t)
+ (setq look (if (and re-look
+ (eq (current-column) col))
+ (looking-at re-look)
+ t))
+ (if look
+ (insert str))
+ (forward-line 1)))))))
+
+;;}}}
+
+;;{{{ buffer: lists handling, sorting
+
+;;; ----------------------------------------------------------------------
+;;; - The default sort-regexp-fields is too limited and awkward to use.
+;;; - This one offers easy interface to 'sort'
+;;;
+(defun ti::buffer-sort-regexp-fields (list level re &optional numeric reverse case)
+ "Sort LIST of strings at subexpression LEVEL of RE.
+Sort can optionally be NUMERIC, REVERSE or CASE sensitive.
+
+Return:
+ sorted list."
+ (let* ((clist (copy-list list))) ;sort modifies it otw.
+ (sort clist
+ (function
+ (lambda (l r &optional ret elt1 elt2)
+ (cond
+ ((not case) ;not sensitive
+ (setq l (downcase l) ;ignore case
+ r (downcase r))))
+ ;; read the maches from strings
+ (setq elt1 (ti::string-match re level l)
+ elt2 (ti::string-match re level r))
+ (cond
+ ((not (and elt1 elt2)) ;make sure match happened
+ (setq ret nil))
+ (numeric
+ (setq ret
+ (if reverse
+ (< (string-to-int elt2) (string-to-int elt1))
+ (< (string-to-int elt1) (string-to-int elt2)))))
+ (t
+ (setq ret
+ (if reverse
+ (string< elt2 elt1)
+ (string< elt1 elt2)))))
+ ret)))
+ clist))
+
+;;}}}
+
+;;{{{ misc: shell, exec, process
+
+;;; ......................................................... &process ...
+;;; - Current "misc" category
+
+;;; ----------------------------------------------------------------------
+;;; - This is great function to build up completions for login names...
+;;; - I have 400 entries in passwd file and it's not very fast.
+;;; - You Should call this only once with regexp "." and put all the entries
+;;; into some variable. Use that variable for lookup.
+;;;
+(defun ti::file-passwd-grep-user-alist (re &optional not-re passwd-alist)
+ "Grep all login names, where person name match RE.
+The matches are gathered from `ti::var-passwd-buffer' and if it does not
+exist, error is signaled.
+
+If optional NOT-RE is string, it will be used after the RE match is done.
+It is used to exclude items.
+
+If PASSWD-ALIST is given it will be used instead to gather needed
+information. It should be alist int he form returned by function
+`ti::file-passwd-build-alist'
+
+Return:
+ ((login . user-name-entry) ..)"
+ (let* ((passwd-buffer ti::var-passwd-buffer)
+ ;; The name is 5th entry
+ ;; neva:I5KJd2C33dtMg:418:200:Max Neva,Houston Texas ...
+ (passwd-re "^\\([^:]+\\):[^:]+:[^:]+:[^:]+:\\([^:,]+\\)")
+ alist
+ line
+ login
+ person)
+ (cond
+ (passwd-alist
+ ;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ list ^^^
+ ;; Hm, the loops are almost identical, but what the heck...
+ (while passwd-alist
+ (setq line (cdr (car passwd-alist)))
+ ;; It's possible, that there is no "person" field, e.g.
+ ;; "lp:*:9:7::/usr/spool/lp:/bin/sh"
+ ;; |
+ ;; empty field
+ ;;
+ ;; It's quicker to test 2 at the same time, and only then decode
+ ;; the field into parts
+ (when (and (string-match re line)
+ (string-match passwd-re line))
+ (setq login (match-string 1 line))
+ (setq person (match-string 2 line))
+ (when (and login person)
+ (if (or (not (stringp not-re))
+ (and (stringp not-re)
+ (not (string-match not-re person))))
+ (push (cons login person) alist))))
+ (pop passwd-alist)))
+ (t
+ ;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ buffer ^^^
+ (if (null (ti::set-buffer-safe passwd-buffer))
+ (error "Passwd buffer does not exist"))
+ (if (eq (point-min) (point-max))
+ (error "Passwd buffer is empty."))
+ (ti::pmin)
+ (while (not (eobp))
+ (setq line (ti::read-current-line))
+ (when (and (string-match re line)
+ (looking-at passwd-re))
+ (setq login (match-string 1))
+ (setq person (match-string 2))
+
+ (if (null (and login person))
+ nil
+ (if (or (not (stringp not-re))
+ (and (stringp not-re)
+ (not (string-match not-re person))))
+ (push (cons login person) alist))))
+ (forward-line 1))))
+ alist))
+
+;;; ----------------------------------------------------------------------
+;;; E.g. in HP-UX the command is this
+;;; (my-read-passwd-entry "jaalto" "ypcat passwd")
+;;;
+(defun ti::file-passwd-read-entry (&optional user cmd)
+ "Return USER's password entry using Shell CMD.
+
+If the password buffer's content is not empty, the CMD isn't called, instead
+the entry is searched from the buffer. This reduces overhead of calling
+processes every time function is invoked.
+
+References:
+ `ti::var-passwd-buffer'"
+ (let* ( ;; Permanent buffer, since launching process is expensive
+ (user (or user (user-login-name)))
+ (re (concat "^" user ":"))
+ (buffer (get-buffer-create ti::var-passwd-buffer))
+ ret)
+ (unwind-protect
+ (with-current-buffer buffer
+ (when (eq (point-min) (point-max)) ;No entries yet
+ (if (null cmd)
+ (error "Need command to get the passwd file")
+ (erase-buffer)
+ (let ((list (split-string cmd)))
+ (apply 'call-process
+ (car list)
+ nil
+ (current-buffer)
+ nil
+ (cdr list)))))
+ (ti::pmin)
+ (if (re-search-forward re nil t)
+ (setq ret (ti::read-current-line)))))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::file-passwd-build-alist (cmd)
+ "Build assoc list out of passwd table using CMD.
+Please note, that building a list takes some time, so call this
+only once per program. The CMD must be a command to retrieve
+contents of passwd file.
+
+Note:
+
+ The performance of this function is not very good. Expect
+ parsing 1000 users/15 seconds.
+
+Return:
+
+ ((login . full-passwd-entry) ..)"
+ (let* ((passwd-buffer ti::var-passwd-buffer)
+ alist
+ line
+ login)
+ ;; force loading passwd entries
+ (ti::file-passwd-read-entry "SomeUser" cmd)
+ (with-current-buffer passwd-buffer
+ (ti::pmin)
+ (while (not (eobp))
+ (beginning-of-line)
+ (setq line (buffer-substring
+ (point) (progn (end-of-line) (point))))
+ ;; password entry looks like this, sometimes there may be garbage
+ ;; after shell command like these two grep notes.
+ ;;
+ ;; grep: can't open a
+ ;; grep: can't open tty
+ ;;
+ ;; lm58817:x:23193:23193:Leena M{ki|:/home3/li7/lm58817:/bin/tcsh
+ (when (setq login (ti::string-match "^[^:]+" 0 line))
+ (setq alist (cons (cons login line) alist)))
+ (forward-line 1)))
+ alist))
+
+;;}}}
+;;{{{ misc: function
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::buffer-defun-function-name (&optional point)
+ "Return possible function name.
+Starts searching backward form current or optional POINT.
+Be sure to be in right mode, so that right `beginning-of-defun' is used.
+
+In Lisp, the current function can be found only if it is left flushed.
+
+In C++, this will simply returns line portion, which it thinks
+contains function name.
+
+In Perl, it is supposed that word following \"sub\" is function name.
+
+Input:
+ point where to look
+
+Return:
+ nil
+ string"
+ (let* ((name (symbol-name major-mode))
+ (lisp-re (concat
+ "def\\(un\\|subst\\|macro\\|advice\\|var\\|const\\)"
+ "[ \t]+\\([^ \t]+\\)"))
+ line
+ ret)
+ (setq line (ti::read-current-line))
+ (save-excursion
+ (ignore-errors
+ ;; Now comes fun part...Ugh!
+ (cond
+ ((or (setq ret (ti::string-match lisp-re 2 line))
+ (string-match "lisp" name))
+ ;; This beginning-of-defun only finds only left
+ ;; flushed FORMS
+ ;;
+ (or ret
+ (progn
+ (beginning-of-defun) (setq line (ti::read-current-line))
+ (setq ret (ti::string-match lisp-re 2 line)))))
+
+ ((or (string-match "CC" name)
+ (string-match "C++" name))
+ (beginning-of-defun)
+ ;; A nightmare...
+ ;;
+ ;; perAtom_c *
+ ;; pMscCg_c::DecodeV7
+ ;; ()
+ ;; {
+ ;;
+ ;; perAtom_c *pMscCg_c::DecodeV7
+ ;; ()
+ ;; {
+ ;; Try our best...
+ ;;
+ (search-backward "(")
+ (beginning-of-line)
+ (or (setq ret (ti::buffer-match "^[ \t]*\\([^ \t(]+\\)[ \t]*(" 1))
+ (progn ;skip one line up
+ (forward-line -1)
+ (setq ret (ti::buffer-match "^[ \t]*\\([^\n(]+\\)" 1)))))
+
+ ((and (string-match "perl" name)
+ (re-search-backward "^[ \t]*sub[ \t]+\\([^ \t]+\\)" nil t))
+ (setq ret (match-string 1)))))
+ ret)))
+
+;;}}}
+;;{{{ file
+
+;;; ############################################################ &File ###
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::file-days-old (file)
+ "Calculate how many days old the FILE is. This is approximation."
+ (let ((now (current-time))
+ (file (nth 5 (file-attributes file))))
+ (/ (ti::date-time-difference now file) 86400)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::file-touch (file)
+ "Touch FILE by updating time stamp. FILE is created if needed.
+Note: the filename is handed to the shell binary `touch'. Make sure the
+filename is understood by shell and does not contain meta characters."
+ (if (not (file-exists-p file))
+ (with-temp-buffer (write-region (point) (point) file))
+ (let* ((touch (or (get 'ti::file-touch 'touch-binary)
+ (executable-find "touch")
+ (error "`touch' binary not found."))))
+ (put 'ti::file-touch 'touch-binary touch)
+ (call-process touch nil nil nil (expand-file-name file)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::file-ange-completed-message (&rest args)
+ "Default message after file has been loaded. Ignore ARGS."
+ (message "Ange-ftp bg completed"))
+
+;;; ----------------------------------------------------------------------
+;;; #todo: Not quite what I want...
+;;;
+(defun ti::file-ange-status (ange-ref)
+ "Return status on ANGE-REF ftp buffer.
+
+Return:
+ 'no-ange if no ange buffer exists
+ (..) some ange status values"
+ (let* ((ret 'no-ange)
+ ange
+ buffer
+ host
+ user
+ proc
+ line
+ stat
+ busy)
+ (require 'ange-ftp)
+ (setq ange (ange-ftp-ftp-name ange-ref) ;crack addr
+ host (nth 0 ange)
+ user (nth 1 ange))
+ (cond
+ ((setq buffer (ti::buffer-find-ange-buffer user host))
+ (if (null buffer) (setq buffer buffer)) ;XEmacs 19.14 Bytecomp silencer
+ ;; Create a new process if needed
+ (setq proc (ange-ftp-get-process host user))
+ ;; The status value is valid only when process finishes.
+ (save-excursion
+ (set-buffer (process-buffer proc))
+ (ti::pmax)
+ (setq ret ange-ftp-process-result
+ line (ti::read-current-line)
+ stat (ange-ftp-process-handle-line line proc)
+ busy ange-ftp-process-busy)
+ ;; STAT
+ ;; t = skip message
+ ;; ange-ftp-process-result-line = good
+ ;; fatal, deletes process.
+ (setq ret (list ret stat busy)))))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;; - an easy interface to ange ftp to get dingle file in bg.
+;;; - this actually is a "macro" or toplevel func to the
+;;; ti::file-ange-file-handle
+;;;
+(defun ti::file-ange-download-file (ange-ref download-dir &optional not-bg)
+ "Download single file pointed by ANGE-REF in background to the DOWNLOAD-DIR.
+
+Input:
+
+ ANGE-REF /login@site:/dir/dir/file.xx
+ DOWNLOAD-DIR valid directory where to put the file.
+ NOT-BG if non-nil the ftp is done in foregroung.
+
+Return:
+
+ nil if job is done in background
+ status if in fg. Nil means failure."
+
+ (let* (ange
+ host
+ user
+ dir
+ file
+ to-dir)
+ (require 'ange-ftp)
+ (setq ange (ange-ftp-ftp-name ange-ref) ;crack addr
+ host (nth 0 ange)
+ user (nth 1 ange)
+ dir (file-name-directory (nth 2 ange))
+ file (file-name-nondirectory (nth 2 ange))
+ to-dir (expand-file-name download-dir))
+ (ti::file-ange-file-handle 'get user host dir to-dir (list file) not-bg)))
+
+;;; ----------------------------------------------------------------------
+;;; - an easy interface to ange ftp to get/put wanted files
+;;; #todo: sometimes ange hangs, rarely but... should check if
+;;; process is live somehow?
+;;; #todo: check that no process is going in the buffer, so that it's
+;;; not called many times (overlapping).
+;;;
+(defun ti::file-ange-file-handle
+ (mode user host dir lcd file-list &optional not-bg msg-func)
+ "Get files from remote or put files to remote site.
+
+Important:
+
+ All directory names must be absolute
+
+Input:
+
+ MODE 'put or 'get
+ USER login name when logging to site
+ HOST site name
+ DIR remote site directory
+ LCD download local dir
+ FILE-LIST files to get from/put to remote site
+ NOT-BG should we wait until ange is done?
+ nil = run on bg, non-nil = wait until done.
+ MSG-FUNC function to call after download completes. Should
+ contain &rest args parameter. See more in ange-ftp.el
+Return:
+
+ nil always if NOT-BG is nil
+ status if NOT-BG is non-nil. Value nil means that session
+ failed."
+ (let* ((func (or msg-func 'ti::file-ange-completed-message))
+ (max-try 5)
+ (try 0)
+ proc
+ point
+ ret)
+ (require 'ange-ftp)
+ (cond ;get commands
+ ((eq mode 'get)
+ (setq mode "mget"))
+ ((eq mode 'put)
+ (setq mode "mput")
+ (setq func 'ignore)) ;can't use any function for this...
+ (t
+ (error "What mode?")))
+ (if (not (ti::listp file-list))
+ (error "file-list must be LIST and _not_ empty"))
+ ;; We need absolute directory names, because the FTP process
+ ;; running does not understand anything else.
+ (setq lcd (expand-file-name lcd))
+ ;; Start FTP session if it does not exist
+ ;;
+ (setq proc (ange-ftp-get-process host user))
+;;; (setq M mode U user H host D dir L lcd F file-list P proc)
+ ;; - Expand remote site's directory reference
+ (setq dir (ange-ftp-real-file-name-as-directory
+ (ange-ftp-expand-dir host user dir)))
+ ;; Without this, the next command dies. This is already called in function
+ ;; ange-ftp-get-process, but for some unknown reason it must be called
+ ;; again to be sure: the hash mark size was sometimes nil
+ (with-current-buffer (ange-ftp-ftp-process-buffer host user)
+ (if (null ange-ftp-ascii-hash-mark-size)
+ (setq ange-ftp-ascii-hash-mark-size 1024))
+ (if (null ange-ftp-binary-hash-mark-size)
+ (setq ange-ftp-binary-hash-mark-size 1024)))
+ (ange-ftp-set-binary-mode host user)
+ ;; - After this commands ANGE hangs quite often and never executes
+ ;; the "raw" commands
+ ;; - That's why we loop MAX-TRY times to start the
+ ;; command.
+ (ange-ftp-send-cmd host user (list 'lcd lcd) "Setting lcd...")
+ (message "")
+ ;; CD command dies if it the directory is wrong
+ ;;
+ ;; The socond command just makes sure the command was successfull.
+ ;; I added this, because when connection was cloased and ange
+ ;; opened the connection again, the CWD command didn't succeed
+ ;; right away. We must wait here until it succeeds and only then
+ ;; send the real put or get request.
+ (ange-ftp-cd host user dir)
+ (save-excursion
+ (set-buffer (process-buffer proc))
+ (setq try 0)
+ (while
+ (and (progn
+ (ti::pmax) (forward-line -1)
+ ;; ftp> 250 CWD command successful.
+ (not (string-match "success" (ti::read-current-line))))
+ (< try max-try))
+ (incf try)))
+ (push mode file-list) ;command for ange
+ (save-excursion
+ (set-buffer (process-buffer proc))
+ (ti::pmax)
+ ;; Try sending untill the point moves... => process started
+ (setq point (point) try 0)
+ (while (and (eq point (point))
+ (< try max-try))
+;;; (ti::d! (eq point (point)) point (point))
+ (ange-ftp-raw-send-cmd
+ proc
+ (ti::list-to-string file-list)
+ "ftp ..." ;message displayed during 0%..100%
+ (list func) ;called after completion ?
+ (not not-bg)) ;continue without wait
+ (ti::pmax)
+ (incf try)))
+ ;; The status value is valid only when process finishes.
+ (if not-bg
+ (save-excursion
+ (set-buffer (process-buffer proc))
+ (setq ret ange-ftp-process-result)))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::file-chmod-w-toggle (file)
+ "Toggle read-only flag for FILE.
+If file does not exist, or is not owned by user this function does nothing.
+
+Return:
+
+ 'w+ file made writable
+ 'w- file made read-only.
+ nil file not processed."
+ (let* ((file (expand-file-name file))
+ mode)
+ (when (ti::file-modify-p file)
+ (setq mode (ti::file-toggle-read-write (file-modes file)))
+ (set-file-modes file mode)
+ ;; return value , -r--r--r-- , 600 oct= 384 dec
+ (if (= 0 (logand mode 128))
+ 'w-
+ 'w+))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::file-chmod-make-writable (file)
+ "Make FILE writable."
+ (set-file-modes file (ti::file-mode-make-writable (file-modes file))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::file-chmod-make-read-only (file)
+ "Make FILE read only."
+ (set-file-modes file (ti::file-mode-make-read-only (file-modes file))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::file-find-shadows (&optional path)
+ "Find duplicate files along optional PATH, which defaults to `load-path'."
+ (interactive)
+ (or path (setq path load-path))
+ (save-excursion
+ (let ((true-names (mapcar 'file-truename path))
+ (reduds 0)
+ files dir
+ out-buffer
+ curr-files
+ orig-dir
+ files-seen-this-dir
+ file
+ d1
+ d2) ;directories
+ (while path
+ (if (member (car true-names) (cdr true-names))
+ (setq reduds (1+ reduds))
+ (setq dir (car path))
+ (setq curr-files (if (file-accessible-directory-p dir)
+ (directory-files dir nil ".\\.elc?$" t)))
+ (and curr-files
+ (interactive-p)
+ (message "Checking %d files in %s..." (length curr-files) dir))
+ (setq files-seen-this-dir nil)
+ (while curr-files
+ (setq file (car curr-files))
+ (setq file (substring
+ file 0 (if (string= (substring file -1) "c") -4 -3)))
+ (unless (member file files-seen-this-dir)
+ (setq files-seen-this-dir (cons file files-seen-this-dir))
+ (if (not (setq orig-dir (assoc file files)))
+ (setq files (cons (list file dir) files))
+ (if (null out-buffer)
+ (progn
+ (setq out-buffer (get-buffer-create "*Shadows*"))
+ (display-buffer out-buffer)
+ (set-buffer out-buffer)
+ (erase-buffer)))
+ ;; Do not print if directories are the same
+ ;; ++ [jari]
+ (setq d1 (file-name-as-directory (car (cdr orig-dir)))
+ d2 (file-name-as-directory dir))
+ (unless (string= d1 d2)
+ (insert
+ (format "%s%s shadows\n%s%s\n\n" d1 file d2 file)))))
+ (setq curr-files (cdr curr-files)))) ;; if
+ (setq path (cdr path)
+ true-names (cdr true-names)))
+ (if (interactive-p)
+ (let ((msg
+ (if out-buffer
+ (let ((n (/ (count-lines (point-min) (point-max)) 3)))
+ (format "%d shadowing%s found" n (if (eq n 1) "" "s")))
+ "No shadowings found")))
+ (message "%s%s" msg
+ (if (zerop reduds) ""
+ (format " (skipped %d redundant entr%s in path)"
+ reduds (if (eq reduds 1) "y" "ies"))))))
+ out-buffer)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::directory-part-last (dir)
+ "Return last portion of DIR.
+Like ~/this/dir/ would return `dir'.
+for `dir/' return `dir'."
+ (when (or (string-match "^.*[\\/]\\([^\\/]+\\)[\\/]?$" dir)
+ (string-match "^\\([^\\/]+\\)[\\/]?$" dir))
+ (match-string 1 dir)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::directory-unique-roots (path-list)
+ "Return unique root directories of PATH-LIST.
+Non-strings or empty strings in PATH-LIST are ignored.
+
+For example for directories ~/elisp/packages and ~/elisp/packages/more
+the unique root is ~/elisp/packages."
+ (with-temp-buffer
+ (dolist (path path-list)
+ (when (and (stringp path)
+ (not (ti::nil-p path)))
+ (insert (expand-file-name path) "\n")))
+ (sort-lines nil (point-min) (point-max))
+ (ti::pmin)
+ (let (list
+ line)
+;;; (pop-to-buffer (current-buffer)) (ti::d! 'starting)
+ (while (not (eobp))
+ (setq line (ti::buffer-read-line))
+ (push line list)
+ (beginning-of-line)
+ (save-excursion
+ (delete-matching-lines (concat "^" (regexp-quote line)))))
+;;; (ti::d! 'ok list)
+ list)))
+
+;;; ----------------------------------------------------------------------
+;;; (tinypath-subdirectory-list "~")
+;;;
+(defun ti::directory-subdirectory-list (path)
+ "Return all subdirectories under PATH."
+ (let* (list)
+ (dolist (elt (directory-files path 'absolute) )
+ (when (and (not (string-match "\\.\\.?$" elt)) ;; skip . and ..
+ (file-directory-p elt)) ;; take only directories
+ (push elt list)))
+ list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::directory-recursive-do (root function)
+ "Start at ROOT and call FUNCTION recursively in each ascended directory."
+ (let* ((list (ti::directory-subdirectory-list root)))
+ (if (null list)
+ (funcall function root)
+ (dolist (path list)
+ (ti::directory-recursive-do path function)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::directory-up (path)
+ "Go one PATH directory level up.
+
+Cygwin hpath handling:
+
+ /cygdrive/ => / May not be what you want
+ /cygdrive/c/ => /cygdrive/c Can't go no more upward
+ /cygdrive/c/tmp => /cygdrive/c
+
+Dos path handling:
+
+ c:/temp => d:/ Notice, cannot return \"d:\"
+
+Unix path handling:
+
+ /path1/path2 => /path1
+ /path1/path2/ => /path1
+ /path1/path2/file.txt => /path1/path2"
+ (cond
+ ((string-match "^/$\\|^[a-z]:[\\/]?$" path)
+ path)
+ (t
+ (if (string-match "[/\\]$" path)
+ (setq path (ti::string-match "^\\(.*\\)[^\\/]+" 1 path)))
+ ;; /cygdrive/c/ is already a root directory
+ (cond
+ ((string-match "^\\(/cygdrive/.\\)/?$" path)
+ (match-string 1 path))
+ (t
+ (setq path (file-name-directory path))
+ ;; d:/temp => d:/ ,do not return "d:"
+ (if (and (string-match "[/\\].+[/\\]" path)
+ (string-match "^\\([a-z]:\\)?.+[^/\\]" path))
+ (match-string 0 path)
+ path))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::directory-subdirs (dir)
+ "Return directories under DIR."
+ (let* (list)
+ (when (file-directory-p dir)
+ (dolist (elt (directory-files dir 'full))
+ (if (file-directory-p elt)
+ (push elt list))))
+ list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::directory-unix-man-path-root ()
+ "Determine manual page root path. "
+ (let (root)
+ (dolist (try '("/opt/local/man" ;HP-UX new
+ "/usr/share/man" ;HP old
+ "/usr/man")) ;Sun and Linux
+ (if (ti::win32-cygwin-p)
+ (setq try (w32-cygwin-path-to-dos try)))
+ (when (and try
+ (file-directory-p try))
+ (return try)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::directory-files (dir re &optional absolute form not-re-form)
+ "Return files from DIR.
+
+Input:
+
+ DIR directory name
+ RE regexp for files to match
+ ABSOLUTE flag, Return files as absolute names?
+ FORM eval form, test each file with FORM instead of RE
+ NOT-RE-FORM eval form, drop file if this evaluates to t
+
+Example:
+
+ ;; Get all filenames that aren't zipped, backups or objects.
+ ;; The 'arg' will hold the filename
+
+ (ti::directory-files dir re t nil '(string-match \"g?[Z~#o]$\" arg)))
+
+ ;; Return only directory names
+
+ (ti::directory-files dir \".\" 'absolute
+ '(file-directory-p arg)
+ '(string-match \"\\\\.\\\\.?$\" arg))
+
+Return:
+
+ list (file file file ..)"
+ (let* (ret)
+ (dolist (arg
+ (directory-files dir absolute re))
+ (when (or (null form) ;accept all
+ (eval form)) ;accept only these
+ (when (or (null not-re-form)
+ (null (eval not-re-form)))
+ (push arg ret ))))
+ (nreverse ret)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;
+(defun ti::file-files-only (list &optional eval-form)
+ "Return existing files. Drop directories from LIST of strings.
+Note: 200 files takes about 2-3 secs. If you supply EVAL-FORM, the item
+will be included if the form Return t. You can refer to current item
+with symbol 'arg'.
+
+Input:
+
+ LIST list of strings
+ EVAL-FORM optional eval statement
+
+Return:
+ (file ..) list"
+ (let* (ret)
+ (dolist (arg list)
+ (if (if eval-form
+ (eval eval-form)
+ (and (file-exists-p arg)
+ (not (file-directory-p arg))))
+ (push arg ret)))
+ (nreverse ret)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::file-newer-exist (f1 f2)
+ "Return file F1 or F2 which is newer. If only one of them exist, return it.
+
+Return:
+ str file
+ nil none of them exist"
+ (cond
+ ((and (file-exists-p f1)
+ (file-exists-p f2))
+ (if (file-newer-than-file-p f1 f2)
+ f1 f2))
+ ((file-exists-p f1)
+ f1)
+ ((file-exists-p f2)
+ f1)
+ (t
+ nil)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::file-get-extension (file &optional mode)
+ "Return FILE extension.
+If MODE is nil, then return nil if none exist,
+if MODE is non-nil, return empty string instead."
+ (let* (list
+ ext
+ len)
+;;; (ti::d! (null file) (null (string-match "\\." file)))
+ (if (or (null file)
+ (null (string-match "\\." file)))
+ nil
+ (setq list (split-string file "[\.]"))
+ (setq len (length list))
+ (if (eq 1 len)
+ (setq ext (car list)) ; first element
+ (setq ext (nth (1- len) list)))) ; last element
+ (if ext ext ;what to return?
+ (if mode
+ ""
+ nil))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::file-path-and-line-info (path)
+ "Return (PATH . LINE-NBR) if path is in format PATH:NBR."
+ (let* (line)
+ (when (string-match ":\\([0-9]+\\):?[ \t\f]*$" path)
+ (setq line (string-to-int (match-string 1 path)))
+ (setq path (ti::replace-match 0 "" path))
+ (cons path line))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::file-path-to-unix (path)
+ "Convert PATH to Unix forward slash format."
+ (replace-char-in-string ?/ ?\\ path))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::file-path-to-msdos (path)
+ "Convert PATH to MS-DOS backward slash format."
+ (replace-char-in-string ?\\ ?/ path))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::file-make-path (dir &optional file)
+ "Make full path by combining DIR and FILE.
+In Win32, return backward slashed paths. Otherwise forward slashed
+paths.
+
+DIR will always have trailing directory separator.
+You need to call this function if you pass a absolute path to
+external processes. Emacs in the other hand can handle both \\ and /
+internally."
+ (if (ti::emacs-type-win32-p)
+ (replace-char-in-string
+ ?\\ ?/ (concat (file-name-as-directory dir) (or file "")))
+ (replace-char-in-string
+ ?/ ?\\ (concat (file-name-as-directory dir) (or file "")))))
+
+;;; ----------------------------------------------------------------------
+;;; #defalias (defalias 'which 'ti::file-get-load-path)
+;;;
+(defun ti::file-get-load-path (fn paths &optional all-paths verb)
+ "Return full path name for FN accross the PATHS.
+Input:
+
+ FN filename to search
+ PATHS list of path names
+ ALL-PATHS return all matches.
+ VERB verbose flag. Allows printing values in echo area
+
+Return:
+
+ nil no matches
+ str first match if all-paths is nil
+ list list of matches along paths."
+ (interactive
+ (let* ((map (copy-keymap minibuffer-local-map))
+ var1
+ var2)
+ (define-key map "\t" 'lisp-complete-symbol)
+ (define-key map "\C-m" 'exit-minibuffer)
+ (setq var1 (read-from-minibuffer "sFile: "))
+ (setq var2 (read-from-minibuffer "Lisp var: " "exec-path" map))
+ (list var1 (eval (intern-soft var2)))))
+ (let (file found)
+ (ti::verb)
+ (dolist (elt paths)
+ (when (stringp elt) ;you never know what's in there...
+ (setq file (ti::file-make-path elt fn))
+ (when (and (file-exists-p file)
+ (not (file-directory-p file)))
+ (if all-paths
+ (push file found)
+ (setq found file)
+ (return)))))
+ (if (and found all-paths) ;preserve order
+ (setq found (nreverse found)))
+ (if (and found verb)
+ (message (prin1-to-string found)))
+ found))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::file-user-home ()
+ "Try to guess user's home directory.
+
+Return:
+ /PATH/PATH/USER/ users home
+ nil not found"
+ (let* ((usr (or (getenv "USER") (getenv "LOGNAME") ))
+ (home (or (getenv "HOME") (getenv "home") ))
+ (path (expand-file-name "~")))
+ (cond
+ (path)
+ ((> (length home) 0) ;$HOME exist
+ (setq path home))
+ ((> (length usr) 0) ;users name exist
+ (with-temp-buffer
+ (cond
+ ((executable-find "pwd") ;Win32 test
+ ;; Try to get via 'pwd' process then.
+ (call-process "pwd" nil (current-buffer) nil)
+ (ti::pmin)
+ (if (re-search-forward usr nil t)
+ (setq path (buffer-substring (point-min) (match-end 0)))))
+ ((executable-find "ls")
+ ;; Failed ? try ls then...
+ (erase-buffer)
+ (call-process "ls" nil (current-buffer) nil)
+ (if (re-search-forward usr nil t)
+ (setq path (buffer-substring
+ (point-min) (match-end 0)))))))))
+ ;; make sure it has trailing "/"
+ (and (stringp path)
+ (setq path (ti::file-make-path path)))
+ path))
+
+;;; ----------------------------------------------------------------------
+;;; You can use this in interactive command to build up a completion list:
+;;; like this:
+;;;
+;;; (interactive
+;;; (list (completing-read
+;;; "Visit file: " (ti::file-file-list load-path "\\.el$"))))
+;;; (let ((pair (assoc emacs-file (ti::file-file-list load-path "\\.el$"))))
+;;; (if pair
+;;; (find-file (cdr pair))
+;;; (find-file (expand-file-name emacs-file "~/emacs")))))
+;;;
+(defun ti::file-file-list (dirs re)
+ "Read DIRS and return assoc of files matching RE. (FILE FULL-PATH-FILE)."
+ (let ((files nil))
+ (and (stringp dirs) ;only one entry given ?
+ (setq dirs (list dirs)))
+ (while dirs
+ (setq files
+ (append files (directory-files (car dirs) t re)))
+ (setq dirs (cdr dirs)))
+ (mapcar
+ (function
+ (lambda (file)
+ (cons (file-name-nondirectory file) file))
+ files))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::file-complete-file-name (file-name &optional dir flist)
+ "Given a FILE-NAME string return the completed file name.
+
+Input:
+
+ If FILE-NAME is invalid entry, signal no error and return nil
+ If no DIR is not given, use FILE-NAME's directory.
+ If no DIR nor FILE-NAME dir, use `default-directory'
+ if non-nil flag FLIST, then return completed filename list
+
+Nots:
+
+ DIR must end to a slash or otherwise it is considered partial
+ filename.
+
+Return:
+
+ str full completion
+ list list of completions if FLIST is set.
+ nil not unique"
+ (let* ((type (cond
+ ((and (ti::win32-p)
+ (ti::emacs-type-win32-p)
+ (string-match "/cygdrive" file-name))
+ 'cygwin)
+ (t
+ 'emacs)))
+ (file (substitute-in-file-name file-name))
+ (uncomplete (file-name-nondirectory file))
+ odir
+ completed)
+ (setq odir ;Save the original directory.
+ (substring file-name 0 (- (length file-name) (length uncomplete))))
+ ;; Relative path
+ (if (and (stringp odir)
+ (stringp dir)
+ (string-match "^\\.\\." odir))
+ (setq dir (format "%s%s" (file-name-as-directory dir) odir)))
+ ;; expand-file-name dies if default-directory is nil
+ (setq dir
+ (expand-file-name
+ (or dir
+ (file-name-directory file-name)
+ default-directory
+ "~")))
+ (setq completed
+ ;; if given impossible entry like "!@#!#"
+ (ignore-errors
+ (file-name-all-completions uncomplete dir)))
+ ;; Only one match in the list? voila!
+ (if (and completed
+ (eq 1 (length completed)))
+ (setq completed (ti::file-name-forward-slashes (car completed))))
+ (cond
+ ((and (stringp completed)
+ (not (string= completed uncomplete)))
+ (concat odir completed))
+ ((and flist completed)
+ completed))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::file-complete-file-name-word (&optional word no-msg)
+ "Complete filename WORD at point.
+`default-directory' is used if no directory part in filename.
+See `ti::file-complete-file-name'.
+
+You can use this feature easily in Lisp interactive call.
+See macro `ti::file-complete-filename-minibuffer-macro' for more.
+
+NO-MSG if non-nil, do not flash possible choices at current point
+ The `sit-for' command is used for displaying, so you can
+ interrupt it by pressing any key."
+ (interactive "P")
+ (or word
+ (setq word
+ (save-excursion
+ (forward-char -1)
+ (ti::buffer-read-space-word))))
+ (let* ((oword word)
+ (enable-recursive-minibuffers t)
+ all
+ tmp
+ dir
+ msg)
+ ;; expand-file-name dies if default-directory is nil
+ (or default-directory
+ (error "default-directory is nil !!"))
+ (unless (ti::nil-p word)
+ (setq word (ti::file-complete-file-name word nil 'list))
+ (when (ti::listp word)
+ (let ((alist (ti::list-to-assoc-menu word)))
+ (when (stringp (setq tmp (try-completion oword alist)))
+ (setq word tmp
+ ;; still completions left? Was this unique?
+ all (all-completions word alist)))))
+ (when (stringp word)
+ (when (and (null no-msg)
+ ;; This completion is not unique, so show all matches
+ (string= oword word)
+ (ti::listp all))
+ (setq msg (format "%d: %s"
+ (length all)
+ (ti::list-to-string all)))
+ (message msg)
+ (sit-for 0.5)))
+ (when (and (stringp word)
+ (not (string= word oword)))
+ (skip-chars-backward "^\n\t ")
+ (let ((point (point)))
+ (skip-chars-forward "^\n\t ")
+ (delete-region point (point))
+ (insert (ti::file-name-forward-slashes word)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'ti::file-complete-filename-minibuffer-macro 'lisp-indent-function 0)
+(defmacro ti::file-complete-filename-minibuffer-macro (&rest body)
+ "Complete filename in minibuffer and do BODY.
+Use variable 'map' to pass map to `read-from-minibuffer' function.
+
+Example call:
+
+ (ti::file-complete-filename-minibuffer-macro
+ (read-from-minibuffer \"test\" nil map))
+
+Example 2:
+
+ (defun my-example (string file-list)
+ \"FILE-LIST is string. Allow completion on words\"
+ (interactive
+ (list
+ (read-from-minibuffer \"Gimme string: \")
+ (split-string
+ (ti::file-complete-filename-minibuffer-macro
+ (read-from-minibuffer \"Gimme file-list: \" nil map)))))
+ (list string file-list))
+
+ (setq result (call-interactively 'my-example)) \"test\" RET <files> RET
+ result
+ --> (\"test\" (\"~/\" \"~/bin\" \"~/exe/\"))"
+ (`
+ (let* ((map (copy-keymap minibuffer-local-map)))
+ ;; this event also exists for tab
+ (define-key map [kp-tab] 'ti::file-complete-file-name-word)
+ (define-key map [tab] 'ti::file-complete-file-name-word)
+ (define-key map "\t" 'ti::file-complete-file-name-word)
+ (,@ body))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::file-read-file-list (&optional message)
+ "Read file or directory list as one string, and return it as LIST.
+Display optional MESSAGE, otherwise use default message.
+
+Filesnames can be completed with tab. `default-directory' is used for
+files that do not have directory part. Make sure default dir has ending
+slash.
+
+Example:
+
+ (setq files (mapcar 'expand-file-name (ti::file-read-file-list)))
+
+Return:
+
+ (ELT ELT ..) with `default-directory'
+ nil no input"
+ (let* (list
+ str)
+ (setq str
+ (ti::file-complete-filename-minibuffer-macro
+ (read-from-minibuffer
+ (or message (format
+ "...%s: "
+ ;; limit the directory name
+ (ti::string-right default-directory 10)))
+ nil map)))
+ (unless (ti::nil-p str) ;not empty?
+ (dolist (str (split-string str " "))
+ (if (not (string-match "/" str))
+ (setq str (concat default-directory str)))
+ (push str list)))
+ (nreverse list)))
+
+;;}}}
+
+;;{{{ Network streams
+
+;;; ......................................................... &network ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::process-finger-error (&optional buffer)
+ "Read BUFFER containing a finger response after `ti::process-finger'.
+If there is an error, then return possible error cause string.
+
+Return:
+ string cause of error
+ nil no error"
+ (let* (ret)
+ (with-current-buffer (or buffer (current-buffer))
+ (ti::pmin)
+ (when (re-search-forward "unknown host:" nil t)
+ (setq ret (ti::read-current-line))))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;; Original function in mc-pgp.el:mc-pgp-fetch-from-finger
+;;;
+(defun ti::process-finger (email &optional port timeout buffer verb)
+ "Finger EMAIL on PORT with TIMEOUT.
+The output is clered from possible ^M characters.
+
+Input:
+
+ EMAIL email address foo@site.com
+ PORT default is 79
+ TIME default is 25
+ BUFFER where to store result, default is *finger tmp*
+ VERB print verbose messages
+
+Return:
+
+ string error while doing opening network stream
+ buffer-pointer"
+ (interactive "sFiger email: ")
+ (let (connection
+ user
+ host
+ ret)
+ (setq verb (or verb (interactive-p))
+ port (or port 79)
+ timeout (or timeout 25))
+ (if (not (string-match "^\\([^ \t]+\\)@\\([^[ \t]+\\)" email))
+ (error "Need email address foo@site.com '%s'" email)
+ (setq user (match-string 1 email)
+ host (match-string 2 email))
+ (save-excursion
+ (unwind-protect
+ (progn
+ (if verb (message "Fingering %s ..." email))
+ (setq buffer (or buffer (ti::temp-buffer "*finger tmp*" 'clear)))
+;;; (pop-to-buffer buffer) (ti::d! "going finger....")
+ (condition-case error
+ (progn
+ (setq
+ connection
+ (open-network-stream "*finger*" buffer host port))
+ (process-send-string
+ connection (concat "/W " user "\r\n"))
+ (while (and (memq (process-status connection) '(open))
+ (accept-process-output connection timeout))))
+ (file-error
+ ;; '(file-error "connection refused "connection failed" ..)
+ (setq ret (ti::list-to-string (cdr error))))
+ (error
+ (setq ret (ti::list-to-string (cdr error)))))
+ (if connection (delete-process connection))
+ ;; Strip Ctrl-M marks
+ (with-current-buffer buffer
+ (ti::buffer-lf-to-crlf 'dos2unix)))))
+ (when verb
+ (message "Fingering %s ...done" email))
+ (if (interactive-p)
+ (pop-to-buffer buffer))
+ (if connection
+ buffer ret))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::process-http-request (command &optional port timeout buffer verb)
+ "Send http COMMAND i.e. URL request.
+Control character C-m is removed from response.
+
+If COMMAND includes port number, e.g.:
+
+ http://www-swiss.ai.mit.edu:80/htbin/pks-extract-key.pl
+
+This is actually intepreted as
+
+ http = www-swiss.ai.mit.edu
+ port = 80
+ command = /htbin/pks-extract-key.pl
+
+Input:
+
+ COMMAND http command string
+ PORT default is 80
+ TIMEOUT default is 60
+ BUFFER where to store result, default is *finger tmp*
+ VERB print verbose messages
+
+Return:
+
+ '(buffer-pointer error-string)
+
+ error-string network stream error message.
+ buffer HTTP response."
+ (interactive "sHttp request: ")
+ (let (connection
+ host
+ ret)
+ (setq verb (or verb (interactive-p))
+ port (or port 80)
+ timeout (or timeout 60))
+ (if (not (string-match "^http://\\([^/]+\\)\\(/.*\\)" command))
+ (error "Must be _http_ request '%s'" command)
+ (setq host (match-string 1 command)
+ command (match-string 2 command))
+ (if (string-match "\\(.*\\):\\([0-9]+\\)" host)
+ (setq port (string-to-int (match-string 2 host))
+ host (match-string 1 host))))
+;;; (ti::d!! "\n" command "HOST" host "PORT" port "TIME" timeout buffer)
+ (save-excursion
+ (unwind-protect
+ (progn
+ (when verb
+ (message "Http %s ..." host))
+ (setq buffer (or buffer (ti::temp-buffer "*http tmp*" 'clear)))
+;;; (ti::d! host port command "sending http....")
+ (condition-case error
+ (progn
+ (setq
+ connection
+ (open-network-stream "*http*" buffer host port))
+ (process-send-string
+ connection
+ (concat "GET "
+ command
+ " HTTP/1.0\r\n\r\n"))
+ (while (and (eq 'open (process-status connection))
+ (accept-process-output connection timeout))))
+ (file-error
+ ;; '(file-error "connection refused "connection failed" ..)
+ (setq ret (ti::list-to-string (cdr error))))
+ (error
+ (setq ret (ti::list-to-string (cdr error))))))
+ ;; ................................................... cleanup ...
+ (if connection
+ (delete-process connection))
+ ;; Strip Ctrl-M marks
+ (with-current-buffer buffer
+ (ti::buffer-lf-to-crlf 'dos2unix))))
+ (when verb
+ (message "Http %s ...done" host))
+ (if (interactive-p)
+ (pop-to-buffer buffer))
+ (list buffer ret)))
+
+;;}}}
+;;{{{ shell: zipping
+
+;;; ....................................................... &shell-zip ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::process-uname ()
+ "Call `uname -a'."
+ (let* ((uname (executable-find "uname")))
+ (when uname
+ (with-temp-buffer
+ (call-process uname nil (current-buffer) nil "-a")
+ (buffer-string)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;; #todo
+;;; #not tested
+;;;
+(defun ti::process-zip (zip-file files &optional zip-cmd)
+ "Achive to ZIP-FILE. FILES is list (file file ..).
+The ZIP-CMD defaults to \"zip -9 -q\",
+Command will not return until the process has finished."
+ (let* ((zcmd (or zip-cmd "zip -9 -q "))
+ (shell-buffer (get-buffer-create "*Shell output*"))
+ (flist (ti::list-join files))
+ (cmd (concat zcmd " " zip-file " " flist)))
+ (call-process cmd nil shell-buffer)
+ (if (interactive-p)
+ (display-buffer shell-buffer))
+ shell-buffer))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::process-zip-view-command (file &optional buffer nice zip-cmd verb)
+ "Insert zip file listing to point.
+
+Input:
+
+ FILE tar file
+ BUFFER defaults to current buffer
+ NICE if non-nil, insert file name and empty lines around listing.
+ ZIP-CMD defaults to 'unzip -v %s'
+ VERB verbose mode
+
+Return:
+
+ nil no action [file not exist ...]
+ nbr shell return code"
+ (interactive "fTar file: ")
+ (let* ((cmd (or zip-cmd "unzip -v %s")))
+ (ti::verb)
+ (if (not (and (stringp file)
+ (file-exists-p file)))
+ (error "Invalid file argument")
+ (if nice
+ (insert "file " (file-name-nondirectory file) ":\n"))
+ (call-process cmd nil (or buffer (current-buffer)) nil
+ (expand-file-name file))
+ (if nice
+ (insert "\n")))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::process-tar-zip-view-maybe-command (file)
+ "If FILE is zip/tar then insert listing to current point."
+ (cond
+ ((string-match "\\.tar$\\|\\.tar.gz$\\|\\.tgz$" file)
+ (ti::process-tar-view-command file nil 'nice))
+ ((string-match "\\.zip$" file)
+ (ti::process-zip-view-command file nil 'nice))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'ti::process-perl-process-environment-macro 'lisp-indent-function 1)
+(put 'ti::process-perl-process-environment-macro 'edebug-form-spec '(body))
+(defmacro ti::process-perl-process-environment-macro (perl-type &rest body)
+ "Check PERL-TYPE and run BODY in correct Win32/Cygwin environment.
+Fixe TEMP variable during the process call.
+
+Input:
+
+ PERL-TYPE 'perl 'win32-cygwin 'win32-activestate
+ BODY Code to run."
+ (`
+ (let ((process-environment process-environment) ;; Make a local copy
+ new)
+ (dolist (elt process-environment)
+ (cond
+ ((string-match "^TEMP=\\(.*\\)" elt)
+ (let* ((tmp-dir (match-string 1 elt))
+ (dir (if (and (stringp tmp-dir)
+ (file-directory-p tmp-dir))
+ (expand-file-name tmp-dir))))
+ (cond
+ ((and (ti::win32-shell-p)
+ ;; c:\temp or \\server\temp
+ (not (string-match "=[a-z]:[\\]\\|=[\\][\\][a-z]" elt)))
+ (if (file-directory-p "C:/TEMP")
+ (push "TEMP=C:\\TEMP" new)
+ (push "TEMP=C:\\" new)))
+ ((and (string-match "[\\]\\|[a-z]:" tmp-dir) ;; Dos path
+ (not (eq perl-type 'win32-activestate)))
+ ;; Path must be in Unix format
+ (let* ((path (if dir
+ (w32-cygwin-dos-path-to-cygwin dir)
+ "/tmp"))
+ (env (format "PATH=%s" path)))
+ (push env new)))
+ (t
+ (push elt new)))))
+ ((string-match "^PAGER=" elt)) ;; Delete this
+ (t
+ (push elt new))))
+ (setq process-environment new)
+ (,@ body))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::process-perl-version (&optional binary)
+ "Check type of perl BINARY.
+
+Return:
+
+ (VERSION TYPE PATH OUTPUT)
+
+ VERSION Version number from command line option -version
+ TYPE is 'win32-activestate 'win32-cygwin or 'perl
+ PATH Path to the BINARY or `perl'.
+ OUTPUT Whole output of -v."
+ (let* ((perl (if binary
+ (executable-find binary)
+ (executable-find "perl")))
+ version
+ type
+ string)
+ (when perl
+ (with-temp-buffer
+ (call-process perl
+ nil
+ (current-buffer)
+ nil
+ "-v")
+ (setq string (buffer-string)))
+ (setq type
+ (cond
+ ((string-match "cygwin" string)
+ 'win32-cygwin)
+ ((string-match "activestate" string)
+ 'win32-activestate)
+ ((not (ti::nil-p string))
+ 'perl)
+ (t
+ (error "Unknown perl type: %s" string))))
+ ;; This is perl, v5.6.1 built for cygwin-multi
+ (when (string-match
+ "This[ \t]+is[ \t]+perl[ ,v\t]+\\([0-9.]+\\)"
+ string)
+ (setq version (match-string 1 string)))
+ (list version type perl string))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::process-java-version (&optional binary)
+ "Return java BINARY type and version number.
+
+Return:
+
+ (VERSION TYPE PATH FULL)
+
+ VERSION Version number from command line option -version
+ TYPE is 'sun or 'gcc or any other known Java vendor.
+ PATH Path to the BINARY or `java'.
+ FULL Whole output of -version."
+
+ (let* ((java (executable-find (or binary "java")))
+ version
+ type
+ string)
+ ;; Under Debian, `call-process' will hang during
+ ;; call to /usr/bin/java, which is a symlink
+ (when (and java
+ (file-symlink-p java))
+ (message "TinyLib: %s is symlink, cannot get version." java)
+ (setq java nil))
+ (when java
+ ;; #todo: gcj Java version?
+ (with-temp-buffer
+ (call-process java
+ nil
+ (current-buffer)
+ nil
+ "-version")
+ (setq string (buffer-string)))
+ (when
+ ;; Java HotSpot(TM) Client VM (build 1.3.0_02, mixed mode)
+ (or (string-match "build[ \t]+\\([0-9_.]+\\)" string)
+ ;; Debian:
+ ;;
+ ;; java version "1.3.1"
+ ;; Java(TM) 2 Runtime Environment, Standard Edition \
+ ;; (build Blackdown-1.3.1-02b-FCS)
+ (string-match "java +version +\"\\([0-9][0-9.]+\\)" string))
+ (setq version (match-string 1 string)))
+ (cond
+ ;; Java(TM) 2 Runtime Environment, Standard Edition (build 1.3.0_02)
+ ((string-match "Java(TM)[ \t]+[0-9]" string)
+ (setq type 'sun))
+ (t
+ (setq type 'gcc)))
+ (list version type java string))))
+
+;;}}}
+;;{{{ shell: tar
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::process-tar-view-command (file &optional buffer nice verb test)
+ "Insert tar file listing to point.
+
+Input:
+
+ FILE tar file
+ BUFFER default to current buffer
+ NICE if non-nil, insert file name and empty lines around listing.
+ VERB verbose mode
+ TEST Do not execute command. Print what would happen.
+
+Return:
+
+ nil no action [file not exist ...]
+ nbr shell return code"
+ (interactive "fTar file: ")
+ (let* ((def (cond
+ ((string-match "\\.tar$" file)
+ "tar tvf %s")
+ ((string-match "\\.tar\\.gz$" file)
+ "gzip -d -c %s |tar -tvf -")
+ ;; don't know this currently ...
+ ((string-match "\\.tgz$" file)
+ nil)))
+ cmd)
+
+ ;; Default tar switches:
+ ;; -t ,List the name
+ ;; -v ,verbose
+ ;; -f ,next arg argument as the name of the archive (file)
+ ;;
+ (ti::verb)
+ (when (and
+ (stringp file)
+ (file-exists-p file)
+ (progn
+ (or (file-exists-p "/hp-ux/")
+ (file-exists-p "/vol/")
+ (and verb
+ (y-or-n-p
+ (format "\
+Can't guess tar command, try using default %s ? " def))))
+ (setq cmd def)))
+ (if nice
+ (insert "file " (file-name-nondirectory file) ":\n"))
+ (call-process cmd nil (or buffer (current-buffer)) nil
+ (expand-file-name file))
+ (if nice (insert "\n")))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::process-tar-read-listing-forward ()
+ "Read all tar filenames from current line forward.
+The point is not preserved. The tar listing looks like:
+
+r-xr-xr-x 240/222 4269 Feb 3 09:25 1997 aa.cc
+r-xr-xr-x 240/222 41515 Feb 3 09:40 1997 bb.cc
+r-xr-xr-x 240/222 3013 Feb 3 09:40 1997 dd.cc
+
+or
+
+-r--r--r-- foo/bar 14764 1998-06-22 15:05:55 file.txt
+
+Return:
+
+ '((FILE SIZE PERMISSIONS) ..)"
+ (let* ((re (concat
+ "^\\([drwx-]+\\)[ \t]+[0-9A-Za-z_]+/[0-9A-Za-z_]+"
+ "[ \t]+\\([0-9]+\\)[ \t]+.*[0-9]:[0-9]+[ \t]+"
+ "\\(.*\\)"))
+ list)
+ (beginning-of-line)
+ (when (or (looking-at re)
+ (re-search-forward re nil t))
+ (beginning-of-line)
+ (while (and (looking-at re)
+ (not (eobp)))
+ (push (list (match-string 3) (match-string 2) (match-string 1)) list)
+ (forward-line 1) ))
+ (nreverse list)))
+
+;;}}}
+;;{{{ Reading lines, passwords
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::query-read-input-invisible ()
+ "Read keyboard input. If user presses ESC, the asking is interrupted.
+Return:
+ nil
+ string"
+ (let* ((echo-keystrokes 0) ;prevent showing
+ str
+ ch)
+ (while (not (ti::char-in-list-case ch '(?\n ?\C-m ?\e)))
+ (cond
+ ((ti::char-in-list-case ch '(?\b ?\177))
+ (if (eq 0 (length str))
+ (beep)
+ (setq str (substring str 0 (1- (length str)))) ))
+ ((ti::print-p ch)
+ (setq str (concat str (char-to-string ch))) ))
+ (setq ch (ti::read-char-safe-until)))
+ (if (char= ch ?\e)
+ (setq str nil))
+ str))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::query-read-input-as-password (&optional prompt max echo-char)
+ "Return read password using PROMPT, MAX chacters with ECHO-CHAR.
+If user presses ESC, return nil."
+ (let* (
+ (prompt (or prompt ""))
+ (cursor-in-echo-area nil)
+ (max (or max 80)) ;maximum string
+ (bar (if echo-char
+ (make-string (+ max 2) echo-char )
+ (make-string (+ max 2) ?* )))
+ str
+ ch
+ len)
+ (message prompt)
+ (while (not (ti::char-in-list-case ch '(?\n ?\C-m ?\e)))
+ (cond
+ ((or (ti::char-in-list-case ch '(?\b ?\177)))
+ (setq len (length str))
+ (unless (= len 0 )
+ (setq str (substring str 0 (1- len)))) )
+ ((ti::print-p ch)
+ (if (>= (length str) max)
+ (beep) ;signal error
+ (setq str (concat str (char-to-string ch)))
+ (message (substring bar 0 (length str)))) ))
+ (setq ch (ti::read-char-safe-until
+ (concat prompt (substring bar 0 (length str))))))
+ (message "")
+ (if (char= ch ?\e)
+ (setq str nil))
+ str))
+
+;;}}}
+
+;;{{{ misc: advice control
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::advice-control
+ (single-or-list regexp &optional disable verb msg)
+ "Enables/disable SINGLE-OR-LIST of adviced functions that match REGEXP.
+Signals no errors, even if function in LIST is not adviced.
+All advice classes ['any] are ena/disabled for REGEXP.
+
+Input:
+
+ SINGLE-OR-LIST function of list of functions.
+ REGEXP advice name regexp. Should normally have ^ anchor
+ DISABLE flag, if non-nil then disable
+ VERB enable verbose messages
+ MSG display this message + on/off indication"
+ (dolist (func (ti::list-make single-or-list))
+ (ignore-errors
+ (if disable
+ (ad-disable-advice func 'any regexp)
+ (ad-enable-advice func 'any regexp))
+ ;;change state
+ (ad-activate func)))
+ (if verb
+ (message
+ (concat
+ (or msg "advice(s): ")
+ (if disable "off" "on")))))
+
+;;}}}
+
+;;{{{ misc: -- packaging, install, reports
+
+;;; ..................................................... &bug-reports ...
+;;; - Take a look at lisp-mnt.el if you're writing
+;;; your own packages.
+
+;;; ----------------------------------------------------------------------
+;;; #defalias (defalias 'package-feedback 'ti::package-feedback)
+;;;
+(defun ti::package-submit-feedback (lib)
+ "Composes feedback report with lisp-mnt.el conmoncerning Lisp file LIB.
+Make sure the file beeing reported is valid according to
+lisp-mnt's command `lm-verify'."
+ (interactive "sSend mail regarding file: ")
+ (let (file
+ version
+ buffer)
+ (cond
+ ((setq file
+ (or (locate-library lib)
+ (progn
+ (setq lib (concat lib ".gz"))
+ (locate-library lib))))
+ (require 'lisp-mnt)
+ (set-buffer (setq buffer (ti::find-file-literally file)))
+ (setq version (ti::vc-rcs-buffer-version))
+ (lm-report-bug
+ (format "%s %s Feedback"
+ (or version "")
+ (file-name-nondirectory file)))
+ (kill-buffer buffer))
+ (t
+ (error (concat "No such file in load path: " lib))))))
+
+;;; ----------------------------------------------------------------------
+;;; - See package tinydiff.el and function tdi-feedback there if you
+;;; are still curious how to use this function
+;;;
+(defun ti::package-submit-bug-report
+ (lib id var-list &optional verb elts)
+ "Submit bug report with reporter.
+
+PRECONDITIONS before using this function
+
+1. The file must be in version control and it must have the \"\$ Id \$\" identifier
+ stored into variable. Like the following:
+
+ (defconst tinylib-version-id
+ \"\$ Id: tinylib.el,v 1.18 1996/01/24 09:44:48 jaalto Exp jaalto \$\"
+ \"Latest modification time and version number.\")
+
+2. The package must be valid according to lisp-mnt.el's command
+ `lm-verify' so that the \"maintainer\" information can be extracted.
+ This means that you file must have header like this:
+
+ ;; Maintainer: Foo Bar <foo@example.com>
+
+Input:
+
+ LIB filename without path. E.g. \"tinylib.el\"
+ ID the RCS Id string
+ VAR-LIST list of variables to get from package. Like '(var1 var2)
+ VERB Verbose messages and questions.
+ ELTS a) Buffer to included in report.
+ b) If this is functionp, then function must return a
+ string or buffer pointer to include.
+ c) if this is boundp, the value is taken as buffer
+ name string."
+ (interactive)
+ (let* (maintainer
+ subj
+ list)
+ (ti::verb)
+ (require 'reporter)
+ (setq maintainer
+ (or (car-safe (ti::package-get-header lib "maintainer")) ""))
+ (setq list (split-string id " "))
+ (setq subj (concat (nth 2 list) " " (nth 1 list))) ;; name && version
+ ;; ................................................... compose mail ...
+ (when (or (null verb)
+ (y-or-n-p "Do you really want to submit a report? "))
+ (reporter-submit-bug-report
+ maintainer
+ (nth 1 list)
+ var-list
+ nil nil
+ (concat "Hi,\n"))
+ ;; ............................................... insert content ...
+ (let (status
+ str
+ name
+ len
+ function)
+ (dolist (buffer elts)
+ (setq str nil
+ status nil
+ function nil)
+ ;; .............................................. detect type ...
+ (cond
+ ((stringp buffer)
+ (setq status (get-buffer buffer)))
+ ((memq buffer '(nil t))) ;; Ignore
+ ((and (symbolp buffer)
+ (boundp buffer))
+ (setq buffer (symbol-value buffer))
+ (if (stringp buffer)
+ (setq status (get-buffer buffer))
+ (message "TinyLib: bug report ERROR. Malformed syntax %s"
+ (prin1-to-string buffer))
+ (sleep-for 3)))
+ ((functionp buffer)
+ (setq function buffer)
+ (setq status (funcall function))
+ (cond
+ ((stringp status)
+ (setq str status))
+ ((bufferp status)
+ (setq buffer status)
+ (setq status t)))))
+ (when buffer
+ (when (and (interactive-p)
+ (null status))
+ (or
+ (y-or-n-p (format "Buffer `%s' missing, continue? Are you sure? "
+ (prin1-to-string buffer)))
+ (error "Abort.")))
+ ;; ................................................. insert ...
+ (when status
+ (setq name (cond
+ ((bufferp buffer)
+ (buffer-name buffer))
+ ((stringp buffer)
+ buffer)
+ (t
+ (symbol-name function))))
+ (setq len (- 70 (length name)))
+ (insert "\n\n[" name "] " (make-string len ?= ) "\n\n")
+ (setq len (buffer-size))
+ (if str
+ (insert str)
+ (insert-buffer buffer))
+ ;; `insert-buffer' does not put point after insert,
+ ;; go there manually
+ (when (> (buffer-size) len)
+ (forward-char (- (buffer-size) len)))))))
+ ;; ............................................... position point ...
+ (ti::pmin)
+ (if (re-search-forward "Subject: *" nil t)
+ (insert subj))
+ (re-search-forward "Hi,\n"))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::package-version-info (lib &optional arg)
+ "Gets package information and prints it to another buffer.
+The LIB is searched along 'load-path'.
+
+Preconditions:
+
+ The file must be valid according to lisp-mnt.el::lm-verify
+
+Interactive call:
+
+ You can complete the filename with TAB key
+
+Input:
+
+ LIB filename with .el added
+ ARG prefix arg, print the versionin info in mode-line
+ instead of creating full version buffer."
+ (interactive
+ (let* (file)
+ (setq
+ file
+ (ti::file-complete-filename-minibuffer-macro
+ (read-from-minibuffer
+ (format "[%s] Version info for library: " default-directory)
+ nil
+ map)))
+ (if (null file)
+ (setq file file)) ;XEmacs 19.14 bytecompiler silencer
+ ;; Make sure there is .el
+ (list
+ (ti::string-verify-ends file ".el")
+ current-prefix-arg)))
+ (let (out
+ file
+ buffer
+ tmp
+ lm-version
+ lm-summary
+ lm-maintainer
+ lm-creation-date
+ lm-last-modified-date
+ lm-commentary
+ rcs-id
+ maintainer-name
+ maintainer-email)
+ (cond
+ ((setq file
+ (or (locate-library lib)
+ (progn
+ (setq lib (concat lib ".gz"))
+ (locate-library lib))))
+ (require 'lisp-mnt)
+ (cond
+ ((not (null arg))
+ (set-buffer (setq buffer (ti::find-file-literally file)))
+ (setq rcs-id (or (ti::vc-rcs-str-find-buffer "Id") "<no rcs id>"))
+ (kill-buffer buffer)
+ (ti::read-char-safe-until rcs-id))
+
+ (t
+ (setq out (ti::temp-buffer "*version*" 'clear))
+ ;; Now get the information from file with lisp-mnt.el
+ (with-current-buffer (setq buffer (ti::find-file-literally file))
+ (setq
+ lm-version (lm-version)
+ lm-summary (lm-summary)
+ lm-maintainer (lm-maintainer)
+ lm-creation-date (lm-creation-date)
+ lm-last-modified-date (lm-last-modified-date)
+ lm-commentary (lm-commentary)
+ rcs-id (ti::vc-rcs-str-find-buffer "Id")))
+ (when (and (stringp lm-last-modified-date)
+ (eq 3 (length (setq tmp (split-string lm-last-modified-date))))
+ (eq 3 (length (nth 1 tmp))))
+ ;; Convert "16 Feb 2000" --> to ISO 8601 Date
+ (setq lm-last-modified-date
+ (format "%s-%s-%s"
+ (nth 2 tmp)
+ (ti::month-to-0number (nth 1 tmp))
+ (nth 0 tmp))))
+ (kill-buffer buffer)
+ (setq maintainer-name
+ (if (not (null lm-maintainer))
+ (or (car-safe lm-maintainer) "<name not known>")
+ "<name not known>"))
+ (setq maintainer-email
+ (if (not (null lm-maintainer))
+ (or (cdr-safe lm-maintainer) "no email info")
+ "no email info"))
+ (switch-to-buffer-other-window out)
+ (insert
+ lib " -- " (or lm-summary "<no info>") "\n\n"
+ "Created : " (or lm-creation-date "<no info>") "\n"
+ "Last modified: " (or lm-last-modified-date "<no info>") "\n"
+ "Maintainer : " maintainer-name " <" (or maintainer-email "") ">\n"
+ "Version : " (or lm-version "<no info>") "\n"
+ "\n\n"
+ (or lm-commentary "<no commentary found>"))
+ (pop-to-buffer out)
+ (ti::pmin) (ti::buffer-replace-regexp "^;;;" 0 " ")
+ (ti::pmin) (ti::buffer-replace-regexp "^;;" 0 " ")
+ (ti::pmin) (ti::buffer-lf-to-crlf 'dos2unix 'force)
+ (ti::pmin))))
+ (t
+ (error (concat "No such file in load path: " lib))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;
+(defun ti::package-get-header (lib header-list)
+ "Get standard header information: e.g. maintainer, version, author.
+The valid syntax of these headers is defined in lisp-mnt.el.
+Make sure the file being visited can be run with lisp-mnt's
+command `lm-verify'.
+
+Input:
+
+ LIB the filename of the package, including \".el\"
+ HEADER-LIST string or list of strings. E.g. '(\"maintainer\")
+
+Return:
+
+ list notice that empty hits are stored: '(nil nil ..)
+ nil"
+ (let ((header-list (ti::list-make header-list))
+ hit elt
+ file
+ buffer
+ ret)
+ (cond
+ ((setq file (locate-library lib))
+ (require 'lisp-mnt)
+ (unwind-protect ;make sure file is removed
+ (progn
+ (set-buffer (setq buffer (ti::find-file-literally file)))
+ (mapcar
+ (function
+ (lambda (header)
+ (setq elt (lm-header header))
+ (if elt ;did we find any ?
+ (setq hit t)) ;raise flag
+ (push elt ret)))
+ header-list))
+ ;; Kill the file no matter what happens.
+ (kill-buffer buffer)))
+ (t
+ (error (concat "No such file in load path: " lib))))
+ (if (null hit) ;if no hits, clear the ret value
+ (setq ret nil))
+ ret))
+
+;;; ......................................................... &package ...
+;;; - Here is some special functions. When you insert some example to
+;;; your package, you can convert functions and text directly to
+;;; "poor man's shar" format :-)
+;;; - With function ti::package-make-mode-magic, you just
+;;;
+;;; 1. Be in lisp mode
+;;; 2. Select example area to be inserted into somewhere
+;;; 3. call the functions --> The result is inserted into registed
+;;; 4. Go to package buffer and insert the register contents there.
+;;;
+;;; - Likewise the user can rip these "shar" examples with function
+;;; ti::package-rip-magic
+;;;
+;;; 1. Select area and call the function. --> examples in register
+;;; 2. Put them into your .emacs or another favourite file.
+;;;
+;;; - Use similar bindings
+;;; (global-set-key "\C-cp" 'ti::package-make-mode-magic)
+;;; (global-set-key "\C-cP" 'ti::package-rip-magic)
+
+;;; ----------------------------------------------------------------------
+;;
+(defun ti::package-install-example (lib &optional re)
+ "Install example setup for you from LIB.
+The LIB must be normal source file name ending in '.el'.
+Function tries to find $PackageInstallRe: 'REGEXP' $
+line which has the installation code chars in the surrounding
+quotes. The common practise is to have '^[ \t]*;;+[*]' for Lisp.
+If that regexp is followed by char '_' it means that the line is left empty.
+
+If you supply RE, it must have match in LEVEL 1.
+
+Return:
+ buffer pointer"
+ (interactive "sLibrary: ")
+ (let* ((tmp "*ti::pkg*")
+ (file (locate-library lib))
+ (verb (interactive-p))
+ ;; There has to be " " after the ":" otherwise it's not
+ ;; rcs ident(1) compatible. Also before the last $ ,
+ ;; there must be space.
+ (re (or re "[$]PackageInstallRe: [ \t]*'\\(.*\\)' [$]"))
+ (empty-line-ch "_")
+ bp ;buffer pointer
+ id
+ comment-re)
+ (if (or (null file)
+ (null (file-readable-p file)))
+ (error (concat "Cannot locate/read " lib " in load-path: " file))
+ (setq bp (ti::temp-buffer tmp 'clear))
+ (with-current-buffer bp
+ (insert-file-contents file)
+ (ti::pmin)
+ (if (or (null (re-search-forward re nil t))
+ (null (match-end 1)))
+ (progn
+ (pop-to-buffer bp)
+ (error (concat "Cannot find install regexp: " re)))
+ (setq comment-re (match-string 1)) ;read match in level 1
+ (if (ti::nil-p comment-re)
+ (error (concat "Level 1 mismatch_" (match-string 0) "_" re)))
+ (save-excursion (setq id (ti::vc-rcs-str-find "Id" )))
+ (ti::package-rip comment-re empty-line-ch (point-min) (point-max) )
+ (ti::pmin)
+ ;; And final touch, add version id if it existed.
+ (if (null id )
+ (insert (concat ";; No rcs id found.\n\n"))
+ (insert (concat ";; " id "\n\n")))
+ ;; Show contents if user called interactively.
+ (when verb
+ (pop-to-buffer bp)
+ (message "Automatic install done.")))))
+ bp))
+
+;;; ----------------------------------------------------------------------
+;;
+(defun ti::package-rip (re ch &optional beg end)
+ "Delete section of commented text, so that only code remains.
+The installed code portion should have RE at front of each line.
+
+RE must have anchor ^ and CH must have some magic char to
+mean empty line. like RE = '^;;+[*]' and CH = '_':
+
+ ;;* ;;This belongs to automatic install, below is empty line code
+ ;;* _
+
+Input:
+
+ RE ,regexp matching the examples
+ CH character signifying empty lines
+ BEG END area bounds
+
+Return:
+
+ t or nil"
+ (interactive)
+ (let* (ret)
+ (unless (and beg end)
+ (pop-to-buffer (current-buffer))
+ (error "ti::package-rip: Region not defined %s" (current-buffer)))
+ (save-restriction
+ (narrow-to-region beg end)
+ (ti::pmin)
+ (when (re-search-forward re nil t)
+ (ti::pmin)
+ (save-excursion (delete-non-matching-lines re))
+ ;; Now we have only RE lines
+ (while (not (eobp))
+ (when (looking-at re)
+ (delete-region (match-beginning 0) (match-end 0))
+ (if (looking-at ch) ;remove that char
+ (delete-char 1)))
+ (forward-line)
+ (setq ret t))))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::package-rip-magic (beg end &optional verb)
+ "As `ti::package-rip' BEG END, except the area is pasted to temporary buffer.
+Tthe lines are prepared AND the result is inserted to register. VERB.
+
+Make sure your are viewing the piece of code in the same mode that it is
+supposed to be used. Otherwise the magic syntax isn't regognized.
+
+Return:
+ t or nil"
+ (interactive "r")
+ (let* ((ob (current-buffer))
+ (str (ti::package-make-var))
+ (empty "_")
+ (reg ?p) ; "p" as "package"
+ ret
+ re)
+ (ti::verb)
+ (if (ti::nil-p str)
+ (error "\
+Couldn't set rip syntax, maybe `comment-start' is not defined.")
+ (with-temp-buffer
+ (insert-buffer-substring ob beg end) ;get the area
+ (setq re (concat "^" (regexp-quote str)))
+ (setq ret (ti::package-rip re empty (point-min) (point-max)))
+ (pop-to-buffer (current-buffer))
+ (cond
+ (ret
+ (set-register reg (buffer-string))
+ (if verb
+ (message "Example ripped to register `%c' " reg)))
+ (t
+ (when verb
+ (message "could find Rip regexp `%s' from region." re))))))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::package-make-mode-magic (beg end)
+ "As `ti::package-make-mode', except BEG END is pasted to temporary buffer.
+The lines are prepared AND the result is inserted to register.
+
+Return:
+ t or nil according to success."
+ (interactive "r")
+ (let* ((source (current-buffer)) ;source buf
+ (m major-mode) ;we must use same mode
+ (verb (interactive-p))
+ (reg ?p))
+ (with-temp-buffer
+ (insert-buffer-substring source beg end)
+ ;; turning mode on may have effects, since it runs hooks...
+ ;;
+ (funcall m) ;turn on same mode
+ (when (ti::package-make-mode (point-min) (point-max))
+ (set-register reg (buffer-string))
+ (if verb
+ (message "example in register `%c'" reg))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;
+(defun ti::package-make-mode (beg end)
+ "Make embedded package around BEG END according to mode.
+** DOES NOT WORK FOR MODES WITH `comment-end' ***
+
+Return:
+ nil or t if successfull."
+ (interactive "*r")
+ (let* ((str (ti::package-make-var))
+ (empty "_")
+ ret)
+ (if (not (ti::nil-p comment-end))
+ (message "tinylib: Comment end found, cannot proceed.")
+ (ti::package-make beg end str empty)
+ (setq ret t))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::package-make-var ()
+ "Return Packaging variable 'str' according to mode.
+If mode has no comment syntax default ';;* ' is used."
+ (let* ((cs comment-start)
+ (cs (cond ;set up something special
+ ((memq major-mode
+ '(lisp-mode emacs-lisp-mode lisp-interaction-mode))
+ (setq cs ";;")) ;default ';' isn't enough
+ (t cs))) ;do not change it
+ (str (if (null cs)
+ ";;* "
+ ;; make sure there is space
+ (concat cs "* "))))
+ str))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::package-make (beg end str ch)
+ "Format area for automatic install.
+
+Input:
+
+ BEG END area
+ STR string to be added at front
+ CH additional character for empty lines."
+ (let* ((empty (concat str
+ (cond
+ ((integerp ch)
+ (char-to-string ch))
+ (
+ ch)))))
+ (save-restriction
+ (narrow-to-region beg end)
+ (goto-char (min beg end))
+ (while (not (eobp))
+ (if (looking-at "^[ \t]*$")
+ (insert empty)
+ (insert str))
+ (forward-line 1)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::package-autoload-create-on-file
+ (file &optional buffer no-show no-desc)
+ "Very simple autoload function generator out of FILE.
+Optionally put results to BUFFER. NO-SHOW does not show buffer.
+
+Note:
+
+ Doesn't recognize ###autoload tags; reads only functions.
+
+Input:
+
+ FILE Lisp .el to read
+ BUFFER Where to insert autoloads.
+ NO-SHOW Do not show autoload buffer
+ NO-DESC Do not include function description comments."
+ (interactive "fConstruct lisp autoloads from file: ")
+ (let* ((fn (file-name-nondirectory file))
+ (regexp (concat
+ "^(\\("
+ "defun\\|defmacro\\|defsubst"
+ ;; SEMI poe.el
+ "\\|defun-maybe\\|defsubst-maybe\\|defmacro-maybe"
+
+ "\\)"
+ "[ \t]+\\([^ \t\n(]+\\)[ \t]*"))
+ list
+ args
+ func
+ type
+ str
+ iact
+ point
+ read-buffer
+ tmp)
+ (or buffer
+ (setq buffer (get-buffer-create (or buffer "*Autoloads*"))))
+ ;; We want to say (autoload 'func "pacakge" t t)
+ ;; and not (autoload 'func "pacakge.el" t t)
+ ;; so that .elc files can be used.
+ (if (string-match "\\(.*\\).el" fn)
+ (setq fn (match-string 1 fn)))
+ (unless (setq read-buffer (find-buffer-visiting file))
+ (setq read-buffer (setq tmp (ti::find-file-literally file))))
+ (with-current-buffer read-buffer
+ ;; Can't use forward-sexp etc otherwise
+ (unless (string-match "lisp" (symbol-name major-mode))
+ (let (emacs-lisp-mode-hook) ;; Run no hooks
+ (if emacs-lisp-mode-hook ;; Quiet ByteCompiler "unused var"
+ (setq emacs-lisp-mode-hook nil))
+ (emacs-lisp-mode)))
+ (ti::append-to-buffer
+ buffer (concat "\n;; "
+ (file-name-nondirectory file)
+ "\n"
+ ";; "
+ file
+ "\n\n"))
+ (ti::pmin)
+ (while (re-search-forward regexp nil t)
+ (setq iact nil ;interactive flag
+ args nil
+ type (match-string 1)
+ func (match-string 2))
+ (when (and func
+ (progn
+ (goto-char (goto-char (match-end 0)))
+ (when (search-forward "(" nil t)
+ (setq point (point))
+ (backward-char 1)
+ (forward-sexp 1)
+ (backward-char 1)
+ (setq
+ args
+ (subst-char-in-string
+ ;; Convert multiline args to one line.
+ ?\n ?\
+ (buffer-substring point (point)) )))))
+ (if (re-search-forward
+ "[ \t\n]+([ \t]*interactive"
+ (save-excursion (end-of-defun) (point))
+ t)
+ (setq iact "t"))
+ (cond
+ ((null args)
+ (setq args (format ";; %-36s <args not known>\n" func))
+ ((string= args "")
+ (setq args (format ";; %s\n" func)))
+ ((> (length args) 32)
+ (setq args (format ";; %-15s %s\n" func args)))
+ (t
+ (setq args (format ";; %-36s %s\n" func args)))))
+ (push args list)
+ ;; (autoload FUNCTION FILE &optional DOCSTRING INTERACTIVE TYPE)
+ (setq str (format "(autoload '%-36s %s \"\" %s%s)%s\n"
+ func
+ (format "\"%s\"" fn)
+ (or iact "nil")
+ (if (string-match "defmacro" type )
+ " 'macro" "")
+ (if (string= type "defsubst")
+ (format ";;%s" type) "")))
+ (ti::append-to-buffer buffer str)
+ (setq iact "t")))
+ (unless no-desc
+ (with-current-buffer buffer
+ (insert "\n") ;list arguments for functions.
+ (dolist (elt list) (insert elt)))))
+ (if tmp ;We loaded this to Emacs, remove it
+ (kill-buffer tmp))
+ (unless no-show
+ (pop-to-buffer buffer)
+ (ti::pmin))
+ buffer))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::package-autoload-create-on-directory
+ (dir &optional buffer no-show no-desc)
+ "Create autoloads from function definitions in lisp files in DIR.
+Optionally put results to BUFFER. NO-SHOW does not show buffer.
+
+Note:
+
+ Doesn't recognize ###autoload tags; reads only functions.
+
+Input:
+
+ See argument description in function `ti::package-autoload-create-on-file'."
+ (let* ((files (directory-files
+ dir
+ 'full
+ "\\.el$")))
+ (dolist (file files)
+ (ti::package-autoload-create-on-file file buffer no-show no-desc))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::package-autoload-loaddefs-create-maybe (file)
+ "Make sure `generated-autoload-file' exists for FILE."
+ (unless (file-exists-p file)
+ (let* ((name1 (file-name-nondirectory file)))
+ (with-temp-buffer
+ (insert
+ (format ";;; %s -- " name1)
+ "loaddef definitions of program files\n"
+ ";; Generate date: " (format-time-string "%Y-%m-%d" (current-time))
+ "\n\
+;; This file is automatically generated. Do not Change."
+ "\n\n"
+ (format "\n(provide '%s)\n\n"
+ (file-name-sans-extension (file-name-nondirectory name1))))
+ (ti::with-coding-system-raw-text
+ (write-region (point-min) (point-max) file))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::package-autoload-loaddefs-dir-files (dir &optional regexp)
+ "Return from DIR .el files that do not matching REGEXP.
+TO-FILE is excluded from autoload search."
+ (let* (ret)
+ (dolist (file (directory-files dir 'abs))
+ (when (and (not (file-directory-p file))
+ (string-match "\.el$" file)
+ (or (null regexp)
+ (not (string-match regexp file))))
+ (push file ret )))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::package-autoload-loaddefs-build-dir-1 (dir &optional regexp to-file)
+ "Build autoloads in DIR not matching REGEXP TO-FILE."
+ (let ((files (ti::package-autoload-loaddefs-dir-files dir regexp)))
+ (when files
+ (let* (
+ ;; the original Emacs autload.el var does not contain "^"
+ ;; and this picks up wrong autoload definitions e.g. in
+ ;; auctex/tex-info.el which contains code
+ ;; ;;; Do not ;;;###autoload because conflicts standard texinfo.el.
+ ;; (defun texinfo-mode ()
+ ;;
+ ;; (generate-autoload-cookie "^;;;###autoload")
+ ;;
+ ;; ...but, we cannot do that because
+ ;; generate-autoload-cookie is not a regexp, because in
+ ;; autoload.el there is statement in
+ ;; generate-file-autoloads()
+ ;;
+ ;; (regexp-quote generate-autoload-cookie)
+ ;;
+ find-file-hooks
+ write-file-hooks
+ font-lock-mode
+ ;; buffer-auto-save-file-name
+ auto-save-hook
+ auto-save-default
+ (auto-save-interval 0)
+ (original-backup-inhibited backup-inhibited)
+ (backup-inhibited t))
+ ;; Reset also global
+ (setq-default backup-inhibited t)
+ ;; When each file is loaded to emacs, do not turn on lisp-mode
+ ;; or anything else => cleared file hooks. These are byte compiler
+ ;; silencers:
+ (if (null find-file-hooks)
+ (setq find-file-hooks nil))
+ (if (null write-file-hooks)
+ (setq write-file-hooks nil))
+ (if (null font-lock-mode)
+ (setq font-lock-mode nil))
+ (if (null auto-save-hook)
+ (setq auto-save-hook nil))
+ (if (null auto-save-default)
+ (setq auto-save-default nil))
+ (if auto-save-interval
+ (setq auto-save-interval 0))
+ (if backup-inhibited
+ (setq backup-inhibited t))
+ (ti::package-autoload-loaddefs-create-maybe to-file)
+ (dolist (file files)
+ ;; (message "TinyLib: Updating loaddefs %s %s"
+ ;; generated-autoload-file file)
+ (message "TinyLib: Updated loaddefs %s => %s" dir to-file)
+ (update-file-autoloads file))
+ (setq-default backup-inhibited original-backup-inhibited)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::package-autoload-loaddefs-build-dir
+ (dir to-file &optional regexp force)
+ "Build autoloads in DIR TO-FILE like like `update-file-autoloads' does.
+
+Input:
+
+ DIR Directory
+ TO-FILE The autoload file
+ REGEXP Ignore files matching regexp.
+ FORCE If non-nil, delete previous TO-FILE."
+ (let* ((generated-autoload-file to-file) ;; See autoload.el, must be bound
+ (name (file-name-nondirectory to-file))
+ (buffer (find-buffer-visiting to-file))
+ load)
+ (unless generated-autoload-file ;; just byte compiler silencer.
+ (setq generated-autoload-file nil))
+ ;; Exclude to-file from search.
+ (if regexp
+ (setq regexp (concat regexp "\\|" (regexp-quote name)))
+ (setq regexp (regexp-quote name)))
+ (when buffer
+ (ti::kill-buffer-safe buffer)
+ (setq load t))
+ (when (and force
+ (file-exists-p to-file))
+ (ti::file-delete-safe to-file))
+;;; (dolist (file (ti::package-autoload-loaddefs-dir-files dir regexp))
+;;; (message "TinyLib: loaddefs %s %s" generated-autoload-file file)
+;;; (update-file-autoloads file))
+ (ti::package-autoload-loaddefs-build-dir-1 dir regexp to-file)
+ (when (setq buffer (find-buffer-visiting to-file))
+ (with-current-buffer buffer
+ (let (buffer-auto-save-file-name
+ auto-save-default)
+ (save-buffer))))
+ (when load ;; Reload, because buffer was in Emacs
+ (find-file-noselect to-file))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::package-autoload-directories (list)
+ "Return only directories from LIST, excluding version control directories."
+ (let* (ret)
+ (dolist (elt list)
+ (when (and (file-directory-p elt)
+ ;; Drop . ..
+ (not (string-match
+ "[/\\]\\..?$\\|CVS\\|RCS"
+ elt)))
+ (push elt ret)))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::package-autoload-loaddefs-build-recursive
+ (dir regexp &optional force function)
+ "Build like `update-file-autoloads' recursively below DIR.
+Input:
+
+ DIR Root directory to start searching
+ REGEXP Regexp to exclude files.
+ FORCE Recreate TO-FILE from scratch by deleting previous.
+ You should do this if you have renamed any files in the directories.
+ FUNCTION Function to return autoload filename for each directory.
+ Called with arg `dir'. The default file is loaddefs.el."
+ (interactive "DEmacs autoload build root:\nfTo file: ")
+ (unless dir
+ (error "need DIR"))
+ (let* ((dirs (ti::package-autoload-directories
+ (directory-files
+ (expand-file-name dir)
+ 'abs)))
+ (to-file (or (and function
+ (funcall function dir))
+ "loaddefs.el")))
+ (cond
+ (dirs
+ (ti::package-autoload-loaddefs-build-dir dir to-file regexp force)
+ (dolist (dir dirs)
+ (ti::package-autoload-loaddefs-build-recursive
+ dir regexp force function)))
+ (t
+ (ti::package-autoload-loaddefs-build-dir dir to-file regexp force)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::package-install-pgp-tar (dir &optional log-buffer source test)
+ "Install PGP signed tar block using DIR from the end of current buffer.
+The 'BEGIN PGP MESSAGE' is searched from the end of buffer backward.
+
+The TAR block in the buffer looks like this and it is base64 pgp
+signed (clearsig is off) with Author's public key.
+
+ ;; -----BEGIN PGP MESSAGE-----
+ ;; Version: 2.6.3ia
+ ;;
+ ;; owHsWc1vG0l2n0GwwYjA3pJLgEXKlNaSDJLilySblrWWLXrMrCQrpOydzcxA02wW
+ ;; ...
+ ;; ...
+ ;; -----END PGP MESSAGE-----
+
+This function
+
+o Asks to what directory the tar files are installed.
+o shows the log buffer and echoes commads used.
+o Calls pgp to unpack the signed block
+o Calls tar to unpack the files
+o temporary files are stored to TMP, TMPDIR or /tmp
+
+Error conditions:
+
+o if 'pgp' executable is not found, function aborts.
+o if 'tar' executable is not found, function aborts.
+o if previously installed files exists, function aborts.
+
+Input:
+
+ DIR where to unpack the files
+ LOG-BUFFER where to print log messages.
+ SOURCE instead of using current buffer, read this file"
+
+ (interactive "DSave programs to directory: ")
+ (let* (
+ (pgp (or (and (executable-find "pgp")
+ ;; Do not use returned absolute path
+ ;; due to platform independency
+ "pgp")
+ (message "TinyLib: Can't find `pgp'.")))
+ (gpg (or (and (executable-find "pgp")
+ "pgp")
+ (message "TinyLib: Can't find `gpg'.")))
+ (pgp-bin (or pgp gpg))
+ (tar (or (executable-find "tar")
+ (error "TinyLib: Can't find 'tar'.")))
+ (tmp (or (and (getenv "TMP")
+ (ti::file-make-path (getenv "TMP")))
+ (and (getenv "TMPDIR")
+ (ti::file-make-path (getenv "TMPDIR")))
+ "/tmp/"))
+ ;; This may be system dependent someday..
+ (tar-opt-show "tvf")
+ (tar-opt-x "xvf")
+ (obuffer (current-buffer))
+ (in-file (expand-file-name (concat tmp "t.in")))
+ (out-file (expand-file-name (concat tmp "t.out")))
+ cmd
+ in
+ buffer
+ beg
+ end
+ file-list
+ list)
+ (unless pgp-bin
+ (error "TinyLib: PGP or GPG is required to unpack."))
+ ;; We need to expand this for shell calls
+ (setq dir (expand-file-name (ti::file-make-path dir)))
+ (cond
+ ((and source
+ (not (file-exists-p source)))
+ (error "TinyLib: Can't find '%s'" source))
+ ((not (file-directory-p tmp))
+ (error "TinyLib: Can't use directory '%s'. Set env variable TMP." tmp))
+ ((not (file-exists-p dir))
+ (error "TinyLib: No such directory %s." dir)))
+ (setq buffer (ti::temp-buffer
+ (or log-buffer "*tinylib::install*")
+ 'clear))
+ (with-current-buffer buffer
+ ;; .............................................. extract base64 ...
+ (buffer-disable-undo)
+ (if source
+ (insert-file-contents source)
+ (insert-buffer obuffer))
+ (ti::pmax)
+ (unless (re-search-backward
+ (concat "^;;+[ \t]*\\(" (ti::mail-pgp-msg-end-line) "\\)")
+ nil t)
+ (pop-to-buffer (current-buffer))
+ (error "TinyLib: Can't find PGP end %s " source))
+ (setq end (match-beginning 1))
+ (unless (re-search-backward
+ (concat "^;;+[ \t]*" (ti::mail-pgp-msg-begin-line))
+ nil t)
+ (pop-to-buffer (current-buffer))
+ (error "TinyLib: Can't find PGP beginning %s " source))
+ (beginning-of-line)
+ ;; remove comments
+ (delete-rectangle (point) end)
+ ;; Leave only the signed region, remove rest
+ (delete-region (point-min) (point))
+ (buffer-enable-undo)
+ ;; .................................................... call pgp ...
+ (setq cmd (format "%% rm %s %s\n" in-file out-file))
+ (unless test
+ (ti::file-delete-safe (list in-file out-file)))
+ (write-region (point-max) (point-min) in-file)
+ (unless (file-exists-p in-file)
+ (error "TinyLib: Writing PGP data failed to file %s" in-file))
+ ;; Write-file may have some strange modes, be sure we can read them
+ ;; 384dec = 600oct
+ (set-file-modes in-file (logior (file-modes in-file) 384))
+ (erase-buffer)
+ ;; Start showing the log to user
+ (pop-to-buffer buffer)
+ (insert cmd)
+ (let* ((out-file (ti::file-name-forward-slashes out-file))
+ (default-directory (file-name-directory out-file))
+ (file (file-name-nondirectory out-file)))
+ (insert (format "%% cd %s ; %s -o %s %s\n"
+ default-directory
+ pgp-bin
+ file
+ (file-name-nondirectory in-file)))
+ (unless test
+ (call-process pgp-bin
+ nil
+ buffer
+ nil
+ "-o" file (file-name-nondirectory in-file))
+ (ti::pmin)
+ (unless (re-search-forward "Plaintext filename:" nil t)
+ (error "TinyLib: Can't proceed, PGP didn't set filename.")))
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. show tar content ..
+ (ti::pmax)
+ (setq cmd (format "cd %s ; %s %s %s"
+ default-directory
+ tar
+ tar-opt-show
+ file))
+
+ (insert "% " cmd "\n") (setq beg (point))
+ (unless test
+ (call-process tar
+ nil buffer nil
+ tar-opt-show
+ file)
+ (goto-char beg)
+ (if (null (setq file-list (ti::process-tar-read-listing-forward)))
+ (error "TinyLib: Can't find tar listing."))))
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. previously installed? ..
+ (setq list file-list)
+ (dolist (elt list)
+ (setq in (concat dir (car elt)))
+ (when (file-exists-p in)
+ (if (y-or-n-p
+ (format
+ "TinyLib: Previously installed file `%s'. Overwrite ? "
+ in))
+ (unless test
+ (delete-file in))
+ (error "Abort.")) ))
+ (setq cmd (format "cd %s ; tar %s %s"
+ (expand-file-name dir)
+ tar-opt-x
+ out-file))
+ (insert "% "cmd "\n")
+ (unless test
+ (let* ((default-directory (expand-file-name dir)))
+ (call-process tar nil buffer nil
+ tar-opt-x
+ (expand-file-name out-file))))
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. . clean ..
+ (when (y-or-n-p "TinyLib: Clean up tmp files? ")
+ (push in-file file-list)
+ (push out-file file-list)
+ (dolist (elt file-list)
+ (insert (format "%% rm %s\n" elt))
+ (unless test
+ (ti::file-delete-safe elt) )))
+ (message "TinyLib: installation to %s complete" dir))))
+
+;;}}}
+;;{{{ misc: XEmacs compatibility
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::compat-installation-root ()
+ "Return XEmacs installation root directory without trailing slash.
+If this is queried unde Emacs, `exec-path' must contain XEmacs binary,
+otherwise `load-path' is conculted."
+ (let* ((xemacs (ti::xemacs-p))
+ (ver (if xemacs
+ (ti::emacs-version-number-as-string))) ;eg "19.14"
+ match
+ ret)
+ (dolist (path (if xemacs
+ load-path
+ exec-path))
+ ;; When we find the version from the path, ve know the root
+ ;; directory
+ ;;
+ ;; /opt/local/lib/xemacs-19.14/lisp/vms -->
+ ;; /opt/local/lib/xemacs-19.14/lisp/
+ (when (and (stringp path)
+ (string-match "xemacs" path)
+ (if ver
+ ;; running under XEmacs, we know what to look for.
+ (setq match (ti::string-match
+ (concat "^.*" ver) 0 path))
+ ;; Take a guess, anything that looks like XEmacs in path
+ (setq match
+ (ti::string-match
+ ;; XEmacs-21.2.36/ or XEmacs/21.2.36/
+ "^\\(.*xemacs[-\\/][0-9]+\\.[0-9.]*[0-9]\\)[\\/]"
+ 1 path))))
+ (setq ret (concat match "/lisp"))
+ (return)))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::compat-overlay-some ()
+ "Return some existing overlay that is used in Emacs.
+Usually the primary mouse selection. You can use this function to get an
+overlay that you can move in text if you don't want to create
+new overlay.
+
+Return:
+ overlay symbol"
+ (cond
+ ((and (ti::xemacs-p)
+ (boundp 'primary-selection-extent))
+ 'primary-selection-extent)
+ ((and (ti::emacs-p)
+ (boundp 'mouse-drag-overlay))
+ 'mouse-drag-overlay)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::compat-overlay-properties (overlay)
+ "Return properties of OVERLAY."
+ (cond
+ ((ti::overlay-supported-p)
+ (ti::funcall 'overlay-properties overlay))
+ ((ti::xemacs-p)
+ (ti::funcall 'extent-properties overlay))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::compat-overlays-at (point)
+ "Return overlays at POINT."
+ (cond
+ ((ti::overlay-supported-p)
+ (ti::funcall 'overlays-at point))
+ ((ti::xemacs-p)
+ (let* (list)
+ (ti::funcall
+ 'map-extents
+ (function (lambda (ov maparg) (push ov list)))
+ (current-buffer) point point)
+ list))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::compat-overlay-put (ov-sym prop val)
+ "Set properties to overlay OV-SYM. Put PROP VAL pair to OV-SYM."
+ (cond
+ ((ti::overlay-supported-p)
+ (ti::funcall 'overlay-put (symbol-value ov-sym) prop val))
+ ((ti::xemacs-p)
+ (ti::funcall 'set-extent-property (symbol-value ov-sym) prop val))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::compat-overlay-move (ov-sym beg end &optional make-local face)
+ "Move overlay OV-SYM to BEG END. Overlay is created if it does not exist.
+MAKE-LOCAL localizes the overlay. If the overlay is created,
+then FACE is assigned to it (default 'highlight)"
+ (cond
+ ((ti::overlay-supported-p)
+ ;; ................................................ create overlay ...
+ ;; later XEmacs may have overlay emulation
+ (or (symbol-value ov-sym) ;Exist?
+ (progn
+ (if make-local (make-local-variable ov-sym))
+ (set ov-sym
+ (ti::funcall 'make-overlay (point) (point)))
+ (ti::funcall 'overlay-put
+ (symbol-value ov-sym)
+ 'face (or face 'highlight))))
+ ;; .......................................................... move ...
+ (ti::funcall 'move-overlay (symbol-value ov-sym)
+ beg end (current-buffer)))
+ ((ti::xemacs-p)
+ (or (symbol-value ov-sym) ;Exist?
+ (progn
+ (if make-local (make-local-variable ov-sym))
+ (set ov-sym
+ (ti::funcall 'make-extent (point) (point)))
+ (ti::funcall 'set-extent-property
+ (symbol-value ov-sym)
+ 'face (or face 'highlight))))
+ (ti::funcall 'set-extent-endpoints
+ (symbol-value ov-sym)
+ beg end (current-buffer)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::compat-activate-region (&optional off)
+ "Activate region or turn the region OFF."
+ (if (ti::emacs-p)
+ (ti::funcall 'transient-mark-mode (if off 0 1)) ;From Simple.el
+ (if off
+ (ti::funcall 'zmacs-deactivate-region)
+ (set 'zmacs-regions (if off nil t)) ;Avoid bute compile mesage in Emacs
+ (ti::funcall 'activate-region))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::compat-read-password (&optional prompt)
+ "Read password with PROMPT which defaults to 'Password: '."
+ (let* ((var-bind (boundp 'record-keystrokes))
+ ;; If a GC occurred during that timing window, and a core dump was
+ ;; forced later, the core might contain the string.
+ ;; --> use most-positive-fixnum
+ (gc-cons-threshold (* 1024 1024))
+ record-keystrokes) ;XEmacs 20.4
+ (setq prompt (or prompt "Password: "))
+ (prog1
+ (cond
+ ((ti::xemacs-p)
+ ;; if one follows the
+ ;; - as soon as you are done with the returned string,
+ ;; destroy it with (fillarray string 0).
+ ;;
+ (require 'passwd) ;utils/passwd.el
+ (ti::funcall 'read-passwd prompt))
+ (t
+ ;; Could also use (comint-read-noecho prompt)
+ ;; Comint won't echo anything.
+ (ti::query-read-input-as-password prompt)))
+ ;; ByteComp silencer; non used variable
+ (if record-keystrokes
+ (setq record-keystrokes nil))
+ ;; In old Emacs versions 19.35< and XEmacs 19.16< 20.3<
+ ;; you can actually read the password from lossage buffer with C-h l
+ ;;
+ ;; --> We can clear it by filling it with 100 new characters.
+ ;; But this really works in XEmacs only, because Emacs
+ ;; Doesn't log events from macros.
+ ;;
+ (cond
+ ((fboundp 'clear-lossage)
+ (ti::funcall 'clear-lossage))
+ ((fboundp 'clear-recent-keys)
+ (ti::funcall 'clear-recent-keys))
+ ((and (ti::xemacs-p)
+ (not var-bind))
+ (save-window-excursion
+ (with-temp-buffer
+ ;; force writing "1" x 100 in this buffer
+ ;;
+ (switch-to-buffer (current-buffer))
+ (ti::dotimes counter 1 100 (execute-kbd-macro "1")))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::compat-key-local-map (key)
+ "Return local map function for KEY"
+ (let* ((prop (text-properties-at (point)))
+ (map (and prop
+ (nth 1 (memq 'keymap prop))))
+ (function (and map
+ (lookup-key map key))))
+ function))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::compat-key-call-original (minor-mode-symbol key-binding)
+ "Turn of MINOR-MODE-SYMBOL and execute original KEY-BINDING.
+This won't work on mouse commands that examine the mouse `event'"
+ (let* ((map (or (current-local-map) global-map))
+ (function (lookup-key map key-binding))
+ (this-command (if function function this-command)))
+ (when (and (not (ti::bool-p function))
+ (symbolp function)
+ (fboundp function))
+ (unwind-protect
+ (progn
+ (put minor-mode-symbol 'ti::orig-value-key
+ (symbol-value minor-mode-symbol))
+ (set minor-mode-symbol nil)
+ ;; This is very simplistic call. E.g. mouse event should
+ ;; be called with (funcall function event)
+ (call-interactively function)))
+ ;; Make sure minor mode setting is restored
+ (set minor-mode-symbol
+ (get minor-mode-symbol 'ti::orig-value-key)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::compat-mouse-position-coordinates ()
+ "Return '(LINE COLUMN) where mouse pointer is currently.
+If mouse is not supported, return nil."
+ (when (fboundp 'mouse-position)
+ (let ( ;; (frame (car (mouse-position)))
+ (x (cadr (mouse-position)))
+ (y (cddr (mouse-position))))
+ ;; window-list returns all windows starting from TOP. Count
+ ;; Lines in every window and compare that to mouse-position
+ (let ((win (get-buffer-window (current-buffer)))
+ (count 0))
+ (save-window-excursion
+ (dolist (elt (window-list))
+ (when (eq elt win)
+ (return))
+ (select-window elt)
+ ;; Modeline is not counted as +1
+ (setq count (+ count (window-height)))))
+ ;; (ti::d! count x y)
+ (list (1+ (- y count))
+ ;; In Emacs 21.x there is a "fringe" that mouse-position
+ ;; reports as X=0,
+ (if (eq x 0)
+ ;; Consider "fringe" as column 0
+ 0
+ ;; Removed "fringe" count
+ (1- x)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::compat-mouse-key (event)
+ "Return mouse key for EVENT."
+ (cond
+ ((ti::emacs-p)
+ (make-vector 1 (car event)))
+ ((ti::xemacs-p)
+ (vector
+ (append (event-modifiers event)
+ (list (intern
+ (format
+ "button%d"
+ (ti::funcall 'event-button event)))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::compat-mouse-call-original-function (minor-mode-symbol &optional event)
+ "Return original function behind MINOR-MODE-SYMBOL with mouse EVENT.
+See. `ti::-xe-mouse-call-original'."
+ (let* (ret
+ flyspell-p)
+ (or event
+ (setq event last-input-event))
+ (when (or (null minor-mode-symbol)
+ (not (symbolp minor-mode-symbol))
+ (not (boundp minor-mode-symbol)))
+ (error "Invalid minor-mode-symbol `%s'." minor-mode-symbol))
+ ;; Turn off minor mode, so that we can see the real
+ ;; function behind it.
+ (put minor-mode-symbol 'ti::orig-value (symbol-value minor-mode-symbol))
+ (set minor-mode-symbol nil)
+ ;; Unfortunately if flyspell is active (mouse-2 binding), ir does not look
+ ;; key definition of mouse-2, but a `this-command-keys',
+ ;; which is not correct.
+ ;; => Turn off flyspell if there is no flyspell overlay underneath
+ (when (and (boundp 'flyspell-mode)
+ flyspell-mode
+ (fboundp 'flyspell-overlay-p)
+ (not (ti::funcall 'flyspell-overlay-p (overlays-at (point)))))
+ (put minor-mode-symbol 'ti::orig-value-flyspell flyspell-mode)
+ (setq flyspell-p t)
+ (setq flyspell-mode nil))
+ (setq ret (key-binding (ti::compat-mouse-key event))) ;Read it
+ ;; Restore active modes
+ (when flyspell-p
+ (put minor-mode-symbol 'ti::orig-value-flyspell flyspell-mode))
+ (set minor-mode-symbol (get minor-mode-symbol 'ti::orig-value))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defvar ti::-xe-mouse-call-original nil "See ti::keymap-mouse-call-original.")
+
+(defun ti::compat-mouse-call-original (minor-mode-symbol &optional event)
+ "Execute original mouse function by turning of MINOR-MODE-SYMBOL.
+EVENT is mouse event. You use this function to to handle 'hot spots' in the
+buffer and in other places you call the original function.
+
+Do nothing if original function does not exist.
+Does nothing when called by a function which has earlier been called
+by us.
+
+Example for some minor mode implementation:
+
+ext-pro (defun folding-mode-context-sensitive (event)
+ (interactive \"e\")
+ ;; If test.. if test..no, then call original function
+ (ti::compat-mouse-call-original 'folding-mode event))
+
+Note:
+
+ Works in XEmacs and Emacs
+
+Sets global:
+
+ `ti::-xe-mouse-call-original'"
+ ;; Without the following test we could easily end up in a endless
+ ;; loop in case we would call a function which would call us.
+ (if ti::-xe-mouse-call-original ;; We're looping already
+ nil
+ (setq ti::-xe-mouse-call-original t)
+ (unwind-protect
+ (let* ((orig-buf (current-buffer))
+ (mouse-func (ti::compat-mouse-call-original-function
+ minor-mode-symbol event))
+ (local-func (ti::compat-key-local-map
+ (ti::compat-mouse-key event)))
+ (orig-func (or local-func
+ mouse-func))
+ (event-p (when orig-func
+ (string-match
+ "event"
+ (or (ti::function-args-p orig-func)
+ "")))))
+ (when orig-func
+ ;; Only if existed
+ ;; call it with the event as argument.
+ ;; We have to restore the current buffer too, because
+ ;; the minor mode is there.
+ (put minor-mode-symbol 'ti::orig-value
+ (symbol-value minor-mode-symbol))
+ (unwind-protect
+ (if event-p
+ (funcall orig-func event)
+ ;; Try direct call first, or pass the EVENT
+ (or (eq 'done (progn (call-interactively orig-func) 'done))
+ (eq 'done (progn (funcall orig-func event) 'done))))
+ (set-buffer orig-buf)
+ (set minor-mode-symbol (get minor-mode-symbol
+ 'ti::orig-value)))))
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. unwind ..
+ ;; This is always executed, even if the above generates an error.
+ (setq ti::-xe-mouse-call-original nil))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::compat-popup (string-list &optional event mode title)
+ "Show STRING-LIST pop up. If EVENT is nil, use default tinylib coordinates.
+Works in XEmacs and Emacs.
+
+Input:
+
+ STRING-LIST '(str str ..)
+ EVENT mouse-event or nil
+ MODE if non-nil, return selection NBR [0..n]. Normally
+ returns the selection itself.
+ TITLE title of popup
+
+Return:
+
+ selection member or nbr
+ nil nothing selected"
+ (interactive "e")
+ (let* ((title (or title ""))
+ (count 0)
+ ;; Allow calling from key press also.
+ (event (or event
+ (ti::compat-make-x-popup-event
+ ti::var-x-coord ti::var-y-coord)))
+ menu
+ item-list
+ alist
+ ret)
+ (when (ti::listp string-list)
+ (setq alist (ti::list-to-assoc-menu string-list))
+ (cond
+ ((ti::emacs-p)
+ (setq item-list alist)
+ (setq menu
+ (cons title
+ (list (cons title item-list))))
+ (if (fboundp 'x-popup-menu)
+ (setq ret (ti::funcall 'x-popup-menu event menu)))
+ (if ret
+ (if (null mode)
+ (setq ret (nth ret string-list)))))
+ (t
+ ;; Scenario: User selects item from menu-bar-menu which calls
+ ;; function that should be called from mouse press --> selecting
+ ;; from pull-down-menu, is not a mouse event!
+ ;;
+ ;; First one is real mouse call for function; the other one
+ ;; is called from popup selection
+ ;;
+ ;; #<buttondown-event button1>
+ ;; #<misc-user-event (call-interactively tig-index-x-popup)>
+ ;;
+ ;; get-popup-menu-response call breaks if EVENT is something
+ ;; else than mouse-event. Check it immediately and set EVENT
+ ;; to nil, because the parameter is optional.
+ (if (and event (null (ti::funcall 'mouse-event-p event)))
+ (setq event nil))
+ ;; Menu format is like this in XEmacs
+ ;;
+ ;; '("title" ["A" ("A") t] ["B" ("B") t] ["C" ("C") t]
+ (setq item-list string-list)
+ (setq menu
+ (mapcar
+ (function
+ (lambda (x &optional vec)
+ (setq vec (make-vector 3 nil))
+ (aset vec 0 x)
+ (aset vec 1 (list x))
+ (aset vec 2 t)
+ vec))
+ item-list))
+ (setq menu (push title menu))
+ ;; #todo, I don't know why there is nothing in the RET
+ ;; after the selection has been done...
+ ;; See menubar.el
+ ;;
+ (setq ret (ti::funcall 'get-popup-menu-response menu event ))
+ (if (ti::funcall 'misc-user-event-p ret)
+ (setq ret (car-safe (ti::funcall 'event-object ret))))
+ (when (and ret mode) ;find position in list
+ (dolist (arg menu)
+ (when (and (vectorp arg)
+ (string= ret (elt arg 0)))
+ (setq ret (1- count))
+ (return))
+ (incf count))))))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::compat-display-depth ()
+ "Return how many colors display can show."
+ (cond
+ ((ti::emacs-p)
+ (ti::funcall 'x-display-planes (symbol-value 'x-display-name)))
+ (t
+ (ti::funcall 'device-bitplanes (ti::funcall 'default-x-device)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::compat-read-event ()
+ "Read X event."
+ (cond
+ ((ti::emacs-p)
+ (if (fboundp 'event-to-character)
+ (ti::funcall 'read-event)
+ (error "Cannot read events.")))
+ (t
+ (ti::funcall 'next-command-event))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::compat-executing-macro ()
+ "Check if executing macro."
+ (cond
+ ((boundp 'executing-macro)
+ (symbol-value 'executing-macro)) ;Emacs and old XEmacs
+ ((boundp 'executing-kbd-macro) ;New XEmacs
+ (symbol-value 'executing-kbd-macro))))
+
+;; briefly: events in 19.28, see subr.el
+;; -------------------------------------------
+;; event :(mouse-3 (#<window 34 on *scratch*> 128 (20 . 104) -23723628))
+;;
+;; (setq event-start event)
+;; event-start :(#<window 34 on *scratch*> 128 (20 . 104) -23723628))
+;; | | time
+;; mouse point coordinates
+;;
+;; (setq posn-col-row event-start) --> turn (20 . 104) into (col row)
+;;
+(defun ti::compat-make-x-popup-event (x y)
+ "Make fake EVENT using X and Y coordinates.
+Very handy if you call from kbd a function that requires mouse event."
+ (cond
+ ((ti::emacs-p)
+ (list (list x y) (selected-window)))
+ (t
+ ;;; (message "ti::compat-make-x-popup-event, XEmacs implementation not known.")
+ nil)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::compat-make-fake-event (x y &optional mouse-sym)
+ "Make fake event using X and Y coordinates and MOUSE-SYM[mouse - 1].
+
+Remeber: this is not full blown fake, just sufficent one, if
+receiver uses any of 'posn-' function, this doesn't fool it."
+
+ ;; (mouse-1 (#<window 42 on tinylib.el> 271088 (92 . 138) -492011))
+ (cond
+ ((ti::emacs-p)
+ (list
+ (or mouse-sym 'mouse-1 )
+ (list
+ (selected-window)
+ 1 ;<just some calue>
+ (cons x y )
+ -23723628)))
+ (t
+ ;; (message "ti::compat-make-fake-event, XEmacs implementation not known.")
+ ;;
+ ;; You can't create fake events in XEmacs. The object data is
+ ;; hidden behind an abstraction layer and there are no functions to
+ ;; build or modify event objects. You can only allocate and copy
+ ;; them.
+ ;;
+ nil)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::compat-modeline-update ()
+ "XEmacs and Emacs Compatibility. Update modeline."
+ (cond
+ ((and (ti::xemacs-p)
+ (fboundp 'redraw-modeline))
+ ;; Xe 19.14
+ ;; force-mode-line-update is an obsolete function; use redraw-modeline
+ (ti::funcall 'redraw-modeline))
+ ((fboundp 'force-mode-line-update)
+ (ti::funcall 'force-mode-line-update))
+ (t
+ (set-buffer-modified-p (buffer-modified-p)))))
+
+;;; ----------------------------------------------------------------------
+;;; - Changing the frame label is same as changing the icon label
+;;;
+(defun ti::compat-set-frame-parameter (prop-or-list value &optional frame)
+ "Use PROP-OR-LIST and VALUE to set FRAME's parameters.
+When called interactively, set name of the frame.
+
+Input:
+ PROP-OR-LIST alist of parameters or single property name
+ '((param . val) ..)
+ VALUE only used if single property given.
+ FRAME defaults to current frame."
+ (interactive
+ (list
+ 'name
+ (read-from-minibuffer "frame label name: ")))
+ (let* ((frame (or frame (selected-frame))))
+ (cond
+ ((and (ti::xemacs-p)
+ (fboundp 'set-frame-properties))
+ ;; #todo: Why don't these work in XEmacs 19.14 ?
+ (if (ti::listp prop-or-list)
+ (ti::funcall 'set-frame-properties frame prop-or-list)
+ (ti::funcall 'set-frame-property frame prop-or-list value)))
+ (t
+ (if (not (ti::listp prop-or-list))
+ (setq prop-or-list (list (cons prop-or-list value))))
+ (ti::funcall 'modify-frame-parameters frame prop-or-list)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::compat-set-frame-name (string &optional frame get)
+ "Change the frame display STRING in FRAME.
+The implementation works differently in various emacs versions.
+
+If GET is non-nil return frame name."
+ (let* ((symbol 'name))
+ (when (ti::emacs-p)
+ ;; somewhere along the line the symbol was renamed to 'title
+ ;; #todo: 19.31 - 33, frame, Would someone confirm this?
+ (when (and (> emacs-minor-version 31)
+ (< emacs-minor-version 34))
+ (setq symbol 'title)))
+ (if get
+ (frame-parameter frame symbol)
+ (ti::compat-set-frame-parameter symbol string frame))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::compat-frame-window-config ()
+ "Return list '((FRAME WINDOW-CONFIGURATION) (F W) ..)."
+ (let (ret)
+ (dolist (elt
+ (cdr (current-frame-configuration)))
+ (push (list (nth 0 elt) (nth 2 elt)) ret))
+ (nreverse ret)))
+
+;;; ----------------------------------------------------------------------
+;;; XEmacs 19.14 "window-system is an obsolete variable; use (console-type)"
+;;;
+(defun ti::compat-window-system ()
+ "XEmacs and Emacs Compatibility, Mimic Emacs `window-system' variable.
+In XEmacs the `cosole-type' returns 'tty on terminal, but this function
+return nil to be in par with Emacs behavior. An 'tty is not a windowed
+environment."
+ (cond
+ ((fboundp 'console-type)
+ (let ((val (ti::funcall 'console-type)))
+ (unless (eq 'tty val)
+ val)))
+ ((boundp 'window-system)
+ (symbol-value 'window-system))))
+
+;;; ....................................................... &xe-timers ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::compat-timer-list-control (&optional mode)
+ "Timer handling: MODE can be 'save 'restore or 'kill.
+
+Example:
+
+ ;; Turn off all processes for a while...
+
+ (ti::compat-timer-list-control 'save)
+ (ti::compat-timer-list-control 'kill)
+
+ ;; ... do something
+
+ ;; Now restore the prosesses
+
+ (ti::compat-timer-list-control 'restore)"
+
+ (let* ((sym
+ (cond
+ ((boundp 'timer-alist) 'timer-alist)
+ ((boundp 'timer-list) 'timer-list)
+ ((boundp 'itimer-list) 'itimer-list))))
+ ;; We store/restore the list into the timer variable symbol
+ ;; properties.
+ (cond
+ ((eq 'kill mode)
+ (set sym nil))
+ ((eq 'save mode)
+ (put sym 'ti::saved (symbol-value sym)))
+ ((eq 'restore mode)
+ (set sym (get sym 'ti::saved))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun ti::compat-timer-control
+ (&optional time repeat function delete verb)
+ "With `run-at-time' TIME REPEAT FUNCTION keep or remove timer. VERB."
+ (let* (timer)
+ (ti::verb)
+ (ti::compat-timer-cancel-function function)
+ (cond
+ (delete
+ (if verb (message "TinyLib: timer process %s removed." function)))
+ (t
+ ;; this will also restart timer
+ ;; In Emacs 19.28 - 19.30 , you could pass parameter
+ ;; "now", but later emacs releases do not accept it.
+ ;;
+ (setq timer
+ (run-at-time time repeat function))
+
+ (if verb
+ (message "TinyScroll: timer process started."))))
+ timer))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::compat-timer-elt (function)
+ "Search FUNCTION and return timer elt.
+You can use this function to check if some function is currently
+in timer list. (ie. active)
+
+The timer lists are searched in following order:
+
+ `itimer-list'
+ `timer-list'
+ 'timer-idle-list'
+
+Return:
+
+ '(timer-elt timer-variable)"
+ (let* (pos
+ list
+ item
+ ret)
+ (flet ((get-elt (elt place)
+ (if (vectorp elt)
+ (aref elt place)
+ (nth place elt))))
+ (dolist (timer '( ;; (("Mon Dec 9 10:01:47 1996-0" 10 tipgp-process nil))
+ (timer-idle-list . 5)
+ (timer-alist . 2)
+ (timer-list . 2) ;; 19.34+
+ (itimer-list . 3)))
+ (when (boundp (car timer))
+ (setq list (symbol-value (car timer))
+ pos (cdr timer))
+ ;; NOTE: this is different in Xemacs. It is not a vector
+ ;; timer-[idle-]list Emacs 19.34
+ ;; NOTE: this is different in Xemacs. It is not a vector
+
+ ;; ([nil 12971 57604 0 60 display-time-event-handler nil nil])
+ ;; [nil 13971 14627 646194 60
+ ;; (lambda (f) (run-at-time ...))
+ ;; (irchat-Command-keepalive) nil]
+ (if (and (ti::emacs-p)
+ (vectorp (car list)))
+ (setq pos 5))
+ (dolist (elt list)
+ (setq item (get-elt elt pos))
+ (when (or (and (symbolp item)
+ (eq item function))
+ ;; It may be lambda expression
+ (and (functionp item)
+ (string-match (regexp-quote (symbol-name function))
+ (prin1-to-string
+ (get-elt elt (1+ pos))))))
+ (setq ret (list elt (car timer)))
+ (return))))))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::compat-timer-process-status ()
+ "XEmacs and Emacs Compatibility. Return timer process status: t if active."
+ (cond
+ ((boundp 'timer-alist) ;Emacs
+ (symbol-value 'timer-process))
+ ((boundp 'timer-list) ;Emacs 19.34
+ (ti::compat-timer-elt 'display-time-event-handler))
+ ((boundp 'itimer-list) ;
+ ;; it is built in in XEmacs
+ t)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::compat-timer-cancel (key &optional cancel-function)
+ "Delete timer KEY entry, where KEY is full element in (i)`timer-alist'.
+Function `ti::compat-timer-cancel-function' may be more what you want
+if you know the function in timer list."
+ (let (var)
+ (if (null key)
+ nil ;Do nothing
+ (when (and (null var)
+ (boundp 'timer-alist)) ;Emacs
+ (setq var 'timer-alist)
+ (ti::funcall 'cancel-timer key)
+ (set var (delete key (symbol-value 'timer-alist))))
+
+ (when (and (null var)
+ (boundp 'timer-list)) ;Emacs 19.34
+ (setq var 'timer-list)
+ ;; Must use this command
+ (ti::funcall 'cancel-timer key))
+ (when (and (null var)
+ (boundp 'timer-idle-list)) ;Emacs 19.34
+ (setq var 'timer-idle-list)
+ ;; Must use this command
+ (ti::funcall 'cancel-timer key))
+ (when (and (null var)
+ (boundp 'itimer-list)) ;XEmacs
+ (setq var 'itimer-list)
+ (ti::funcall 'cancel-itimer key)
+ (set var (delete key (symbol-value 'itimer-list))))
+ var)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::compat-timer-cancel-function (function)
+ "Delete all timer entries for FUNCTION."
+ (let (key
+ ret)
+ (while (setq key (car-safe (ti::compat-timer-elt function)))
+ (push key ret)
+ (ti::compat-timer-cancel key))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::compat-set-mode-line-format (fmt)
+ "Set modeline format using FMT."
+ (let* ((sym
+ (if (ti::emacs-p)
+ 'mode-line-format
+ 'modeline-format)))
+ ;; XEmacs 19.14 says:
+ ;; ** mode-line-format is an obsolete var; use modeline-format instead.
+ (set sym fmt)))
+
+;;}}}
+;;{{{ misc: create standard functions, variables
+
+;;; .......................................................... &fmacro ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro ti::macrov-minor-mode
+ (pfx
+ mode-Name
+ mode-Name-prefix-key
+ easymenu-Name
+ custom-group
+
+ &optional style)
+ "Return standard minor mode variables.
+See below how to call this function from the top of your minor mode package.
+
+Input:
+
+ PFX string, the package prefix, usually one or two
+ words. E.g. \"xxx\" or \"xxx-mode\"
+ MODE-NAME string; which is displayed in modeline, should have
+ leading space. E.g. \" Lisp\"
+ MODE-NAME-PREFIX-KEY string, Key sequences to access the minor mode
+ functions.
+ EASYMENU-NAME string, the Menu bar name string.
+ CUSTOM-GROUP symbol, the defcustom.el group name.
+ PREFIX-STYLE string, How the characters should be named.
+ if nil then uses standard Emacs naming.
+
+Example, when:
+
+ PFX is \"xxx-\"
+ STYLE is nil ;; Standard Emacs style
+
+ (defvar xxx-mode nil)
+ (make-variable-buffer-local 'xxx-mode)
+
+ (defvar xxx-mode-name MODE-NAME)
+ (defvar xxx-mode-prefix-key MODE-NAME-PREFIX-KEY)
+ (defvar xxx-mode-map nil)
+ (defvar xxx-mode-prefix-map nil)
+ (defvar xxx-mode-define-keys-hook nil)
+ (defvar xxx-mode-hook nil)
+ (defvar xxx-mode-easymenu nil)
+ (defvar xxx-mode-easymenu-name nil)
+
+Example, when:
+
+ PFX is \"xxx\"
+ STYLE is 'xxx-:
+
+ (defvar xxx-mode nil)
+ (make-variable-buffer-local 'xxx-mode)
+
+ (defvar xxx-:mode-name MODE-NAME)
+ (defvar xxx-:mode-prefix-key MODE-NAME-PREFIX-KEY)
+ (defvar xxx-:mode-map nil)
+ (defvar xxx-:mode-prefix-map nil)
+ (defvar xxx-:mode-define-keys-hook nil)
+ (defvar xxx-:mode-hook nil)
+ (defvar xxx-:mode-easymenu nil)
+ (defvar xxx-:mode-easymenu-name nil)
+
+How to call this function:
+
+ (ti::macrov-minor-mode \"xxx\" \" Xmode\" \"C-cx\" \"Xmenubar\" nil)"
+ (` (, (ti::macrov-minor-mode-1
+ pfx
+ mode-Name
+ mode-Name-prefix-key
+ easymenu-Name
+ custom-group
+ style))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::macrov-minor-mode-1
+ (pfx
+ mode-Name
+ mode-Name-prefix-key
+ easymenu-Name
+ custom-group
+
+ &optional prefix-style)
+ "Use `ti::macrov-minor-mode' and see call arguments there.
+PFX MODE-NAME MODE-NAME-PREFIX-KEY
+EASYMENU-NAME CUSTOM-GROUP PREFIX-STYLE"
+ (let* ((x "-")
+ sym
+ ret)
+ (if prefix-style
+ (if (not (stringp prefix-style))
+ (error "style must be string")
+ (setq x prefix-style))
+ (setq x pfx))
+;;; (push 'progn ret)
+ ;; Force seeing variables at compile time
+ ;;
+ ;; Note 97-09-27
+ ;; Thee started to appear errors from easymenu define command and
+ ;; after byte compiler was forced to see the defvar definitions
+ ;; of the variables during compile time, the compile was clean again.
+ ;;
+ ;; This was very odd.
+ ;;
+ ;; (easy-menu-define
+ ;; tdi-:mode-easymenu
+ ;; tdi-:mode-map << if not defvar seen, gives error
+ ;; "Elp summary sort menu."
+ ;; nil
+ ;; )
+ (push 'eval-and-compile ret)
+ (setq sym (intern (format "%smode" pfx)))
+ (push (list 'defvar (` (, sym)) nil
+ "mode on off variable.")
+ ret)
+ (push (list 'make-variable-buffer-local (` (quote (, sym)))) ret)
+
+ (setq sym (intern (format "%smode-name" x)))
+ (push (list 'defcustom (` (, sym))
+ (` (, mode-Name))
+ "*Minor mode name."
+ ':type ''string
+ ':group (` (, custom-group)))
+ ret)
+ (setq sym (intern (format "%smode-prefix-key" x)))
+ (push (list 'defcustom (` (, sym))
+ (` (, mode-Name-prefix-key))
+ "*Prefix key to access mode."
+ ':type ''(string :tag "Key sequence")
+ ':group (` (, custom-group)))
+ ret)
+ (setq sym (intern (format "%smode-map" x)))
+ (push (list 'eval-and-compile
+ (list
+ 'defvar (` (, sym))
+ nil
+ "Minor mode map."))
+ ret)
+ (setq sym (intern (format "%smode-prefix-map" x)))
+ (push (list 'eval-and-compile
+ (list
+ 'defvar (` (, sym))
+ nil
+ "Prefix minor mode map."))
+ ret)
+ (setq sym (intern (format "%smode-easymenu" x)))
+ (push (list 'defvar (` (, sym))
+ nil
+ "Easymenu variable.")
+ ret)
+ (setq sym (intern (format "%smode-easymenu-name" x)))
+ (push (list 'defcustom (` (, sym))
+ (` (, easymenu-Name))
+ "*Easymenu name that appears in menu-bar."
+ ':type ''string
+ ':group (` (, custom-group)))
+ ret)
+ (setq sym (intern (format "%smode-define-keys-hook" x)))
+ (push (list 'defcustom (` (, sym))
+ nil
+ "*Hook that defines all keys and menus."
+ ':type ''hook
+ ':group (` (, custom-group)))
+ ret)
+ (setq sym (intern (format "%smode-hook" x)))
+ (push (list 'defcustom (` (, sym))
+ nil
+ "*Hook that runs when mode function is called."
+ ':type ''hook
+ ':group (` (, custom-group)))
+ ret)
+ (nreverse ret)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro ti::macrof-minor-mode
+ (func-min-sym
+ doc-str
+
+ install-func ;3
+ mode-var
+ mode-Name ;5
+ prefix-var
+ menu-var ;7
+
+ no-mode-msg
+ mode-desc ;9
+
+ hook
+ &optional body)
+ "Create standard functions for minor mode.
+
+Input:
+
+ FUNC-MIN-SYM symbol, the name of the function that is created.
+ E.g. 'xxx-mode
+
+ DOC-STR string, the function documentation string
+
+ INSTALL-FUNC symbol, if func-min-sym isn't in `minor-mode-alist', this
+ function is called to install the minor mode.
+
+ MODE-VAR symbol, a variable which turns minor mode on or off
+ MODE-NAME symbol, a variable, contains mode name.
+ [PREFIX-VAR] symbol, a variable, mode's prefix key. Can be nil
+ [MENU-VAR] symbol, a variable, mode's menu definitions. The menu must be
+ in format of easy-menu.el so that it is Emacs and
+ XEmacs compatible
+
+ [NO-MODE-MSG] if non-nil, then default mode turn on or off message
+ is not displayed. The default message is
+ 'MODE-DESC mode minor mode is ON. Prefix key is XXX'
+ MODE-DESC string, used in the default turn on message, see above.
+
+ [HOOK] symbol, hook that is run when mode is called.
+
+ [BODY] Lisp code to be added inside middle body. Can be nil.
+
+Created function's arguments:
+
+ (&optional arg verb)
+ ARG is mode on off variable. nil toggles mode.
+ VERB is set in interactive call and controlls printing mode
+ turn on or off message. If nil, then no messages are
+ displayed.
+
+Example how to use this macro:
+
+ ;;; We have to inform autoload that function exist after macro
+ ;;;###autoload (autoload 'xxx-mode \"package-file\" t t)
+
+ (ti::macrof-minor-mode
+ xxx-mode
+ \"XXX minor mode. This helps you to do ....
+
+ Defined keys:
+ \\\\{xxx-mode-prefix-map}
+ \"
+ xxx-install-mode
+ xxx-mode
+ xxx-:mode-name
+ xxx-:mode-prefix-key
+ nil ;; no menu variables
+ nil
+ \"XXX\"
+ xxx-:mode-hook
+ ;; The forms
+ ;;
+ (progn
+ (message \"Hey!\")))
+
+Example how to call created functions:
+
+ (xxx-mode) ;; toggles
+ (xxx-mode 1) ;; on
+ (xxx-mode 0) ;; off, could also be -1
+ (turn-on-xxx-mode) ;; function can be put to hook
+ (turn-off-xxx-mode)"
+ (` (,
+ (ti::macrof-minor-mode-1
+ func-min-sym
+ doc-str
+
+ install-func
+ mode-var
+ mode-Name
+ prefix-var
+ menu-var
+
+ no-mode-msg
+ mode-desc
+
+ hook
+ body))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::macrof-minor-mode-1
+ (func-min-sym
+ doc-str ;1
+
+ install-func ;2
+ mode-var ;3
+ mode-Name ;4
+ prefix-var ;5
+ menu-var ;6
+
+ no-mode-msg ;7
+ mode-desc ;8
+
+ hook ;9
+ &rest body) ;10
+ "Use macro `ti::macrof-minor-mode'. And see arguments there.
+FUNC-MIN-SYM DOC-STR INSTALL-FUNC MODE-VAR
+MODE-NAME PREFIX-VAR MENU-VAR NO-MODE-MSG MODE-DESC
+HOOK BODY"
+
+;;; (ti::d!! "\n\n" body)
+ (let* ((sym
+ (intern (symbol-name (` (, func-min-sym)))))
+ (viper-sym
+ (intern (concat (symbol-name (` (, func-min-sym)))
+ "-viper-attach"))))
+ (`
+ (defun (, sym)
+ (&optional arg verb)
+ (, doc-str)
+ (interactive "P")
+ (ti::verb)
+ (if (null (assq (quote (, func-min-sym)) minor-mode-alist))
+ ((, install-func)))
+;;; (let* ((val (symbol-value (, mode-var)))
+;;; )
+;;; (setq (, mode-var) (ti::bool-toggle val arg)))
+ (ti::bool-toggle (, mode-var) arg)
+ ;; XEmacs needs this call, in emacs turning on the minor
+ ;; mode automatically adds the menu too.
+ ;;
+;;; (if (symbol-value (, mode-var))
+;;; (easy-menu-add (symbol-value (, menu-var)))
+;;; (easy-menu-remove (symbol-value (, menu-var))))
+ (if (and (, mode-var)
+ (, menu-var))
+ ;; easy-menu-add dies if menu-var is nil
+ (easy-menu-add (, menu-var))
+ (easy-menu-remove (, menu-var)))
+ (when (, mode-var)
+ (funcall (quote (, viper-sym))))
+ (,@ body)
+ (ti::compat-modeline-update)
+ (if (and verb (null (, no-mode-msg)))
+ (message
+ "%s minor mode is %s %s"
+ (, mode-desc)
+ (if (, mode-var) "on." "off.")
+ (if (null (, mode-var))
+ ""
+ (if (, prefix-var)
+ (format "Prefix key is %s" (, prefix-var))
+ ""))))
+ (run-hooks (quote (, hook)))
+ ;; Return status of minor mode as last value.
+ (, mode-var)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::macrof-minor-mode-on (mode-func-sym)
+ "Create standard function to turn on the minor mode MODE-FUNC-SYM."
+ (let* ((sym
+ (intern (concat "turn-on-" (symbol-name (` (, mode-func-sym)))))))
+ (`
+ (defun (, sym) ()
+ "Turn minor mode on"
+ (interactive)
+ ((, mode-func-sym) 1)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::macrof-minor-mode-off (mode-func-sym)
+ "Create standard function to turn off the minor mode MODE-FUNC-SYM."
+ (let* ((sym
+ (intern (concat "turn-off-" (symbol-name (` (, mode-func-sym)))))))
+ (`
+ (defun (, sym) ()
+ "Turn minor mode off"
+ (interactive)
+ ((, mode-func-sym) -1)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::macrof-minor-mode-help (mode-func-sym)
+ "Create standard function to print MODE-FUNC-SYM function's destription."
+ (let* ((sym (intern (concat (symbol-name (` (, mode-func-sym))) "-help"))))
+ (`
+ (defun (, sym) ()
+ "Mode help."
+ (interactive)
+ (with-output-to-temp-buffer "*help*"
+ (princ (documentation (quote (, mode-func-sym)))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::macrof-minor-mode-commentary (pfx mode-func-sym)
+ "Create standard function to print PFX MODE-FUNC-SYM Commentary."
+ (let* ((name pfx) ;; (symbol-name (` (, mode-func-sym))))
+ (sym (intern (concat name "commentary")))
+ (file1 (substring pfx 0 (1- (length name))))
+ (file2 (concat file1 ".el")))
+ (`
+ (defun (, sym) ()
+ "Display `finder-commentary'."
+ (interactive)
+ ;; Same as what `finde-commentary' uses
+ ;; One problem: lm-commentary has a bug, which causes killing
+ ;; the file from emacs after it's done. But we don't want that
+ ;; if use is viewing or loaded it to emacs before us.
+ ;;
+ ;; Work around that bug.
+ (let ((buffer (or
+ (get-buffer (, file2))
+ (find-buffer-visiting (, file2))
+ (find-buffer-visiting (, file1)))))
+ (if (not buffer)
+ (finder-commentary (, file2))
+ ;; This is only a pale emulation....will do for now.
+ (let (str)
+ (with-current-buffer buffer
+ (setq str (lm-commentary))
+ (with-current-buffer (ti::temp-buffer "*Finder*" 'clear)
+ (insert str)
+ (ti::pmin) (ti::buffer-replace-regexp "^;+" 0 "")
+ (ti::pmin) (ti::buffer-replace-regexp "\r" 0 "")
+ (display-buffer (current-buffer)))))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::macrof-minor-mode-viper-attach (pfx mode-func-sym)
+ "Create standard function PFX MODE-FUNC-SYM to attach mode to viper."
+ (let* ((name pfx) ;; (symbol-name (` (, mode-func-sym))))
+ (sym (intern (concat (symbol-name (` (, mode-func-sym)))
+ "-viper-attach")))
+ (file1 (substring pfx 0 (1- (length name)))))
+ (`
+ (defun (, sym) ()
+ "Attach minor mode to viper with `viper-harness-minor-mode'."
+ (if (featurep 'viper)
+ (ti::funcall 'viper-harness-minor-mode (, file1)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro ti::macrof-minor-mode-install
+ (func-ins-sym
+ mode-sym
+ map-sym
+ prefix-map-sym
+ mode-name-sym
+ hook-sym
+ &rest body)
+ "Return standard function form.
+Returned function will install and remove minor mode.
+
+Input:
+
+ FUNC-INS-SYM symbol, the name of the function that is created.
+ E.g. 'xxx-install-mode
+
+ MODE-SYM function symbol to call to run the mode e.g. 'xxx-mode
+
+ MAP-SYM mode's keymap symbol. E.g. 'xxx-mode-map
+
+ MODE-NAME-SYM mode's name symbol. E.g. 'xxx-mode-name
+
+ HOOK-SYM hook symbol to call when mode has been installed.
+ e.g. 'xxx-key-define-hook, which calls necessary
+ functions to install keys and menus.
+
+ BODY Lisp forms executed in the beginning of function.
+
+Created function's arguments:
+
+ (&optional remove verb)
+ REMOVE uninstall minor mode
+ VERB is set for interactive calls: non-nil allows
+ displaying messages.
+
+How to call this function:
+
+ (ti::macrof-minor-mode-install
+ xxx-install-mode
+ xxx-mode
+ xxx-:mode-map
+ xxx-:prefix-map-sym
+ xxx-:mode-name
+ xxx-:mode-define-keys-hook
+ (progn
+ ;; Lisp forms here
+ nil))
+
+Example how to call created function:
+
+ M -x xxx-install-mode ;; this calls created function and installs mode
+ (xxx-install-mode) ;; Same
+ (xxx-install-mode 'remove) ;; Or prefix ARG, removes the minor mode"
+ (` (, (ti::macrof-minor-mode-install-1
+ func-ins-sym
+ mode-sym
+ map-sym
+ prefix-map-sym
+ mode-name-sym
+ hook-sym
+ body))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::macrof-minor-mode-install-1
+ (func-ins-sym
+ mode-sym
+ map-sym
+ prefix-map-sym
+ mode-name-sym
+ hook-sym
+
+ &rest body)
+ "Use macro `ti::macrof-minor-mode-install'. See arguments there.
+FUNC-INS-SYM MODE-SYM MAP-SYM MODE-NAME-SYM HOOK-SYM BODY"
+ (let* ((sym (intern (symbol-name (` (, func-ins-sym))))))
+ (`
+ (defun (, sym) (&optional remove verb)
+ "Install or optionally REMOVE minor mode. Calling this always
+removes old mode and does reintall."
+ (interactive "P")
+ (ti::verb)
+ (,@ body)
+ (cond
+ (remove
+ (ti::keymap-add-minor-mode '(, mode-sym) nil nil 'remove)
+ (if verb
+ (message "minor mode removed")))
+ (t
+ (setq (, map-sym) (make-sparse-keymap)) ;; always refresh
+ (setq (, prefix-map-sym) (make-sparse-keymap)) ;; always refresh
+ (run-hooks '(, hook-sym))
+ ;; Always do reinstall; because keymaps stored permanently and
+ ;; making a change later is impossible.
+ (ti::keymap-add-minor-mode '(, mode-sym) nil nil 'remove)
+ (ti::keymap-add-minor-mode '(, mode-sym)
+ '(, mode-name-sym)
+ (, map-sym))
+ (if verb
+ (message "minor mode installed"))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro ti::macrof-define-keys
+ (minor--mode-name
+ minor--mode-desc
+ func-def-sym
+ keymap-sym
+ prefix-keymap-sym
+ prefix-key-sym
+ easymenu-sym
+ easymenu-Name-sym
+ easymenu-doc-str
+ easy-menu-forms
+ eval-body)
+ "Return standard function form.
+The returned function will install keymaps and menu-bar menu for minor mode.
+
+Inside the function you can refer to variables
+
+ 'root-map' refers to ROOT keymap from where the prefix map is accessed
+ This is the original keymap where the PREFIX-KEY is
+ assigned. The actual commands are put to 'map'.
+ 'map' refers to separate minor mode prefix keymap
+ 'p' holds the prefix key.
+
+Input:
+
+ MINOR--MODE-NAME string
+ MINOR--MODE-DESC string
+ FUNC-DEF-SYM symbol, function name which is created
+ KEYMAP-SYM symbol, keymap where to define keys, must exist
+ PREFIX-KEY-SYM symbol, variable holding the prefix key.
+ [EASYMENU-SYM] symbol, easy menu variable or nil.
+ [EASYMENU-NAME-SYM] symbol, easy menu's menu-bar name variable or nil
+ [EASYMENU-DOC-STR] string, Describe string for menu.
+ [EASY-MENU-FORMS] forms to define menus
+ EVAL-BODY forms executed at the end of function.
+
+Created function's arguments:
+
+ ()
+
+How to call this function:
+
+ (ti::macrof-define-keys
+ xxx-mode-define-keys
+ xxx-:mode-prefix-map
+ xxx-:mode-prefix-key
+ xxx-:mode-easymenu
+ xxx-:mode-easymenu-name
+ (list
+ xxx-:mode-easymenu-name
+ [\"menu item1\" xxx-function1 t]
+ [\"menu item2\" xxx-function2 t]
+ \"----\"
+ [\"menu item3\" xxx-function3 t])
+ (progn
+ (define-key map \"a\" 'xxx-function1)
+ (define-key map \"b\" 'xxx-function2)
+ (define-key map \"c\" 'xxx-function3)))
+
+Example how to call created function:
+
+ (xxx-mode-define-keys)"
+ (` (, (ti::macrof-define-keys-1
+ minor--mode-name
+ minor--mode-desc
+ func-def-sym
+ keymap-sym
+ prefix-keymap-sym
+ prefix-key-sym
+ easymenu-sym
+ easymenu-Name-sym
+ easymenu-doc-str
+ easy-menu-forms
+ eval-body))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro ti::macrov-mode-line-mode-menu (mode-symbol text)
+ "Add MODE-SYMBOL to minor mode list in Emacs mode line menu."
+ (let ((sym (vector (intern (symbol-name (` (, mode-symbol)))))))
+ (` (when (boundp 'mode-line-mode-menu) ;; Emacs 21.1
+ (define-key mode-line-mode-menu (, sym)
+ '(menu-item (, text)
+ (, mode-symbol)
+ :button (:toggle . (, mode-symbol))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::macrof-define-keys-1
+ (minor--mode-name
+ minor--mode-desc
+ func-def-sym
+ keymap-sym
+ prefix-keymap-sym
+ prefix-key-sym
+ easymenu-sym
+ easymenu-Name-sym
+ easymenu-doc-str
+ easy-menu-forms
+ body)
+ "Use macro `ti::macrof-define-keys' and see arguments there.
+MODE-NAME FUNC-DEF-SYM KEYMAP-SYM PREFIX-KEYMAP-SYM PREFIX-KEY-SYM
+EASYMENU-SYM EASYMENU-NAME-SYM EASYMENU-DOC-STR EASY-MENU-FORMS
+BODY"
+ (let* (sym)
+ (setq sym (intern (symbol-name (` (, func-def-sym)))))
+ (`
+ (defun (, sym) ()
+ (let* ((root-map (, keymap-sym))
+ (map (, prefix-keymap-sym))
+ (p (, prefix-key-sym)))
+ (when (stringp (, easymenu-doc-str)) ;This could be nil (no menus)
+ (if (ti::xemacs-p)
+ (easy-menu-define
+ (, easymenu-sym)
+ nil
+ (, easymenu-doc-str)
+ (, easy-menu-forms))
+ (easy-menu-define
+ (, easymenu-sym)
+ (, keymap-sym)
+ (, easymenu-doc-str)
+ (, easy-menu-forms))))
+ ;; This is no-op, ByteComp silencer.
+ ;; ** variable p bound but not referenced
+ (if (null p) (setq p nil))
+ (if (null map) (setq map nil))
+ (if (null root-map) (setq root-map nil))
+ (ti::macrov-mode-line-mode-menu
+ (, minor--mode-name) (, minor--mode-desc))
+ ;; (define-key mode-map mode-prefix-key mode-prefix-map)
+ (when (, prefix-key-sym)
+ (define-key
+ (, keymap-sym)
+ (, prefix-key-sym)
+ (, prefix-keymap-sym)))
+ ;; If you have selected a prefix key that is a natural ABC key;
+ ;; then define "aa" as self insert command for "a" character.
+ ;;
+ ;; check also if prefix key defined is like [{a)]] where "a"
+ ;; if a single character. The [{?\C-a)]] is nto accepted as
+ ;; repeated key: C-aC-a, only "aa"
+ (let* ((char (ti::keymap-single-key-definition-p p)))
+ (when (and (characterp char) (ti::print-p char))
+ ;; The prefix key is single; printable character.
+ (define-key map p 'self-insert-command)))
+ (, body))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::macrof-version-bug-report-1
+ (filename
+ prefix
+ version-variable
+ version-value
+ bug-var-list
+
+ &optional
+ buffer-list
+ bug-body)
+ "Use macro `ti::macrof-version-bug-report' and see arguments there.
+FILENAME PREFIX VERSION-VARIABLE VERSION-VALUE
+BUG-VAR-LIST BUFFER-LIST BUG-BODY."
+ (let* (sym
+ ret
+ elt)
+ (push 'progn ret)
+ (setq elt
+ (list
+ 'defconst (` (, version-variable))
+ (` (, version-value))
+ "Package's version information."))
+ (push elt ret)
+ (setq sym (intern (format "%s-version" prefix)))
+ (setq
+ elt
+ (`
+ (defun (, sym) (&optional arg)
+ "Version information."
+ (interactive "P")
+ (ti::package-version-info (, filename) arg))))
+ (push elt ret)
+ (setq sym (intern (format "%s-submit-bug-report" prefix)))
+ (setq
+ elt
+ (`
+ (defun (, sym) ()
+ "Send bug report or feedback."
+ (interactive)
+ (ti::package-submit-bug-report
+ (, filename)
+ (, version-variable)
+ (, bug-var-list)
+ 'verbose
+ (, buffer-list))
+ (, bug-body))))
+ (push elt ret)
+ (nreverse ret)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro ti::macrof-version-bug-report
+ (filename
+ prefix
+ version-variable
+ version-value
+ bug-var-list
+ &optional
+ buffer-list
+ bug-body)
+ "Return standard function form.
+One variable and two functions are created.
+
+Input:
+
+ FILENAME string e.g. xxx.el
+ PREFIX package prefix for functions e.g. xxx
+ VERSION-VARIABLE symbol variable holding the version information.
+ VERSION-VALUE value for the variable. Should be RCS Id string or the
+ like.
+ BUG-VAR-LIST variable list to send with bug report
+ BUG-BODY Lisp forms for the bug function.
+
+How to call this macro:
+
+ (ti::macrof-version-bug-report
+ \"xxx.el\"
+ \"xxx\"
+ xxx-:version-id
+ \"...version Id string here, RCS controlled.\"
+
+ '(xxx-:load-hook
+ xxx-:mode-hook
+ xxx-mode-define-keys-hook
+ xxx-:mode-name))
+
+Example how to call created functions:
+
+ M - x xxx-submit-bug-report
+ M - x xxx-version"
+ (`(, (ti::macrof-version-bug-report-1
+ filename
+ prefix
+ version-variable
+ version-value
+ bug-var-list
+ buffer-list
+ bug-body))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::macrof-debug-1
+ (prefix
+ debug-function
+ debug-toggle-function
+ debug-buffer-show-function
+ debug-variable
+ debug-buffer)
+ "Use macro `ti::macrof-debug' and see argument there.
+PREFIX
+DEBUG-FUNCTION DEBUG-TOGGLE-FUNCTION DEBUG-BUFFER-SHOW-FUNCTION
+DEBUG-VARIABLE DEBUG-BUFFER."
+ (let* (str
+ ret
+ elt)
+ (push 'progn ret)
+
+ (setq elt
+ (list
+ 'defvar (` (, debug-variable))
+ nil
+ "Debug control: on or off."))
+ (push elt ret)
+
+ (setq elt
+ (list
+ 'defvar (` (, debug-buffer))
+ (format "*%s-debug*" prefix)
+ "Debug output buffer."))
+ (push elt ret)
+ (setq str
+ (concat
+ "Generate debug\n"
+ "Prefix ARG: nil = toggle, 0 = off, 1 = on."))
+ (setq
+ elt
+ (`
+ (defun (, debug-toggle-function) (&optional arg)
+ (, str)
+ (interactive "P")
+ (let* ((buffer (get-buffer (, debug-buffer))))
+ (ti::bool-toggle (, debug-variable) arg)
+ (when (and (, debug-variable)
+ buffer
+ (y-or-n-p "Clear debug buffer?"))
+ (ti::erase-buffer buffer))
+ (if (interactive-p)
+ (message "Debug is %s"
+ (if (, debug-variable)
+ "on"
+ "off")))))))
+ (push elt ret)
+ (when debug-buffer-show-function
+ (setq str "Show debug buffer.")
+ (setq
+ elt
+ (`
+ (defun (, debug-buffer-show-function) (&optional arg)
+ (, str)
+ (interactive "P")
+ (let* ((buffer (get-buffer (, debug-buffer))))
+ (ti::bool-toggle (, debug-variable) arg)
+ (if (null buffer)
+ (message "There is no debug buffer to show.")
+ (display-buffer buffer))))))
+ (push elt ret))
+ (setq str
+ (concat "Write debug log to " ;; (` (, debug-buffer ))
+ " if "
+;;; (symbol-name (quote (` (, debug-variable)) ))
+ "is non-nil."))
+
+ ;; We are returning a macro in next elt.
+ (setq
+ elt
+ (`
+ (defmacro (, debug-function) (&rest args)
+;;; (when (, debug-variable)
+;;; (let* ((ti:m-debug-buffer (, debug-buffer )))
+ (when (, debug-variable)
+ (with-current-buffer (get-buffer-create (, debug-buffer))
+ (goto-char (point-max))
+ (while args
+ (insert (format "|%s" (eval (pop args)))))
+ (insert "\n"))))))
+ (push elt ret)
+ (nreverse ret)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro ti::macrof-debug-lowlevel
+ (prefix
+ debug-function
+ debug-toggle-function
+ debug-buffer-show-function
+ debug-variable
+ debug-buffer)
+ "Return standard function forms for debug interface.
+One variable, one function and one macro will be created.
+
+Input:
+
+ PREFIX string, symbols' prefix.
+ DEBUG-FUNCTION symbol, function name to generate debug
+ DEBUG-TOGGLE-FUNCTION symbol, function name to turn on/off debug
+ DEBUG-BUFFER-SHOW-FUNCTION symbol, fucntion to display debug buffer.
+ DEBUG-VARIABLE symbol, variable to control debug
+ DEBUG-BUFFER string, buffer name where to write debug.
+
+How to call this macro:
+
+ (ti::macrof-debug xxx-debug xxx-debug-toggle xxx-debug-show
+ xxx-debug \"*xxx-debug*\")
+
+Example how to call created functions:
+
+ M - x xxx-debug-show
+
+ M - x xxx-debug-toggle ;; To turn on or off debug package debug
+ (xxx-debug-toggle 0) ;; off
+ (xxx-debug-toggle 1) ;; on
+
+ ;; To generate debug from inside code, you call:
+ (xxx-debug ... anything frame-pointer buffer-pointer ...)"
+ (`(, (ti::macrof-debug-1
+ prefix
+ debug-function
+ debug-toggle-function
+ debug-buffer-show-function
+ debug-variable
+ debug-buffer))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro ti::macrof-debug-standard (prefix &optional var-prefix)
+ "Make standard debug interface according to PREFIX and VAR-PREFIX."
+ (let* ((d-func (intern (format "%s-debug" prefix)))
+ (dt-func (intern (format "%s-debug-toggle" prefix)))
+ (ds-func (intern (format "%s-debug-show" prefix)))
+ (pfx (or var-prefix "-"))
+ (d-var (intern (format "%s%sdebug" prefix pfx)))
+ (d-buffer (intern (format "%s%sdebug-buffer" prefix pfx))))
+ (`(, (ti::macrof-debug-1
+ prefix
+ d-func
+ dt-func
+ ds-func
+ d-var
+ d-buffer)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::macrof-install-pgp-tar-1
+ (func-ins-sym elisp-file &optional log-buffer)
+ "Use macro `ti::macrof-install-pgp-tar' and see arguments there.
+FUNC-INS-SYM ELISP-FILE LOG-BUFFER."
+ (let* (sym)
+
+ (setq sym (intern (symbol-name (` (, func-ins-sym)))))
+
+ (`
+ (defun (, sym) (dir)
+ "Install additional programs from the end of package."
+ (interactive "DSave programs to directory: ")
+ (let* ((file (, elisp-file))
+ (source (or (locate-library file)
+ (error "can't find %s along load-path." file))))
+ (ti::package-install-pgp-tar
+ dir
+ (or (, log-buffer)
+ "*install-log*")
+ source))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro ti::macrof-install-pgp-tar
+ (func-ins-sym elisp-file &optional log-buffer)
+ "Return standard pgp tar install function.
+It handles installing pgp base 64 signed tar block from the end of file.
+
+ 1. Create tar file (it sould not have directory names, but ...)
+ 2. pgp base64 sign the tar file (clearsig off)
+ 3. paste pgp data to to end of your lisp package
+
+ ;; -----BEGIN PGP MESSAGE-----
+ ;; Version: 2.6.3ia
+ ;;
+ ;; owHsWc1vG0l2n0GwwYjA3pJLgEXKlNaSDJLilySblrWWLXrMrCQrpOydzcxA02wW
+ ...
+ ;; -----END PGP MESSAGE-----
+
+And nothing more is needed to get your programs untarred nicely.
+The drop directory is asked from the user when he calls this function.
+
+Input:
+
+ FUNC-INS-SYM symbol, the created install function name
+ ELISP-FILE your Lisp package name (with .el)
+ [LOG-BUFFER] where to print the install log. Can be nil.
+
+Created function's arguments:
+
+ (dir)
+ DIR Where to untar the included file, asked interactively
+
+How to call this function:
+
+ ;;;###autoload (autoload 'xxx-install-programs \"package-file\" t t)
+
+ (ti::macrof-install-pgp-tar
+ xxx-install-programs
+ \"xxx.el\"
+ \"*xxx-install-log*\"))
+
+Example how to call created function:
+
+ M - x xxx-install-programs"
+ (` (, (ti::macrof-install-pgp-tar-1
+ func-ins-sym
+ elisp-file
+ log-buffer))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro ti::macrof-minor-mode-wizard
+ (pfx ;1
+ mode-Name ;
+ mode-Name-prefix-key ;
+ easymenu-Name ;
+ custom-group ;
+ variable-style ;6
+
+ doc-str ;7
+ mode-desc ;
+ minor-mode-body ;
+
+ easymenu-doc ;10
+ easymenu-body ;
+ define-key-body) ;12
+ "Do all the necessary things to create minor mode.
+Following macros are called one by one. If you want personalized
+minor mode control, call each of these individually and don't use
+this wizard.
+
+ `ti::macrov-minor-mode'
+ `ti::macrof-minor-mode-install'
+ `ti::macrof-minor-mode'
+ `ti::macrof-minor-mode-on'
+ `ti::macrof-minor-mode-off'
+ `ti::macrof-minor-mode-help'
+ `ti::macrof-define-keys'
+
+Input:
+
+ PFX See -vmacro-
+ MODE-NAME See -vmacro-
+ MODE-NAME-PREFIX-KEY See -vmacro-
+ EASYMENU-NAME See -vmacro-
+ CUSTOM-GROUP See -vmacro-
+ VARIABLE-STYLE See -vmacro-
+
+ DOC-STR See -fmacro-minor-mode
+ MODE-DESC See -fmacro-minor-mode
+ MINOR-MODE-BODY See -fmacro-minor-mode must be in format ((BOBY))
+
+ EASYMENU-DOC See -fmacro-define-keys must be in format ((BOBY))
+ EASYMENU-BODY See -fmacro-define-keys must be in format ((BOBY))
+ DEFINE-KEY-BODY See -fmacro-define-keys
+
+How to call this function:
+
+ See example tinylisp.el package which uses this function to create
+ minor mode.
+
+If you want to see what this macro produces, use
+
+ (macroexpand '(ti::macrof-minor-mode-wizard ...))C - x C - e
+
+Here is example how you would define the minor mode.
+
+ (eval-and-compile ;; So that defvars and defuns are seen
+ (ti::macrof-minor-mode-wizard
+ \"xxx-\" ;; prefix for variables and functions
+ \" xxxModeline\" ;; Modeline name
+ \"\\C-cx\" ;; prefix key for mode.
+ \"xxxMenubar\" ;; Menu bar name
+ nil ;; <forget this>
+
+ \"XXX minor mode. Does fancy things.\" ;; mode description
+
+ \"XXX help\" ;; message displayed when user calls mode
+
+ ;; ............................................................
+ (progn
+ ;; Run body-of-code when minor mode is called
+ nil)
+
+ ;; ............................................................
+ ;; Next id used by easy-menu.el and defines menu items.
+ (list
+ xxx-mode-easymenu-name
+ [\"Eval whole buffer\" xxx-eval-current-buffer t]
+ ..)
+
+ ;; ............................................................
+ ;; this block defines keys to the mode. The mode minor map is
+ ;; locally bound to 'map' symbol.
+ (progn
+ (define-key map \"-\" 'xxx-eval-current-buffer)
+ (define-key map \"=\" 'xxx-calculate))))
+"
+ (` (,
+ (ti::macrof-minor-mode-wizard-1
+ pfx ;1
+ mode-Name ;
+ mode-Name-prefix-key ;
+ easymenu-Name ;
+ custom-group ;
+ variable-style ;6
+
+ doc-str ;7
+ mode-desc ;
+ minor-mode-body ;9
+
+ easymenu-doc ;10
+ easymenu-body ;
+ define-key-body)))) ;12
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::macrof-minor-mode-wizard-1
+ (pfx ;1
+ mode-Name ;2
+ mode-Name-prefix-key ;3
+ easymenu-Name ;4
+ custom-group ;5
+ variable-style ;6
+
+ doc-str ;7
+ mode-desc ;8
+ minor-mode-body ;9
+
+ easymenu-doc ;10
+ easymenu-body ;11
+ define-key-body) ;12
+ "Use macro `ti::macrof-minor-mode-wizard' and see parameters there.
+ PFX
+ MODE-NAME
+ MODE-NAME-PREFIX-KEY
+ EASYMENU-NAME
+ CUSTOM-GROUP
+ VARIABLE-STYLE
+ DOC-STR
+ MODE-DESC
+ MINOR-MODE-BODY
+
+ EASYMENU-DOC
+ EASYMENU-BODY
+ DEFINE-KEY-BODY"
+
+ (let* (sym1
+ sym2
+ sym3
+ sym4
+ sym5
+ sym6
+ sym7
+ ret
+ elt
+ vs)
+ (ti::nconc ret 'eval-and-compile)
+ ;; ........................................... create variables ...
+ (setq elt
+ (ti::macrov-minor-mode-1
+ pfx
+ mode-Name
+ mode-Name-prefix-key
+ easymenu-Name
+ custom-group
+ variable-style))
+ (setq vs (if variable-style
+ variable-style
+ pfx))
+;;; (ti::d!! "\n\n>>" elt)
+ (ti::nconc ret elt)
+ ;; .................................... create install function ...
+ (setq sym1 (intern (concat pfx "install-mode"))
+ sym2 (intern (concat pfx "mode"))
+ sym3 (intern (concat vs "mode-map"))
+ sym4 (intern (concat vs "mode-prefix-map"))
+ sym5 (intern (concat vs "mode-name"))
+ sym6 (intern (concat vs "mode-define-keys-hook")))
+;;; (ti::d!! "\n\n>>minor-mode-install" sym1 sym2 sym3 sym4 sym5 "\n")
+ (setq elt (ti::macrof-minor-mode-install-1
+ sym1 sym2 sym3 sym4 sym5 sym6))
+ (ti::nconc ret elt)
+ ;; ....................................... define keys function ...
+ (setq sym1 (intern (concat pfx "mode-define-keys"))
+ sym2 (intern (concat vs "mode-map"))
+ sym3 (intern (concat vs "mode-prefix-map"))
+ sym4 (intern (concat vs "mode-prefix-key"))
+ sym5 (intern (concat vs "mode-easymenu"))
+ sym6 (intern (concat vs "mode-easymenu-name"))
+ sym7 (intern (concat pfx "mode")))
+;;; (ti::d!! "\n\n>>define-keys" sym1 sym2 sym3 sym4 sym5)
+ (setq elt
+ (ti::macrof-define-keys-1
+ sym7
+ mode-desc
+ sym1
+ sym2
+ sym3
+ sym4
+ sym5
+ sym6
+ easymenu-doc
+ easymenu-body
+ define-key-body))
+ (ti::nconc ret elt)
+ ;; ................................. create minor mode function ...
+ (setq sym1 (intern (concat pfx "mode"))
+ sym2 (intern (concat pfx "install-mode"))
+ sym3 (intern (concat pfx "mode"))
+ sym4 (intern (concat vs "mode-name"))
+ sym5 (intern (concat vs "mode-prefix-key"))
+ sym6 (intern (concat vs "mode-easymenu"))
+ sym7 (intern (concat vs "mode-hook")))
+;;; (ti::d!! "\n\n>>minor-mode" sym1 sym2 sym3 sym4 sym5 sym6 sym7 "\n")
+ (setq elt
+ (ti::macrof-minor-mode-1
+ sym1 doc-str sym2
+ sym3 sym4 sym5
+ sym6 nil mode-desc
+ sym7
+ minor-mode-body))
+ (ti::nconc ret elt)
+ (setq elt (ti::macrof-minor-mode-on sym1))
+ (ti::nconc ret elt)
+ (setq elt (ti::macrof-minor-mode-off sym1))
+ (ti::nconc ret elt)
+ (setq elt (ti::macrof-minor-mode-help sym1))
+ (ti::nconc ret elt)
+ (setq elt (ti::macrof-minor-mode-commentary pfx sym1))
+ (ti::nconc ret elt)
+ (setq elt (ti::macrof-minor-mode-viper-attach pfx sym1))
+ (ti::nconc ret elt)
+ ret))
+
+;;}}}
+
+(provide 'tinylib)
+
+;;; tinylib.el ends here
--- /dev/null
+;;; tinyliba.el --- Library for (a)utoload definitions
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 1998-2007 Jari Aalto
+;; Keywords: extensions
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program, call M-x tinyliba-version.
+;; Look at the code with folding.el
+
+;; COPYRIGHT NOTICE
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;; ........................................................ &t-install ...
+;; DO NOT LOAD THIS FILE, but load the central library "m". It loads this
+;; file and backward compatible library "b"
+;;
+;; (require 'tinylibm)
+;;
+;; See also Sourceforge project `apel'
+
+;;}}}
+;;{{{ Documentation
+
+;; ..................................................... &t-commentary ...
+
+;;; Commentary:
+
+;; Preface, 1998
+;;
+;; This is lisp function library, package itself does nothing.
+;; This library defines autoload functions and few emacs version
+;; detection functions.
+;;
+;; The autoloads are automatically generated and YOU SHOULD NOT
+;; FIX THEM BY HAND. To add or update autoloads from a package,
+;; do it like this:
+;;
+;; o Generate autoloads to separate buffer with
+;; command
+;;; C-u M-x tinylisp-autoload-generate-library RET file.el RET
+;; o At the end of buffer *tinylisp-autoloads* cut'n paste
+;; the definititions to this file.
+;;
+;; NOTE: If function already exists in Emacs/XEmacs, an autoload
+;; definition here does nothing. Like `describe-symbol-find-file',
+;; which is already defined in XEmacs.
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+;;{{{ code: Init
+
+(provide 'tinyliba)
+
+;; Older byte compiler doesn't allow putting these inside
+;; `eval-and-compile'. The message was:
+;;
+;; ** The compiler ignores `autoload' except at top level. You should
+;; probably put the autoload of the macro `with-timeout' at top-level.
+
+(autoload 'with-timeout "timer" "" nil 'macro)
+(autoload 'easy-menu-define "easymenu" "" nil 'macro)
+(autoload 'executable-find "executable")
+
+(eval-and-compile ;; function must be visible at load time
+ (defun ti::tmp-cl-library-check ()
+ "Check that cl.el library is correct and force loading if not.
+This function is run only once at tinynyliba.el load."
+ (let* ((pkg (featurep 'tinypath))
+ (mode (if (and pkg
+ (boundp 'tinypath-:cache-mode))
+ ;; Quiet Byte Compiler
+ (symbol-value 'tinypath-:cache-mode))))
+ ;; Turn off advices and cache only IF the package is active
+ (if (and pkg mode)
+ (let ((func 'tinypath-cache-mode))
+ (if (fboundp func)
+ (funcall func -1))))
+ (unless (fboundp 'return)
+ ;; cl.el version 3.0 does not define macro `return'. cl
+ ;; 2.02(19.34) is ok. This was noticed by Sami Khoury
+ ;; <skhoury@cse.dnd.ca>
+ (let ((location (locate-library "cl")))
+ (error "\
+** tinyliba.el: Core library `cl' [%s] is dysfunctional.
+ (require 'cl) dind't provide standard CL statement
+ `return'. This may be a problem in `load-path' order.
+ Do you need to re-arrange it? The package `cl' is in [%s]"
+ location)))
+ ;; But, even if there is `return', the `dolist' macro may be broken.
+ ;; In Emacs 21.3 the dolist was moved to subr.el but with a
+ ;; broken implementation.
+ (condition-case err
+ (dolist (elt '(1))
+ (return elt))
+ (error
+ (message "\
+** tinyliba.el [ERROR] Broken `dolist' implementation!
+ A simple `dolist' call with `return' statement failed
+ with error [%s]. Trying to fix this by loading
+ `cl-macs.el' explicitly." err)
+ (load-library "cl-macs.el")))
+ ;; Do post-check if everything is ok.
+ (condition-case nil
+ (dolist (elt '(1))
+ (return elt))
+ (error
+ (message "\
+** tinyliba.el [ERROR] Still broken `dolist' implementation!
+ It's impossible to know why this happened,
+ Try searching all cl*.el files along path and checking
+ if any of them define dysfunctional `dolist'")))
+ ;; Restore caching feature
+ (if (and pkg mode)
+ (let ((func 'tinypath-cache-mode))
+ (if (fboundp func)
+ (funcall func 1)))))))
+
+(eval-and-compile
+ (require 'cl)
+ (ti::tmp-cl-library-check)
+ ;; defvar silences Byte Compiler
+ (defvar byte-compile-dynamic nil "") ;; Introduced in Emacs 19.29
+ (make-local-variable 'byte-compile-dynamic)
+ (setq byte-compile-dynamic t))
+
+;;}}}
+
+(eval-and-compile
+
+ ;; XEmacs and Emacs differ here
+
+ ;; (if (locate-library "rsz-mini")
+ ;; (autoload 'resize-minibuffer-mode "rsz-mini")
+ ;; (autoload 'resize-minibuffer-mode "rsz-minibuf"))
+ ;;
+
+ ;;{{{ code: Autoload easymenu.el
+
+ ;; These are from XEmacs 19.14, they should suffice
+
+ (autoload 'easy-menu-do-define "easymenu" "" nil)
+ (autoload 'easy-menu-add "easymenu" "" nil)
+ (autoload 'easy-menu-remove "easymenu" "" nil)
+
+;;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. Emacs 19.30 ..
+
+ ;; (autoload 'easy-menu-define "easymenu" "" nil 'macro)
+ ;; (autoload 'easy-menu-do-define "easymenu" "" t)
+ ;; (autoload 'easy-menu-create-keymaps "easymenu" "" nil)
+ ;; (autoload 'easy-menu-change "easymenu" "" nil)
+ ;; (autoload 'easy-menu-remove "easymenu" "" nil)
+ ;; (autoload 'easy-menu-add "easymenu" "" nil)
+
+ ;;}}}
+ ;;{{{ code: Autoload skeleton.el
+
+ (autoload 'define-skeleton "skeleton" "" t 'macro)
+ (autoload 'skeleton-proxy-new "skeleton" "" t)
+ (autoload 'skeleton-proxy "skeleton" "" t)
+ (autoload 'skeleton-abbrev-cleanup "skeleton" "" nil)
+ (autoload 'skeleton-insert "skeleton" "" nil)
+ (autoload 'skeleton-read "skeleton" "" nil)
+ (autoload 'skeleton-internal-list "skeleton" "" nil)
+ (autoload 'skeleton-internal-1 "skeleton" "" nil)
+ (autoload 'skeleton-pair-insert-maybe "skeleton" "" t)
+
+ ;;}}}
+ ;;{{{ code: Autoload cl
+
+ ;; cl-compat.el Emacs 19.34
+
+ (autoload 'defkeyword "cl-compat" "" nil 'macro)
+ (autoload 'keywordp "cl-compat" "" nil)
+ (autoload 'keyword-of "cl-compat" "" nil)
+ (autoload 'values "cl-compat" "" nil)
+ (autoload 'values-list "cl-compat" "" nil)
+ (autoload 'multiple-value-list "cl-compat" "" nil 'macro)
+ (autoload 'multiple-value-call "cl-compat" "" nil 'macro)
+ (autoload 'multiple-value-bind "cl-compat" "" nil 'macro)
+ (autoload 'multiple-value-setq "cl-compat" "" nil 'macro)
+ (autoload 'multiple-value-prog1 "cl-compat" "" nil 'macro)
+ (autoload 'build-klist "cl-compat" "" nil)
+ (autoload 'extract-from-klist "cl-compat" "" nil)
+ (autoload 'keyword-argument-supplied-p "cl-compat" "" nil)
+ (autoload 'elt-satisfies-test-p "cl-compat" "" nil)
+ (autoload 'cl-floor "cl-compat" "" nil)
+ (autoload 'cl-ceiling "cl-compat" "" nil)
+ (autoload 'cl-round "cl-compat" "" nil)
+ (autoload 'cl-truncate "cl-compat" "" nil)
+ (autoload 'safe-idiv "cl-compat" "" nil)
+ (autoload 'pair-with-newsyms "cl-compat" "" nil)
+ (autoload 'zip-lists "cl-compat" "" nil)
+ (autoload 'unzip-lists "cl-compat" "" nil)
+ (autoload 'reassemble-argslists "cl-compat" "" nil)
+ (autoload 'duplicate-symbols-p "cl-compat" "" nil)
+ (autoload 'setnth "cl-compat" "" nil)
+ (autoload 'setnthcdr "cl-compat" "" nil)
+ (autoload 'setelt "cl-compat" "" nil)
+
+ ;; cl-extra.el 19.34
+
+ ;; (autoload 'cl-push "cl-extra" "" nil 'macro)
+ ;; (autoload 'cl-pop "cl-extra" "" nil 'macro)
+ (autoload 'coerce "cl-extra" "" nil)
+ (autoload 'equalp "cl-extra" "" nil)
+ (autoload 'cl-mapcar-many "cl-extra" "" nil)
+ (autoload 'map "cl-extra" "" nil)
+ (autoload 'maplist "cl-extra" "" nil)
+ (autoload 'mapc "cl-extra" "" nil)
+ (autoload 'mapl "cl-extra" "" nil)
+ (autoload 'mapcan "cl-extra" "" nil)
+ (autoload 'mapcon "cl-extra" "" nil)
+ (autoload 'some "cl-extra" "" nil)
+ (autoload 'every "cl-extra" "" nil)
+ (autoload 'notany "cl-extra" "" nil)
+ (autoload 'notevery "cl-extra" "" nil)
+ (autoload 'cl-map-keymap "cl-extra" "" nil)
+ (autoload 'cl-map-keymap-recursively "cl-extra" "" nil)
+ (autoload 'cl-map-intervals "cl-extra" "" nil)
+ (autoload 'cl-map-overlays "cl-extra" "" nil)
+ (autoload 'cl-set-frame-visible-p "cl-extra" "" nil)
+ (autoload 'cl-progv-before "cl-extra" "" nil)
+ (autoload 'cl-progv-after "cl-extra" "" nil)
+ (autoload 'gcd "cl-extra" "" nil)
+ (autoload 'lcm "cl-extra" "" nil)
+ (autoload 'isqrt "cl-extra" "" nil)
+ (autoload 'cl-expt "cl-extra" "" nil)
+ (autoload 'floor* "cl-extra" "" nil)
+ (autoload 'ceiling* "cl-extra" "" nil)
+ (autoload 'truncate* "cl-extra" "" nil)
+ (autoload 'round* "cl-extra" "" nil)
+ (autoload 'mod* "cl-extra" "" nil)
+ (autoload 'rem* "cl-extra" "" nil)
+ (autoload 'signum "cl-extra" "" nil)
+ (autoload 'random* "cl-extra" "" nil)
+ (autoload 'make-random-state "cl-extra" "" nil)
+ (autoload 'random-state-p "cl-extra" "" nil)
+ (autoload 'cl-finite-do "cl-extra" "" nil)
+ (autoload 'cl-float-limits "cl-extra" "" nil)
+ (autoload 'subseq "cl-extra" "" nil)
+ (autoload 'concatenate "cl-extra" "" nil)
+ (autoload 'revappend "cl-extra" "" nil)
+ (autoload 'nreconc "cl-extra" "" nil)
+ (autoload 'list-length "cl-extra" "" nil)
+ (autoload 'tailp "cl-extra" "" nil)
+ (autoload 'cl-copy-tree "cl-extra" "" nil)
+ (autoload 'get* "cl-extra" "" nil)
+ (autoload 'getf "cl-extra" "" nil)
+ (autoload 'cl-set-getf "cl-extra" "" nil)
+ (autoload 'cl-do-remf "cl-extra" "" nil)
+ (autoload 'cl-remprop "cl-extra" "" nil)
+ (autoload 'make-hash-table "cl-extra" "" nil)
+ (autoload 'hash-table-p "cl-extra" "" nil)
+ (autoload 'cl-not-hash-table "cl-extra" "" nil)
+ (autoload 'cl-hash-lookup "cl-extra" "" nil)
+ (autoload 'cl-gethash "cl-extra" "" nil)
+ (autoload 'cl-puthash "cl-extra" "" nil)
+ (autoload 'cl-remhash "cl-extra" "" nil)
+ (autoload 'cl-clrhash "cl-extra" "" nil)
+ (autoload 'cl-maphash "cl-extra" "" nil)
+ (autoload 'hash-table-count "cl-extra" "" nil)
+ (autoload 'cl-prettyprint "cl-extra" "" nil)
+ (autoload 'cl-do-prettyprint "cl-extra" "" nil)
+ (autoload 'cl-macroexpand-all "cl-extra" "" nil)
+ (autoload 'cl-macroexpand-body "cl-extra" "" nil)
+ (autoload 'cl-prettyexpand "cl-extra" "" nil)
+
+ ;; cl-seq.el 19.34
+ ;; Hm. Sometimemes you find this message:
+ ;; "Tried to load `cl-seq' before `cl'!"
+ ;;
+ ;; These are commented for now
+
+ (when nil
+
+ (autoload 'cl-push "cl-seq" "" nil 'macro)
+ (autoload 'cl-pop "cl-seq" "" nil 'macro)
+ (autoload 'cl-parsing-keywords "cl-seq" "" nil 'macro)
+ (autoload 'cl-check-key "cl-seq" "" nil 'macro)
+ (autoload 'cl-check-test-nokey "cl-seq" "" nil 'macro)
+ (autoload 'cl-check-test "cl-seq" "" nil 'macro)
+ (autoload 'cl-check-match "cl-seq" "" nil 'macro)
+ (autoload 'reduce "cl-seq" "" nil)
+ (autoload 'fill "cl-seq" "" nil)
+ (autoload 'replace "cl-seq" "" nil)
+ (autoload 'remove* "cl-seq" "" nil)
+ (autoload 'remove-if "cl-seq" "" nil)
+ (autoload 'remove-if-not "cl-seq" "" nil)
+ (autoload 'delete* "cl-seq" "" nil)
+ (autoload 'delete-if "cl-seq" "" nil)
+ (autoload 'delete-if-not "cl-seq" "" nil)
+ (autoload 'remove "cl-seq" "" nil)
+ (autoload 'remq "cl-seq" "" nil)
+ (autoload 'remove-duplicates "cl-seq" "" nil)
+ (autoload 'delete-duplicates "cl-seq" "" nil)
+ (autoload 'cl-delete-duplicates "cl-seq" "" nil)
+ (autoload 'substitute "cl-seq" "" nil)
+ (autoload 'substitute-if "cl-seq" "" nil)
+ (autoload 'substitute-if-not "cl-seq" "" nil)
+ (autoload 'nsubstitute "cl-seq" "" nil)
+ (autoload 'nsubstitute-if "cl-seq" "" nil)
+ (autoload 'nsubstitute-if-not "cl-seq" "" nil)
+ (autoload 'find "cl-seq" "" nil)
+ (autoload 'find-if "cl-seq" "" nil)
+ (autoload 'find-if-not "cl-seq" "" nil)
+ (autoload 'position "cl-seq" "" nil)
+ (autoload 'cl-position "cl-seq" "" nil)
+ (autoload 'position-if "cl-seq" "" nil)
+ (autoload 'position-if-not "cl-seq" "" nil)
+ (autoload 'count "cl-seq" "" nil)
+ (autoload 'count-if "cl-seq" "" nil)
+ (autoload 'count-if-not "cl-seq" "" nil)
+ (autoload 'mismatch "cl-seq" "" nil)
+ (autoload 'search "cl-seq" "" nil)
+ (autoload 'sort* "cl-seq" "" nil)
+ (autoload 'stable-sort "cl-seq" "" nil)
+ (autoload 'merge "cl-seq" "" nil)
+ (autoload 'member* "cl-seq" "" nil)
+ (autoload 'member-if "cl-seq" "" nil)
+ (autoload 'member-if-not "cl-seq" "" nil)
+ (autoload 'cl-adjoin "cl-seq" "" nil)
+ (autoload 'assoc* "cl-seq" "" nil)
+ (autoload 'assoc-if "cl-seq" "" nil)
+ (autoload 'assoc-if-not "cl-seq" "" nil)
+ (autoload 'rassoc* "cl-seq" "" nil)
+ (autoload 'rassoc-if "cl-seq" "" nil)
+ (autoload 'rassoc-if-not "cl-seq" "" nil)
+ (autoload 'union "cl-seq" "" nil)
+ (autoload 'nunion "cl-seq" "" nil)
+ (autoload 'intersection "cl-seq" "" nil)
+ (autoload 'nintersection "cl-seq" "" nil)
+ (autoload 'set-difference "cl-seq" "" nil)
+ (autoload 'nset-difference "cl-seq" "" nil)
+ (autoload 'set-exclusive-or "cl-seq" "" nil)
+ (autoload 'nset-exclusive-or "cl-seq" "" nil)
+ (autoload 'subsetp "cl-seq" "" nil)
+ (autoload 'subst-if "cl-seq" "" nil)
+ (autoload 'subst-if-not "cl-seq" "" nil)
+ (autoload 'nsubst "cl-seq" "" nil)
+ (autoload 'nsubst-if "cl-seq" "" nil)
+ (autoload 'nsubst-if-not "cl-seq" "" nil)
+ (autoload 'sublis "cl-seq" "" nil)
+ (autoload 'cl-sublis-rec "cl-seq" "" nil)
+ (autoload 'nsublis "cl-seq" "" nil)
+ (autoload 'cl-nsublis-rec "cl-seq" "" nil)
+ (autoload 'tree-equal "cl-seq" "" nil)
+ (autoload 'cl-tree-equal-rec "cl-seq" "" nil)
+
+ ;; cl-indent.el 19.34
+
+ (autoload 'common-lisp-indent-function "cl-indent" "" nil)
+ (autoload 'lisp-indent-report-bad-format "cl-indent" "" nil)
+ (autoload 'lisp-indent-259 "cl-indent" "" nil)
+ (autoload 'lisp-indent-tagbody "cl-indent" "" nil)
+ (autoload 'lisp-indent-do "cl-indent" "" nil)
+ (autoload 'lisp-indent-function-lambda-hack "cl-indent" "" nil)
+
+ ) ;; when-nil
+
+ ;; assoc.el 20.4
+
+ (autoload 'asort "assoc" "" nil)
+ (autoload 'aelement "assoc" "" nil)
+ (autoload 'aheadsym "assoc" "" nil)
+ (autoload 'anot-head-p "assoc" "" nil)
+ (autoload 'aput "assoc" "" nil)
+ (autoload 'adelete "assoc" "" nil)
+ (autoload 'aget "assoc" "" nil)
+ (autoload 'amake "assoc" "" nil)
+
+ ;;}}}
+ ;;{{{ Backward compatible lib: tinylibb.el
+
+ (autoload 'shell-command-to-string "tinylibm" "" nil)
+ (autoload 'describe-symbol-find-file "tinylibb" "" nil)
+ (autoload 'subst-char-with-string "tinylibb" "" nil)
+ (autoload 'subst-char-in-string "tinylibb" "" nil)
+ (autoload 'font-lock-mode-maybe "tinylibb" "" nil)
+ (autoload 'turn-on-font-lock-mode "tinylibb" "" nil)
+ (autoload 'turn-on-font-lock-mode-maybe "tinylibb" "" nil)
+ (autoload 'int-to-float "tinylibb" "" nil)
+ (autoload 'logtest "tinylibb" "" nil)
+ (autoload 'bin-string-to-int "tinylibb" "" nil)
+ (autoload 'int-to-bin-string "tinylibb" "" nil)
+ (autoload 'int-to-hex-string "tinylibb" "" nil)
+ (autoload 'int-to-oct-string "tinylibb" "" nil)
+ (autoload 'radix "tinylibb" "" nil)
+ (autoload 'bin-to-int "tinylibb" "" nil)
+ (autoload 'oct-to-int "tinylibb" "" nil)
+ (autoload 'hex-to-int "tinylibb" "" nil)
+ (autoload 'int-to-net "tinylibb" "" nil)
+ (autoload 'rmac "tinylibb" "" nil)
+ (autoload 'ctime "tinylibb" "" nil)
+ (autoload 'rand0 "tinylibb" "" nil) ;;defsubst
+ (autoload 'rand1 "tinylibb" "" nil)
+ (autoload 'randij "tinylibb" "" nil)
+ (autoload 'byte-compiling-files-p "tinylibb" "" nil 'macro)
+
+ ;;}}}
+ ;;{{{ code: Autoload 'env' lib -- Emacs and XEmacs environment checks
+
+ (autoload 'defalias-maybe "tinylibenv" "" nil 'macro)
+ (autoload 'defconst-maybe "tinylibenv" "" nil 'macro)
+ (autoload 'defmacro-maybe "tinylibenv" "" nil 'macro)
+ (autoload 'defsubst-maybe "tinylibenv" "" nil 'macro)
+ (autoload 'defun-maybe "tinylibenv" "" nil 'macro)
+ (autoload 'ti::emacs-debug-mode "tinylibenv" "" t)
+ (autoload 'ti::emacs-install-root "tinylibenv" "" nil)
+ (autoload 'ti::emacs-install-root-emacsen "tinylibenv" "" nil)
+ (autoload 'ti::emacs-p "tinylibenv" "" nil) ;;defsubst
+ (autoload 'ti::xemacs-p "tinylibenv" "" nil) ;;defsubst
+ (autoload 'ti::emacs-type-cygwin-p "tinylibenv" "" nil) ;;defsubst
+ (autoload 'ti::emacs-type-unix-like-p "tinylibenv" "" nil) ;;defsubst
+ (autoload 'ti::emacs-type-win32-p "tinylibenv" "" nil) ;;defsubst
+ (autoload 'ti::emacs-version-number-as-string "tinylibenv" "" nil) ;;defsubst
+ (autoload 'ti::emacs-version-number-as-string-major "tinylibenv" "" nil) ;;defsubst
+ (autoload 'ti::executable-find "tinylibenv" "" nil)
+ (autoload 'ti::file-version "tinylibenv" "" nil)
+ (autoload 'ti::os-check-gnu-support-p "tinylibenv" "" nil) ;;defsubst
+ (autoload 'ti::os-check-hpux-p "tinylibenv" "" nil) ;;defsubst
+ (autoload 'ti::os-check-linux-like-p "tinylibenv" "" nil) ;;defsubst
+ (autoload 'ti::os-check-linux-p "tinylibenv" "" nil) ;;defsubst
+ (autoload 'ti::os-check-sunos-p "tinylibenv" "" nil) ;;defsubst
+ (autoload 'ti::turn-off-emacs-debug "tinylibenv" "" t)
+ (autoload 'ti::turn-on-emacs-debug "tinylibenv" "" t)
+ (autoload 'ti::win32-9x-p "tinylibenv" "" nil) ;;defsubst
+ (autoload 'ti::win32-cygwin-binary-p "tinylibenv" "" nil)
+ (autoload 'ti::win32-cygwin-p "tinylibenv" "" nil) ;;defsubst
+ (autoload 'ti::win32-cygwin-p-1 "tinylibenv" "" nil)
+ (autoload 'ti::win32-nt-p "tinylibenv" "" nil) ;;defsubst
+ (autoload 'ti::win32-p "tinylibenv" "" nil)
+ (autoload 'ti::win32-shell-p "tinylibenv" "" nil)
+
+ ;;{{{ code: Autoload
+
+ (autoload 'ti::function-car-test "tinylibm" "" nil)
+ (autoload 'ti::defalias-p "tinylibm" "" nil)
+ (autoload 'ti::subrp-p "tinylibm" "" nil)
+ (autoload 'ti::defmacro-p "tinylibm" "" nil)
+ (autoload 'ti::autoload-p "tinylibm" "" nil)
+ (autoload 'ti::autoload-file "tinylibm" "" nil)
+ (autoload 'ti::lambda-p "tinylibm" "" nil)
+ (autoload 'ti::compatibility-advice-setup "tinylibm" "" nil)
+ (autoload 'tinylibm-version "tinylibm" "" t)
+ (autoload 'tinylibm-submit-bug-report "tinylibm" "" t)
+ (autoload 'ti::definteractive "tinylibm" "" t 'macro)
+ (autoload 'ti::fboundp-check-autoload "tinylibm" "" nil 'macro)
+ (autoload 'ti::narrow-safe "tinylibm" "" nil 'macro)
+ (autoload 'ti::narrow-to-paragraph "tinylibm" "" nil 'macro)
+ (autoload 'ti::nconc "tinylibm" "" nil 'macro)
+ (autoload 'ti::consp "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::listp "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::when-package "tinylibm" "" nil 'macro)
+ (autoload 'ti::with-require "tinylibm" "" nil 'macro)
+ (autoload 'ti::with-time-this "tinylibm" "" nil 'macro)
+ (autoload 'ti::with-coding-system-raw-text "tinylibm" "" nil 'macro)
+ (autoload 'ti::process-mark "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::verb "tinylibm" "" t 'macro)
+ (autoload 'ti::pmin "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::pmax "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::dotimes "tinylibm" "" nil 'macro)
+ (autoload 'ti::funcall "tinylibm" "" nil 'macro)
+ (autoload 'ti::string-value "tinylibm" "" nil)
+ (autoload 'ti::prin1-mapconcat "tinylibm" "" nil)
+ (autoload 'ti::d! "tinylibm" "" nil 'macro)
+ (autoload 'ti::d!! "tinylibm" "" nil 'macro)
+ (autoload 'ti::string-left "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::string-right "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::string-match-case "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::month-list "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::month-list-regexp "tinylibm" "" nil)
+ (autoload 'ti::month-mm-alist "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::month-nn-alist "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::month-to-number "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::month-to-0number "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::number-to-month "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::date-eu-list "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::date-us-list "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::date-list-regexp "tinylibm" "" nil)
+ (autoload 'ti::read-char-safe "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::read-char-safe-until "tinylibm" "" nil)
+ (autoload 'ti::remove-properties "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::applycar "tinylibm" "" nil 'macro)
+ (autoload 'ti::add-command-line-arg "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::buffer-modified-p "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::first-line-p "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::last-line-p "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::buffer-narrowed-p "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::buffer-empty-p "tinylibm" "" nil)
+ (autoload 'ti::ck-maybe-activate "tinylibm" "" nil)
+ (autoload 'ti::register-live-p "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::file-dos-p "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::space-p "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::compat-face-p "tinylibm" "" nil)
+ (autoload 'ti::color-type "tinylibm" "" nil)
+ (autoload 'ti::colors-supported-p "tinylibm" "" nil)
+ (autoload 'ti::overlay-supported-p "tinylibm" "" nil)
+ (autoload 'ti::idle-timer-supported-p "tinylibm" "" nil)
+ (autoload 'ti::replace-match "tinylibm" "" nil)
+ (autoload 'ti::buffer-kill-control-characters "tinylibm" "" t) ;;defsubst
+ (autoload 'ti::string-match "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::buffer-match "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::selective-display-line-p "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::bool-p "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::print-p "tinylibm" "" nil 'macro)
+ (autoload 'ti::char-case-p "tinylibm" "" nil)
+ (autoload 'ti::nil-p "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::window-pmin-visible-p "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::window-pmax-visible-p "tinylibm" "" nil 'macro)
+ (autoload 'ti::window-pmax-line-p "tinylibm" "" nil)
+ (autoload 'ti::window-pmin-line-p "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::window-pmax-line-bol "tinylibm" "" nil)
+ (autoload 'ti::window-middle-line "tinylibm" "" nil)
+ (autoload 'ti::no-action-in-progress-p "tinylibm" "" nil)
+ (autoload 'ti::current-line-number "tinylibm" "" nil)
+ (autoload 'ti::read-current-line "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::line-length "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::line-wrap-p "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::re-search-check "tinylibm" "" nil)
+ (autoload 'ti::re-search-point-list "tinylibm" "" nil)
+ (autoload 'ti::assoc-append-inside "tinylibm" "" nil 'macro)
+ (autoload 'ti::assoc-replace-maybe-add "tinylibm" "" nil)
+ (autoload 'ti::char-in-list-case "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::list-make "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::list-flatten "tinylibm" "" nil)
+ (autoload 'ti::list-join "tinylibm" "" nil)
+ (autoload 'ti::list-to-assoc-menu "tinylibm" "" nil)
+ (autoload 'ti::list-to-cons "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::list-remove-successive "tinylibm" "" nil)
+ (autoload 'ti::list-merge-elements "tinylibm" "" nil)
+ (autoload 'ti::list-print "tinylibm" "" t)
+ (autoload 'ti::list-to-string "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::list-elt-position "tinylibm" "" nil)
+ (autoload 'ti::list-find "tinylibm" "" nil)
+ (autoload 'ti::non-dedicated-frame "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::select-frame-non-dedicated "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::byte-compile-defun-compiled-p "tinylibm" "" nil 'macro)
+ (autoload 'ti::byte-compile-defun-maybe "tinylibm" "" nil 'macro)
+ (autoload 'ti::package-use-dynamic-compilation "tinylibm" "" nil 'macro)
+ (autoload 'ti::function-autoload-file "tinylibm" "" nil)
+ (autoload 'ti::package-require-for-emacs "tinylibm" "" nil 'macro)
+ (autoload 'ti::package-require-view "tinylibm" "" nil 'macro)
+ (autoload 'ti::package-package-require-timer "tinylibm" "" nil 'macro)
+ (autoload 'ti::package-require-mail-abbrevs "tinylibm" "" nil 'macro)
+ (autoload 'ti::use-file-compression "tinylibm" "" nil 'macro)
+ (autoload 'ti::use-file-compression-maybe "tinylibm" "" nil)
+ (autoload 'ti::push-definition "tinylibm" "" nil)
+ (autoload 'ti::pop-definition "tinylibm" "" nil)
+ (autoload 'ti::use-prefix-key "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::swap-keys-if-not-keymap "tinylibm" "" nil)
+ (autoload 'ti::define-buffer-local-keymap "tinylibm" "" nil 'macro)
+ (autoload 'ti::define-key-if-free "tinylibm" "" nil 'macro)
+ (autoload 'ti::define-in-function-keymap "tinylibm" "" nil)
+ (autoload 'ti::copy-key-definition "tinylibm" "" nil 'macro)
+ (autoload 'ti::beginning-of-defun-point "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::digit-length "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::add-hook-fix "tinylibm" "" nil)
+ (autoload 'ti::add-hooks "tinylibm" "" nil)
+ (autoload 'ti::prefix-arg-to-text "tinylibm" "" nil)
+ (autoload 'ti::keep-lower-order "tinylibm" "" nil 'macro)
+ (autoload 'ti::bool-toggle "tinylibm" "" nil 'macro)
+ (autoload 'ti::compat-load-user-init-file "tinylibm" "" nil 'macro)
+ (autoload 'ti::compat-Info-directory-list-symbol "tinylibm" "" nil) ;; defsubst
+ (autoload 'ti::compat-Info-directory-list "tinylibm" "" nil) ;; defsubst
+ (autoload 'ti::buffer-pointer-of-info "tinylibm" "" nil)
+ (autoload 'ti::buffer-pointer-of-messages "tinylibm" "" nil)
+ (autoload 'ti::last-message-line "tinylibm" "" nil)
+ (autoload 'ti::dolist-buffer-list "tinylibm" "" nil 'macro)
+ (autoload 'ti::erase-buffer "tinylibm" "" nil)
+ (autoload 'ti::temp-buffer "tinylibm" "" nil)
+ (autoload 'ti::append-to-buffer "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::set-buffer-safe "tinylibm" "" nil)
+ (autoload 'ti::kill-buffer-safe "tinylibm" "" nil)
+ (autoload 'cl-clrhash-paranoid "tinylibm" "" nil)
+ (autoload 'ti::vector-table-init "tinylibm" "" nil 'macro)
+ (autoload 'ti::vector-table-get "tinylibm" "" nil 'macro)
+ (autoload 'ti::vector-table-property "tinylibm" "" nil)
+ (autoload 'ti::vector-table-clear "tinylibm" "" nil 'macro)
+ (autoload 'ti::expand-file-name-tilde-in-string "tinylibm" "" nil)
+ (autoload 'ti::file-name-path-p "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::file-name-path-absolute-p "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::directory-move "tinylibm" "" nil)
+ (autoload 'ti::write-file-with-wrapper "tinylibm" "" nil)
+ (autoload 'ti::load-file-with-wrapper "tinylibm" "" nil 'macro)
+ (autoload 'ti::write-file-as-is-macro "tinylibm" "" nil 'macro)
+ (autoload 'ti::directory-list "tinylibm" "" nil)
+ (autoload 'ti::directory-recursive-macro "tinylibm" "" nil 'macro)
+ (autoload 'ti::file-name-remote-p "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::file-name-backward-slashes "tinylibm" "" nil)
+ (autoload 'ti::file-name-forward-slashes "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::file-name-forward-slashes-cygwin "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::file-changed-on-disk-p "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::file-mode-make-read-only "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::file-mode-make-read-only-all "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::file-mode-make-writable "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::file-mode-make-executable "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::file-mode-protect "tinylibm" "" t) ;;defsubst
+ (autoload 'ti::file-toggle-read-write "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::file-owned-p "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::file-modify-p "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::file-find-file-p "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::file-read-only-p "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::file-name-run-real-handler "tinylibm" "" nil)
+ (autoload 'ti::find-file-literally "tinylibm" "" t)
+ (autoload 'ti::file-eval "tinylibm" "" nil)
+ (autoload 'ti::directory-writable-p "tinylibm" "" nil)
+ (autoload 'ti::file-delete-safe "tinylibm" "" nil)
+ (autoload 'ti::temp-directory "tinylibm" "" nil)
+ (autoload 'ti::temp-file "tinylibm" "" nil)
+ (autoload 'ti::pop-to-buffer-or-window "tinylibm" "" nil)
+ (autoload 'ti::find-file-or-window "tinylibm" "" nil)
+ (autoload 'ti::mouse-point "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::i-macro-region-ask "tinylibm" "" nil) ;;defsubst
+ (autoload 'ti::i-macro-region-body "tinylibm" "" nil 'macro)
+ (autoload 'ti::with-unix-shell-environment "tinylibm" "" nil 'macro)
+ (autoload 'ti::package-defgroup-tiny "tinylibm" "" nil 'macro)
+ (autoload 'ti::package-tiny-defgroup-mail "tinylibm" "" nil)
+ (autoload 'ti::grep-output-parse-macro "tinylibm" "" nil 'macro)
+ (autoload 'ti::occur-macro "tinylibm" "" nil 'macro)
+ (autoload 'ti::momentary-output-macro "tinylibm" "" nil 'macro)
+ (autoload 'ti::save-excursion-macro "tinylibm" "" nil 'macro)
+ (autoload 'ti::save-with-marker-macro "tinylibm" "" nil 'macro)
+ (autoload 'ti::save-line-column-macro "tinylibm" "" nil 'macro)
+ (autoload 'ti::widen-safe "tinylibm" "" nil 'macro)
+ (autoload 'ti::package-config-file-directory-default "tinylibm" "" nil)
+ (autoload 'ti::package-config-file-prefix "tinylibm" "" nil)
+ (autoload 'ti::overlay-require-macro "tinylibm" "" nil 'macro)
+ (autoload 'ti::pp-variable-list "tinylibm" "" nil)
+ (autoload 'ti::write-file-variable-state "tinylibm" "" nil)
+
+;;; tinylib.el
+
+ (autoload 'tinylib-version "tinylib" "" t)
+ (autoload 'tinylib-submit-feedback "tinylib" "" t)
+ (autoload 'ti::string-trim-blanks "tinylib" "" nil)
+ (autoload 'ti::string-verify-ends "tinylib" "" nil)
+ (autoload 'ti::string-add-space "tinylib" "" nil) ;;defsubst
+ (autoload 'ti::string-remove-whitespace "tinylib" "" nil)
+ (autoload 'ti::string-mangle "tinylib" "" nil)
+ (autoload 'ti::string-regexp-delete "tinylib" "" nil) ;;defsubst
+ (autoload 'ti::string-format-percent "tinylib" "" nil)
+ (autoload 'ti::string-url-to-ange-ftp "tinylib" "" nil)
+ (autoload 'ti::buffer-backslash-fix-paragraph "tinylib" "" t)
+ (autoload 'ti::buffer-upcase-words-to-variable-names "tinylib" "" t)
+ (autoload 'ti::string-nth-from-number "tinylib" "" nil) ;;defsubst
+ (autoload 'ti::date-time-elements "tinylib" "" t)
+ (autoload 'ti::string-char-to-escape-char "tinylib" "" nil)
+ (autoload 'ti::string-plain-string-to-regexp "tinylib" "" nil)
+ (autoload 'ti::file-access-mode-to-string "tinylib" "" nil)
+ (autoload 'ti::file-name-for-correct-system "tinylib" "" nil)
+ (autoload 'ti::vc-rcs-delta-get-revisions "tinylib" "" nil) ;;defsubst
+ (autoload 'ti::vc-rcs-delta-get-file "tinylib" "" nil)
+ (autoload 'ti::vc-rcs-delta-lock-status "tinylib" "" nil)
+ (autoload 'ti::vc-rcs-delta-lock-status-user "tinylib" "" nil) ;;defsubst
+ (autoload 'ti::vc-rcs-delta-highest-version "tinylib" "" t) ;;defsubst
+ (autoload 'ti::vc-rcs-read-val "tinylib" "" nil) ;;defsubst
+ (autoload 'ti::vc-rcs-look-id "tinylib" "" nil)
+ (autoload 'ti::vc-cvs-to-cvs-dir "tinylib" "" nil) ;;defsubst
+ (autoload 'ti::vc-cvs-to-cvs-dir-p "tinylib" "" nil) ;;defsubst
+ (autoload 'ti::vc-cvs-to-cvs-file "tinylib" "" nil)
+ (autoload 'ti::vc-cvs-to-cvs-file-content "tinylib" "" nil)
+ (autoload 'ti::vc-cvs-file-exists-p "tinylib" "" nil)
+ (autoload 'ti::vc-cvs-entry-split "tinylib" "" nil) ;;defsubst
+ (autoload 'ti::vc-cvs-entry-type "tinylib" "" nil) ;;defsubst
+ (autoload 'ti::vc-cvs-entry-split-info "tinylib" "" nil) ;;defsubst
+ (autoload 'ti::vc-rcs-file-p "tinylib" "" nil) ;;defsubst
+ (autoload 'ti::vc-rcs-make-filename "tinylib" "" nil)
+ (autoload 'ti::vc-rcs-file-exists-p "tinylib" "" nil) ;;defsubst
+ (autoload 'ti::vc-rcs-normal-file "tinylib" "" nil) ;;defsubst
+ (autoload 'ti::vc-rcs-sort-same-level-list "tinylib" "" nil)
+ (autoload 'ti::vc-rcs-files-in-dir "tinylib" "" nil)
+ (autoload 'ti::vc-rcs-head-version "tinylib" "" nil) ;;defsubst
+ (autoload 'ti::vc-rcs-guess-buffer-version "tinylib" "" nil)
+ (autoload 'ti::vc-rcs-buffer-version "tinylib" "" nil)
+ (autoload 'ti::vc-rcs-rlog-get-revisions "tinylib" "" nil) ;;defsubst
+ (autoload 'ti::vc-rcs-all-versions "tinylib" "" nil) ;;defsubst
+ (autoload 'ti::vc-rcs-previous-version "tinylib" "" nil)
+ (autoload 'ti::vc-rcs-get-all-branches "tinylib" "" nil)
+ (autoload 'ti::vc-version-string-p "tinylib" "" nil)
+ (autoload 'ti::vc-version-simple-p "tinylib" "" nil)
+ (autoload 'ti::vc-version-lessp "tinylib" "" nil)
+ (autoload 'ti::vc-rcs-str-find "tinylib" "" nil)
+ (autoload 'ti::vc-rcs-str-find-buffer "tinylib" "" nil) ;;defsubst
+ (autoload 'ti::date-standard-rfc-regexp "tinylib" "" nil)
+ (autoload 'ti::date-standard-date "tinylib" "" t)
+ (autoload 'ti::date-month-to-number "tinylib" "" t)
+ (autoload 'ti::date-time-difference "tinylib" "" nil)
+ (autoload 'ti::date-time-diff-days "tinylib" "" nil)
+ (autoload 'ti::date-parse-date "tinylib" "" nil)
+ (autoload 'ti::string-repeat "tinylib" "" nil)
+ (autoload 'ti::string-syntax-info "tinylib" "" t)
+ (autoload 'ti::string-syntax-kill-double-quote "tinylib" "" t)
+ (autoload 'ti::string-tabify "tinylib" "" nil)
+ (autoload 'ti::string-match-string-subs "tinylib" "" nil)
+ (autoload 'ti::string-match-string-list "tinylib" "" nil)
+ (autoload 'ti::string-case-replace "tinylib" "" nil)
+ (autoload 'ti::string-index "tinylib" "" nil)
+ (autoload 'ti::string-index-substring "tinylib" "" nil)
+ (autoload 'ti::string-replace-one-space "tinylib" "" nil)
+ (autoload 'ti::string-listify "tinylib" "" nil)
+ (autoload 'ti::dired-buffer "tinylib" "" nil)
+ (autoload 'ti::buffer-get-ange-buffer-list "tinylib" "" nil) ;;defsubst
+ (autoload 'ti::buffer-find-ange-buffer "tinylib" "" nil)
+ (autoload 'ti::buffer-find-ange-to-dired-buffer "tinylib" "" nil)
+ (autoload 'ti::buffer-uu-area "tinylib" "" nil)
+ (autoload 'ti::buffer-uu-line-p "tinylib" "" t)
+ (autoload 'ti::buffer-area-bounds "tinylib" "" nil)
+ (autoload 'ti::buffer-parse-grep-line "tinylib" "" nil)
+ (autoload 'ti::buffer-parse-grep-line2 "tinylib" "" nil)
+ (autoload 'ti::buffer-parse-line-main "tinylib" "" nil)
+ (autoload 'ti::buffer-join-region "tinylib" "" t)
+ (autoload 'ti::buffer-read-if-solid "tinylib" "" nil)
+ (autoload 'ti::buffer-read-whitespace "tinylib" "" nil)
+ (autoload 'ti::buffer-read-line "tinylib" "" nil)
+ (autoload 'ti::buffer-grep-lines "tinylib" "" nil)
+ (autoload 'ti::buffer-looking-back-at "tinylib" "" nil)
+ (autoload 'ti::buffer-read-char "tinylib" "" nil)
+ (autoload 'ti::buffer-read-word "tinylib" "" nil)
+ (autoload 'ti::buffer-read-space-word "tinylib" "" nil)
+ (autoload 'ti::buffer-read-syntax-word "tinylib" "" nil)
+ (autoload 'ti::buffer-read-nth-word "tinylib" "" nil)
+ (autoload 'ti::buffer-replace-keywords-with-table "tinylib" "" t)
+ (autoload 'ti::buffer-replace-region-with "tinylib" "" nil) ;;defsubst
+ (autoload 'ti::buffer-zap-to-regexp "tinylib" "" t)
+ (autoload 'ti::buffer-leave-nth-word "tinylib" "" t)
+ (autoload 'ti::buffer-kill-line "tinylib" "" t)
+ (autoload 'ti::buffer-strip-control-m "tinylib" "" nil)
+ (autoload 'ti::buffer-lf-to-crlf "tinylib" "" t)
+ (autoload 'ti::buffer-arrow-control "tinylib" "" nil)
+ (autoload 'ti::buffer-insert-line-numbers "tinylib" "" t)
+ (autoload 'ti::buffer-remove-line-numbers "tinylib" "" t) ;;defsubst
+ (autoload 'ti::buffer-randomize-lines "tinylib" "" t)
+ (autoload 'ti::buffer-make-dup-line "tinylib" "" t)
+ (autoload 'ti::buffer-inc-string-nbr "tinylib" "" t)
+ (autoload 'ti::buffer-copy-line-and-inc-numbers "tinylib" "" t)
+ (autoload 'ti::buffer-copy-word "tinylib" "" t)
+ (autoload 'ti::buffer-add-newlines-to-region "tinylib" "" t)
+ (autoload 'ti::buffer-cnv-empty-lines "tinylib" "" t)
+ (autoload 'ti::buffer-del-dup-lines "tinylib" "" t)
+ (autoload 'ti::buffer-delete-until-non-empty-line "tinylib" "" t)
+ (autoload 'ti::buffer-trim-blanks "tinylib" "" t)
+ (autoload 'ti::buffer-replace-regexp "tinylib" "" nil)
+ (autoload 'ti::buffer-diff-type-p "tinylib" "" nil)
+ (autoload 'ti::buffer-outline-widen "tinylib" "" t)
+ (autoload 'ti::buffer-buffer-list-files "tinylib" "" nil)
+ (autoload 'ti::buffer-count-words "tinylib" "" t)
+ (autoload 'ti::buffer-count-chars-in-delimited-area "tinylib" "" t)
+ (autoload 'ti::buffer-word-move "tinylib" "" t)
+ (autoload 'ti::buffer-find-duplicate-same-word "tinylib" "" t)
+ (autoload 'ti::buffer-move-paragraph-to-column "tinylib" "" t)
+ (autoload 'ti::buffer-move-to-col "tinylib" "" t) ;;defsubst
+ (autoload 'ti::buffer-selective-display-copy-to "tinylib" "" t)
+ (autoload 'ti::buffer-selective-display-print "tinylib" "" t)
+ (autoload 'ti::window-frame-list "tinylib" "" nil)
+ (autoload 'ti::window-list "tinylib" "" nil)
+ (autoload 'ti::window-single-p "tinylib" "" nil) ;;defsubst
+ (autoload 'ti::window-get-buffer-window-other-frame "tinylib" "" nil)
+ (autoload 'ti::window-find-bottom "tinylib" "" nil)
+ (autoload 'ti::window-match-buffers "tinylib" "" nil)
+ (autoload 'ti::keymap-single-key-definition-p "tinylib" "" nil)
+ (autoload 'ti::keymap-define-key-backspace "tinylib" "" t)
+ (autoload 'ti::keymap-function-bind-info "tinylib" "" nil)
+ (autoload 'ti::keymap-reinstall-minor-mode "tinylib" "" nil)
+ (autoload 'ti::keymap-add-minor-mode "tinylib" "" nil)
+ (autoload 'ti::keymap-bind-control "tinylib" "" nil)
+ (autoload 'ti::keymap-translate-table "tinylib" "" nil)
+ (autoload 'ti::keymap-put-abc-map "tinylib" "" nil)
+ (autoload 'ti::keymap-put-map "tinylib" "" nil)
+ (autoload 'ti::keymap-mapkeys "tinylib" "" nil)
+ (autoload 'ti::buffer-text-properties-wipe "tinylib" "" t)
+ (autoload 'ti::set-face-try-list "tinylib" "" nil)
+ (autoload 'ti::buffer-forward-line "tinylib" "" t) ;;defsubst
+ (autoload 'ti::buffer-surround-with-char "tinylib" "" t)
+ (autoload 'ti::buffer-fill-region-spaces "tinylib" "" t)
+ (autoload 'ti::buffer-quote-words-in-region "tinylib" "" t)
+ (autoload 'ti::buffer-find-longer-line "tinylib" "" nil)
+ (autoload 'ti::buffer-scramble-region "tinylib" "" t)
+ (autoload 'ti::buffer-add-string-region "tinylib" "" t)
+ (autoload 'ti::buffer-sort-regexp-fields "tinylib" "" nil)
+ (autoload 'ti::file-passwd-grep-user-alist "tinylib" "" nil)
+ (autoload 'ti::file-passwd-build-alist "tinylib" "" nil)
+ (autoload 'ti::file-passwd-read-entry "tinylib" "" nil)
+ (autoload 'ti::buffer-defun-function-name "tinylib" "" nil)
+ (autoload 'ti::file-days-old "tinylib" "" nil) ;;defsubst
+ (autoload 'ti::file-touch "tinylib" "" nil)
+ (autoload 'ti::file-ange-completed-message "tinylib" "" nil)
+ (autoload 'ti::file-ange-status "tinylib" "" nil)
+ (autoload 'ti::file-ange-download-file "tinylib" "" nil)
+ (autoload 'ti::file-ange-file-handle "tinylib" "" nil)
+ (autoload 'ti::file-chmod-w-toggle "tinylib" "" nil)
+ (autoload 'ti::file-chmod-make-writable "tinylib" "" nil)
+ (autoload 'ti::file-chmod-make-read-only "tinylib" "" nil)
+ (autoload 'ti::file-find-shadows "tinylib" "" t)
+ (autoload 'ti::directory-part-last "tinylib" "" nil)
+ (autoload 'ti::directory-unique-roots "tinylib" "" nil)
+ (autoload 'ti::directory-subdirectory-list "tinylib" "" nil)
+ (autoload 'ti::directory-recursive-do "tinylib" "" nil)
+ (autoload 'ti::directory-up "tinylib" "" nil)
+ (autoload 'ti::directory-subdirs "tinylib" "" nil)
+ (autoload 'ti::directory-unix-man-path-root "tinylib" "" nil)
+ (autoload 'ti::directory-files "tinylib" "" nil)
+ (autoload 'ti::file-files-only "tinylib" "" nil)
+ (autoload 'ti::file-newer-exist "tinylib" "" nil)
+ (autoload 'ti::file-get-extension "tinylib" "" nil)
+ (autoload 'ti::file-path-and-line-info "tinylib" "" nil)
+ (autoload 'ti::file-path-to-unix "tinylib" "" nil)
+ (autoload 'ti::file-path-to-msdos "tinylib" "" nil)
+ (autoload 'ti::file-make-path "tinylib" "" nil)
+ (autoload 'ti::file-get-load-path "tinylib" "" t)
+ (autoload 'ti::file-user-home "tinylib" "" nil)
+ (autoload 'ti::file-file-list "tinylib" "" nil)
+ (autoload 'ti::file-complete-file-name "tinylib" "" nil)
+ (autoload 'ti::file-complete-file-name-word "tinylib" "" t)
+ (autoload 'ti::file-complete-filename-minibuffer-macro "tinylib" "" t 'macro)
+ (autoload 'ti::file-read-file-list "tinylib" "" nil)
+ (autoload 'ti::process-finger-error "tinylib" "" nil)
+ (autoload 'ti::process-finger "tinylib" "" t)
+ (autoload 'ti::process-http-request "tinylib" "" t)
+ (autoload 'ti::process-uname "tinylib" "" nil)
+ (autoload 'ti::process-zip "tinylib" "" t)
+ (autoload 'ti::process-zip-view-command "tinylib" "" t)
+ (autoload 'ti::process-tar-zip-view-maybe-command "tinylib" "" nil)
+ (autoload 'ti::process-perl-process-environment-macro "tinylib" "" nil 'macro)
+ (autoload 'ti::process-perl-version "tinylib" "" nil)
+ (autoload 'ti::process-java-version "tinylib" "" nil)
+ (autoload 'ti::process-tar-view-command "tinylib" "" t)
+ (autoload 'ti::process-tar-read-listing-forward "tinylib" "" nil)
+ (autoload 'ti::query-read-input-invisible "tinylib" "" nil)
+ (autoload 'ti::query-read-input-as-password "tinylib" "" nil)
+ (autoload 'ti::advice-control "tinylib" "" nil)
+ (autoload 'ti::package-submit-feedback "tinylib" "" t)
+ (autoload 'ti::package-submit-bug-report "tinylib" "" t)
+ (autoload 'ti::package-version-info "tinylib" "" t)
+ (autoload 'ti::package-get-header "tinylib" "" nil)
+ (autoload 'ti::package-install-example "tinylib" "" t)
+ (autoload 'ti::package-rip "tinylib" "" t)
+ (autoload 'ti::package-rip-magic "tinylib" "" t)
+ (autoload 'ti::package-make-mode-magic "tinylib" "" t)
+ (autoload 'ti::package-make-mode "tinylib" "" t)
+ (autoload 'ti::package-make-var "tinylib" "" nil)
+ (autoload 'ti::package-make "tinylib" "" nil)
+ (autoload 'ti::package-autoload-create-on-file "tinylib" "" t)
+ (autoload 'ti::package-autoload-create-on-directory "tinylib" "" nil)
+ (autoload 'ti::package-autoload-loaddefs-create-maybe "tinylib" "" nil)
+ (autoload 'ti::package-autoload-loaddefs-dir-files "tinylib" "" nil)
+ (autoload 'ti::package-autoload-loaddefs-build-dir-1 "tinylib" "" nil)
+ (autoload 'ti::package-autoload-loaddefs-build-dir "tinylib" "" nil)
+ (autoload 'ti::package-autoload-directories "tinylib" "" nil)
+ (autoload 'ti::package-autoload-loaddefs-build-recursive "tinylib" "" t)
+ (autoload 'ti::package-install-pgp-tar "tinylib" "" t)
+ (autoload 'ti::compat-installation-root "tinylib" "" nil)
+ (autoload 'ti::compat-overlay-some "tinylib" "" nil)
+ (autoload 'ti::compat-overlay-properties "tinylib" "" nil)
+ (autoload 'ti::compat-overlays-at "tinylib" "" nil)
+ (autoload 'ti::compat-overlay-put "tinylib" "" nil)
+ (autoload 'ti::compat-overlay-move "tinylib" "" nil)
+ (autoload 'ti::compat-activate-region "tinylib" "" nil)
+ (autoload 'ti::compat-read-password "tinylib" "" nil)
+ (autoload 'ti::compat-key-local-map "tinylib" "" nil)
+ (autoload 'ti::compat-key-call-original "tinylib" "" nil)
+ (autoload 'ti::compat-mouse-position-coordinates "tinylib" "" nil)
+ (autoload 'ti::compat-mouse-key "tinylib" "" nil)
+ (autoload 'ti::compat-mouse-call-original-function "tinylib" "" nil)
+ (autoload 'ti::compat-mouse-call-original "tinylib" "" t)
+ (autoload 'ti::compat-popup "tinylib" "" t)
+ (autoload 'ti::compat-display-depth "tinylib" "" nil)
+ (autoload 'ti::compat-read-event "tinylib" "" nil)
+ (autoload 'ti::compat-executing-macro "tinylib" "" nil)
+ (autoload 'ti::compat-make-x-popup-event "tinylib" "" nil)
+ (autoload 'ti::compat-make-fake-event "tinylib" "" nil)
+ (autoload 'ti::compat-modeline-update "tinylib" "" nil)
+ (autoload 'ti::compat-set-frame-parameter "tinylib" "" t)
+ (autoload 'ti::compat-set-frame-name "tinylib" "" nil)
+ (autoload 'ti::compat-frame-window-config "tinylib" "" nil)
+ (autoload 'ti::compat-window-system "tinylib" "" nil)
+ (autoload 'ti::compat-timer-list-control "tinylib" "" nil)
+ (autoload 'ti::compat-timer-control "tinylib" "" nil)
+ (autoload 'ti::compat-timer-elt "tinylib" "" nil)
+ (autoload 'ti::compat-timer-process-status "tinylib" "" nil)
+ (autoload 'ti::compat-timer-cancel "tinylib" "" nil)
+ (autoload 'ti::compat-timer-cancel-function "tinylib" "" nil)
+ (autoload 'ti::compat-set-mode-line-format "tinylib" "" nil)
+ (autoload 'ti::macrov-minor-mode "tinylib" "" nil 'macro)
+ (autoload 'ti::macrov-minor-mode-1 "tinylib" "" nil)
+ (autoload 'ti::macrof-minor-mode "tinylib" "" nil 'macro)
+ (autoload 'ti::macrof-minor-mode-1 "tinylib" "" t)
+ (autoload 'ti::macrof-minor-mode-on "tinylib" "" t)
+ (autoload 'ti::macrof-minor-mode-off "tinylib" "" t)
+ (autoload 'ti::macrof-minor-mode-help "tinylib" "" t)
+ (autoload 'ti::macrof-minor-mode-commentary "tinylib" "" t)
+ (autoload 'ti::macrof-minor-mode-viper-attach "tinylib" "" t)
+ (autoload 'ti::macrof-minor-mode-install "tinylib" "" nil 'macro)
+ (autoload 'ti::macrof-minor-mode-install-1 "tinylib" "" t)
+ (autoload 'ti::macrof-define-keys "tinylib" "" nil 'macro)
+ (autoload 'ti::macrov-mode-line-mode-menu "tinylib" "" nil 'macro)
+ (autoload 'ti::macrof-define-keys-1 "tinylib" "" nil)
+ (autoload 'ti::macrof-version-bug-report-1 "tinylib" "" t)
+ (autoload 'ti::macrof-version-bug-report "tinylib" "" nil 'macro)
+ (autoload 'ti::macrof-debug-1 "tinylib" "" t)
+ (autoload 'ti::macrof-debug-lowlevel "tinylib" "" nil 'macro)
+ (autoload 'ti::macrof-debug-standard "tinylib" "" nil 'macro)
+ (autoload 'ti::macrof-install-pgp-tar-1 "tinylib" "" t)
+ (autoload 'ti::macrof-install-pgp-tar "tinylib" "" nil 'macro)
+ (autoload 'ti::macrof-minor-mode-wizard "tinylib" "" nil 'macro)
+ (autoload 'ti::macrof-minor-mode-wizard-1 "tinylib" "" nil)
+
+ ;;}}}
+ ;;{{{ code: Autoload 'mt' lib -- mail tools
+
+ (autoload 'ti::mail-pgp-signature-begin-line "tinylibmail" "" nil) ;;defsubst
+ (autoload 'ti::mail-pgp-signature-end-line "tinylibmail" "" nil) ;;defsubst
+ (autoload 'ti::mail-pgp-signed-begin-line "tinylibmail" "" nil) ;;defsubst
+ (autoload 'ti::mail-pgp-signed-end-line "tinylibmail" "" nil) ;;defsubst
+ (autoload 'ti::mail-pgp-pkey-begin-line "tinylibmail" "" nil) ;;defsubst
+ (autoload 'ti::mail-pgp-pkey-end-line "tinylibmail" "" nil) ;;defsubst
+ (autoload 'ti::mail-pgp-msg-begin-line "tinylibmail" "" nil) ;;defsubst
+ (autoload 'ti::mail-pgp-msg-end-line "tinylibmail" "" nil) ;;defsubst
+ (autoload 'ti::mail-pgp-any-pgp-line-regexp "tinylibmail" "" nil) ;;defsubst
+ (autoload 'ti::mail-ip-raw-p "tinylibmail" "" nil) ;;defsubst
+ (autoload 'ti::mail-ip-top-level-domain "tinylibmail" "" nil) ;;defsubst
+ (autoload 'ti::mail-ip-3-level-domain "tinylibmail" "" nil) ;;defsubst
+ (autoload 'ti::mail-ip-cleanup "tinylibmail" "" nil) ;;defsubst
+ (autoload 'ti::mail-ip-at-point-1 "tinylibmail" "" nil)
+ (autoload 'ti::mail-ip-at-point "tinylibmail" "" nil)
+ (autoload 'ti::mail-news-group "tinylibmail" "" nil) ;;defsubst
+ (autoload 'tinylibmail-version "tinylibmail" "" t)
+ (autoload 'tinylibmail-submit-feedback "tinylibmail" "" t)
+ (autoload 'ti::mail-signature-p "tinylibmail" "" nil)
+ (autoload 'ti::mail-body-empty-p "tinylibmail" "" nil)
+ (autoload 'ti::mail-body-clear "tinylibmail" "" nil)
+ (autoload 'ti::mail-set-region "tinylibmail" "" nil 'macro)
+ (autoload 'ti::mail-point-in-header-macro "tinylibmail" "" nil 'macro)
+ (autoload 'ti::mail-message-length "tinylibmail" "" nil)
+ (autoload 'ti::mail-get-2re "tinylibmail" "" nil)
+ (autoload 'ti::mail-required-headers "tinylibmail" "" nil)
+ (autoload 'ti::mail-mail-mode-p "tinylibmail" "" nil)
+ (autoload 'ti::mail-mailbox-p "tinylibmail" "" nil)
+ (autoload 'ti::mail-mail-p "tinylibmail" "" nil)
+ (autoload 'ti::mail-header-area-size "tinylibmail" "" nil)
+ (autoload 'ti::mail-hmax "tinylibmail" "" nil)
+ (autoload 'ti::mail-text-start "tinylibmail" "" nil)
+ (autoload 'ti::mail-point-at-header-p "tinylibmail" "" nil)
+ (autoload 'ti::mail-point-at-body-p "tinylibmail" "" nil)
+ (autoload 'ti::mail-narrow "tinylibmail" "" nil)
+ (autoload 'ti::mail-mail-buffer-name "tinylibmail" "" nil)
+ (autoload 'ti::mail-generate-buffer-name "tinylibmail" "" t)
+ (autoload 'ti::mail-mail-simple-p "tinylibmail" "" nil)
+ (autoload 'ti::mail-to-list-p "tinylibmail" "" nil)
+ (autoload 'ti::mail-vm-macro "tinylibmail" "" nil 'macro)
+ (autoload 'ti::mail-mh-macro "tinylibmail" "" nil 'macro)
+ (autoload 'ti::mail-gnus-macro "tinylibmail" "" nil 'macro)
+ (autoload 'ti::mail-rmail-macro "tinylibmail" "" nil 'macro)
+ (autoload 'ti::mail-rmail-do-message-macro "tinylibmail" "" nil 'macro)
+ (autoload 'ti::mail-rmail-copy-message "tinylibmail" "" t)
+ (autoload 'ti::mail-pgp-v3xx-p "tinylibmail" "" nil)
+ (autoload 'ti::mail-pgp-p "tinylibmail" "" nil)
+ (autoload 'ti::mail-pgp-signed-conventional-p "tinylibmail" "" nil)
+ (autoload 'ti::mail-pgp-signature-detached-p "tinylibmail" "" nil)
+ (autoload 'ti::mail-pgp-signed-conventional-multi-p "tinylibmail" "" nil)
+ (autoload 'ti::mail-pgp-signed-xpgp-p "tinylibmail" "" nil)
+ (autoload 'ti::mail-pgp-signed-p "tinylibmail" "" nil)
+ (autoload 'ti::mail-pgp-public-key-p "tinylibmail" "" nil)
+ (autoload 'ti::mail-pgp-remail-p "tinylibmail" "" nil)
+ (autoload 'ti::mail-pgp-comment-file-p "tinylibmail" "" nil)
+ (autoload 'ti::mail-pgp-encrypted-p "tinylibmail" "" nil)
+ (autoload 'ti::mail-pgp-normal-p "tinylibmail" "" nil)
+ (autoload 'ti::mail-pgp-headers-p "tinylibmail" "" nil)
+ (autoload 'ti::mail-pgp-re "tinylibmail" "" nil)
+ (autoload 'ti::mail-pgp-block-area-kill-forward "tinylibmail" "" nil)
+ (autoload 'ti::mail-pgp-block-area "tinylibmail" "" nil)
+ (autoload 'ti::mail-pgp-re-search "tinylibmail" "" nil)
+ (autoload 'ti::mail-pgp-exe-version-string "tinylibmail" "" nil)
+ (autoload 'ti::mail-pgp-data-type "tinylibmail" "" nil)
+ (autoload 'ti::mail-pgp-trim-buffer "tinylibmail" "" nil)
+ (autoload 'ti::mail-pgp-chop-region "tinylibmail" "" nil)
+ (autoload 'ti::mail-pgp-header-kill-in-body "tinylibmail" "" nil)
+ (autoload 'ti::mail-pgp-data-char-to-int "tinylibmail" "" nil)
+ (autoload 'ti::mail-pgp-data-string-to-bin-string "tinylibmail" "" nil)
+ (autoload 'ti::mail-pgp-data-bin-string-to-int-list "tinylibmail" "" nil)
+ (autoload 'ti::mail-pgp-data-ascii-armor-convert "tinylibmail" "" nil) ;;defsubst
+ (autoload 'ti::mail-pgp-data-study-ctb-byte "tinylibmail" "" nil)
+ (autoload 'ti::mail-pgp-stream-study-1-ver "tinylibmail" "" nil) ;;defsubst
+ (autoload 'ti::mail-pgp-stream-study-1-key-id "tinylibmail" "" nil 'macro)
+ (autoload 'ti::mail-pgp-stream-study-1-time "tinylibmail" "" nil)
+ (autoload 'ti::mail-pgp-stream-study-enc "tinylibmail" "" nil)
+ (autoload 'ti::mail-pgp-stream-study-signed "tinylibmail" "" nil)
+ (autoload 'ti::mail-pgp-stream-study-pring "tinylibmail" "" nil)
+ (autoload 'ti::mail-pgp-stream-study "tinylibmail" "" nil)
+ (autoload 'ti::mail-pgp-stream-forward-xpgp "tinylibmail" "" nil)
+ (autoload 'ti::mail-pgp-stream-forward "tinylibmail" "" nil)
+ (autoload 'ti::mail-pgp-stream-forward-and-study "tinylibmail" "" t)
+ (autoload 'ti::mail-pgp-stream-forward-info "tinylibmail" "" nil)
+ (autoload 'ti::mail-pgp-stream-data-elt "tinylibmail" "" nil)
+ (autoload 'ti::mail-pgpk-id-lines-in-region "tinylibmail" "" nil)
+ (autoload 'ti::mail-pgpk-id-0x-lines-in-region "tinylibmail" "" nil)
+ (autoload 'ti::mail-pgpk-public-get-region "tinylibmail" "" nil)
+ (autoload 'ti::mail-pgp-signature-remove "tinylibmail" "" nil)
+ (autoload 'ti::mail-pgp-signature-normal-do-region "tinylibmail" "" nil 'macro)
+ (autoload 'ti::mail-get-article-buffer "tinylibmail" "" nil) ;;defsubst
+ (autoload 'ti::mail-with-article-buffer "tinylibmail" "" nil 'macro)
+ (autoload 'ti::mail-pgp-signature-normal-info "tinylibmail" "" nil)
+ (autoload 'ti::mail-pgp-sig-header-info-v2xx "tinylibmail" "" nil)
+ (autoload 'ti::mail-pgp-signature-header-info-v3xx "tinylibmail" "" nil)
+ (autoload 'ti::mail-pgp-signature-header-info "tinylibmail" "" nil)
+ (autoload 'ti::mail-mime-parse-header "tinylibmail" "" nil)
+ (autoload 'ti::mail-pgp-pkey-read "tinylibmail" "" nil)
+ (autoload 'ti::mail-pgpr-close "tinylibmail" "" nil)
+ (autoload 'ti::mail-pgpr-anonymize-headers "tinylibmail" "" nil)
+ (autoload 'ti::mail-pgpr-reply-type "tinylibmail" "" nil)
+ (autoload 'ti::mail-pgpr-block "tinylibmail" "" nil)
+ (autoload 'ti::mail-pgpr-reply-block "tinylibmail" "" nil)
+ (autoload 'ti::mail-pgpr-parse-levien-list "tinylibmail" "" nil)
+ (autoload 'ti::mail-email-make-anti-spam-address "tinylibmail" "" nil)
+ (autoload 'ti::mail-email-domain "tinylibmail" "" nil)
+ (autoload 'ti::mail-email-domain-canonilize "tinylibmail" "" nil)
+ (autoload 'ti::mail-email-find-region "tinylibmail" "" nil)
+ (autoload 'ti::mail-email-from-string "tinylibmail" "" nil)
+ (autoload 'ti::mail-test-parse-name "tinylibmail" "" nil)
+ (autoload 'ti::mail-parse-name "tinylibmail" "" nil)
+ (autoload 'ti::mail-parse-email "tinylibmail" "" nil)
+ (autoload 'ti::mail-parse-received-regexp-list "tinylibmail" "" nil)
+ (autoload 'ti::mail-parse-received-line "tinylibmail" "" nil)
+ (autoload 'ti::mail-parse-received-string-smtp "tinylibmail" "" nil)
+ (autoload 'ti::mail-parse-received-string-clean "tinylibmail" "" nil) ;;defsubst
+ (autoload 'ti::mail-parse-received-string-from "tinylibmail" "" nil) ;;defsubst
+ (autoload 'ti::mail-parse-received-string-by "tinylibmail" "" nil) ;;defsubst
+ (autoload 'ti::mail-parse-received-string-smtp-id "tinylibmail" "" nil) ;;defsubst
+ (autoload 'ti::mail-parse-received-string-for "tinylibmail" "" nil) ;;defsubst
+ (autoload 'ti::mail-parse-received-string-date "tinylibmail" "" nil) ;;defsubst
+ (autoload 'ti::mail-parse-date-string "tinylibmail" "" nil)
+ (autoload 'ti::mail-parse-date-string-iso8601 "tinylibmail" "" t)
+ (autoload 'ti::mail-parse-received-string "tinylibmail" "" nil)
+ (autoload 'ti::mail-parse-received "tinylibmail" "" nil)
+ (autoload 'ti::with-mail-received-header "tinylibmail" "" nil 'macro)
+ (autoload 'ti::mail-whois-parse-cleanup "tinylibmail" "" nil)
+ (autoload 'ti::mail-whois-parse-paragraph "tinylibmail" "" nil)
+ (autoload 'ti::mail-whois-parse-referral "tinylibmail" "" nil)
+ (autoload 'ti::mail-whois-parse-email "tinylibmail" "" nil)
+ (autoload 'ti::mail-whois-parse-paragraph-end-condition "tinylibmail" "" nil) ;;defsubst
+ (autoload 'ti::mail-whois-parse-registrant-1 "tinylibmail" "" nil)
+ (autoload 'ti::mail-whois-parse-registrant-organization "tinylibmail" "" nil)
+ (autoload 'ti::mail-whois-parse-registrant-organization-2 "tinylibmail" "" nil)
+ (autoload 'ti::mail-whois-parse-registrant-domain "tinylibmail" "" nil)
+ (autoload 'ti::mail-whois-parse-registrant "tinylibmail" "" nil)
+ (autoload 'ti::mail-whois-parse-tech "tinylibmail" "" nil)
+ (autoload 'ti::mail-whois-parse-zone "tinylibmail" "" nil)
+ (autoload 'ti::mail-whois-parse-records "tinylibmail" "" nil)
+ (autoload 'ti::mail-whois-parse-servers "tinylibmail" "" nil)
+ (autoload 'ti::mail-whois-parse-admin "tinylibmail" "" nil)
+ (autoload 'ti::mail-whois-error-p "tinylibmail" "" nil)
+ (autoload 'ti::mail-whois-parse "tinylibmail" "" nil)
+ (autoload 'ti::with-mail-whois "tinylibmail" "" nil 'macro)
+ (autoload 'ti::mail-whois "tinylibmail" "" nil)
+ (autoload 'ti::mail-nslookup-parse "tinylibmail" "" nil)
+ (autoload 'ti::mail-nslookup "tinylibmail" "" nil)
+ (autoload 'ti::with-mail-nslookup "tinylibmail" "" nil 'macro)
+ (autoload 'ti::mail-dig "tinylibmail" "" nil)
+ (autoload 'ti::mail-get-buffer "tinylibmail" "" nil)
+ (autoload 'ti::mail-signature-insert-break "tinylibmail" "" nil)
+ (autoload 'ti::mail-yank "tinylibmail" "" nil)
+ (autoload 'ti::mail-trim-buffer "tinylibmail" "" nil)
+ (autoload 'ti::mail-field-space-count "tinylibmail" "" nil) ;;defsubst
+ (autoload 'ti::mail-field-start "tinylibmail" "" nil)
+ (autoload 'ti::mail-next-field-start "tinylibmail" "" nil)
+ (autoload 'ti::mail-field-string-wrap "tinylibmail" "" nil) ;;defsubst
+ (autoload 'ti::mail-field-string-p "tinylibmail" "" nil) ;;defsubst
+ (autoload 'ti::mail-field-line-p "tinylibmail" "" nil)
+ (autoload 'ti::mail-field-read-line-at-point "tinylibmail" "" nil)
+ (autoload 'ti::mail-field-read-fuzzy "tinylibmail" "" nil)
+ (autoload 'ti::mail-current-field-name "tinylibmail" "" nil)
+ (autoload 'ti::mail-field-email-send-p "tinylibmail" "" nil)
+ (autoload 'ti::mail-field-email-address-p "tinylibmail" "" nil)
+ (autoload 'ti::mail-kill-field-in-body "tinylibmail" "" nil)
+ (autoload 'ti::mail-kill-field "tinylibmail" "" nil)
+ (autoload 'ti::mail-get-field-1 "tinylibmail" "" nil)
+ (autoload 'ti::mail-get-field "tinylibmail" "" nil)
+ (autoload 'ti::mail-add-field "tinylibmail" "" nil)
+ (autoload 'ti::mail-add-to-field-string "tinylibmail" "" nil)
+ (autoload 'ti::mail-kill-field-elt "tinylibmail" "" nil)
+ (autoload 'ti::mail-kill-non-rfc-fields "tinylibmail" "" nil)
+ (autoload 'ti::mail-get-all-email-addresses "tinylibmail" "" nil)
+ (autoload 'ti::mail-set-recipients "tinylibmail" "" nil)
+ (autoload 'ti::mail-news-buffer-p "tinylibmail" "" t)
+ (autoload 'ti::mail-article-regexp-read-line "tinylibmail" "" nil)
+ (autoload 'ti::mail-news-reply-p "tinylibmail" "" nil)
+ (autoload 'ti::mail-anon-penet-p "tinylibmail" "" nil)
+ (autoload 'ti::mail-anon-penet-to-p "tinylibmail" "" nil)
+ (autoload 'ti::mail-nymserver-email-convert "tinylibmail" "" nil)
+ (autoload 'ti::mail-mime-tm-featurep-p "tinylibmail" "" nil) ;;defsubst
+ (autoload 'ti::mail-mime-semi-featurep-p "tinylibmail" "" nil) ;;defsubst
+ (autoload 'ti::mail-mime-feature-p "tinylibmail" "" nil) ;;defsubst
+ (autoload 'ti::mail-mime-tm-edit-p "tinylibmail" "" nil) ;;defsubst
+ (autoload 'ti::mail-mime-semi-edit-p "tinylibmail" "" nil) ;;defsubst
+ (autoload 'ti::mail-mime-tm-edit-mode-macro "tinylibmail" "" nil 'macro)
+ (autoload 'ti::mail-mime-semi-edit-mode-macro "tinylibmail" "" nil 'macro)
+ (autoload 'ti::mail-mime-funcall-0-macro "tinylibmail" "" nil 'macro)
+ (autoload 'ti::mail-mime-funcall-2-macro "tinylibmail" "" nil 'macro)
+ (autoload 'ti::mail-mime-turn-on-mode "tinylibmail" "" t)
+ (autoload 'ti::mail-mime-turn-off-mode "tinylibmail" "" t)
+ (autoload 'ti::mail-mime-sign-region "tinylibmail" "" t)
+ (autoload 'ti::mail-mime-encrypt-region "tinylibmail" "" t)
+ (autoload 'ti::mail-mime-tm-split-macro "tinylibmail" "" nil 'macro)
+ (autoload 'ti::mail-mime-maybe-p "tinylibmail" "" nil)
+ (autoload 'ti::mail-mime-p "tinylibmail" "" t)
+ (autoload 'ti::mail-mime-qp-decode "tinylibmail" "" nil)
+ (autoload 'ti::mail-qp-mime-prepare "tinylibmail" "" t)
+ (autoload 'ti::mail-plugged-p "tinylibmail" "" nil)
+ (autoload 'ti::mail-sendmail-reset-send-hooks "tinylibmail" "" nil)
+ (autoload 'ti::mail-sendmail-pure-env-macro "tinylibmail" "" nil 'macro)
+ (autoload 'ti::mail-sendmail-macro-1 "tinylibmail" "" nil 'macro)
+ (autoload 'ti::mail-sendmail-macro "tinylibmail" "" nil 'macro)
+ (autoload 'ti::mail-abbrev-table "tinylibmail" "" nil)
+ (autoload 'ti::mail-abbrev-expand-mail-aliases "tinylibmail" "" t)
+ (autoload 'ti::mail-abbrev-get-alist "tinylibmail" "" nil)
+ (autoload 'ti::mail-mail-abbrevs-email-list "tinylibmail" "" nil)
+
+ ;;}}}
+ ;;{{{ code: Autoload 'y' lib -- system
+
+ (autoload 'tinyliby-version "tinyliby" "" t)
+ (autoload 'tinyliby-submit-feedback "tinyliby" "" t)
+ (autoload 'ti::system-package-where-is-source "tinyliby" "" nil)
+ (autoload 'ti::system-load-cleanup "tinyliby" "" nil)
+ (autoload 'ti::system-load-history-emacs-lisp-files "tinyliby" "" nil)
+ (autoload 'ti::system-load-history-where-exactly "tinyliby" "" nil)
+ (autoload 'ti::system-load-history-where-1 "tinyliby" "" nil)
+ (autoload 'ti::system-doc-where-is-source "tinyliby" "" nil)
+ (autoload 'ti::system-load-history-where-is-source "tinyliby" "" nil)
+ (autoload 'ti::system-load-history-get "tinyliby" "" nil)
+ (autoload 'ti::system-enable-disabled-options "tinyliby" "" t)
+ (autoload 'ti::system-feature-kill "tinyliby" "" nil)
+ (autoload 'ti::system-unload-symbols "tinyliby" "" nil)
+ (autoload 'ti::system-unload "tinyliby" "" nil)
+ (autoload 'ti::system-unload-feature "tinyliby" "" t)
+ (autoload 'ti::system-unload-feature-list "tinyliby" "" nil)
+ (autoload 'ti::system-symbol-dolist-macro "tinyliby" "" nil 'macro)
+ (autoload 'ti::system-remove-from-hooks "tinyliby" "" nil)
+ (autoload 'ti::system-match-in-hooks "tinyliby" "" t)
+ (autoload 'ti::system-get-symbols "tinyliby" "" nil)
+ (autoload 'ti::system-autoload-function-list "tinyliby" "" nil)
+ (autoload 'ti::system-autoload-function-file-list "tinyliby" "" nil)
+ (autoload 'ti::system-get-file-documentation "tinyliby" "" t)
+ (autoload 'ti::system-describe-symbols-i-args "tinyliby" "" nil)
+ (autoload 'ti::system-describe-symbols "tinyliby" "" t)
+ (autoload 'ti::system-describe-symbol-summary "tinyliby" "" t)
+
+ ;;}}}
+ ;;{{{ code: Autoload 'o' lib -- overlays
+
+ (autoload 'tinylibo-version "tinylibo" "" t)
+ (autoload 'tinylibo-feedback "tinylibo" "" t)
+ (autoload 'ti::overlay-make "tinylibo" "" nil) ;;defsubst
+ (autoload 'ti::overlay-makec "tinylibo" "" nil) ;;defsubst
+ (autoload 'ti::overlay-make-match "tinylibo" "" nil)
+ (autoload 'ti::overlay-buffer-substring "tinylibo" "" nil) ;;defsubst
+ (autoload 'ti::overlay-mouse-on-p "tinylibo" "" nil)
+ (autoload 'ti::overlay-get-mouse "tinylibo" "" nil)
+ (autoload 'ti::overlay-get-prop "tinylibo" "" nil)
+ (autoload 'ti::overlay-get-prop-val "tinylibo" "" nil)
+ (autoload 'ti::overlay-re-search "tinylibo" "" nil)
+ (autoload 'ti::overlay-re-search-move "tinylibo" "" nil)
+ (autoload 'ti::overlay-get-within-area "tinylibo" "" nil)
+ (autoload 'ti::overlay-remove-region "tinylibo" "" t)
+
+ ;;}}}
+ ;;{{{ code: Autoload Text property library
+
+ (autoload 'ti::text-search-face-reset "tinylibt" "" nil 'macro)
+ (autoload 'ti::text-search-face-set "tinylibt" "" nil 'macro)
+ (autoload 'ti::text-face "tinylibt" "" nil 'macro)
+ (autoload 'ti::text-stack-clear "tinylibt" "" nil) ;;defsubst
+ (autoload 'ti::text-stack-length "tinylibt" "" nil) ;;defsubst
+ (autoload 'ti::text-stack-full-p "tinylibt" "" nil) ;;defsubst
+ (autoload 'ti::text-stack-p "tinylibt" "" nil) ;;defsubst
+ (autoload 'ti::text-save-data "tinylibt" "" nil)
+ (autoload 'ti::text-undo "tinylibt" "" t)
+ (autoload 'ti::text-clear-buffer-properties "tinylibt" "" t)
+ (autoload 'ti::text-clear-region-properties "tinylibt" "" t)
+ (autoload 'ti::text-get-mouse-property "tinylibt" "" nil)
+ (autoload 'ti::text-match-level "tinylibt" "" nil)
+ (autoload 'ti::text-re-search "tinylibt" "" t)
+ (autoload 'ti::text-property-search-and-modify "tinylibt" "" nil)
+ (autoload 'ti::text-read-regexp "tinylibt" "" nil)
+ (autoload 'ti::text-looking-at "tinylibt" "" t)
+ (autoload 'ti::text-buffer "tinylibt" "" t)
+ (autoload 'ti::text-re-search-forward "tinylibt" "" t)
+ (autoload 'ti::text-re-search-backward "tinylibt" "" t)
+ (autoload 'ti::text-mouse-mark-region "tinylibt" "" t)
+ (autoload 'ti::text-mouse-unmark-region "tinylibt" "" t)
+ (autoload 'ti::text-unmark-region "tinylibt" "" t)
+ (autoload 'ti::text-mark-region "tinylibt" "" t)
+
+ ;;}}}
+
+ ;;{{{ code: Autoload other 'tiny tools'
+
+ (autoload 'ti::ck-advice-control "tinylibck")
+
+ (autoload 'ti::id-info "tinylibid")
+ (autoload 'ti::id-cnv-txt2comment "tinylibid")
+
+ (autoload 'ti::menu-help "tinylibmenu")
+ (autoload 'ti::menu-menu "tinylibmenu")
+
+ (autoload 'tinytab-mode "tinytab" "" t)
+ (autoload 'turn-on-tinytab-mode "tinytab" "" t)
+ (autoload 'turn-off-tinytab-mode "tinytab" "" t)
+ (autoload 'turn-on-tinytab-return-key-mode "tinytab" "" t)
+
+ (autoload 'turn-on-tinyurl-mode-maybe "tinyurl" "" nil)
+ (autoload 'turn-on-tinyurl-mode-mail "tinyurl" "" nil)
+ (autoload 'turn-on-tinyurl-mode-1 "tinyurl" "" t)
+ (autoload 'turn-off-tinyurl-mode-1 "tinyurl" "" t)
+ (autoload 'tinyurl-mode-1 "tinyurl" "" t)
+ (autoload 'turn-on-tinyurl-mode "tinyurl" "" t)
+ (autoload 'turn-off-tinyurl-mode "tinyurl" "" t)
+ (autoload 'tinyurl-mode "tinyurl" "" t)
+ (autoload 'tinyurl-mode-action "tinyurl" "" nil)
+ (autoload 'tinyurl-install "tinyurl" "" t)
+ (autoload 'tinyurl-mark-line "tinyurl")
+ (autoload 'tinyurl-overlay-get "tinyurl")
+ (autoload 'tinyurl-dispatcher "tinyurl")
+ (autoload 'tinyurl-agent-funcall "tinyurl")
+
+ ;;}}}
+ ;;{{{ code: autoload other
+
+ (autoload 'byte-compile "bytecomp")
+ (autoload 'occur "replace" "" t)
+
+ (autoload 'folding-open-buffer "folding" "" t)
+
+ (autoload 'mail-yank-original "sendmail")
+ (autoload 'mail-send-and-exit "sendmail")
+ (autoload 'mail-setup "sendmail")
+ (autoload 'mail-mode "sendmail")
+ (autoload 'mail-position-on-field "sendmail")
+
+ (autoload 'mail-fetch-field "mail-utils")
+
+ (autoload 'hexl-hex-string-to-integer "hexl")
+
+ (autoload 'browse-url "browse-url")
+ (autoload 'browse-url-w3 "browse-url")
+ (autoload 'browse-url-netscape "browse-url")
+ (autoload 'browse-url-lynx-emacs "browse-url")
+
+ (autoload 'display-time "time")
+ (autoload 'shuffle-vector "cookie1")
+ (autoload 'name-last-kbd-macro "macros")
+ (autoload 'mail-extract-address-components "mail-extr")
+
+ ;; This is special case. if there is Igrep package available, it
+ ;; will define autoload to "grep" and we must reflect the
+ ;; situation accordingly. See `igrep-insinuate'
+
+ (unless (fboundp 'grep)
+ (if (locate-library "igrep")
+ (autoload 'grep "igrep" "" t)
+ (autoload 'grep "grep" "" t)))
+
+ (autoload 'compile "compile" "" t)
+ (autoload 'compile-internal "compile")
+
+ ;; Emacs 20.6 sort.el
+
+ (autoload 'sort-subr "sort" "" nil)
+ (autoload 'sort-build-lists "sort" "" nil)
+ (autoload 'sort-reorder-buffer "sort" "" nil)
+ (autoload 'sort-lines "sort" "" t)
+ (autoload 'sort-paragraphs "sort" "" t)
+ (autoload 'sort-pages "sort" "" t)
+ (autoload 'sort-numeric-fields "sort" "" t)
+ (autoload 'sort-fields "sort" "" t)
+ (autoload 'sort-fields-1 "sort" "" nil)
+ (autoload 'sort-skip-fields "sort" "" nil)
+ (autoload 'sort-regexp-fields-next-record "sort" "" nil)
+ (autoload 'sort-regexp-fields "sort" "" t)
+ (autoload 'sort-columns "sort" "" t)
+ (autoload 'reverse-region "sort" "" t)
+
+ ;; tabify.el
+
+ (autoload 'tabify "tabify" "" t)
+ (autoload 'untabify "tabify" "" t)
+
+ ;; pp.el
+
+ (autoload 'pp-to-string "pp" "" nil)
+ (autoload 'pp "pp" "" nil)
+ (autoload 'pp-eval-expression "pp" "" t)
+ (autoload 'pp-eval-last-sexp "pp" "" t)
+
+ ;; thingatpt.el
+
+ (autoload 'forward-thing "thingatpt" "" nil)
+ (autoload 'bounds-of-thing-at-point "thingatpt" "" nil)
+ (autoload 'thing-at-point "thingatpt" "" nil)
+ (autoload 'beginning-of-thing "thingatpt" "" nil)
+ (autoload 'end-of-thing "thingatpt" "" nil)
+ (autoload 'in-string-p "thingatpt" "" nil)
+ (autoload 'end-of-sexp "thingatpt" "" nil)
+ (autoload 'forward-whitespace "thingatpt" "" t)
+ (autoload 'forward-symbol "thingatpt" "" t)
+ (autoload 'forward-same-syntax "thingatpt" "" t)
+ (autoload 'word-at-point "thingatpt" "" nil)
+ (autoload 'sentence-at-point "thingatpt" "" nil)
+ (autoload 'read-from-whole-string "thingatpt" "" nil)
+ (autoload 'form-at-point "thingatpt" "" nil)
+ (autoload 'sexp-at-point "thingatpt" "" nil)
+ (autoload 'symbol-at-point "thingatpt" "" nil)
+ (autoload 'number-at-point "thingatpt" "" nil)
+ (autoload 'list-at-point "thingatpt" "" nil)
+
+ ;; rect.el
+
+ (autoload 'operate-on-rectangle "rect" "" nil)
+ (autoload 'delete-rectangle-line "rect" "" nil)
+ (autoload 'delete-extract-rectangle-line "rect" "" nil)
+ (autoload 'extract-rectangle-line "rect" "" nil)
+ (autoload 'spaces-string "rect" "" nil)
+ (autoload 'delete-rectangle "rect" "" t)
+ (autoload 'delete-extract-rectangle "rect" "" nil)
+ (autoload 'extract-rectangle "rect" "" nil)
+ (autoload 'kill-rectangle "rect" "" t)
+ (autoload 'yank-rectangle "rect" "" t)
+ (autoload 'insert-rectangle "rect" "" nil)
+ (autoload 'open-rectangle "rect" "" t)
+ (autoload 'open-rectangle-line "rect" "" nil)
+ (autoload 'string-rectangle "rect" "" t)
+ (autoload 'string-rectangle-line "rect" "" nil)
+ (autoload 'clear-rectangle "rect" "" t)
+ (autoload 'clear-rectangle-line "rect" "" nil)
+
+ ;; jka-compr.el
+
+ (autoload 'jka-compr-info-regexp "jka-compr" "" nil)
+ (autoload 'jka-compr-info-compress-message "jka-compr" "" nil)
+ (autoload 'jka-compr-info-compress-program "jka-compr" "" nil)
+ (autoload 'jka-compr-info-compress-args "jka-compr" "" nil)
+ (autoload 'jka-compr-info-uncompress-message "jka-compr" "" nil)
+ (autoload 'jka-compr-info-uncompress-program "jka-compr" "" nil)
+ (autoload 'jka-compr-info-uncompress-args "jka-compr" "" nil)
+ (autoload 'jka-compr-info-can-append "jka-compr" "" nil)
+ (autoload 'jka-compr-info-strip-extension "jka-compr" "" nil)
+ (autoload 'jka-compr-get-compression-info "jka-compr" "" nil)
+ (autoload 'jka-compr-error "jka-compr" "" nil)
+ (autoload 'jka-compr-partial-uncompress "jka-compr" "" nil)
+ (autoload 'jka-compr-call-process "jka-compr" "" nil)
+ (autoload 'jka-compr-make-temp-name "jka-compr" "" nil)
+ (autoload 'jka-compr-delete-temp-file "jka-compr" "" nil)
+ (autoload 'jka-compr-write-region "jka-compr" "" nil)
+ (autoload 'jka-compr-insert-file-contents "jka-compr" "" nil)
+ (autoload 'jka-compr-file-local-copy "jka-compr" "" nil)
+ (autoload 'jka-compr-load "jka-compr" "" nil)
+ (autoload 'jka-compr-byte-compiler-base-file-name "jka-compr" "" nil)
+ (autoload 'jka-compr-handler "jka-compr" "" nil)
+ (autoload 'jka-compr-run-real-handler "jka-compr" "" nil)
+ (autoload 'toggle-auto-compression "jka-compr" "" t)
+ (autoload 'jka-compr-build-file-regexp "jka-compr" "" nil)
+ (autoload 'jka-compr-install "jka-compr" "" nil)
+ (autoload 'jka-compr-uninstall "jka-compr" "" nil)
+ (autoload 'jka-compr-installed-p "jka-compr" "" nil)
+
+ ;; Advice.el (partial autoloads only)
+
+ (autoload 'ad-disable-advice "advice")
+ (autoload 'ad-enable-advice "advice")
+ (autoload 'ad-activate "advice")
+
+ ;; finder.el
+
+ (autoload 'finder-compile-keywords "finder" "" nil)
+ (autoload 'finder-compile-keywords-make-dist "finder" "" nil)
+ (autoload 'finder-insert-at-column "finder" "" nil)
+ (autoload 'finder-mouse-face-on-line "finder" "" nil)
+ (autoload 'finder-list-keywords "finder" "" t)
+ (autoload 'finder-list-matches "finder" "" nil)
+ (autoload 'finder-find-library "finder" "" nil)
+ (autoload 'finder-commentary "finder" "" t)
+ (autoload 'finder-current-item "finder" "" nil)
+ (autoload 'finder-select "finder" "" t)
+ (autoload 'finder-mouse-select "finder" "" t)
+ (autoload 'finder-by-keyword "finder" "" t)
+ (autoload 'finder-mode "finder" "" t)
+ (autoload 'finder-summary "finder" "" t)
+ (autoload 'finder-exit "finder" "" t)
+
+ ;; lisp-mnt.el
+
+ (autoload 'lm-get-header-re "lisp-mnt" "" nil) ;;defsubst
+ (autoload 'lm-get-package-name "lisp-mnt" "" nil) ;;defsubst
+ (autoload 'lm-section-mark "lisp-mnt" "" nil)
+ (autoload 'lm-code-mark "lisp-mnt" "" nil) ;;defsubst
+ (autoload 'lm-commentary-mark "lisp-mnt" "" nil) ;;defsubst
+ (autoload 'lm-history-mark "lisp-mnt" "" nil) ;;defsubst
+ (autoload 'lm-header "lisp-mnt" "" nil)
+ (autoload 'lm-header-multiline "lisp-mnt" "" nil)
+ (autoload 'lm-summary "lisp-mnt" "" nil)
+ (autoload 'lm-crack-address "lisp-mnt" "" nil)
+ (autoload 'lm-authors "lisp-mnt" "" nil)
+ (autoload 'lm-maintainer "lisp-mnt" "" nil)
+ (autoload 'lm-creation-date "lisp-mnt" "" nil)
+ (autoload 'lm-last-modified-date "lisp-mnt" "" nil)
+ (autoload 'lm-version "lisp-mnt" "" nil)
+ (autoload 'lm-keywords "lisp-mnt" "" nil)
+ (autoload 'lm-adapted-by "lisp-mnt" "" nil)
+ (autoload 'lm-commentary "lisp-mnt" "" nil)
+ (autoload 'lm-insert-at-column "lisp-mnt" "" nil)
+ (autoload 'lm-verify "lisp-mnt" "" t)
+ (autoload 'lm-synopsis "lisp-mnt" "" t)
+ (autoload 'lm-report-bug "lisp-mnt" "" t)
+
+ ;; dired.el
+
+ (defvar dired-directory nil)
+
+ ;; reporter.el
+
+ (autoload 'reporter-update-status "reporter" "" nil)
+ (autoload 'reporter-beautify-list "reporter" "" nil)
+ (autoload 'reporter-lisp-indent "reporter" "" nil)
+ (autoload 'reporter-dump-variable "reporter" "" nil)
+ (autoload 'reporter-dump-state "reporter" "" nil)
+ (autoload 'reporter-calculate-separator "reporter" "" nil)
+ (autoload 'reporter-mail "reporter" "" nil)
+ (autoload 'reporter-compose-outgoing "reporter" "" nil)
+ (autoload 'reporter-submit-bug-report "reporter" "" nil)
+ (autoload 'reporter-bug-hook "reporter" "" nil)
+ (autoload 'define-mail-user-agent "reporter" "" nil)
+
+ ;; vc-hooks.el
+ ;; /usr/share/emacs/21.2/lisp/vc-hooks.el
+
+ (autoload 'vc-mistrust-permissions "vc-hooks" "" nil)
+ (autoload 'vc-mode "vc-hooks" "" nil)
+ (autoload 'vc-error-occurred "vc-hooks" "" nil 'macro)
+ (autoload 'vc-file-setprop "vc-hooks" "" nil)
+ (autoload 'vc-file-getprop "vc-hooks" "" nil)
+ (autoload 'vc-file-clearprops "vc-hooks" "" nil)
+ (autoload 'vc-make-backend-sym "vc-hooks" "" nil)
+ (autoload 'vc-find-backend-function "vc-hooks" "" nil)
+ (autoload 'vc-call-backend "vc-hooks" "" nil)
+ (autoload 'vc-call "vc-hooks" "" nil 'macro)
+ (autoload 'vc-parse-buffer "vc-hooks" "" nil) ;;defsubst
+ (autoload 'vc-insert-file "vc-hooks" "" nil)
+ (autoload 'vc-registered "vc-hooks" "" nil)
+ (autoload 'vc-backend "vc-hooks" "" nil)
+ (autoload 'vc-backend-subdirectory-name "vc-hooks" "" nil)
+ (autoload 'vc-name "vc-hooks" "" nil)
+ (autoload 'vc-checkout-model "vc-hooks" "" nil)
+ (autoload 'vc-user-login-name "vc-hooks" "" nil)
+ (autoload 'vc-state "vc-hooks" "" nil)
+ (autoload 'vc-up-to-date-p "vc-hooks" "" nil) ;;defsubst
+ (autoload 'vc-default-state-heuristic "vc-hooks" "" nil)
+ (autoload 'vc-workfile-version "vc-hooks" "" nil)
+ (autoload 'vc-default-registered "vc-hooks" "" nil)
+ (autoload 'vc-possible-master "vc-hooks" "" nil)
+ (autoload 'vc-check-master-templates "vc-hooks" "" nil)
+ (autoload 'vc-toggle-read-only "vc-hooks" "" t)
+ (autoload 'vc-default-make-version-backups-p "vc-hooks" "" nil)
+ (autoload 'vc-version-backup-file-name "vc-hooks" "" nil)
+ (autoload 'vc-delete-automatic-version-backups "vc-hooks" "" nil)
+ (autoload 'vc-make-version-backup "vc-hooks" "" nil)
+ (autoload 'vc-before-save "vc-hooks" "" nil)
+ (autoload 'vc-after-save "vc-hooks" "" nil)
+ (autoload 'vc-mode-line "vc-hooks" "" t)
+ (autoload 'vc-default-mode-line-string "vc-hooks" "" nil)
+ (autoload 'vc-follow-link "vc-hooks" "" nil)
+ (autoload 'vc-find-file-hook "vc-hooks" "" nil)
+ (autoload 'vc-file-not-found-hook "vc-hooks" "" nil)
+ (autoload 'vc-kill-buffer-hook "vc-hooks" "" nil)
+
+ ;; font-lock from Emacs 20.6
+
+ (defvar font-lock-mode nil)
+
+ (autoload 'font-lock-mode "font-lock" "" t)
+ (autoload 'turn-on-font-lock "font-lock" "" nil)
+
+ ;; Not necessarily in XEmacs font-lock.el
+ ;; (autoload 'global-font-lock-mode "font-lock" "" t)
+ ;; (autoload 'font-lock-add-keywords "font-lock" "" nil)
+
+ (autoload 'font-lock-change-major-mode "font-lock" "" nil)
+ (autoload 'turn-on-font-lock-mode-if-enabled "font-lock" "" nil)
+ (autoload 'font-lock-turn-on-thing-lock "font-lock" "" nil)
+ (autoload 'font-lock-turn-off-thing-lock "font-lock" "" nil)
+ (autoload 'font-lock-after-fontify-buffer "font-lock" "" nil)
+ (autoload 'font-lock-after-unfontify-buffer "font-lock" "" nil)
+ (autoload 'font-lock-fontify-buffer "font-lock" "" t)
+ (autoload 'font-lock-unfontify-buffer "font-lock" "" nil)
+ (autoload 'font-lock-fontify-region "font-lock" "" nil)
+ (autoload 'font-lock-unfontify-region "font-lock" "" nil)
+ (autoload 'font-lock-default-fontify-buffer "font-lock" "" nil)
+ (autoload 'font-lock-default-unfontify-buffer "font-lock" "" nil)
+ (autoload 'font-lock-default-fontify-region "font-lock" "" nil)
+ (autoload 'font-lock-default-unfontify-region "font-lock" "" nil)
+ (autoload 'font-lock-after-change-function "font-lock" "" nil)
+ (autoload 'font-lock-fontify-block "font-lock" "" t)
+ (autoload 'font-lock-prepend-text-property "font-lock" "" nil)
+ (autoload 'font-lock-append-text-property "font-lock" "" nil)
+ (autoload 'font-lock-fillin-text-property "font-lock" "" nil)
+ (autoload 'font-lock-apply-syntactic-highlight "font-lock" "" nil)
+ (autoload 'font-lock-fontify-syntactic-anchored-keywords "font-lock" "" nil)
+ (autoload 'font-lock-fontify-syntactic-keywords-region "font-lock" "" nil)
+ (autoload 'font-lock-fontify-syntactically-region "font-lock" "" nil)
+ (autoload 'font-lock-apply-highlight "font-lock" "" nil) ;;defsubst
+ (autoload 'font-lock-fontify-anchored-keywords "font-lock" "" nil) ;;defsubst
+ (autoload 'font-lock-fontify-keywords-region "font-lock" "" nil)
+ (autoload 'font-lock-compile-keywords "font-lock" "" nil)
+ (autoload 'font-lock-compile-keyword "font-lock" "" nil)
+ (autoload 'font-lock-eval-keywords "font-lock" "" nil)
+ (autoload 'font-lock-value-in-major-mode "font-lock" "" nil)
+ (autoload 'font-lock-choose-keywords "font-lock" "" nil)
+ (autoload 'font-lock-set-defaults "font-lock" "" nil)
+ (autoload 'font-lock-unset-defaults "font-lock" "" nil)
+ (autoload 'font-lock-match-c-style-declaration-item-and-skip-to-next "font-lock" "" nil)
+ (autoload 'font-lock-match-c++-style-declaration-item-and-skip-to-next "font-lock" "" nil)
+
+ ;; imenu.el in Emacs 20.6, Not in XEmacs.
+
+ (when (locate-library "imenu")
+ (autoload 'imenu--subalist-p "imenu" "" nil)
+ ;; ** The compiler ignores `autoload' except at top level.
+ ;; (autoload 'imenu-progress-message "imenu" "" nil 'macro)
+ (autoload 'imenu-example--name-and-position "imenu" "" nil)
+ (autoload 'imenu-example--lisp-extract-index-name "imenu" "" nil)
+ (autoload 'imenu-example--create-lisp-index "imenu" "" nil)
+ (autoload 'imenu-example--create-c-index "imenu" "" nil)
+ (autoload 'imenu--sort-by-name "imenu" "" nil)
+ (autoload 'imenu--sort-by-position "imenu" "" nil)
+ (autoload 'imenu--relative-position "imenu" "" nil)
+ (autoload 'imenu--split "imenu" "" nil)
+ (autoload 'imenu--split-menu "imenu" "" nil)
+ (autoload 'imenu--split-submenus "imenu" "" nil)
+ (autoload 'imenu--truncate-items "imenu" "" nil)
+ (autoload 'imenu--make-index-alist "imenu" "" nil)
+ (autoload 'imenu--cleanup "imenu" "" nil)
+ (autoload 'imenu--create-keymap-2 "imenu" "" t)
+ (autoload 'imenu--create-keymap-1 "imenu" "" nil)
+ (autoload 'imenu--in-alist "imenu" "" nil)
+ (autoload 'imenu-default-create-index-function "imenu" "" nil)
+ (autoload 'imenu--replace-spaces "imenu" "" nil)
+ (autoload 'imenu--generic-function "imenu" "" nil)
+ (autoload 'imenu--completion-buffer "imenu" "" nil)
+ (autoload 'imenu--mouse-menu "imenu" "" nil)
+ (autoload 'imenu-choose-buffer-index "imenu" "" nil)
+ (autoload 'imenu-add-to-menubar "imenu" "" t)
+ (autoload 'imenu-add-menubar-index "imenu" "" t)
+ (autoload 'imenu-update-menubar "imenu" "" nil)
+ (autoload 'imenu--menubar-select "imenu" "" nil)
+ (autoload 'imenu-default-goto-function "imenu" "" nil)
+ (autoload 'imenu "imenu" "" t))
+
+ ;;}}}
+
+ ;;{{{ code: XEmacs emulation.
+
+ (when t ;; (locate-library "timer")
+ ;; XEmacs provides xemacs-packages\lisp\fsf-compat\timer.el
+ ;;
+ ;; These functions are the "common denominator" of XEmacs 21.2
+ ;; And Emacs 20.4
+ ;;
+ (autoload 'cancel-function-timers "timer" "" t)
+ (autoload 'cancel-timer "timer" "" nil)
+ (autoload 'run-at-time "timer" "" t)
+ (autoload 'run-with-idle-timer "timer" "" t)
+ (autoload 'run-with-timer "timer" "" t)
+ (autoload 'timer-activate "timer" "" nil)
+ (autoload 'timer-activate-when-idle "timer" "" nil)
+ (autoload 'timer-duration "timer" "" nil)
+ (autoload 'timer-inc-time "timer" "" nil)
+ (autoload 'timer-relative-time "timer" "" nil)
+ (autoload 'timer-set-function "timer" "" nil)
+ (autoload 'timer-set-idle-time "timer" "" nil)
+ (autoload 'timer-set-time "timer" "" nil)
+ (autoload 'timer-set-time-with-usecs "timer" "" nil)
+ (autoload 'with-timeout-handler "timer" "" nil)
+ (autoload 'y-or-n-p-with-timeout "timer" "" nil))
+
+ (when (featurep 'xemacs)
+
+ (autoload 'set-cursor-color "tinylibxe" "" t)
+ (autoload 'set-foreground-color "tinylibxe" "" t)
+ (autoload 'set-background-color "tinylibxe" "" t)
+ (autoload 'transient-mark-mode "tinylibxe" "" t)
+
+ (unless (fboundp 'run-at-time)
+ (autoload 'run-at-time "tinylibxe"))
+
+ (unless (fboundp 'cancel-timer)
+ (autoload 'cancel-timer "tinylibxe"))
+
+ (autoload 'posn-window "tinylibxe")
+ (autoload 'posn-point "tinylibxe")
+ (autoload 'posn-timestamp "tinylibxe")
+ (autoload 'window-edges "tinylibxe")
+
+ (autoload 'event-start "tinylibxe")
+ (autoload 'event-x "tinylibxe")
+ (autoload 'event-y "tinylibxe")
+ (autoload 'posn-x-y "tinylibxe")
+
+ (autoload 'frame-parameters "tinylibxe")
+
+ (eval-when-compile
+ ;; emulation in xe library
+ (put 'frame-parameters 'byte-obsolete-variable nil))
+
+ (autoload 'dired-unmark "tinylibxe")
+ (autoload 'dired-mark "tinylibxe")
+ (autoload 'dired-get-marked-files "tinylibxe")
+ (autoload 'dired-map-over-marks "tinylibxe"))
+
+ ;;}}}
+ ;;{{{ code: XEmacs and Emacs autoloads
+
+ (defvar view-mode nil)
+
+ (cond
+ ;; XEmacs 21.x changed package name
+ ((and (featurep 'xemacs)
+ (locate-library "view-less"))
+ (autoload 'view-exit "view-less" "" t)
+ (autoload 'view-mode "view-less" "" t))
+ (t
+ (autoload 'view-exit "view" "" t)
+ (autoload 'view-mode "view" "" t)))
+
+ (when t ;; (locate-library "overlay") ;; XEmacs includes emulation lib
+ ;; overlay.el
+ ;; xemacs-packages/lisp/fsf-compat/overlay.el
+ (autoload 'overlayp "overlay" "" nil)
+ (autoload 'make-overlay "overlay" "" nil)
+ (autoload 'move-overlay "overlay" "" nil)
+ (autoload 'delete-overlay "overlay" "" nil)
+ (autoload 'overlay-start "overlay" "" nil)
+ (autoload 'overlay-end "overlay" "" nil)
+ (autoload 'overlay-buffer "overlay" "" nil)
+ (autoload 'overlay-properties "overlay" "" nil)
+ (autoload 'overlays-at "overlay" "" nil)
+ (autoload 'overlays-in "overlay" "" nil)
+ (autoload 'next-overlay-change "overlay" "" nil)
+ (autoload 'previous-overlay-change "overlay" "" nil)
+ (autoload 'overlay-lists "overlay" "" nil)
+ (autoload 'overlay-recenter "overlay" "" nil)
+ (autoload 'overlay-get "overlay" "" nil)
+ (autoload 'overlay-put "overlay" "" nil))
+
+ ;;}}}
+
+ ) ;; eval-and-compile
+
+;;; tinyliba.el ends here
--- /dev/null
+;;; tinylibb.el --- Library of (b)ackward compatible functions.
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 1998-2007 Jari Aalto
+;; Keywords: extensions
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program, call M-x tinylibb-version.
+;; Look at the code with folding.el
+
+;; COPYRIGHT NOTICE
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;; ........................................................ &t-install ...
+;; DO NOT LOAD THIS FILE, but load the central library "m". It loads this
+;; file and autoload library "a"
+;;
+;; (require 'tinylibm)
+
+;;}}}
+;;{{{ Documentation
+
+;; ..................................................... &t-commentary ...
+
+;;; Commentary:
+
+;; Preface, 1998
+;;
+;; This is lisp function library, package itself does nothing.
+;; This library defines new [X]Emacs release functions for older
+;; [X]Emacs releases.
+;;
+;; Usage
+;;
+;; You must not autoload this package; but always include
+;;
+;; (require 'tinylibm)
+;;
+;; Yes, there is no typo, you load "m" lib. It will handle arranging
+;; everything for you. This library is included by "m" library
+;; automatically. Repeat: you DO NOT PUT any of these in your
+;; packages:
+;;
+;; (require 'tinylib)
+;; (require 'tinyliba)
+;; (require 'tinylibb)
+;; (require 'tinylibo)
+;; (require 'tinyliby)
+;;
+;; A single statement will arrange everything:
+;;
+;; (require 'tinylibm)
+;;
+;; Notes
+;;
+;; 2000-09-12 <ttn@revel.glug.org> in gnu.emacs.sources
+;; http://www.glug.org/people/ttn/software/ttn-pers-elisp/ reported that:
+;; New file core/veneration.el allows GNU Emacs 19 support.
+;; In this file some functions are available
+;; in GNU Emacs 20, but not in GNU Emacs 19: `compose-mail' and
+;; minimal supporting functions (see mail-n-news/compose-mail.el),
+;; `shell-command-to-string', and `char-before'. We also redefine
+;; `match-data' to handle arguments.
+;;
+;; 1998-10 SEMI's poe*el libraries also emulate various Emacs
+;; versions.
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+;;; .......................................................... provide ...
+
+(require 'tinyliba)
+(provide 'tinylibb)
+
+;;{{{ code: Emacs compatibility, aliases, byteCompiler
+
+(eval-and-compile
+ (defvar temporary-file-directory)
+ (autoload 'ti::replace-match "tinylibm"))
+
+;;; ....................................................... &emulation ...
+
+(defun-maybe force-mode-line-update ()
+ ;; XEmacs, labels this obsolete
+ ;; In older Emacs it does not exist
+ (set-buffer-modified-p (buffer-modified-p)))
+
+(defun-maybe eval-after-load (arg1 form) ;; XEmacs 19.14 doesn't have this
+ ;; "A simple emulation. Eval FORM immediately."
+ (load arg1)
+ (eval form))
+
+;; Some XEmacs doesn't have 'buffer-flush-undo
+(defalias-maybe 'buffer-disable-undo 'buffer-flush-undo)
+
+(defalias-maybe 'number-to-string 'int-to-string)
+
+(defalias-maybe 'set-text-properties 'ignore)
+
+(defalias-maybe 'string-to-number 'string-to-int)
+
+;; Doesn't exist in Emacs
+(defalias-maybe 'read-directory-name 'read-file-name)
+
+(and (fboundp 'insert-file-contents-literally)
+ ;; Emacs includes `insert-file-literally'.
+ (defalias-maybe 'insert-file-literally 'insert-file-contents-literally))
+
+(defun-maybe make-local-hook (hook) ;; Exists in 19.30+
+ ;; "Make HOOK local to buffer."
+ ;; - I need locals so many times it make sme cry, e.g. post-command-hook
+ ;; - And why doesn't the add-hook accepts list by default ??
+ ;;
+ ;; - This aapplies to 19.29.1 and newer
+ ;; (add-hook HOOK FUNCTION &optional APPEND LOCAL)
+ ;; Do not use `make-local-variable' to make a hook
+ ;; variable buffer-local. Use `make-local-hook'
+ ;; instead.
+ ;;
+ ;; the variable may be local already, but we do not do
+ ;; any checkings
+ (make-local-variable hook)
+ ;; Copy this because add-hook modifies the list structure.
+ (set hook (copy-sequence (eval hook))))
+
+(defun-maybe find-buffer-visiting (file) ;not in XEmacs 19.14
+ ;; "Find buffer for FILE."
+ ;; file-truename dies if there is no directory part in the name
+ ;; Check it first
+ (or (and (string-match "^/" file)
+ (get-file-buffer (file-truename file)))
+ (get-file-buffer file)))
+
+(defun-maybe backward-line (&optional arg)
+ (forward-line (if (integerp arg)
+ (- 0 arg)
+ -1)))
+
+(defun-maybe abs (x)
+ ;; "Absolute value of X."
+ (if (< x 0)
+ (- x)
+ x))
+
+(defun-maybe int-to-float (nbr)
+ "Convert integer NBR to float."
+ (read (concat (int-to-string nbr) ".0")))
+
+(defun-maybe logtest (x y)
+ "Tinylibm: True if any bits set in X are also set in Y.
+Just like the Common Lisp function of the same name."
+ (not (zerop (logand x y))))
+
+(defun-maybe bin-string-to-int (8bit-string)
+ "Convert 8BIT-STRING string to integer."
+ (let* ((list '(128 64 32 16 8 4 2 1))
+ (i 0)
+ (int 0))
+ (while (< i 8)
+ (if (not (string= "0" (substring 8bit-string i (1+ i))))
+ (setq int (+ int (nth i list) )))
+ (incf i))
+ int))
+
+(defun-maybe int-to-bin-string (n &optional length)
+ "Convert integer N to bit string (LENGTH, default 8)."
+ (let* ((i 0)
+ (len (or length 8))
+ (s (make-string len ?0)))
+ (while (< i len)
+ (if (not (zerop (logand n (ash 1 i))))
+ (aset s (- len (1+ i)) ?1))
+ (setq i (1+ i)))
+ s))
+
+(defun-maybe int-to-hex-string (n &optional separator pad)
+ "Convert integer N to hex string. SEPARATOR between hunks is \"\".
+PAD says to padd hex string with leading zeroes."
+ (or separator
+ (setq separator ""))
+ (mapconcat
+ (function (lambda (x)
+ (setq x (format "%X" (logand x 255)))
+ (if (= 1 (length x))
+ (concat "0" x) x)))
+ (list (ash n -24)
+ (ash n -16)
+ (ash n -8)
+ n)
+ separator))
+
+(defun-maybe int-to-oct-string (n &optional separator)
+ "Convert integer N into Octal. SEPARATOR between hunks is \"\"."
+ (or separator
+ (setq separator ""))
+ (mapconcat
+ (function (lambda (x)
+ (setq x (format "%o" (logand x 511)))
+ (if (= 1 (length x)) (concat "00" x)
+ (if (= 2 (length x)) (concat "0" x) x))))
+ (list (ash n -27) (ash n -18) (ash n -9) n)
+ separator))
+
+(defun radix (str base)
+ "Convert STR according to BASE."
+ (let ((chars "0123456789abcdefghijklmnopqrstuvwxyz")
+ (case-fold-search t)
+ (n 0)
+ i)
+ (mapcar '(lambda (c)
+ (setq i (string-match (make-string 1 c) chars))
+ (if (>= (or i 65536) base)
+ (error "%c illegal in base %d" c base))
+ (setq n (+ (* n base) i)))
+ (append str nil))
+ n))
+
+(defun-maybe bin-to-int (str)
+ "Convert STR into binary."
+ (radix str 2))
+
+(defun-maybe oct-to-int (str)
+ "Convert STR into octal."
+ (radix str 8))
+
+(defun hex-to-int (str)
+ "Convert STR into hex."
+ (if (string-match "\\`0x" str)
+ (setq str (substring str 2)))
+ (radix str 16))
+
+(defun-maybe int-to-net (float)
+ "Decode packed FLOAT 32 bit IP addresses."
+ (format "%d.%d.%d.%d"
+ (truncate (% float 256))
+ (truncate (% (/ float 256.0) 256))
+ (truncate (% (/ float (* 256.0 256.0)) 256))
+ (truncate (% (/ float (* 256.0 256.0 256.0)) 256))))
+
+(defun-maybe rmac (string)
+ "Decode STRING x-mac-creator and x-mac-type numbers."
+ (if (numberp string)
+ (setq string (format "%X" string)))
+ (let ((i 0)
+ (r ""))
+ (while (< i (length string))
+ (setq r (concat
+ r
+ (make-string
+ 1
+ ;; EWas call to 'rhex'
+ (hex-to-int (concat (make-string 1 (aref string i))
+ (make-string 1 (aref string (1+ i)))))))
+ i (+ i 2)))
+ r))
+
+(defun-maybe ctime (time)
+ "Print a time_t TIME."
+ (if (and (stringp time) (string-match "\\`[0-9]+\\'" time))
+ (setq time (string-to-number (concat time ".0"))))
+ (let* ((top (floor (/ time (ash 1 16))))
+ ;; (bot (floor (mod time (1- (ash 1 16)))))
+ (bot (floor (- time (* (ash 1 16) (float top))))))
+ (current-time-string (cons top bot))))
+
+(defsubst rand0 (n)
+ "Random number in [0 .. N]."
+ (cond
+ ((<= n 0)
+ 0)
+ (t
+ (abs (% (random) n)))))
+
+(defsubst-maybe rand1 (n)
+ "Random number [1 .. N]."
+ (1+ (rand0 n)))
+
+(defun-maybe randij (i j)
+ "Random number [I .. J]."
+ (cond
+ ((< i j) (+ i (rand0 (1+ (- j i)))))
+ ((= i j) i)
+ ((> i j) (+ j (rand0 (1+ (- i j)))))
+ (t (error "randij wierdness %s %s"
+ (ti::string-value i)
+ (ti::string-value j)))))
+
+;;; ... ... ... ... ... ... ... ... ... ... ... ... ... ... ... split ..
+
+(unless (fboundp 'split-sting)
+ (eval-and-compile
+ (defun ti::split-string (string &optional regexp level cont-level)
+ "Do not use this function. Call `split-string' instead.
+This function exists, because current Emacs did not define `split-string' and
+there is now alias which emulates the new Emacs behavior.
+
+If called with only STRING, then split on white space.
+
+Input:
+
+ STRING
+ REGEXP The delimiter in string, Default is '[\\f\\t\\n\\r\\v]+'
+ LEVEL The sub match in REGEXP to end reading substring.
+ Default is 0
+ CONT-LEVEL The sub match end to continue reading the STRING.
+ Default is 0 (REGEXP match's end point)
+
+Example:
+
+ (split-string \"-I/dir1 -I/dir2\" \" *-I\")
+ --> '(\"/dir1\" \"/dir2\")"
+ (let ((start 0)
+ str
+ ret)
+ (or regexp
+ (setq regexp "[ \f\t\n\r\v]+"))
+ (or level
+ (setq level 0))
+ (or cont-level
+ (setq cont-level 0))
+
+ ;; If no match, return as is '(string)
+
+ (if (null (string-match regexp string ))
+ (setq ret (list string))
+ (while (string-match regexp string start)
+ (setq str (substring string start (match-beginning level)))
+ (setq start (match-end cont-level))
+ ;; Ignore BOL matches. There is no string for us.
+ (if (> (match-beginning level) 0)
+ (push str ret)))
+ ;; Try with " test" --> '("test")
+ (if (and (> start 0)
+ (< start (length string)))
+ (push (substring string start) ret)))
+ (nreverse ret)))))
+
+(defun-maybe split-string (string &optional separators)
+ ;; (split-string STRING &optional SEPARATORS)
+ ;; in XEmacs 19.14 subr.el
+ ;; "Split string on whitespace."
+ (ti::split-string string separators))
+
+;;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. higher Emacs . .
+;;: Features found from new emacs only 20.xx
+
+;; In simple.el, old Emacs does not have this.
+(and (fboundp 'delete-indentation)
+ (defalias-maybe 'join-lines 'delete-indentation))
+
+(defun-maybe replace-char-in-string (ch1 ch2 string)
+ ;; "Search CH1, change it with CH2 in STRING."
+ (nsubstitute ch1 ch2 string))
+
+(defun-maybe string-prefix-p (s1 s2)
+ ;; "True if string S1 is a prefix of S2 (i.e. S2 starts with S1)"
+ (equal 0 (string-match (regexp-quote s1) s2)))
+
+(put 'with-temp-buffer 'lisp-indent-function 0)
+(put 'with-temp-buffer 'edebug-form-spec '(body))
+(defmacro-maybe with-temp-buffer (&rest forms)
+ "Create a temporary buffer, and evaluate FORMS there like `progn'."
+ (let ((temp-buffer (make-symbol "temp-buffer")))
+ (`
+ (let (((, temp-buffer)
+ (get-buffer-create (generate-new-buffer-name " *temp*"))))
+ (unwind-protect
+ (save-excursion
+ (set-buffer (, temp-buffer))
+ (,@ forms))
+ (and (buffer-name (, temp-buffer))
+ (kill-buffer (, temp-buffer))) )))))
+
+(defun-maybe byte-compiling-files-p ()
+ "Return t if currently byte-compiling files."
+ (string= (buffer-name) " *Compiler Input*"))
+
+;; #todo: This already exists in some XEmacs
+
+(put 'with-output-to-string 'edebug-form-spec '(body))
+(defmacro-maybe with-output-to-string (&rest body) ;XEmacs has this
+ "Please use `shell-command-to-string'. Execute BODY and return string."
+ (`
+ (save-current-buffer
+ (set-buffer (get-buffer-create " *string-output*"))
+ (setq buffer-read-only nil)
+ (buffer-disable-undo (current-buffer))
+ (erase-buffer)
+ (let ((standard-output (current-buffer)))
+ (,@ body))
+ (buffer-string))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(unless (fboundp 'with-buffer-unmodified)
+ ;; Appeared in Emacs 21.2
+ (put 'with-buffer-modified 'lisp-indent-function 0)
+ (put 'with-buffer-modified 'edebug-form-spec '(body))
+ (defmacro with-buffer-modified (&rest body)
+ "This FORM saves modified state during execution of body.
+Suppose buffer is _not_ modified when you do something in the BODY,
+e.g. set face properties: changing face also signifies
+to Emacs that buffer has been modified. But the result is that when
+BODY finishes; the original buffer modified state is restored.
+
+This form will also make the buffer writable for the execution of body,
+but at the end of form it will restore the possible read-only state as
+seen my `buffer-read-only'
+
+\(with-buffer-modified
+ (set-text-properties 1 10 '(face highlight)))
+
+"
+ (` (let* ((Buffer-Modified (buffer-modified-p))
+ (Buffer-Read-Only buffer-read-only))
+ (prog1
+ (progn
+ (setq buffer-read-only nil)
+ (,@ body)))
+ (if Buffer-Modified
+ (set-buffer-modified-p t)
+ (set-buffer-modified-p nil))
+ (if Buffer-Read-Only
+ (setq buffer-read-only t)
+ (setq buffer-read-only nil))))))
+
+;; `save-excursion' is expensive; use `save-current-buffer' instead
+(put 'save-current-buffer 'edebug-form-spec '(body))
+(defmacro-maybe save-current-buffer (&rest body)
+ "Save the current buffer; execute BODY; restore the current buffer.
+ Executes BODY just like `progn'."
+ (` (save-excursion (,@ body))))
+
+(put 'with-current-buffer 'lisp-indent-function 1)
+(put 'with-current-buffer 'edebug-form-spec '(body))
+(defmacro-maybe with-current-buffer (buffer &rest body)
+ "tinylibm.el
+Execute the forms in BODY with BUFFER as the current buffer.
+ The value returned is the value of the last form in BODY.
+ See also `with-current-buffer'."
+ (`
+ (save-current-buffer
+ (set-buffer (, buffer))
+ (,@ body))))
+
+(defmacro-maybe with-output-to-file (file &rest body)
+ "Open FILE and run BODY.
+\(with-output-to-file \"foo\"
+ (print '(bar baz)))."
+ `(with-temp-file ,file
+ (let ((standard-output (current-buffer)))
+ ,@body)))
+
+;; Emacs 19.30 and below don't have this
+
+(defun-maybe match-string (level &optional string)
+ ;; "Read match from buffer at sub match LEVEL. Optionally from STRING.
+ ;;Return nil, if match at LEVEL doesn't exist.
+ ;;
+ ;;You have to call `looking-at' etc. before using this function.
+ ;;You can use use `ti::buffer-match' or `ti::string-match' directly too."
+ (if (match-end level)
+ (if (stringp string)
+ (substring
+ string
+ (match-beginning level) (match-end level))
+ (buffer-substring
+ (match-beginning level) (match-end level)))))
+
+;; (replace-regexp-in-string
+;; REGEXP REP STRING &optional FIXEDCASE LITERAL SUBEXP START)
+
+;; (string regexp rep &optional subexp count)
+;;
+(defun-maybe replace-regexp-in-string
+ (regexp rep string &optional fixedcase literal subexp start)
+ (let* ((i 0))
+ (or subexp
+ (setq subexp 0))
+ (while (string-match regexp string)
+ (if (> (incf i) 5000)
+ (error "Substituted string causes circular match. Loop never ends.")
+ (inline (setq string (ti::replace-match subexp rep string)))))
+ string))
+
+(defun-maybe buffer-substring-no-properties (beg end)
+ (ti::remove-properties (buffer-substring beg end)))
+
+;; Here's the pre-Emacs 20.3 definition. Note the optional arg.
+
+(defun-maybe match-string-no-properties (num &optional string)
+ ;; "Return string of text matched by last search, without text properties.
+ ;; NUM specifies which parenthesized expression in the last regexp.
+ ;; Value is nil if NUMth pair didn't match, or there were less than NUM pairs.
+ ;; Zero means the entire text matched by the whole regexp or whole string.
+ ;; STRING should be given if the last search was by `string-match' on STRING."
+ (if (match-beginning num)
+ (if string
+ (let ((result
+ (substring string (match-beginning num) (match-end num))))
+ (set-text-properties 0 (length result) nil result)
+ result)
+ (buffer-substring-no-properties (match-beginning num)
+ (match-end num)))))
+
+;; This is from pcvs.el
+(defun-maybe file-to-string (file &optional oneline args)
+ "Read the content of FILE and return it as a string.
+If ONELINE is t, only the first line (no \\n) will be returned.
+If ARGS is non-nil, the file will be executed with ARGS as its
+arguments. If ARGS is not a list, no argument will be passed."
+ (with-temp-buffer
+ (condition-case nil
+ (progn
+ (if args
+ (apply 'call-process
+ file nil t nil (when (listp args) args))
+ (insert-file-contents file))
+ (buffer-substring (point-min)
+ (if oneline
+ (progn (goto-char (point-min))
+ (end-of-line)
+ (point))
+ (point-max))))
+ (file-error nil))))
+
+(defun-maybe file-name-extension (filename)
+ (ti::file-get-extension filename))
+
+(defun-maybe file-name-sans-extension (filename)
+ ;; "Return FILENAME without extension."
+ (replace-regexp-in-string "\\.[^.]+$" "" filename))
+
+;; Emacs 20.3 invented its own function names `line-beginning-position'
+;; `line-end-position' while XEmacs already had had point-* function
+;; names since 1996: `point-at-eol' and `point-at-bol'.
+
+(defsubst-maybe line-beginning-position (&optional n)
+ "Return begin position of line forward N."
+ (save-excursion
+ (if n
+ (forward-line n))
+ (beginning-of-line) (point)))
+
+(defsubst-maybe line-end-position (&optional n)
+ "Return end position of line forward N."
+ (save-excursion
+ (if n
+ (forward-line n))
+ (end-of-line) (point)))
+
+(defsubst-maybe insert-file-literally (file) ;; XEmacs 21.4 does not have this
+ "Insert contents of file FILENAME into buffer after point with no conversion."
+ (let (find-file-hooks
+ write-file-hooks
+ auto-save-hook
+ auto-save-default)
+ (insert-file file)))
+
+(eval-and-compile
+ (if (locate-library "executable") ;; 20.4 defines this
+ (autoload 'executable-find "executable")
+ (defun-maybe executable-find (program-name)
+ ;; "Find PROGRAM-NAME along `exec-path'."
+ (ti::file-get-load-path program-name exec-path))))
+
+(defun-maybe executable-find-in-system (program-name) ;Handle Win32 case too.
+ ;; "Find PROGRAM-NAME along `exec-path'.
+ ;; The PROGRAM-NAME should not contain system dependent prefixes; an
+ ;; .exe is added automatically on PC."
+ (if (ti::win32-p)
+ (or (executable-find (concat program-name ".exe"))
+ (executable-find (concat program-name ".com"))
+ (executable-find (concat program-name ".bat"))
+ (executable-find (concat program-name ".cmd")))
+ (executable-find program-name)))
+
+;;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. XEmacs20 char . .
+
+(defmacro ti::compat-character-define-macro (function1 function2)
+ "Define XEmacs compatible character FUNCTION2 as an alias for FUNCTION1."
+ (`
+ (when (or (not (fboundp (, function1)))
+ (and (ti::emacs-p)
+ (fboundp (, function1))
+ (or (not (equal (symbol-function (, function1))
+ (, function2)))
+ ;; If the definition is 'ignore, reassign correct
+ ;; function.
+ (equal (symbol-function (, function1))
+ 'ignore))))
+ (defalias (, function1) (, function2)))))
+
+(defun ti::compat-char-int-p (ch) ;Not in Emacs (in XEmacs20 MULE)
+ (and (integerp ch)
+ (> ch -1) ;valid range 0-255
+ (< ch 255)))
+
+(defun ti::compat-define-compatibility-defalias ()
+ "Emacs and XEmacs compatibility.
+Define XEmacs character functions to work in Emacs.
+Function mappings are:
+
+ int-to-char identity
+ char-equal equal
+ char-to-int identity
+ chars-in-string length
+ characterp integerp
+ char-int-p ti::compat-char-int-p
+ char-int identity"
+ ;; - In Emacs the characters are treated as integers
+ ;; - In XEmacs charactersa are their own data type
+ (dolist (elt '((int-to-char identity)
+ (char-equal equal)
+ ;; Not in Emacs (exist in XEmacs 20)
+ (char-to-int identity)
+ ;; Emacs 20.2/20.3 change
+ (chars-in-string length)
+ ;; exists only in XEmacs
+ (characterp integerp)
+ (char-int-p ti::compat-char-int-p)
+ (char-int identity)))
+ (multiple-value-bind (original alias) elt
+ (ti::compat-character-define-macro original alias))))
+
+(ti::compat-define-compatibility-defalias)
+
+(defun-maybe char= (ch1 ch2 &optional ignored-arg) ;exists in XEmacs 20.1
+ (let* (case-fold-search) ;case sensitive
+ (char-equal ch1 ch2)))
+
+;; eshell-mode.el fix
+(eval-after-load "eshell-mode"
+ '(progn (ti::compat-define-compatibility-defalias)))
+
+;; eshell-2.4.1/esh-mode.el mistakenly defines characterp
+;; as alias to `ignore' => breaks many things
+(eval-after-load "esh-mode"
+ '(progn (ti::compat-define-compatibility-defalias)))
+
+;; Gnus MIME handling also behaves wrong
+(eval-after-load "mm-decode"
+ '(progn (ti::compat-define-compatibility-defalias)))
+
+;; See cplus-md.el
+(defun-maybe count-char-in-string (c s)
+ "Count CHARACTER in STRING."
+ (let ((count 0)
+ (pos 0))
+ (while (< pos (length s))
+ (if (char= (aref s pos) c)
+ (incf count))
+ (incf pos))
+ count))
+
+(defun-maybe count-char-in-region (beg end char)
+ "In region BEG END, count all CHAR occurrences.
+E.g. to have real line count in buffer that
+is running folding.el or outline, you should not call
+count-lines function , but (count-char-in-region ?\\n)"
+ (interactive "r\ncChar: ")
+ (let* ((i 0))
+ (setq end (max beg end)
+ char (char-to-string char))
+ (save-excursion
+ (goto-char (min beg end))
+ (while (search-forward char end t)
+ (incf i)))
+ (if (interactive-p)
+ (message "%d hits in region." i))
+ i))
+
+(defun-maybe char-assq (ch alist)
+ "If CH can be found in ALIST, return entry. If CH is nil, do nothing."
+ (let (case-fold-search
+ ret)
+ (while (and ch alist)
+ (setq ret (car alist))
+ (if (char= ch (car ret))
+ (setq alist nil)
+ (setq alist (cdr alist)
+ ret nil) ))
+ ret))
+
+;; XEmacs : replace-in-string
+;; Emacs 20.4
+(defun-maybe subst-char-in-string (fromchar tochar string &optional inplace)
+ "Replace FROMCHAR with TOCHAR in STRING each time it occurs.
+INPLACE is ignored."
+ (let ((len (length string))
+ (ret (copy-sequence string))) ;because 'aset' is destructive
+ (while (> len 0)
+ (if (char= (aref string (1- len)) fromchar)
+ (aset ret (1- len) tochar))
+ (decf len))
+ ret))
+
+(defun-maybe subst-char-with-string (string &optional char to-string)
+ "In STRING, convert CHAR with TO-STRING.
+Default is to convert all tabs in STRING with spaces."
+ (let* ((len (length string))
+ (i 0)
+ elt
+ ret)
+ (cond
+ ((not (and char to-string))
+ (with-temp-buffer
+ (insert string)
+ (untabify (point-min) (point-max))
+ (setq ret (buffer-string))))
+ (t
+ (while (< i len)
+ (setq elt (char-to-string (aref string i)))
+ (if (char= char (aref string i))
+ (setq elt to-string))
+ (setq ret (concat ret elt))
+ (incf i))))
+ ret))
+
+(eval-and-compile
+ (when (or (featurep 'xemacs)
+ (boundp 'xemacs-logo))
+ ;; Just a forward declaration, because byte-compiler cannot see through
+ ;; defun-maybe. If this function already exists, this autoload
+ ;; definition is no-op.
+ (autoload 'subst-char-in-string "tinylibb.el")))
+
+;; Emacs and XEmacs differ here. Convert Emacs function --> XEmacs name
+
+(cond
+ ((and (fboundp 'exec-to-string)
+ (not (fboundp 'shell-command-to-string)))
+ (defalias-maybe 'shell-command-to-string 'exec-to-string))
+ ((not (fboundp 'shell-command-to-string))
+ (defun-maybe shell-command-to-string (command)
+ "Returns shell COMMAND's ouput as string. Tinylibm."
+ (with-temp-buffer
+ (shell-command command (current-buffer))
+ (buffer-string)))))
+
+;;; XEmacs ilisp.el :: describe-symbol-find-file
+(defun-maybe describe-symbol-find-file (symbol) ;; XEmacs
+ "Find SYMBOL defined in file."
+ (loop for (file . load-data) in load-history
+ do (when (memq symbol load-data)
+ (return file))))
+
+;; shell.el, term.el, terminal.el
+
+(unless (boundp 'explicit-shell-file-name)
+ (defvar explicit-shell-file-name nil))
+
+(unless (boundp 'shell-command-output-buffer)
+ (defvar shell-command-output-buffer "*Shell Command Output*"))
+
+(when (or (not (boundp 'temporary-file-directory))
+ (not (stringp temporary-file-directory))
+ (not (file-directory-p temporary-file-directory)))
+ (let* ((temp (or (getenv "TEMP")
+ (getenv "TEMPDIR")
+ (getenv "TMPDIR"))))
+ (defvar temporary-file-directory ;Emacs 20.3
+ (or temp
+ (cond
+ ((file-directory-p "/tmp") "/tmp")
+ ((file-directory-p "~/tmp") "~/tmp")
+ ((file-directory-p "C:/temp") "C:/temp")
+ ;; don't know what to do, maybe this exists.
+ (t "/")))
+ "*Tinylib: XEmacs and Emacs compatibility.")))
+
+;;; ........................................................... &other ...
+
+;; Emacs 20.7 - 21.2 does not have this
+(defun-maybe turn-off-font-lock ()
+ "Turn off font lock."
+ (font-lock-mode -1))
+
+;; Emacs 21.3 includes `turn-on-font-lock'
+(defun-maybe turn-on-font-lock-mode ()
+ "Turn on font lock."
+ (font-lock-mode 1))
+
+(defun-maybe turn-on-auto-fill-mode ()
+ "Turn on Auto Fill mode."
+ (auto-fill-mode 1))
+
+(defun font-lock-mode-maybe (&optional mode check-global)
+ "Pass MODE to function `font-lock-mode' only on color display.
+If CHECK-GLOBAL is non-nil, the `global-font-lock-mode' flag must also
+be non-nil before calling.
+
+Usually there is no point of turning on `font-lock-mode' if Emacs
+can't display colors, so this is is the umbrella function to
+font-lock.el"
+ (when (and (featurep 'font-lock)
+ (ti::colors-supported-p)
+ (or (null check-global)
+ (and (boundp 'global-font-lock-mode)
+ (symbol-value 'global-font-lock-mode))))
+ (font-lock-mode mode)
+ t))
+
+(defun turn-on-font-lock-mode-maybe ()
+ "Call `font-lock-mode-maybe' with argument 1."
+ (font-lock-mode-maybe 1))
+
+(defalias-maybe 'compose-mail 'mail)
+
+(defun-maybe region-active-p () ;XEmacs function
+ "Return `mark' if mark (region) is active."
+ (cond
+ ((and (ti::xemacs-p)
+ (boundp 'zmacs-regions))
+ (let* ((zmacs-regions t)) ;XEmacs
+ (mark)))
+ ((boundp 'mark-active) ;Emacs
+ (and (symbol-value 'mark-active)
+ ;; used to return (mark-marker)
+ (mark 'noerr)))))
+
+;; Newer advice "2.15" uses this call, make sure it exist.
+(defalias-maybe 'byte-code-function-p 'ignore)
+
+(defun-maybe add-to-list (list-var element)
+ ;; "Add to symbol LIST-VAR ELEMENT."
+ (or (member element (symbol-value list-var)) ;; copy from 19.34
+ (set list-var (cons element (symbol-value list-var)))))
+
+(defun-maybe run-hook-with-args-until-success
+ (hook-sym &optional &rest args)
+ ;; "Run all functions in HOOK-SYM. Stop when first one return non-nil.
+ ;;
+ ;; Input:
+ ;;
+ ;; HOOK-SYM hook symbol, or list of functions.
+ ;; ARGS arguments to functions. if NIL, functions
+ ;; are called without arguments."
+ (let* ((val (symbol-value hook-sym))
+ (list (if (listp val) val (list val))) ;Make list maybe
+ ret
+ func)
+ (while (and (null ret) list)
+ (setq func (car list) list (cdr list))
+ (setq ret (apply func args)))
+ ret))
+
+(defun-maybe buffer-live-p (buffer)
+ ;; "Check if BUFFER exist."
+ (cond
+ ((not (bufferp buffer))
+ (error "must be pointer"))
+ ((stringp buffer)
+ (get-buffer buffer))
+ (buffer
+ (buffer-name buffer))))
+
+(eval-when-compile
+ ;; don't show "obsolete function warning", because we know what
+ ;; we're doing below.
+ (put 'frame-parameters 'byte-compile nil))
+
+(when (not (fboundp 'frame-parameter)) ;Emacs 19.35
+ (if (fboundp 'frame-property)
+ (defalias 'frame-parameter 'frame-property) ; XEmacs.
+ (defun frame-parameter (frame property &optional default)
+ "Return FRAME's value for property PROPERTY."
+ (or (cdr (assq property (frame-parameters frame)))
+ default))))
+
+(unless (and (fboundp 'find-file-binary) ;; Emacs function --> XEmacs
+ (boundp 'buffer-file-coding-system))
+ (defun find-file-binary (file)
+ "Read FILE without conversiosn."
+ (let* ((buffer-file-coding-system 'binary))
+ (unless buffer-file-coding-system
+ (setq buffer-file-coding-system nil)) ;Quiet Bytecompiler "unused var".
+ (find-file file))))
+
+;;}}}
+;;{{{ special
+
+;;; ........................................... &compatibility-special ...
+;;; These need emacs-p xemacs-p tests
+
+;; not known function in 19.14
+
+(eval-and-compile
+ (autoload 'read-kbd-macro "edmacro")
+ (when (ti::emacs-p)
+ (or (fboundp 'kbd) ;Std in Emacs 20.x
+ (defmacro kbd (keys) ;(kbd "C-<delete>")
+ "Convert KEYS to the internal Emacs key representation.
+KEYS should be a string constant in the format used for
+saving keyboard macros (see `insert-kbd-macro')."
+ (let ((f 'read-kbd-macro))
+ (funcall f keys))))))
+
+;;}}}
+;;{{{ code: function test
+
+;;; ...................................................... &func-tests ...
+;;; We define these here because they are used lated in this library
+;;; "define before using"
+
+(eval-and-compile
+
+;;; ----------------------------------------------------------------------
+;;;
+ (defun-maybe functionp (obj) ;; Emacs 20.3+ XEmacs 20.x
+ (or (subrp obj)
+ (byte-code-function-p obj)
+ (and (symbolp obj)
+ (fboundp obj))
+ (and (consp obj)
+ (eq (car obj) 'lambda))))
+
+;;; ----------------------------------------------------------------------
+;;;
+ (defun ti::function-args-p (symbol)
+ "Return function SYMBOL's argument list as string or nil.
+Works for byte compiled functions too.
+
+Notes:
+ if function is alias, the real function behind it is examined.
+ if function is in autoload state, \"(autoload-args)\" is returned."
+ (let* ((args-re-xemacs ;; arguments: (&optional BUFFER)
+ "arguments: +(\\([^)]+\\))")
+ (args-re ;; (buffer-size &optional BUFFER)
+ "([^(]+\\([^)]+)\\)")
+ sym
+ sym-func
+ str
+ ret)
+ (if (ti::autoload-p symbol)
+ ;; We can't know the args. And we don't want to find out,
+ ;; since it would load the package unnecessarily
+ (setq ret "(autoload-args)")
+ (if (setq sym (ti::defalias-p symbol))
+ (setq symbol sym))
+ (setq sym-func (symbol-function symbol))
+ (if (subrp sym-func)
+ (setq str (documentation sym-func))
+ (setq str (prin1-to-string sym-func)))
+ ;; "$ad-doc: mouse-yank-at-click$" (interactive "e\nP")
+ (when (and (string-match "ad-doc:" str)
+ (setq symbol
+ (intern-soft
+ (format "ad-Orig-%s"
+ (symbol-name symbol)))))
+ (setq str (prin1-to-string (symbol-function symbol))))
+ (cond
+ ((ti::emacs-p)
+ (cond
+ ;; "#[(click arg)
+ ((string-match "^#\\[(\\([^)]+\\)" str)
+ (setq ret (match-string 1 str)))
+ ((or (string-match "^(lambda[ \t]+nil" str)
+ (string-match "^#\\[nil" str))
+ (setq ret nil))
+ ((string-match args-re str)
+ (setq ret (match-string 1 str))
+ ;; Empty arg list
+ (if (string= ret "")
+ (setq ret nil)))))
+ (t
+ ;; XEmacs has different Byte compilation format
+ ;; #<compiled-function (from "custom.elc") nil "...(7)
+ (cond
+ ((string-match
+ (concat "compiled-function +\(from.*\) +" args-re) str)
+ (setq ret (match-string 2)))
+ ((string-match "^(lambda +nil" str)) ;bypass
+ ((string-match args-re-xemacs str)
+ (setq ret (match-string 1 str)))
+ ((string-match args-re str)
+ (setq ret (match-string 1 str)))))))
+ ret)))
+
+;;; --++-- --++-- --++-- --++-- --++-- --++-- --++-- eval-and-compile --
+
+;;}}}
+;;{{{ code: Cygwin support
+
+;;; ........................................................... cygwin ...
+
+;;; Patch for these functions has been submitted to Emacs 21.2
+;;; (w32-fns.el)
+
+(defvar w32-cygwin-mount-table nil
+ "Cygwin mount.exe mapping. See `w32-cygwin-mount-table'.")
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'w32-cygwin-mount-table-dolist 'lisp-indent-function 0)
+(put 'w32-cygwin-mount-table-dolist 'edebug-form-spec '(body)) ;;#todo: not working
+(defmacro w32-cygwin-mount-table-dolist (&rest body)
+ "Run DOLIST for Cygwin mount table.
+`mount' is complete mount element (cygwin . dos).
+Variables `cygwin' and `dos' are bound respectively."
+ (`
+ (dolist (mount w32-cygwin-mount-table)
+ ;; mount => ("/tmp" . "c:\\temp")
+ (let* ((cygwin (car mount))
+ (dos (cdr mount)))
+ (,@ body)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'w32-cygwin-shell-environment 'lisp-indent-function 0)
+(put 'w32-cygwin-shell-environment 'edebug-form-spec '(body))
+(defmacro w32-cygwin-shell-environment (&rest body)
+ "Run BODY under Cygwin shell environment.
+For example, you you want to call program ´zgrep' which is not an
+.exe, but a shell program, you have to switch to the Cygwin context.
+
+ (when (and (ti::win32-p)
+ (ti::win32-cygwin-p))
+ (w32-cygwin-shell-environment
+ ...))
+
+Variable ´shell-file-name' is locally bound during call."
+ (`
+ (let ((shell-file-name (format "%s/bin/hash.exe"
+ (ti::win32-cygwin-p 'use-cache))))
+ (,@ body))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun w32-cygwin-mount-table-parse ()
+ ;; "Parse cygwin mount table from current point forward."
+
+ ;; Search lines with backslash
+ ;; f:\\u\\bin /usr/bin user binmode
+ ;;
+ ;; Cygwin 1.3.3 changed format, it is now
+ ;;
+ ;; f:\\u\\bin on /usr/bin type user (binmode)
+ ;; ==
+ ;;
+ ;; \\network\path\this
+
+ (let (list
+ (regexp
+ (save-excursion
+ (if (re-search-forward "^\\([a-z]:\\|[\\][\\]\\).* on " nil t)
+ (concat
+ "^\\([a-zA-Z]:[\\][^ \t\r\n]*"
+ "\\|[a-zA-Z]:"
+ "\\|[\\][\\][^ \t\r\n]+"
+ "\\)"
+ "[ \t]+on[ \t]+"
+ "\\(/[^ \t\r\n]*\\)")
+ (concat
+ "^\\([a-zA-Z]:[\\][^ \t\r\n]*"
+ "\\|[a-zA-Z]:"
+ "\\|[\\][\\][^ \t\r\n]+"
+ "\\)"
+ "[ \t]+"
+ "\\(/[^ \t\r\n]*\\)")))))
+ (while (re-search-forward regexp nil t)
+ (let ((dos (match-string 2))
+ (cygwin (match-string 1)))
+ (push (cons dos cygwin)
+ list)))
+
+ ;; sort the entries so that the longest mounts come first and
+ ;; last the shortest. This makes a difference when Cygwin paths are
+ ;; converted back to dos:
+ ;;
+ ;; /tmp/other mapping must be handled before /tmp
+ ;; /tmp
+ ;; ..
+
+ (sort list
+ (function
+ (lambda (a b)
+ (> (length (car a))
+ (length (car b))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun w32-cygwin-convert (path &optional flag)
+ "Run `cygpath' to find out PATH.
+Return:
+
+ The default concersion is CYGWIN => DOS
+
+ If `flag' is set, then the conversion is
+ DOS => cygwin."
+ (let* ((cmd (executable-find "cygpath"))
+ (option "--windows")
+ ret)
+ (when cmd
+ (when flag
+ (setq option "--unix"))
+ (with-temp-buffer
+ (call-process
+ cmd
+ nil
+ (current-buffer)
+ nil
+ option
+ path)
+ (goto-char (point-min))
+ (when (looking-at "^.*") ;; Filter newlines
+ (setq ret (match-string 0)))))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun w32-cygwin-mount-table ()
+ ;; "Return Cygwin mount table '((CYGWIN . DOS) ..) using `mount' command."
+ (when ;; (memq system-type '(ms-dos windows-nt))
+ (ti::win32-p)
+ ;; specifically request the .exe which must be along PATH
+ ;; if we used only `mount', that could call user's "mount.bat" or
+ ;; something.
+ (let ((cmd (executable-find "mount.exe")))
+ (when cmd
+ (with-temp-buffer
+ (call-process cmd nil (current-buffer))
+ (goto-char (point-min))
+
+ ;; It's a serious error if "mount" does not say where
+ ;; the ROOT "/" is. Should we do something?
+
+ (goto-char (point-min))
+ (let ((ret (w32-cygwin-mount-table-parse)))
+ (unless ret
+ (error "Cygwin mount.exe output parse failed:\n[%s]"
+ (buffer-string)))
+ ret))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun w32-cygwin-mount-point-to-dos (path)
+ "Convert Cygwin mount filenames like /tmp to DOS paths."
+ (let* (last-choice
+ try)
+ (dolist (cygwin w32-cygwin-mount-table)
+ (when (string-match (concat "^" (car cygwin) "\\(.*\\)")
+ path)
+ (setq try
+ ;; expand will ensure that slashes are after glue
+ ;; to the same direction
+ (expand-file-name
+ (concat (file-name-as-directory (cdr cygwin) )
+ (match-string 1 path))))
+ ;; It is difficult to expand the file name correctly because
+ ;; user can make any mount points. That's what we compare which
+ ;; mount point gives the longest match and return it.
+ ;;
+ ;; E.g. the root / will always match, but it is not necessarily
+ ;; the final answer given path /tmp/something where there is
+ ;; separate mount point for longer match /tmp
+ ;;
+ (if (null last-choice)
+ (setq last-choice (cons (car cygwin) try))
+ (if (length (> (car cygwin) (car last-choice)))
+ (setq last-choice (cons (car cygwin) try))))))
+ (if (null last-choice)
+ path
+ (cdr last-choice))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun w32-cygwin-mount-table-set ()
+ ;; "Run mount.exe and set internal variable `w32-cygwin-mount-table'.
+ ;; You should run this function after you have made a change to
+ ;; cygwin mount points."
+ ;; (interactive)
+ (if (ti::win32-p) ;; (memq system-type '(ms-dos windows-nt))
+ (setq w32-cygwin-mount-table
+ (w32-cygwin-mount-table))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun w32-cygwin-mount-table-path-to-dos (path)
+ "Convert PATH to dos using cygwin mount table.
+You should not call this function, use `w32-cygwin-path-to-dos'."
+ ;; Convert Cygwin /usr/local to DOS path. LOCATION/usr/local.
+ ;; This relies on the fact that the longest paths are first
+ ;; in the mount table.
+ (let (final-path)
+ (w32-cygwin-mount-table-dolist
+ ;; mount => ("/tmp" . "c:\\temp")
+ ;; variables `cygwin' and `dos' are part of the macro
+ (when (string-match (concat "^" (regexp-quote cygwin)
+ "\\(.*\\)")
+ path)
+ (unless (string= cygwin "/")
+ (setq dos (concat dos (match-string 1 path))))
+ ;; Convert to forward slashes
+ (setq final-path (subst-char-in-string ?\\ ?/ dos))
+ (return)))
+ (unless final-path
+ ;; None matched, so this path is under cygwin root dir.
+ (let ((root (ti::win32-cygwin-p)))
+ (setq final-path (concat root path))))
+ final-path))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun w32-cygwin-path-to-dos (path)
+ "Convert cygwin like //c/temp or /cygdrive/c/temp path to
+ dos notation c:/temp."
+ ;; NOTE for cygwin and bash shell prompt
+ ;; We can't require a slash after the drive letter, because
+ ;; //c and /cygdrive/c are all top level roots.
+ ;;
+ ;; The bash shell's PS1 setting \w (The current working directory)
+ ;; Does not add trailing slash.
+ (cond
+ ((or (string-match "^//\\([a-z]\\)/?$" path)
+ (string-match "^/cygdrive/\\([a-z]\\)/?$" path))
+ (concat (match-string 1 path) ":/"))
+ ((or (string-match "^//\\([a-z]\\)\\(/.*\\)" path)
+ (string-match "^/cygdrive/\\([a-z]\\)\\(/.*\\)" path))
+ (concat (match-string 1 path) ":" (match-string 2 path)))
+ ((string-match "^(/cygdrive/./\\|//" path)
+ ;; if previous regexps couldn't handle it, this is severe error.
+ (error "Invalid path format for cygwin %s" path))
+ ((string-match "[\\]" path)
+ (error "Invalid backslash path %s" path))
+ ((string-match "^/" path)
+ (w32-cygwin-mount-table-path-to-dos path))
+ (t
+ path)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun w32-cygwin-dos-path-to-cygwin (path)
+ "Convert dos PATH to cygwin path.
+Be sure to call `expand-file-name' before you pass PATH to the function."
+ (cond
+ ((string-match "\\([a-z]\\):[\\/]\\(.*\\)" path)
+ (let ((drive (format "/cygdrive/%s/" (match-string 1 path)))
+ (rest-path (match-string 2 path)))
+ (if (not rest-path)
+ drive
+ (w32-cygwin-mount-table-dolist
+ ;; mount => ("/tmp" . "c:\\temp")
+ ;; variables `cygwin' and `dos' are part of the macro
+ (when (or (string-match (concat "^" dos "\\(.*\\)") path)
+ (string-match (concat "^"
+ ;; Convert to / slashes
+ (expand-file-name dos)
+ "\\(.*\\)") path))
+ (when (match-string 1 path)
+ (setq path (match-string 1 path))
+ (setq cygwin (concat cygwin path)))
+ ;; Convert to forward slashes
+ (return (subst-char-in-string ?\\ ?/ cygwin)))))))
+ (t
+ (error "Cannot convert to cygwin. path is not absolute %s" path))))
+
+;; Make it defconst, so that rereading tinylibb.el will always update
+;; the value. If Cygwin is changed, reloading this library.
+
+(setq w32-cygwin-mount-table
+ (if (ti::win32-p) ;; (memq system-type '(ms-dos windows-nt))
+ (w32-cygwin-mount-table)))
+
+(defsubst w32-expand-file-name-for-cygwin (path)
+ "Expand PATH to Cygwin notation if Cygwin is present."
+ (when (and (string-match "^[A-Za-z]:" path)
+ (ti::win32-cygwin-p))
+ (setq path (w32-cygwin-dos-path-to-cygwin path)))
+ path)
+
+(defsubst w32-expand-file-name-for-emacs (path)
+ "Expand PATH to DOS Emacs notation if PATH is in Cygwin notation."
+ (cond
+ ((and (ti::emacs-type-win32-p)
+ (string-match "^/cygdrive" path))
+ (setq path (w32-cygwin-path-to-dos path)))
+ ((and (ti::emacs-type-cygwin-p)
+ (string-match "^[a-zA-Z]:" path))
+ (setq path (w32-cygwin-dos-path-to-cygwin path))))
+ path)
+
+;;}}}
+
+;;; ########################################################## &custom ###
+
+;;{{{ custom
+
+;;; 2000-03-20
+;;; - This code is beginning to be obsolete now when Newest Emacs is 21.2
+;;; custom.el.
+;;; - This code does nothing if custom.el is present, so let it be here.
+
+(eval-and-compile
+ (cond
+ ((string-match "2[0-9]\\." (emacs-version))
+ (require 'custom)) ;Out of the box
+ (t ;Well, this is old Emacs - lot of work
+ (let* ((list load-path)
+ dir
+ try
+ path)
+ (cond
+ ;; ..................................................... no custom ...
+ ;; The reason why newest custom.el does not work in prior releases is the
+ ;; new bacquote macro syntax it uses. It needs new emacs lisp parser to
+ ;; read the macros.
+ ;;
+ ((or (and (ti::emacs-p)
+ (< emacs-minor-version 34))
+ (and (eq 19 (ti::xemacs-p))
+ (< emacs-minor-version 15)))
+ ;; This emacs is too old for new custom. Emulate it.
+ (defmacro defgroup (&rest args) nil)
+ (defmacro defcustom (var value doc &rest args)
+ (` (defvar (, var) (, value) (, doc)))))
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. custom maybe . .
+ (t
+ ;; Explanation: When I say (require 'custom) in -batch byte
+ ;; compile; and the load-path HAD my private ~/elisp at front,
+ ;; but it still loaded old custom.elc from XEmacs 19.14 distribution.
+ ;;
+ ;; Why? Don't know. That's why we load it manually here.
+ (while (and (null path) ;Where it is?
+ (setq dir (car list)))
+ (setq try
+ (if (string-match "/$" dir)
+ (concat dir "custom.el")
+ (concat dir "/custom.el")))
+ (when (file-exists-p try)
+;;; (message (format "tinylibm: ** Using custom from [%s]" try))
+ (setq path (file-name-directory try)))
+ (setq list (cdr list)))
+ ;; ............................................... load new custom ...
+ (condition-case ()
+ (progn
+ ;; The new custom won't work in .el format, it must be
+ ;; loaded in .elc format.
+ (unless (featurep 'custom)
+ (load (concat path "custom.elc"))))
+ (error
+ (message "tinylibm: ** Couldn't find custom.elc [compiled version]")))
+ ;; Check few things, what this custom.elc provided.
+ ;; This is internal information to debug things
+ ;;
+ (message "tinylibm: ** internal info: Custom [%s] declare [%s]"
+ (if (featurep 'custom)
+ "t"
+ "nil")
+ (if (fboundp 'custom-declare-variable)
+ "t"
+ "nil"))
+ (cond
+ ((and (featurep 'custom)
+ (fboundp 'custom-declare-variable))
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. . case 1 ..
+ ;; 19.14 includes a very old custom.el, and it shouldn't be used
+ ;; any more.
+ ;;
+ ;; custom-XE19.14 : custom.el::customize()
+ ;; custom-1.96 : cus-edit.el::(defun customize (symbol)
+ ;; custom-1.9956 : cus-edit.el:::customize()
+ ;; cus-edit.el::customize-group (group)
+ (cond
+ ((and (null (ti::function-args-p 'customize))
+ (not (fboundp 'customize-group)))
+ (message "\
+tinylibm.el: ** [Ignore, Compilation is still going fine...]
+ ** Hm, loading custom didn't go quite right. Reasons:
+ ** a. You have too old custom.el library, because I can't
+ ** see `customize' function to take ONE argument.
+ ** Be sure to have newest custom.el and cus-edit.el
+ ** b. Your load-path is set so that the old custom.el
+ ** was loaded."))
+ (t
+ ;; The new 1.9956 Custom.el produces warning for defcustom
+ ;; variables not beeing defined. This code is only for
+ ;; 19.34 and won't work anywhere else.
+ ;;
+ (if (string-match
+ "19.2[0-9]\\|19.3[0-3]\\|19.1[0-4]"
+ (emacs-version))
+ (message "\
+ ** ...But you don't have [X]Emacs 19.34, 19.15, or 20+
+ ** That's why you see lot of undefined variables.
+ ** It's a byte compiler issue, nothing to worry about.")
+ ;; This is part of bytecomp.el in 20.1:
+ ;;
+ (put 'custom-declare-variable 'byte-hunk-handler
+ 'byte-compile-file-form-custom-declare-variable)
+ (defun byte-compile-file-form-custom-declare-variable (form)
+ (if (memq 'free-vars byte-compile-warnings)
+ (setq byte-compile-bound-variables
+ (cons (nth 1 (nth 1 form))
+ byte-compile-bound-variables))) form))))
+
+ nil)
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. . case 2 ..
+ (t
+ (unless (string-match "19.2[0-9]\\|19.3[0-3]\\|19.1[0-4]"
+ (emacs-version))
+ (message "\
+tinylibm.el: ** Too old custom.el; You should upgrade your Emacs."))
+ ;; We have the old custom-library, hack around it.
+ (defmacro defgroup (&rest args) nil)
+ (defmacro defcustom (var value doc &rest args)
+ (` (defvar (, var) (, value) (, doc))))))))))))
+
+;;}}}
+
+;;; ################################################### &byte-optimize ###
+
+;;{{{ misc
+
+(when (and nil ;Disabled now
+ (null (get 'concat 'byte-optimizer)))
+ (put 'concat 'byte-optimizer 'tinylibb-byte-optimize-concat)
+
+ ;; Like `concat', but this macro expands to optimized form.
+ ;; Many times you want to divide complex regexps on separate lines like
+ ;; this
+ ;; (looking-at (concat
+ ;; ;; Comment
+ ;; \"regexp-1\"
+ ;; ;; Comment
+ ;; \"regexp-2\"
+ ;; ))
+ ;;
+ ;; This is perfectly good way, but won't be optimized in any way:
+ ;; The compiled version contains `concat' command and separate strings.
+ ;;
+ ;; This optimized `concat' macro will expand the ARGS to single string
+ ;; "regexp-1regexp-2\ if they all are strings.
+ ;; In other cases it expands to normal `concat' call.
+ ;;
+ ;; (defmacro concat-macro (&rest args)
+ ;; (if (every 'stringp args)
+ ;; (apply 'concat args)
+ ;; (cons 'concat args)))
+ ;;
+
+ (defun tinylibb-byte-optimize-concat (form)
+ (let ((args (cdr form))
+ (constant t))
+ (while (and args constant)
+ (or (byte-compile-constp (car args))
+ ;; Stop there
+ (setq constant nil))
+ (setq args (cdr args)))
+
+ (if constant
+ (eval form)
+ form))))
+
+;;}}}
+;;{{{ Version
+
+;;; ......................................................... &version ...
+
+(defconst tinylibb-version
+ (substring "$Revision: 2.73 $" 11 15)
+ "Latest version number.")
+
+(defconst tinylibb-version-id
+ "$Id: tinylibb.el,v 2.73 2007/05/01 17:20:45 jaalto Exp $"
+ "Latest modification time and version number.")
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylibb-version (&optional arg)
+ "Show version information. ARG will instruct to print message to echo area."
+ (interactive "P")
+ (ti::package-version-info "tinylibb.el" arg))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylibb-submit-bug-report ()
+ "Submit bug report."
+ (interactive)
+ (ti::package-submit-bug-report
+ "tinylibb.el"
+ tinylibb-version-id
+ '(tinylibb-version-id)))
+
+;;}}}
+
+;;; tinylibb.el ends here
--- /dev/null
+;;; tinylibck.el --- Library to (c)onvert (k)eybindings for XEmacs or Emacs
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 1996-2007 Jari Aalto
+;; Keywords: tools
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program, call M-x ti::ck-version.
+;; Look at the code with folding.el
+
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;; ....................................................... &t-install ...
+;; Put this file on your Emacs-Lisp load path, add following into your
+;; ~/.emacs startup file. This must be the very first entry before
+;; any keybindings take in effect.
+;;
+;; (require 'tinylibck)
+;;
+;; You can also use the preferred way: autoload
+;;
+;; (autoload 'ti::ck-advice-control "tinylibck")
+;;
+;; And when you need conversion you wrap the code with calls:
+;;
+;; (ti::ck-advice-control) ;; ON
+;; <key definitions>
+;; (ti::ck-advice-control 'disable) ;; OFF
+;;
+;; Remember that you DON'T LEAVE THIS PACKAGE ON. Make sure the 'disable
+;; is the last thing you do. It disables the package and makes sure your
+;; other emacs packages work properly
+;;
+;; If you have any questions, use this function
+;;
+;; M-x ti::ck-submit-feedback
+
+;;}}}
+;;{{{ Documentation
+
+;; ..................................................... &t-commentary ...
+
+;;; Commentary:
+
+;;
+;; Preface
+;;
+;; This file tries to overcome differencies between Emacs and XEmacs
+;; keybinding. Package was developed at the time when there was big
+;; differences between Emacs and XEmacs key bindings. This file is in
+;; fact "library" and propably interests only lisp programmers that
+;; want to make some old package, that has Emacs specific bindings, to
+;; work in XEmacs (or vice versa).
+;;
+;; Emacs 19.30+ note
+;;
+;; Newer Emacs release now supports XEmacs styled bindings.
+;; You can write
+;;
+;; (local-set-key [(control meta up)] 'ignore)
+;;
+;; and it should work both in XEmacs and Emacs. If all your keybindins
+;; are like that and you don't use Emacs lower than 19.30, then you
+;; don't need this package.
+;;
+;; Putting your key definitions to separate file
+;;
+;; You should separate all you keybindings to one file,
+;; do not stuff all your emacs definitions in one huge ~/.emacs,
+;; but instead use some basic structure like this:
+;;
+;; ~/.emacs -- the main; points to ~/rc/emacs-rc.el
+;; ~/rc/emacs-kbd.el -- All the keybindinds
+;; ~/rc/emacs-vc.el -- vc settings and modifications
+;; ~/rc/emacs-gnus.el -- gnus customization
+;; ..
+;;
+;; You can load your other initialize files from .emacs with `load'
+;; command. Suppose you have Emacs keybinding startup file; which you
+;; want to make compatible with XEmacs too. The reason why you should
+;; use `ti::ck-maybe-activate' is that, it can determine your emacs
+;; version and decide when the converter is needed and when not.
+;;
+;; ;; at the beginning of keybindings, you add these
+;;
+;; (require 'tinylibm)
+;; (autoload 'ti::ck-advice-control "tinylibck")
+;;
+;; (ti::ck-maybe-activate 'xemacs-mouse)
+;; (load "~/rc/emacs-rc-keys") ;; All XEmacs styled bindings
+;; (ti::ck-maybe-activate 'xemacs-mouse 'disable)
+;;
+;; ;; End of example
+;;
+;; Some lowlevel explanation
+;;
+;; If you're in Emacs, you use X-event bindings like this
+;;
+;; (global-set-key [C-up] 'ignore)
+;;
+;; Unfortunately, this does not work in XEmacs, but using the
+;; conversion function before the definition, it does.
+;;
+;; (global-set-key (ti::ck-do [C-up]) 'ignore)
+;;
+;; Now the current Emacs version gets the right keybinding,
+;;
+;; for Emacs it returns --> [C-up]
+;; for XEmacs it returns --> '(control up)
+;;
+;; You can also use the XEmacs keybinding, since the conversion goes
+;; both ways. Having the following setting:
+;;
+;; (global-set-key (ti::ck-do '(control up)) 'ignore)
+;;
+;; it converts this to suitable form depending on the current Emacs
+;; in use.
+;;
+;; About advices
+;;
+;; So that you don't have to go and add that 'ti::ck-do' call for
+;; every keybinding, the key binding functions have been adviced.
+;; The conversion is done transparently and no chnages are
+;; needed in files were keys are bound.
+;;
+;; About debugging
+;;
+;; If you suspect any weird behavior in your emacs while
+;; this package is loaded, you should check that the `ti::ck-:debug'
+;; is turned on. (`M-x' `ti::ck-debug-toggle')
+;;
+;; The buffer `ti::ck-:debug-buffer' constantly records any conversion
+;; actions and you can find the problems quickly. Please send the
+;; supicious/false conversion lines to the maintainer of this package
+;; and if possible, tell how the conversion should go in your opinion.
+;;
+;; I'd recommend that you keep the debugging permanently on, because
+;; if problems arise afterwards and if the debug were off, there is
+;; no way to tell what went wrong in what command.
+;;
+;; Important; when you have problems, increase
+;;
+;; ti::ck-:debug-buffer-size
+;;
+;; immediately to some arbitrary big value so that you get all the
+;; conversions recorded.
+;;
+;; Known limitations
+;;
+;; This package tries to do its best to make the conversion, but
+;; sometimes it is just impossible. For example the following
+;; case is beyond of this package. In Emacs you can define
+;;
+;; (define-key xxx-mode-map [?\C-`] 'some-function)
+;; ^^^^^^^
+;;
+;; But when your're in XEmacs and you try to do the same, it gives
+;; error although tinylibck is currently active. The reason is that lisp
+;; intepreter never actually passes key "?\C-`" to `define-key'
+;; but it actually evaluates the vector in place to an integer value
+;; and sends that to `define-key' function . The call actually is
+;; seen in Emacs like this:
+;;
+;; (define-key xxx-mode-map [4194400] 'some-function)
+;; ^^^^^^^^^in HP-UX 9.05
+;;
+;; And in XEmacs it is evaluates to this:
+;;
+;; (define-key xxx-mode-map [0] 'xxx-tab-backward)
+;;
+;; The code "0" appears, because XEmacs doesn't know Emacs "?\C-`".
+;; You should write [(control ?\`)] for XEmacs and it would work ok.
+;; Be aware of this limitation if you plan to use Emacs styled
+;; bindings. Alternatively, you can tell that you that some
+;; particular piece of code has been written by using XEmacs style.
+;; (Wouldn't you want to you use it all the time in Emacs...)
+;;
+;; ;; This is Emacs file.
+;; (require 'tinylibck) ;Convert keys
+;; (ti::ck-advice-control) ;turn it on
+;; ;;
+;; (define-key tinytab-mode-map [(control ?\`)] 'tinytab-tab-backward)
+;; ;; And other similar keybindings ...
+;; ;; ..
+;; (ti::ck-advice-control 'disable) ;don't leave it on
+;;
+;; Thank you
+;;
+;; Vladimir Alexiev <vladimir@cs.ualberta.ca>
+;; Presented initial idea of the conversion process.
+;; Commented how the conversion should go in XEmacs.
+;;
+;; Stephen Eglen <stephene@cogs.susx.ac.uk>
+;; Stephen had the patience to send bug reports from XEmacs 19.12 and
+;; test new versions of tinylibck.el
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+;;{{{ setup: require
+
+;;; ......................................................... &require ...
+
+(eval-when-compile
+ (require 'cl)
+ (require 'advice))
+
+(eval-and-compile
+ ;; Don't require lib package unnecessarily
+ (autoload 'ti::package-version-info "tinylib")
+ (autoload 'ti::package-submit-feedback "tinylib"))
+
+;;}}}
+
+;;{{{ setup: -- private variables
+
+(defvar ti::ck-:load-hook '(ti::ck-advice-control)
+ "*Hook run when file has been loaded.")
+
+(defconst ti::ck-:xemacs-flag (string-match "XEmacs" (emacs-version))
+ "Non-nil means XEmacs is detected.")
+
+(defconst ti::ck-:emacs-minor
+ (if (boundp 'emacs-minor-version)
+ emacs-minor-version 0)
+ "Emacs minor version or 0 if cannot detect one.")
+
+(defconst ti::ck-:advice-re "^ti::ck-keybind"
+ "Advice REGEXP.")
+
+(defvar ti::ck-:this-command nil
+ "Private. Current advice command.")
+
+;; To prevent buffer growing too much
+;;
+(defvar ti::ck-:debug-buffer-size 500
+ "Clear the `ti::ck-:debug-buffer' if line count exceed this value.")
+
+(defvar ti::ck-:debug-buffer "*ti::ck-debug*"
+ "Debug buffer for key binding commands.")
+
+;;}}}
+;;{{{ setup: -- user
+
+;;; ........................................................ &v-public ...
+;;; User configurable, but in general you don't need to touch this
+;;; section.
+
+(defvar ti::ck-:debug nil
+ "*Turn on/off key conversion debugging.")
+
+(defvar ti::ck-:keep-next-symbol-together
+ '("kp")
+ "*Keep SYMBOL and next key bind definition together.
+When this string is found from key binding definition, it is
+not a stand alone event name, but only part of it. After reading the next
+token, the X-event has been qualified.
+
+Eg. `kp' is a prefix for keypad X-event symbols, so we actually mean
+one key when we say 'kp-tab' and not two separate events like `kp' and `tab'.
+
+Format:
+ '(STRING-SYMBOL
+ STRING-SYMBOL
+ ..)")
+
+(defconst ti::ck-:key-table
+ '((A . alt)
+ (C . control)
+ (H . hyper)
+ (S . shift)
+ (s . super)
+ (M . meta)
+ (mouse-1 . button1)
+ (mouse-2 . button2)
+ (mouse-3 . button3)
+ (down-mouse-1 . button1up)
+ (down-mouse-2 . button2up)
+ (down-mouse-3 . button3up))
+ "*Key bind modifier mappings from Emacs to XEmacs.
+This is a primitive table from where the complex keybindings are
+derived, eg you don't put following entry to this table:
+
+ (C-M-mouse-1 . (control meta button1))
+
+Because it can be already contructed from the primitives.
+If you have a need to change this table, please contact maintainer.
+
+Format:
+'((EMACS-MODIFIER . XEMACS-MODIFIER)
+ (EMACS-MODIFIER . XEMACS-MODIFIER)
+ ..)")
+
+;;}}}
+;;{{{ setup: -- version
+
+;;; ......................................................... &version ...
+
+(defvar ti::ck-:version-id
+ "$Id: tinylibck.el,v 2.39 2007/05/07 10:50:07 jaalto Exp $"
+ "Full program version ID string.")
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::ck-version (&optional arg)
+ "Version information. With ARG, print briefly."
+ (interactive "P")
+ (ti::package-version-info "tinylibck.el" arg))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::ck-submit-feedback ()
+ "Submit suggestions, error corrections, impressions, anything..."
+ (interactive)
+ (ti::package-submit-feedback "tinylibck.el"))
+
+;;}}}
+;;{{{ misc, debug
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro ti::ck-do-p (arg)
+ "Check if conversion is needed. ARG is the key definition."
+ (` (not (stringp (, arg))))) ;pass "" string bindings as is
+
+;;; ----------------------------------------------------------------------
+;;; - Just for load hook
+;;;
+(defun turn-on-ti::ck-debug ()
+ "Turn on debug."
+ (interactive)
+ (ti::ck-debug-toggle 1))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun ti::ck-debug-toggle (&optional arg)
+ "Turn debug on or off with ARG. See buffer `ti::ck-:debug-buffer'."
+ (interactive)
+ (cond
+ ((eq 1 arg)
+ (setq ti::ck-:debug t))
+ ((memq arg '(0 -1))
+ (setq ti::ck-:debug nil))
+ (t
+ (setq ti::ck-:debug (not ti::ck-:debug))))
+ (if (interactive-p)
+ (message (concat "Debug " (if ti::ck-:debug "on" "off")))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::ck-debug-write (str)
+ "Record STR to debug buffer."
+ (let* ((buffer (get-buffer-create ti::ck-:debug-buffer)))
+ (with-current-buffer buffer
+ (if (> (count-lines (point-min) (point-max))
+ ti::ck-:debug-buffer-size)
+ (erase-buffer))
+ (goto-char (point-max))
+ (insert str))))
+
+;;}}}
+;;{{{ advice
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::ck-advice-control (&optional disable verb)
+ "Install advices or optionally DISABLE them. VERB."
+ (interactive "P")
+ (let* ((funcs '(global-set-key
+ local-set-key
+ define-key))
+ (re ti::ck-:advice-re)
+ (verb (or verb (interactive-p)))
+ func)
+ (while funcs
+ (setq func (car funcs))
+ (ignore-errors
+ (if disable
+ (ad-disable-advice func 'any re) ;;clear flag
+ (ad-enable-advice func 'any re))
+ (ad-activate func)) ;;change state
+ (setq funcs (cdr funcs)))
+
+ (if verb
+ (if disable
+ (message "tinylibck Advices disabled.")
+ (message "tinylibck Advices activated.")))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defadvice global-set-key (before ti::ck-keybind-converter dis)
+ "XEmacs and Emacs emulation. See function `ti::ck-do' for full story."
+ (setq ti::ck-:this-command 'global-set-key)
+ (if (ti::ck-do-p (ad-get-arg 0))
+ (ad-set-arg 0 (ti::ck-do (ad-get-arg 0)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defadvice local-set-key (before ti::ck-keybind-converter dis)
+ "XEmacs and Emacs emulation. See function `ti::ck-do' for full story."
+ (setq ti::ck-:this-command 'local-set-key)
+ (if (ti::ck-do-p (ad-get-arg 0))
+ (ad-set-arg 0 (ti::ck-do (ad-get-arg 0)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defadvice define-key (before ti::ck-keybind-converter dis)
+ "XEmacs and Emacs emulation. See function`ti::ck-do' for full story."
+ (setq ti::ck-:this-command 'define-key)
+ (let* ((arg (ad-get-arg 1)))
+ (when (ti::ck-do-p arg)
+ (if (and (vectorp arg)
+ (length arg) ; "[0]"
+ (eq 0 (elt arg 0)))
+ (error ; otw user doesn't know what
+ (concat ; going on.. barf immediately
+ "define-key/tinylibck.el: "
+ "Vector contains zero. Did you use Emacs styled \"[?\\C-`]\" "
+ "Wich can't be converted? Use equivalent [(control ?\\`)] "
+ "instead which works for both XEmacs and Emacs. "
+ "See comments in tinylibck.el for more.")))
+ (ad-set-arg 1 (ti::ck-do (ad-get-arg 1))))))
+
+;;; ----------------------------------------------------------------------
+;;; (ad-unadvise 'ti::ck-do)
+;;;
+(defadvice ti::ck-do (around ti::ck-debug act)
+ "Debug filter. Record command, input/output values."
+ (cond
+ ((eq nil ti::ck-:debug)
+ ad-do-it)
+ (t
+ (ti::ck-debug-write
+ (format
+ "\n%-15s %-25s >> "
+ (or (prin1-to-string ti::ck-:this-command) "")
+ (or (prin1-to-string (ad-get-args 0)) "")))
+
+ ad-do-it
+ (ti::ck-debug-write (concat (prin1-to-string ad-return-value))))))
+
+;;}}}
+;;{{{ conversions
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::ck-get-key-code-string (str)
+ "Convert STR A -C -k --> ?\\A -\\C -k."
+ (let* ((ret "?\\")
+ (len (length str))
+ (i 0)
+ case-fold-search
+ ch
+ next)
+ (while (< i len)
+ (setq ch (aref str i)
+ next (if (< (1+ i)
+ len)
+ (aref str (1+ i))))
+ (setq ret
+ (concat
+ ret
+ (if (and (eq ch ?-)
+ ;; A-S-a --> \A-\S-a, but
+ ;; A-s --> \A-s
+ (and next
+ (string-match "[A-Z]"
+ (char-to-string next))))
+ "-\\"
+ (char-to-string ch))))
+ (setq i (1+ i)))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;; - This is kinda faking Emacs, but since there is _no_ other way to
+;;; find the integer code for vector [?\A-a], we have to make Emacs
+;;; tell it to us.
+;;;
+(defun ti::ck-get-key-code (simple-key-sequence)
+ "Find out the integer value for SIMPLE-KEY-SEQUENCE, like S-a."
+ (let* (lisp-mode-hook ;don't run any hooks while here
+ (buffer (get-buffer-create "*tmp*"))
+ (modes '(lisp-mode
+ emacs-lisp-mode
+ lisp-interaction-mode))
+ ret)
+ ;; XEmacs doesn't have this variable, Quiet ByteCompiler warning.
+ ;; This is no-op
+ (if lisp-mode-hook
+ (setq lisp-mode-hook nil))
+ (setq simple-key-sequence
+ (ti::ck-get-key-code-string simple-key-sequence))
+ (save-excursion
+ (set-buffer buffer)
+ (erase-buffer)
+ ;; Don't just always execute (lisp-mode), since
+ ;; setting up major mode may be time consuming.
+ (if (not (memq major-mode modes))
+ (lisp-mode))
+ (insert "[" simple-key-sequence "]")
+ ;; This spits out the integer number
+ (eval-last-sexp 1)
+ (beginning-of-line)
+ (when (looking-at ".*\\[\\([0-9]+\\)")
+ (setq ret
+ (string-to-int
+ (buffer-substring (match-beginning 1) (match-end 1)))))
+
+ ret)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;; (ti::ck-gnu2xe-vector [C-kp-tab])
+;;;
+;;; [C-kp-tab] --> [(control kp-tab)]
+;;; [M-f1 C-f2] --> [(meta f1) (control f2)]
+;;; [?\e delete] --> [(meta delete)] , we suppose meta is same as ESC.
+;;;
+(defun ti::ck-gnu2xe-vector (vec)
+ "Convert Emacs VEC bindings to XEmacs style."
+ (let* ((table ti::ck-:key-table)
+ (keep-list ti::ck-:keep-next-symbol-together)
+ (i 0)
+ len
+ x
+ elt
+ str
+ pos
+ aset-pos
+ list
+ new-vec
+ gather-flag
+ gather-str)
+ (setq len (length vec) elt (elt vec 0))
+ (setq i 0
+ aset-pos 0)
+ (setq new-vec (make-vector len nil)) ;put results here
+ ;; This is for due to ESC key in commands like:
+ ;; Emacs [?\e ?k] --> XEmacs [(meta k)]
+ (cond
+ ((and (eq 27 elt) ;first element is ?\e
+ (symbolp (elt vec 1)))
+ ;; Put elements 0 and 1 together "?\e delete" --> "M-delete"
+ (setq str (concat "M-" (symbol-name (elt vec 1))))
+ (aset vec 1 (intern str))
+ (setq i 1) ;start here, skip item 0
+ (setq new-vec (make-vector (1- len) nil)))
+ ((and (eq 27 elt) ;first element is ?\e
+ (eq 2 len))
+ (setq str (concat "M-" (char-to-string (elt vec 1))))
+ (aset vec 1 (intern str))
+ (setq i 1) ;start here, skip item 0
+ (setq new-vec (make-vector (1- len) nil))))
+ (while (< i len)
+ (setq x (elt vec i))
+ (cond
+ ;; [?\C-x mouse-1] ==> [(control x) (button1)]
+ ((and (integerp x)
+ (< x 27))
+ (setq x
+ (list
+ 'control
+ ;; ?\C-a -- "a"
+ (intern (char-to-string (+ 96 x))))))
+ ((integerp x) ; other [?\C-z ...]
+ nil)
+ ((symbolp x)
+ (setq str (symbol-name x)) ;; [C-up] => "C-up"
+ (setq list nil)
+ (while str
+ (if (or (string-match "^\\(down-\\)?mouse-[1-3]" str)
+ (string-match "^[^-]+" str))
+ (progn
+ (setq pos (match-end 0))
+ (setq elt (substring str 0 pos))
+
+ (if (< pos (length str))
+ (setq str (substring str (1+ pos)))
+ (setq str nil)))
+ ;; No more "-" characters in string
+ (setq elt str str nil))
+ ;; There are certain X symbols that should be kept together
+ ;; [C-kp-tab] --> (control kp_tab) and not (control kp tab)
+ (cond
+ ((member elt keep-list)
+ (setq gather-str elt gather-flag 0 elt nil))
+
+ ((stringp gather-str)
+ (setq gather-flag (1+ gather-flag))
+ (if (eq 1 gather-flag)
+ (setq elt (concat gather-str "_" elt)
+ gather-str nil
+ gather-flag nil)
+ (setq elt gather-str
+ gather-flag nil
+ gather-str nil))))
+ (cond
+ (elt
+ (setq elt (intern elt))
+ (if (setq x (assq elt table))
+ (setq elt (cdr x)))
+ (setq list (append list (list elt))))))
+ (setq x list)))
+
+ (aset new-vec aset-pos x)
+ (setq i (1+ i)
+ aset-pos (1+ aset-pos)))
+ new-vec))
+
+;;; ----------------------------------------------------------------------
+;;; [(meta f1) (control f2)] --> [M-f1 C-f2]
+;;;
+(defun ti::ck-xe2gnu-vector (vec)
+ "Convert XEmacs VEC to Emacs."
+ (let* ((i 0)
+ len
+ sym
+ x
+ new-vec)
+ (setq len (length vec))
+ (setq new-vec (make-vector len nil))
+ (while (< i len)
+ (setq x (elt vec i))
+ (cond
+ ((integerp x) ;[?\C-z ...]
+ nil) ;as is
+ ((and (symbolp x)
+ (setq sym (symbol-name x))
+ (eq 1 (length sym))) ;one character
+ ;; In XEmacs, it's valid to have [f1 a], where 'a' means character
+ ;; a. In Emacs you'd need ?a for that.
+ ;; => as char
+ (setq x (string-to-char sym)))
+ ((listp x)
+ (setq x (ti::ck-xe2gnu-list x))))
+ (aset new-vec i x)
+ (setq i (1+ i)))
+ new-vec))
+
+;;; ----------------------------------------------------------------------
+;;; (meta f1) --> M-f1 symbol, or '(alt a) --> 120345 some keycode integer.
+;;;
+(defun ti::ck-xe2gnu-list (list)
+ "Convert XEmacs bind LIST to emacs."
+ (let* ((table ti::ck-:key-table)
+ item
+ elt
+ str
+ padd
+ ret)
+ (setq str "")
+ (while list
+ (setq elt (car list))
+ (setq padd (if (cdr list)
+ "-"
+ ""))
+ (cond
+ ((setq item (rassq elt table))
+ (setq elt (symbol-name (car item))))
+ ((integerp elt)
+ (setq elt (char-to-string elt)))
+ ((and (stringp str)
+ (symbolp elt)) ;keep it as string, see concat
+ (setq elt (symbol-name elt))))
+
+ (setq str (concat str elt padd))
+ (setq list (cdr list)))
+ (cond
+ ((string= "" str)
+ nil)
+ ((and (not (string-match "mouse" str))
+ ;; "A-a" "A-C-k" "?\C-`"
+ (string-match "-.$\\|^[?][\\]?" str))
+ (setq ret (ti::ck-get-key-code str)))
+ (t
+ (setq ret (intern str))))
+ ret))
+
+;;}}}
+;;{{{ main
+
+;;; ----------------------------------------------------------------------
+;;; - 20 Apr 1996, Idea by Vladimir Alexiev <vladimir@cs.ualberta.ca>
+;;; - 22 Apr 1996, Reprogrammed by Jari Aalto [jari]
+;;;
+;;;###autoload
+(defun ti::ck-do (key &optional xe)
+ "Transform key binding to XEmacs or Emacs in current environment.
+on current emacs. This enables you to have same key binding file
+for both emacs versions. You can write key bindings either in XEmacs
+or Emacs style.
+
+ In Emacs : (ti::ck-do '(meta up)) --> [M-up]
+ In XEmacs: (ti::ck-do [M-up]) --> '(meta up)
+
+This function does the conversion only if it needs to, and returns
+immediately if no conversion is needed. This should minimise performance
+penalty.
+
+Input:
+ KEY key sequence
+ XE flag. If this is nil, then Emacs env. is assumed. However
+ `ti::ck-:xemacs-flag' is obeyed if it is non-nil.
+ If non-nil, then XEmacs env. is assumed and conversion to
+ XEmacs like bindings are done."
+ (let (
+ ;; For greater speed this is read from variable
+ ;; and not dynamically for every call.
+ (xe (or xe ti::ck-:xemacs-flag))
+ ret
+ vec
+ D) ;debug
+ (cond
+ ((and (not xe) ; in Emacs
+ (vectorp key)) ; [C-up]
+ (cond
+ ((and (listp (elt key 0))
+ (< ti::ck-:emacs-minor 30)) ;19.30 supports [(control up)]
+ (setq D "1 xe2gnu-vector")
+ (setq ret (ti::ck-xe2gnu-vector key)))
+ (t
+ (setq D "1 as is")
+ (setq ret key)))) ; return "as is"
+ ((and (not xe) ; '(control f1) --> C-fi
+ (listp key))
+ (setq D "2 ti::ck-xe2gnu-list")
+ (setq vec (make-vector 1 nil))
+ (setq ret (ti::ck-xe2gnu-list key))
+ (aset vec 0 ret)
+ (setq ret vec))
+ ((and xe
+ (or (listp key) ; '(control up) in XEmacs
+ (symbolp key) ; 'button2
+ (and (vectorp key) ; [(button2]) case...
+ (listp (elt key 0)))))
+ (setq D "3")
+ (setq ret key)) ; return "as is"
+ ((and xe
+ (vectorp key)) ; [C-up] to XEmacs
+ (setq D "4 gnu2xe-vector")
+ (setq ret (ti::ck-gnu2xe-vector key))))
+
+ ;; Quiet XEmacs 19.14 ByteCompiler, This is no-op.
+ (if D
+ (setq D D))
+ ret))
+
+;;}}}
+
+(provide 'tinylibck)
+(run-hooks 'ti::ck-:load-hook)
+
+;;; tinylibck.el ends here
--- /dev/null
+;;; tinylibenv.el --- Library for environment check functions
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 2003-2007 Jari Aalto
+;; Keywords: extensions
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program, call M-x tinyliba-version.
+;; Look at the code with folding.el
+
+;; COPYRIGHT NOTICE
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;; ........................................................ &t-install ...
+;; DO NOT LOAD THIS FILE, but load the central library "m". It loads this
+;; file and backward compatible library "b"
+;;
+;; (require 'tinylibm)
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+;;{{{ code: Init
+
+(eval-when-compile
+ (require 'backquote)
+ (autoload 'executable-find "executable")
+ (autoload 'ti::directory-up "tinylib")
+
+ (if (not (or (boundp 'xemacs-logo)
+ (featurep 'xemacs)))
+ ;; Emacs function, but it's buried and not published.
+ (autoload 'w32-system-shell-p "w32-fns")
+ (unless (fboundp 'w32-system-shell-p)
+ ;; Emacs function => compatibility for XEmacs
+ (defun w32-system-shell-p (shell-name)
+ "Tinylib: Emacs an XEmacs compatibility."
+ ;; This is simplistic alternative if the original function
+ ;; is not available.
+ (string-match "cmdproxy"
+ (or shell-name "")))))
+
+ ;; defvar silences Byte Compiler
+ (defvar byte-compile-dynamic nil "") ;; Introduced in 19.29
+ (make-local-variable 'byte-compile-dynamic)
+ (setq byte-compile-dynamic t))
+
+(provide 'tinylibenv)
+
+;;}}}
+;;{{{ code: Macros, utility functions
+
+;; These are from SEMI::APEL::poe.el
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'defun-maybe 'lisp-indent-function 'defun)
+(defmacro defun-maybe (name &rest everything-else)
+ (when (or (not (fboundp name))
+ (and (fboundp name)
+ (string-match
+ "autoload"
+ (prin1-to-string
+ (symbol-function name)))))
+ (` (progn
+ (defun (, name) (,@ everything-else))
+ (put (quote (, name)) 'defun-maybe t)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'defsubst-maybe 'lisp-indent-function 'defun)
+(defmacro defsubst-maybe (name &rest everything-else)
+ (when (or (not (fboundp name))
+ (and (fboundp name)
+ (string-match
+ "autoload"
+ (prin1-to-string
+ (symbol-function name)))))
+ (` (progn
+ (defsubst (, name) (,@ everything-else))
+ (put (quote (, name)) 'defsubst-maybe t)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'defmacro-maybe 'lisp-indent-function 'defun)
+(defmacro defmacro-maybe (name &rest everything-else)
+ (when (or (not (fboundp name))
+ (and (fboundp name)
+ (string-match
+ "autoload"
+ (prin1-to-string
+ (symbol-function name)))))
+ (` (progn
+ (defmacro (, name) (,@ everything-else))
+ (put (quote (, name)) 'defmacro-maybe t)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro defalias-maybe (sym newdef)
+ "Make defalias SYM if it does not exist and NEWDEF exists."
+ (`
+ (when (and (not (fboundp (, sym)))
+ (fboundp (, newdef)))
+ (defalias (, sym) (, newdef)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro defconst-maybe (name &rest everything-else)
+ (or (and (boundp name)
+ (not (get name 'defconst-maybe)))
+ (` (or (boundp (quote (, name)))
+ (progn
+ (defconst (, name) (,@ everything-else))
+ (put (quote (, name)) 'defconst-maybe t))))))
+
+;;}}}
+;;{{{ Environment checks
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::xemacs-p (&optional version-string)
+ "Check if running XEmacs. Optionally at least VERSION-STRING.
+Tested string is like \"20.4\". Value t is returned if version
+is equal or greater than VERSION-STRING."
+ ;; `emacs-version' can't be modified, be bomb sure
+ (let ((case-fold-search t))
+ (when (string-match "xemacs" (emacs-version))
+ (if (or (boundp 'xemacs-logo)
+ (featurep 'xemacs)) ;Appeared in 20.2+
+ (cond
+ ((null version-string)
+ emacs-version)
+ ((not (string< emacs-version version-string))
+ emacs-version))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::emacs-p (&optional version-string)
+ "Check if running Emacs. Optionally at least VERSION-STRING.
+Tested string is like \"20.4\". Value t is returned if version
+is equal or greater than VERSION-STRING."
+ (let ((case-fold-search t))
+ (unless (string-match "xemacs" (emacs-version))
+ (cond
+ ((null version-string)
+ emacs-version)
+ ((not (string< emacs-version version-string))
+ emacs-version)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::emacs-type-cygwin-p ()
+ "Check if running Win32 Cygwin version."
+ (let ((case-fold-search t))
+ (string-match "cygwin" (emacs-version))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::emacs-type-win32-p ()
+ "Check if running native Win32 version of Emacs or XEmacs."
+ (and (ti::win32-p)
+ (not (ti::emacs-type-cygwin-p))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::emacs-type-unix-like-p ()
+ "Check if running Unix Emacs or Cygwin Emacs."
+ (or (not (ti::win32-p))
+ (ti::emacs-type-cygwin-p)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::emacs-version-number-as-string ()
+ "Emacs and XEmacs compatibility. Return plain version number string."
+ ;; Emacs: "19.34", XEmacs: "19.14 XEmacs Lucid".
+ ;; The regexp will work for both Emacs
+ (and (string-match "\\([0-9]+\\(\\.[0-9.]\\)+\\)" emacs-version)
+ (substring emacs-version
+ (match-beginning 1)
+ (match-end 1))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::emacs-version-number-as-string-major ()
+ "Return major version number string. 20.4.1 --> 20.4"
+ (and (string-match "^\\([0-9]+\\.[0-9]+\\)" emacs-version)
+ (substring emacs-version 0 (match-end 1))))
+
+;; Note: While Emacs would return 20.4.1 for version number,
+;; The installation directory is not emacs-20.4.1 but 20.4 for
+;; official releases.
+;;
+;; Win32: (getenv "emacs_dir"))
+;; emacs_dir is one of the variables that are taken from
+;; the registry and mapped into the environment during startup
+;; of the emacs binary.
+;;
+;; See also `invocation-directory', The directory in which the Emacs
+;; executable was found
+;;
+;; See also `data-directory' Directory of machine-independent files that
+;; come with GNU Emacs. These are files intended for Emacs to use while
+;; it runs.
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::emacs-install-root ()
+ "Return Emacs install ROOT by searching emacs version number from `load-path'."
+ (let ((regexp
+ (concat
+ ".*" (regexp-quote (ti::emacs-version-number-as-string-major))
+ "[.0-9]*"))
+ try
+ ret)
+ (dolist (elt load-path)
+ (when (and (stringp elt)
+ (string-match regexp elt)
+ (setq try (match-string 0 elt))
+ ;; load-path may contain whatever directories, but
+ ;; is it on disk too?
+ (file-directory-p (concat try "/lisp" )))
+ (setq ret try)
+ (return)))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::emacs-install-root-emacsen (binary)
+ "Search `exec-path' to find BINARY (emacs, xemacs) install root."
+ (let* ((bin (executable-find binary)))
+ (when bin
+ (ti::directory-up
+ (file-name-directory bin)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::os-check-linux-p ()
+ "Check if operating system is Linux."
+ (or (string-match "linux" (emacs-version))
+ (memq system-type '(gnu/linux))
+ ;; ... in case the above fails, this call is more expensive
+ (or (file-exists-p "/boot/vmlinuz")
+ (file-exists-p "/vmlinuz"))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::os-check-linux-like-p ()
+ "Check Operating system is Linux or If running under Cygwin Emacs."
+ (or (ti::os-check-linux-p)
+ (ti::emacs-type-cygwin-p)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::os-check-sunos-p ()
+ "Check Operating system is SunOS."
+ (or (string-match "sparc\\|sun\\|sunos\\|solaris" (emacs-version))
+ ;; ... in case the above fails
+ (file-directory-p "/vol/bin")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::os-check-hpux-p ()
+ "Check Operating system is HP-UX Unix."
+ (or (string-match "hpux\\|hppa" (emacs-version))))
+ ;; #todo: ... in case the above fails
+ ;; (file-directory-p "/what/to/test/here?")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::win32-p ()
+ "Check if running under Win32 system.
+NOTE: Running under Cygwin is not considered as Win32, use
+functions `ti::os-check-linux-like-p' or `ti::win32-cygwin-p'."
+ (cond
+ ((memq system-type '(ms-dos windows-nt))) ;; Emacs
+ ((fboundp 'console-type)
+ ;; Quiet Emacs byte compiler
+ (memq (funcall (symbol-function 'console-type))
+ '(win32 w32 mswindows)))
+ ((boundp 'window-system)
+ (memq (symbol-value 'window-system)
+ '(win32 w32 mswindows)))
+ ((error "Internal alert, contact maintainer of TinyLib."))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::win32-shell-p ()
+ "Check if shell filename is traditional win32 shell."
+ ;; Prevent loading w32-fns.el, which might cause trouble in Unix
+ (and (ti::win32-p)
+ (w32-system-shell-p (or shell-file-name ""))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::win32-nt-p ()
+ "Check windows NT/W2K/XP."
+ (when (ti::win32-p)
+ (or (and (fboundp 'w32-using-nt)
+ ;; - This function is in w32-fns.el
+ ;; - Hide the call from Byte Compiler that does not understand
+ ;; already checked `fboundp'
+ (funcall (symbol-function 'w32-using-nt)))
+ (let ((nt-root (getenv "systemroot")))
+ (and nt-root
+ (or (string-match "windows.*NT" (or (getenv "OS") "" ))
+ (file-exists-p
+ (concat
+ (file-name-as-directory nt-root)
+ "system32/cmd.exe"))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::win32-9x-p ()
+ "Check windows 9x."
+ (not (ti::win32-nt-p)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::win32-cygwin-p-1 (&optional use-no-cache)
+ "You should use `ti::win32-cygwin-p'. Optionally USE-NO-CACHE value."
+ (let (ret)
+ (cond
+ ((and (null use-no-cache)
+ (get 'ti::win32-cygwin-p 'cache-set))
+ (setq ret (get 'ti::win32-cygwin-p 'cache-value)))
+ (t
+ (put 'ti::win32-cygwin-p 'cache-set t)
+ (dolist (path exec-path)
+ ;; Sometimes there can be $PATH errors like "/bin::/sbin" and
+ ;; Emacs exec-path gets corrupted to read "/:/bin" etc. Fix those.
+ (when (and (stringp path)
+ (not (string-match "^[a-z]:" path))
+ (string-match ".*:" path))
+ (setq path (replace-match "" nil nil path)))
+ (when (and (stringp path)
+ ;; Many embedded programs do include *.dll, but
+ ;; not the whole cygwin suite. Search also typical
+ ;; cygpath.exe
+ (file-exists-p
+ (concat
+ (file-name-as-directory path) "cygwin1.dll"))
+ (file-exists-p
+ (concat
+ (file-name-as-directory path) "cygpath.exe")))
+ ;; The root directory is one DIR up from bin/cygwin1.dll
+ ;;
+ ;; 1) Drop the trailing slash ../bin
+ ;; 2) Go one directory up ..
+ ;;
+ ;; Leave a trailing slash, because the resulting
+ ;; directory may be in the worst case at C:/
+ ;; (which is NOT a recommended place for cygwin install)
+ ;;
+ (when (string-match "^\\(.*\\)[/\\]" path)
+ (setq path
+ (match-string 1 path))
+ (setq ret path)
+ ;; This is native Cygwin Emacs, not a Win32 version
+ ;; if path is empty: /bin => one up => ''
+ (when (string= ret "")
+ (setq ret "/"))
+ (put 'ti::win32-cygwin-p 'cache-value ret)
+ (return))))))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::win32-cygwin-p (&optional use-cache)
+ "Return path if cygwin1.dll is found from `exec-path'.
+ USE-CACHE is non-nil, retrieve cached value which is faster."
+ (and (ti::win32-p)
+ (ti::win32-cygwin-p-1)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::os-check-gnu-support-p ()
+ "Check if GNU tools are available in this system.
+at is, Linux and Cygwin qualifies."
+ (or (ti::os-check-linux-p)
+ (ti::win32-cygwin-p)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::win32-cygwin-binary-p (bin &optional use-cache)
+ "Check if program BIN is from Cygwin. The program must be an .exe
+ USE-CACHE is non-nil, retrieve cached value."
+ (let ((cygwin (ti::win32-cygwin-p))
+ path)
+ (when (and cygwin
+ (setq path (executable-find bin))
+ (string-match (regexp-quote cygwin) path))
+ path)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::emacs-debug-mode (&optional mode)
+ "Toggle XEmacs/Emacs debug on and off."
+ (interactive "P")
+ ;; The normal debug flag
+ (cond
+ ((null mode)
+ (setq debug-on-error (not debug-on-error)))
+ ((and (integerp mode)
+ (> mode 0))
+ (setq debug-on-error t))
+ (t
+ (setq debug-on-error nil)))
+ ;; Save state for later restoring
+ (when (boundp 'debug-ignored-errors)
+ (unless (get 'debug-ignored-errors 'tinyliba)
+ (put 'debug-ignored-errors 'tinyliba t)
+ (put 'debug-ignored-errors 'tinyliba-saved debug-ignored-errors)))
+ (cond
+ (debug-on-error
+ ;; Emacs 20. You want to see all errors when this variable is cleared.
+ (when (boundp 'debug-ignored-errors)
+ (set 'debug-ignored-errors nil))
+ (setq debug-on-error t)
+ ;; Must be nil, otherwise it get's on your nervers
+ ;; too much when yo hit C-g to interrupt inputs.
+ ;; This only exists in New emacs releases.
+ (if (boundp 'debug-on-quit)
+ (setq debug-on-quit nil))
+ (if (boundp 'debug-on-signal) ;; This must *not* be on!
+ (setq debug-on-signal nil))
+ (if (boundp 'stack-trace-on-error) ;; XEmacs
+ (set 'stack-trace-on-error t))
+ (message "TinyLib: Emacs debug is ON"))
+ (t
+ (when (boundp 'debug-ignored-errors)
+ (set 'debug-ignored-errors
+ (get 'debug-ignored-errors 'tinyliba-value)))
+ (if (boundp 'stack-trace-on-error) ;; XEmacs
+ (set 'stack-trace-on-error nil))
+ (message "TinyLib: Emacs debug is OFF"))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::turn-on-emacs-debug ()
+ "Turn on Emacs or XEmacs debug."
+ (interactive)
+ (ti::emacs-debug-mode 1))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::turn-off-emacs-debug ()
+ "Turn off Emacs or XEmacs debug."
+ (interactive)
+ (ti::emacs-debug-mode -1))
+
+;;}}}
+;;{{{ Other
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::file-version (file)
+ "Find 'Version:' tag from lisp FILE. Retun numric version string if any."
+ (let* ((lib (locate-library file))
+ (buffer (and lib (find-file-noselect lib)))
+ find-file-hooks
+ version)
+ (save-excursion
+ (if (null find-file-hooks) ;; No-op, byte compiler silencer
+ (setq find-file-hooks nil))
+ (set-buffer buffer)
+ (goto-char (point-min))
+ (if (re-search-forward
+ "^;+[ \t]+Version:[ \t]+\\(.+\\)" nil t)
+ (setq version (match-string 1)))
+ (kill-buffer buffer)
+ version)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::executable-find (program &optional type)
+ "Find PROGRAM, according to TYPE (default is 'cygwin). For example
+Windows includes program `ftp', but also Cygwin distribution includes
+program `ftp'. The one which is found depends on the order of paths in
+`exec-path'. In some case the wanted location could be either windows or
+Cygwin version, regardless of the path order.
+
+Input:
+
+ PROGRAM the name of the program (.exe not required)
+ TYPE [optional]
+ 'cygwin, which means that windows %SYSTEMROOT% is ignored.
+ 'win32, which means Cygwin root path and below are ignored."
+ (let* ((cygwin-root (ti::win32-cygwin-p))
+ (win32-root (getenv "SYSTEMROOT")) ; Win2000
+ (list exec-path))
+ (cond
+ ((and (eq type 'cygwin)
+ win32-root)
+ (dolist (path exec-path)
+ ;; 1) backward slashes, 2) forward slashes
+ (when (not (or (string-match (regexp-quote win32-root) path)
+ (string-match (regexp-quote
+ (expand-file-name win32-root)) path)))
+ (push path list))))
+ ((and (eq type 'win32)
+ cygwin-root)
+ (dolist (path exec-path)
+ (when (not (or (string-match (regexp-quote cygwin-root) path)
+ (string-match (regexp-quote
+ (replace-regexp "/" "\\" cygwin-root))
+ path)))
+ (push path list)))))
+ (let ((exec-path (nreverse list))) ;; Reverse preserves the order.
+ (executable-find program))))
+
+;;}}}
+
+;;; tinylibenv.el ends here
--- /dev/null
+;;; tinylibid.el --- Library for (Id)entifying buffer, regardless of mode
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 1995-2007 Jari Aalto
+;; Keywords: extensions
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program, call M-x ti::id-version.
+;; Look at the code with folding.el
+
+;; COPYRIGHT NOTICE
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;;; Install:
+
+;; ........................................................ &t-install ...
+;; Put this file on your Emacs-Lisp load path, add following into your
+;; ~/.emacs startup file
+;;
+;; (require 'tinylibid)
+;;
+;; Or use autoload. This is preferred method
+;;
+;; (autolad 'ti::id-info "tinylibid" "Buffer info" t)
+;;
+;; Function to call to get buffer identity. You normally call this
+;; from lisp code and not interactively.
+;;
+;; M-x ti::id-info
+;;
+;; If you have any questions, always use function
+;;
+;; M-x ti::id-submit-bug-report
+;;
+;; Request:
+;;
+;; Please send any example file or mode that I'm not aware of,
+;; I'll try to support any programming mode
+
+;;}}}
+;;{{{ Documentation
+
+;; .................................................... &t-commentary ...
+
+;;; Commentary:
+
+;; Preface, Feb 1995
+;;
+;; Seems quite uninteresting package to you? I bet it does, unless
+;; you're a lisp programmer who has infite time to twiddle his
+;; c++-mode-hook + 20 others hooks and have all the time develop nice
+;; little funcs to make living in emacs easier.
+;;
+;; While someone may think that all users stick to one mode e.g. when
+;; they are programming C++, that's not obvious. For example programmer
+;; may move between all kind of modes during programming and the
+;; trouble is, that while the buffer's logical content remains the same,
+;; the hooks know nothing about it. Hooks are just dummies that get
+;; called whenever you turn some mode on, try C++ mode over nroff code
+;; and you'll be surprised.
+;;
+;; Now let's see one session example:
+;;
+;; . write Lisp ;lisp-mode + folding-mode
+;; . hmm, need center-command ;move to text-mode
+;; . code again ;lisp-mode
+;; . adjust defconst var pos. ;turn on tiny tab minor mode
+;; . code again ;lisp-mode
+;;
+;; Programmer may have bound all common modes into keys so that he can
+;; can access various modes very fast; changing modes is no
+;; problem. What is the problem, is that when you turn off the
+;; CODE-mode, all information about comment-start etc. vanish.
+;;
+;; Overview of features
+;;
+;; o This is LIBRARY package
+;; o Try to identify buffer content
+;; o Useful for checking what kind of file is in buffer and making
+;; decisions based on that. Suitable for hooks.
+;;
+;; Imenu example
+;;
+;; If you're using *imenu.el* to generate buffer jump points, it is
+;; very likely that the imenu command won't generate right jump points
+;; if you're in wrong mode. Let's use imenu example. Here is first
+;; try: The code sniffs around to see if we're on some mode and then
+;; configures imenu according to it.
+;;
+;; (defun my-imenu-mouse (event)
+;; (interactive "e")
+;; (my-imenu))
+;;
+;; (defun my-imenu (&optional arg)
+;; "Sets parameters to imenu."
+;; (let* (raise)
+;; (setq imenu-max-items 20
+;; imenu-sort-function nil)
+;; (cond
+;; ((memq major-mode
+;; '(lisp-mode emacs-lisp-mode lisp-interaction-mode))
+;; (setq imenu-create-index-function
+;; 'imenu-example--create-lisp-index
+;; imenu-sort-function
+;; 'imenu--sort-by-name
+;; raise t))
+;; ((memq major-mode '(c++-mode))
+;; (setq imenu-create-index-function
+;; 'imenu-example--create-c++-index
+;; imenu-sort-function
+;; 'imenu--sort-by-name
+;; raise t))
+;; ((memq major-mode '(c-mode))
+;; (setq imenu-create-index-function
+;; 'imenu-example--create-c-index
+;; imenu-sort-function
+;; 'imenu--sort-by-name
+;; raise t)))
+;; (if raise
+;; (imenu))))
+;;
+;; Here is better and more robust way. It'll let you be in any
+;; mode while retaining right imenu.
+;;
+;; (require 'imenu)
+;;
+;; ;; Separate functions for keyboard and mouse.
+;; (defun my-imenu-mouse (event &optional arg)
+;; (interactive "e\nP")
+;; (my-imenu arg))
+;;
+;; (defun my-imenu (&optional arg)
+;; "Sets parameters to imenu. If called with arg, the output is
+;; unsorted."
+;; (interactive "P")
+;; (let* ((sort-func (if arg nil 'imenu--sort-by-name))
+;; (table
+;; '((lisp-mode
+;; imenu-example--create-lisp-index)
+;; (emacs-lisp-mode
+;; imenu-example--create-lisp-index)
+;; (c++-mode
+;; imenu-example--create-c++-index)
+;; (c-mode
+;; imenu-example--create-c-index)))
+;; ;; So, in what mode were really?
+;; (mode (or (ti::id-info t) major-mode))
+;; (el (assoc mode table)))
+;; (if (null el)
+;; (message "Sorry, no imenu for this buffer.")
+;; (setq imenu-max-items 20
+;; imenu-sort-function sort-func
+;; imenu-create-index-function (nth 1 el))
+;; (imenu))))
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+;;{{{ setup: require
+
+(require 'tinylibm)
+
+(eval-when-compile
+ (ti::package-use-dynamic-compilation))
+
+;;}}}
+;;{{{ setup: hooks
+
+(defvar ti::id-:load-hook nil
+ "*Hook run when file has been loaded.")
+
+;;}}}
+;;{{{ setup: private
+
+(defvar ti::id-:info nil
+ "Buffer local variable.This value is updated every time
+function ti::id-info called. For faster responses, you may wan to write your
+code like this:
+
+ (setq info ti::id-info nil 'var)
+
+Because peeking the variable is 40x times faster.")
+
+(make-variable-buffer-local 'ti::id-:info)
+
+;; Global variables set by functions.
+;; - These are heavily used. User may check these too.
+;; - They are Set after the buffer is studied.
+
+(defconst ti::id-:global-buffer-name nil
+ "Global: set by study func, buffer name")
+
+(defconst ti::id-:global-buffer-file-name nil
+ "Global: set by study func, buffer file name")
+
+(defconst ti::id-:global-buffer-extension nil
+ "Global: set by study func, buffer fn ext.")
+
+(defconst ti::id-:global-buffer-first-line nil
+ "Global: set by study func, 1st line of buffer")
+
+;;}}}
+;;{{{ setup: public, user configurable
+
+;;; it is INTENTIONAL that the variables are defconst, change these
+;;; with ti::id-:load-hook
+
+(defvar ti::id-:file-ext-re "[a-zA-Z0-9]\\(\\.\\)[a-zA-Z0-9]+$"
+ "A regexp that says what files can have extension. Everything after the
+DOT is considered to form extension. Files like ~/.cshrc are not
+considered to have an extension.
+
+The sub match at level 1 indicates the start of an extension.
+
+References:
+
+ See function `ti::id-file-extension'.")
+
+(defconst ti::id-:buffer-first-line-regexp-list
+ '(("^#.*perl" "code-perl")
+ ("^#.*python" "code-python")
+ ("^#.*scm" "code-scheme")
+ ("^#.*tcl" "code-tcl")
+ ;; Of course this is not bullet proof, but many lisp code package
+ ;; has first line describing the package.
+ ("^;;[ \t]+.*\.el " "code-lisp")
+ ("^#.*awk" "code-awk")
+ ;; It's custom to start the file with ':' no-op, if it's
+ ;; sh-coded, since it prevents accidental # for the first line
+ ;; --> intepreted as csh code by shell if it sees # as first char
+ ("^#.*\/sh\\|^[ \t]*:[ \t]*$" "code-shell-sh")
+ ("^#.*\/csh" "code-shell-csh")
+ ("^#.*\/tcsh" "code-shell-tcsh")
+ ("^#.*\/ksh" "code-shell-ksh")
+ ("^#.*\/zsh" "code-shell-zsh")
+ ("^#.*\/bash" "code-shell-bash")
+ ;; Fortran code uses comments beginning with "c", we assume that
+ ;; there must be at least TWO spaces after initial comment
+ ("^c +" "code-fortran")
+ ("^[ \t]*!" "resource-x") ;.Xinitrc ot the like comment
+ ;; It's custom to start an nroff man page with a comment that
+ ;; holds version control Id string. Comment is = .\"
+ ("^\.\\\"" "text-nroff")
+ ;; A "white paper" document that starts with TOC. See e.g tinytf.el
+ ("^Table of contents" "text-white-paper-toc"))
+ "*list of \(REGEXP str) where RE is tried upon 1 line match, normally
+a bang-slash or emacs --** notation")
+
+;; - Remember, first one that macthes id useti::d! Put most restrictive at
+;; the beginning.
+;; - The regexp scanning should be the last resort, because its potential
+;; mishits.
+;; - There is no need to add regexp here if buffer can be identified by other
+;; means easily ie. all WWW files have universal .html extension.
+
+(defconst ti::id-:buffer-match-regexp-list
+ (list
+ (list
+ (concat
+ ;; interface CServicePreferences; /* Forward references */
+ "interface [0-9A-Za-z]+[ \t]+[0-9A-Za-z]+[ \t]*;"
+ ;; exception InvalidRequest{TString aReason;};
+ "\\|exception[ \t]+[0-9A-Za-z]+{.*;"
+ ;; typedef sequence<CosPropertyService::PropertyNames> PropertyNamesList;
+ "\\|typedef[ \t]+[0-9A-Za-z]+<")
+ "code-idl")
+ ;; *FvwmIdentBack MidnightBlue
+ ;; *FvwmIdentFore Yellow
+ ;; Style "FvwmButtons" CirculateSkip
+ '("Style[ \t]+\"FvwmButtons\"[ \t]+[A-Z]\\|^[*]Fvwm"
+ "resource-code-fvwm")
+ '("^@c[ \t]"
+ "text-texinfo")
+ ;; :0
+ ;; * condition
+ ;; {
+ ;; <code block>
+ ;; }
+ '("^:0[ \t]*[\r\n]+[ \t]*[*{]"
+ "code-procmail")
+ '("<\\?php"
+ "code-php")
+ ;; #declare Purple_Clouds = pigment {
+ ;; #include "woodmaps.inc"
+ ;; ...
+ ;; Paraboloid_Y
+ ;; scale <30.0, 10.0, 40.0>
+ ;; rotate 180.0*z
+ ;; translate <40.0, 14.0, 50.0>
+ (list
+ (concat
+ "^#include[ \t]+.*.inc\""
+ "\\|^#declare[ \t]+[^ \t]+[ \t]*="
+ "\\|\\(scale\\|translate\\)[ \t]<[ \t]*[0-9.][ \t]*,.*>")
+ "code-povray")
+ (list
+ (concat
+ "[(][ \t]*\\(defmacro\\|defvar\\|defconst\||defun\\|setq"
+ "\\|add-hook\\|remove-hook\\|let[*]"
+ "\\)")
+ "code-lisp")
+ '("entity[ \t]+[a-z_A-Z]+[ \t]+is" "code-vhdl")
+ (list
+ (concat
+ ;; 01 WORK-AREA.
+ ;; 02 PI PIC S9V9(14).
+ ;;
+ "01[ \t]+WORK-AREA\\.\\|01[ \t]+CONSTANTS\\."
+ ;; ACUCOBOL-85
+ "\\|\\(working-storage\\|portability\\)[ \t]+section\\."
+ "\\|perform[ \t]+initialize-environment\\."
+ ;; display "F4 = Exit Demonstration", line 11, column 8.
+ "\\|display [\"].*,[ \t]*column[ \t]+[0-9]+\\.")
+ "code-cobol")
+ ;; it's "write(*,*)" , and definitely fortran
+ '("write[(][*],[*][)]" "code-fortran")
+ (list
+ (concat
+ "class.+\\(extends\\implements\\)"
+ "\\|"
+ "\\(protected\\|public\\)[ \t]+"
+ "\\(synchronized[ \t]+\\)?Object")
+ "code-java")
+ ;; Function definition
+ ;; def add_doc(self, document, keyword_list):
+ ;; def __init__(self):
+ '("^[ \t]+def[ \t]+[a-zA-Z_]+[(].*:" "code-python")
+ ;; Oracle sql
+ ;; select * from p_msc_rej where measurement_time = '1995061914124675';
+ '("select.*from.*where.*=.*;" "code-sql")
+ '("order[ \t]+by[ \t]+[^ \t\n]+.*\\(asc\\|desc\\)" "code-sql")
+ '("^[.]TH" "text-nroff")
+ '("^Newsgroup:" "text-news")
+ '("^To:.*@" "text-mail")
+ (list
+ ;; conjug :: Words -> Words -> String
+ ;; netails :: [a] -> [[a]]
+ ;; replies :: Words -> Words -> [String]
+ ;;
+ "conjug[ \t]+::.*->\\|netails[ \t]+::.*->\\|replies::[ \t]+.*->"
+ "code-hugs")
+ ;; %HOME\file\path
+ (list
+ "^REM[ \t]\\|^CALL[ \t].*%[^ \t\r\n]+%\\[^ \t\r\n]+"
+ "code-bat"))
+ "*List of \(REGEXP str\) where RE is tried upon whole file.
+First one matched is used to determine file type, so put most restrictive
+REs first.")
+
+(defconst ti::id-:file-extension-alist
+ '((".a" . "code-ada") ;Ada 83/87
+ (".ada" . "code-ada") ;Ada 83/87
+ (".ads" . "code-ada") ;ada 95
+ (".adb" . "code-ada") ;Ada 95 body/implementation
+ (".asp" . "code-asp")
+ (".awk" . "code-awk")
+ (".bat" . "code-bat")
+ (".bash" . "code-shell-bash")
+ (".c" . "code-c")
+ (".cbl" . "code-cobol") ;this is the standard hdr & strc
+ (".cc" . "code-c++")
+ (".cmd" . "code-bat")
+ (".cob" . "code-cobol") ;non-standard unix
+ (".cpp" . "code-c++")
+ (".csh" . "code-shell-csh")
+ (".cxx" . "code-c++")
+ (".C" . "code-c++")
+ (".el" . "code-lisp")
+ (".f" . "code-fortran")
+ (".F" . "code-fortran")
+ (".for" . "code-fortran")
+ (".fvwmrc". "resource-code-fvwm")
+ (".h" . "code-c-header")
+ (".hh" . "code-c++-header")
+ (".hs" . "code-hugs")
+ (".i" . "code-cobol-header") ;non-standard unix
+ (".idl" . "code-idl") ;CORBA idl, hassan@cs.stanford.edu
+ (".html" . "text-html")
+ (".java" . "code-java")
+ (".class" . "code-java-compiled")
+ (".jsp" . "code-jsp")
+ (".ksh" . "code-shell-ksh")
+ (".m" . "code-objective-c")
+ (".mod" . "code-objective-c")
+ (".md" . "code-modula-header") ;at least modula-2
+ (".mi" . "code-modula") ;implementation modula-2
+ (".pas" . "code-pascal")
+ (".php[34]?" . "code-php")
+ (".pl" . "code-perl-library")
+ (".pls" . "code-perl-shell")
+ (".pm" . "code-perl")
+ ;; also uses .inc and .map but I hesitate to add those extension,
+ ;; because some other may use .inc or .map too for other purposes.
+ (".pov" . "code-povray")
+ (".py" . "code-python")
+ (".sh" . "code-shell") ;might be csh/ksh/csh
+ (".sql" . "code-sql")
+ (".tex" . "text-tex")
+ (".texi" . "text-tex-info")
+ (".txt" . "text-normal")
+ (".vhd" . "code-vhdl")
+ (".vhdl" . "code-vhdl")
+ (".wml" . "code-wml")
+ (".xml" . "code-xml")
+ (".xsl" . "code-xsl")
+ (".xsp" . "code-xsp"))
+ "*List of (ASSOC-KEY STR) where KEY is tried upon
+buffer-file-name's extension.")
+
+;; If the file cannot be identified by extension...
+
+(defconst ti::id-:file-regexp-match-list
+ '(("\\.ema" "code-lisp") ;.emacs , .emacs.dired
+ ("\/\\.[Xx]" "resource-x") ;.Xdefauls, .xinirc
+ ("\/\\.kshrc" "resource-code-shell-ksh")
+ ("\/\\.t?cshrc" "resource-code-shell-csh") ;alike csh = tcsh
+ ("\/\\.bashrc" "resource-code-shell-bash")
+ ("\/\\.bashrc" "resource-code-shell-sh") ;alike bash = sh
+ ("\\.csh" "shell-csh")) ;like .cshrc or myScript.csh
+ "*List of (REGEXP STR) where RE is tried upon _whole_ buffer-file-name")
+
+;; - Buffers that do not have buffer-file-name property at all.
+;; - Only put 'trusted' buffer names that are known to all here.
+
+(defconst ti::id-:buffer-name-regexp-list
+ '(("[*]info" "text-manual-info")
+ ("[*]man" "text-manual-shell")
+ ("[*]shell" "process-shell")
+ ("[*]ftp" "process-ftp")
+ ("[*]Article" "text-news")
+ ("[*]Summary" "text-news"))
+ "*List of (REGEXP STR) where RE is tried upon buffer-name")
+
+(defconst ti::id-:function-list
+ '( ;; This first line -*- test should represent exact mode, we trust
+ ;; to it blindly. If the content is not what this mode says, it's
+ ;; user's own mistake.
+ ti::id-test-first-line-emacs-special
+ ti::id-test-first-line
+ ti::id-test-buffer-file-name
+ ti::id-test-buffer-content-special
+ ti::id-test-extension
+ ti::id-test-buffer-name
+ ti::id-test-buffer-search-regexp)
+ "*List of unctions to call to determine buffer type.
+The calling of functions stops immediately when some function
+returns non-nil. Notice, that this is also the order of evaluation.")
+
+(defconst ti::id-:type2mode
+ '(("ada" ada-mode "--")
+ ("awk" awk-mode "#")
+ ("code-c$" c-mode "/*" "*/")
+ ("code-c++" c++-mode "//")
+ ("code-cobol" cobol-mode )
+ ("code-fortran" fortran-mode "C")
+ ("code-fvwm" fvwm-mode )
+ ("code-hugs" hugs-mode "--" )
+ ("code-idl" idl-mode )
+ ("code-java" java-mode "/*" "*/")
+ ("code-objective-c" c-mode )
+ ("code-pascal" pascal-mode )
+ ("html" html-mode "<!---" "-->")
+ ("code-php" php-mode "//")
+ ("code-python" python-mode )
+ ("code-scheme" scheme-mode )
+ ("code-sql" sql-mode "-- ")
+ ("code-tcl" tcl-mode)
+ ("pascal" pascal-mode "{" "}")
+ ("perl" perl-mode "#")
+ ("code-povray" povray-mode "/*" "*/")
+ ("lisp\\|emacs-lisp" lisp-mode ";")
+ ("text-tex" tex-mode "%")
+ ("text-texinfo" texinfo-mode "@c")
+ ("text-tex-info" texinfo-mode "%")
+ ("text-mail" mail-mode)
+ ("text-news" mail-mode)
+ ("shell-sh" sh-mode "#")
+ ("shell-csh" csh-mode "#")
+ ("shell-ksh" ksh-mode "#")
+ ("shell-zsh" zsh-mode "#")
+ ("resource-code-shell-csh" csh-mode "#")
+ ("resource-code-shell-sh" sh-mode "#")
+ ("tex$" tex-mode "%"))
+ "*List of
+'((REGEXP MODE-NAME-SYMBOL [COMMENT-START COMMENT-END]) (
+ (R M C C)
+ ..)
+where RE represent match against string that describes the buffer
+contents. The comment-start and end fields are optional.")
+
+;;}}}
+;;{{{ version
+
+;;; ....................................................... &v-version ...
+
+(eval-and-compile
+ (ti::macrof-version-bug-report
+ "tinylibid.el"
+ "tinylibid"
+ ti::id-:version-id
+ "$Id: tinylibid.el,v 2.50 2007/05/01 17:20:45 jaalto Exp $"
+ '(ti::id-:load-hook
+ ti::id-:function-list
+
+ ti::id-:global-buffer-name
+ ti::id-:global-buffer-file-name
+ ti::id-:global-buffer-extension
+ ti::id-:global-buffer-first-line
+
+ ti::id-:file-ext-re
+ ti::id-:buffer-first-line-regexp-list
+ ti::id-:buffer-match-regexp-list
+ ti::id-:file-extension-alist
+ ti::id-:file-regexp-match-list
+ ti::id-:buffer-name-regexp-list
+ ti::id-:type2mode)))
+
+;;}}}
+;;{{{ misc
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::id-cnv-txt2mode (txt)
+ "This is kinda fake function, it returns the original MODE based
+on the text that represents the buffer contents. This functions purpose
+is solely to return you a _symbol_ that is more commonly known to all, than
+the _string_ representing a mode.
+
+NOTE:
+ Symbol returned does not necessary representy any mode you can turn on.
+ Use 'fboundp' test to be sure the symbol is callable function."
+ (let (ret)
+ (dolist (elt ti::id-:type2mode)
+ (when (string-match (nth 0 elt) txt)
+ (setq ret (nth 1 elt)) ;Mode name
+ (return)))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::id-cnv-txt2comment (txt)
+ "Returns (COMMENT-START . COMMENT-END) variables for text representing
+the buffer contents. Notice that comment-end may be nil meaning it
+is not needed for mode."
+ (let (com-s
+ com-e
+ re)
+ (dolist (elt ti::id-:type2mode)
+ (setq re (nth 0 elt))
+ (if (> (length elt) 2)
+ (setq com-s (nth 2 elt)))
+ (if (> (length elt) 3)
+ (setq com-s (nth 3 elt)))
+ (if (null (string-match re txt))
+ (setq com-s nil com-e nil)
+ (return)))
+ (if com-s
+ (cons com-s com-e))))
+
+;;}}}
+;;{{{ id
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::id-file-extension (file)
+ "Return file extension.
+
+References:
+ See variable `ti::id-:file-ext-re' how file extension is determined."
+ (let* ((re ti::id-:file-ext-re)
+ point)
+ (when (and file ;doesn't have filename at all *temp*
+ (string-match re file))
+ (setq point (match-beginning 1)) ;dot position
+ (substring file point))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::id-read-first-line ()
+ "Return first ID line of the file. Empty lines are skipped."
+ (let* ((comment-beg (regexp-quote (or comment-start " ")))
+ (empty-re (concat "[ \t]*" comment-beg "[ \t]*$")))
+ (save-excursion
+ (ti::widen-safe
+ (ti::pmin)
+ (while (and (not (eobp)) ;search first sensible line
+ (looking-at empty-re))
+ (forward-line 1))
+ (unless (eobp)
+ (ti::read-current-line))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::id-read-first-line-emacs-mode (str)
+ "Emacs supports special first line syntax e.g. -*-Emacs-Lisp-*-,
+to turn on mode when file loads. Try to find function <text>-mode
+from the internal symbol list of emacs if line contains -*- marks.
+
+Return:
+
+ symbol real mode function name found from emacs.
+ Btw, emacs barks you automatically if functions given
+ in line doesn't exist when file is loaded.
+ nil."
+ (let* (ret
+ mode
+ sym)
+ (cond
+ ((setq mode (ti::string-match "-[*]-\\(.*\\)-[*]-" 1 str))
+ ;; let's make symbol out of it
+ (setq mode (concat (downcase mode) "-mode"))
+ (if (null (setq sym (intern-soft mode)))
+ (progn
+ ;; too bad, such mode not loaded into emacs, well if person
+ ;; has loaded file, emacs had barfed already about this unknown
+ ;; mode: "file mode specification error, void function, <mode>"
+ nil)
+ (if (fboundp sym) ;let's make sure sym is func ...
+ (setq ret sym))))) ;it's valid mode
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::id-match (string list)
+ "Match STRING against LIST el 1, return LIST elt 2"
+ (let* (ret
+ regexp)
+ (dolist (elt list)
+ (setq regexp (nth 0 elt))
+ (when (string-match regexp string)
+ (setq ret (nth 1 elt))
+ (return)))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::id-buffer-re-search (&optional point)
+ "Search `ti::id-:buffer-match-regexp-list' from buffer.
+Start searching from `point-min' or from optional POINT."
+ (let ((list ti::id-:buffer-match-regexp-list)
+ ret)
+ (or point
+ (setq point (point-min)))
+ (save-excursion
+ (ti::widen-safe
+ (goto-char point) ;start here
+ (dolist (elt list)
+ (when (re-search-forward (nth 0 elt) nil t)
+ (setq ret (nth 1 elt))
+ (return)))))
+ ret))
+
+;;}}}
+;;{{{ study
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::id-global-variable-reset ()
+ "Reset some globals."
+ (setq ti::id-:global-buffer-file-name nil
+ ti::id-:global-buffer-extension nil
+ ti::id-:global-buffer-first-line nil))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::id-global-variable-set ()
+ "Set some globals, so that they can be used by all functions.
+This reduces overhead of getting these variables multiple times."
+ (let* ((bp (current-buffer))
+ (bn (buffer-name))
+ (bfn (buffer-file-name bp))
+ (ext (ti::id-file-extension bn))
+ (id (ti::id-read-first-line)))
+ (ti::id-global-variable-reset)
+ (setq ti::id-:global-buffer-file-name bfn
+ ti::id-:global-buffer-extension ext
+ ti::id-:global-buffer-first-line id
+ ti::id-:global-buffer-name bn)
+ ;; so that can be hook
+ nil))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::id-study-buffer (type)
+ "Chew buffer contents.
+Be sure to run `ti::id-global-variable-set' first so that global variables get set.
+
+Input:
+ TYPE symbol; See source code of function.
+
+Return:
+ string type string
+ symbol if real mode found in first line -*- ..-*-
+ nil"
+ (let* ( ;; these are already set
+ (id ti::id-:global-buffer-first-line)
+ (ext ti::id-:global-buffer-extension)
+ (bname ti::id-:global-buffer-name)
+ el
+ ret)
+ (cond
+ ((eq type 'extension)
+ (if (setq el (assoc ext ti::id-:file-extension-alist))
+ (setq ret (cdr el))))
+ ((eq type 'buffer-file-name) ;buffer name test
+ ;; whole file match
+ (setq ret (ti::id-match bname ti::id-:file-regexp-match-list)))
+ ((eq type 'buffer-name) ;buffer name test
+ (setq ret (ti::id-match bname ti::id-:buffer-name-regexp-list)))
+ ((and (eq type '1st-emacs) ;special -*-Emacs-Lisp-*-
+ (stringp id))
+ (setq ret (ti::id-read-first-line-emacs-mode id)))
+ ((and (eq type '1st-regexp)
+ (stringp id))
+ (setq ret (ti::id-match id ti::id-:buffer-first-line-regexp-list)))
+ ((eq type 'buffer-regexp) ;whole buffer is searched
+ (setq ret (ti::id-buffer-re-search))))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::id-test-buffer-content-special ()
+ "Check special buffer content."
+ (let* ((text (memq major-mode '(fundamental-mode text-mode))))
+ (cond
+ ((and text
+ (fboundp 'tinytf-text-format-p)
+ (ti::funcall 'tinytf-text-format-p))
+ "text-white-paper"))))
+
+;;; ----------------------------------------------------------------------
+;;; - testing/evaluation functions
+
+(defun ti::id-test-extension ()
+ ""
+ (ti::id-study-buffer 'extension))
+
+(defun ti::id-test-buffer-file-name ()
+ ""
+ (ti::id-study-buffer 'buffer-file-name))
+
+(defun ti::id-test-buffer-name ()
+ ""
+ (ti::id-study-buffer 'buffer-name))
+
+(defun ti::id-test-first-line ()
+ ""
+ (ti::id-study-buffer '1st-regexp))
+
+(defun ti::id-test-first-line-emacs-special
+ ()
+ ""
+ (ti::id-study-buffer '1st-emacs))
+
+(defun ti::id-test-buffer-search-regexp
+ ()
+ ""
+ (ti::id-study-buffer 'buffer-regexp))
+
+;;}}}
+;;{{{ main
+
+;;; ############################################################ &main ###
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun ti::id-info (&optional mode variable-lookup verb)
+ "Try to identify buffer type.
+
+Function doesn't rely on mode, because that doesn't necessarily tell what
+the buffer holds. Many users still program their shell scripts in
+`fundamental-mode' or so. This means that `major-mode' isn't checked,
+because calling function can do it easily.
+
+If this function returns nil, _then_ it's probably the time to check
+the `major-mode'.
+
+The normal order of evaluation is as follows:
+- First line in the file
+- Whole filename including path = `buffer-file-name'
+- File name extension
+- `buffer-name' is checked. [temporary buffer has no file name]
+- Whole buffer is searched for RE texts
+
+Input:
+
+ MODE flag, controls return value format
+ VARIABLE-LOOKUP flag, read buffer type from cache. (From previous call)
+ VERB if non-nil, verbose messages allowed.
+
+Return values:
+
+ when optional MODE = nil
+ Some appropriate _string_ that represents the content. notice that this
+ string is usually generalised description, _but_ it the file has special
+ 1st line in form of -*-..-*- the string is direct mode name string.
+
+ when optional MODE = non-nil
+ Return possible mode name as _symbol_
+
+ when VARIABLE is non-nil, the variable `ti::id-:info' is read instead.
+ If it has non-nil value, the value is returned, otherwise full buffer
+ is parsed again and variable's value is updated.
+
+References:
+
+ `ti::id-func-alist' order of evaluation.
+ `ti::id-:info' buffer local variable updated during every call."
+
+ (interactive)
+ (let* ((funcs ti::id-:function-list)
+ ret
+ func
+ doit)
+ (ti::verb)
+ ;; .................................................... do lookup? ...
+ (setq ret ti::id-:info)
+ (cond
+ ((null variable-lookup)
+ (setq doit t))
+ ((and variable-lookup (null ti::id-:info)) ;no value stored
+ (setq doit t))
+ ((and variable-lookup ;must same type
+ (null mode) ;string request
+ (not (stringp ti::id-:info)))
+ (setq doit t))
+ ((and variable-lookup ;must same type
+ mode ;symbol request
+ (not (symbolp ti::id-:info)))
+ (setq doit t)))
+ ;; .................................................... do the job ...
+ (when doit
+ ;; prepare globals to avoid overhead
+ (ti::id-global-variable-set)
+ (while (and (setq func (pop funcs))
+ (null (setq ret (funcall func)))))
+ ;; how the results should be returned ?
+ (when ret ;found anything?
+ (if mode
+ (if (symbolp ret) ;return symbol
+ ret ;it's real mode name
+ (setq ret (ti::id-cnv-txt2mode ret))) ;return possible mode name
+ (if (symbolp ret)
+ (setq ret (symbol-name ret))))
+ (if verb
+ (message (prin1-to-string ret))))
+ ;; Update the buffer local variable
+ (setq ti::id-:info ret))
+ ret))
+
+;;}}}
+
+(provide 'tinylibid)
+(run-hooks 'ti::id-:load-hook)
+
+;;; tinylibid.el ends here
--- /dev/null
+;;; tinylibm.el --- Library of s(m)all macros or functions
+
+;;{{{ Id
+
+;; Copyright (C) 1995-2007 Jari Aalto
+;; Keywords: extensions
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program, call M-x tinylibm-version.
+;; Look at the code with folding.el
+
+;; COPYRIGHT NOTICE
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;;; Install:
+
+;; Put this file on your Emacs-Lisp load path, add following into your
+;; ~/.emacs startup file
+;;
+;; (require 'tinylibm)
+
+;;}}}
+;;{{{ Documentation
+
+;;; Commentary:
+
+;; Preface, 1995
+;;
+;; This is lisp function library, package itself does nothing.
+;; It contains small functions or macros.
+;;
+;; Usage
+;;
+;; You must not autoload this package; but always include
+;;
+;; (require 'tinylibm)
+;;
+;; You don't need any other require commands: all my other library
+;; functions get defined as well by using autoload. Repeat: you don't
+;; have to put these in your packages:
+;;
+;; (require 'tinylib) ;; leave this out
+;; (require 'tinyliby) ;; not needed either.
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+;;{{{ Load forms
+
+(require 'tinylibb) ;Backward compatible functions
+
+;;{{{ function tests
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::function-car-test (symbol test-val &optional test-func)
+ "Test car of the SYMBOL against TEST-VAL with TEST-FUNC.
+Function must be symbol, not a lambda form.
+
+Return:
+
+ symbol yes, test succeeded
+ nil test failed"
+ (if (and (not (sequencep symbol)) ;; list ?
+ (symbolp symbol) ;; chokes if not sequencep
+ (fboundp symbol)
+
+ ;; Eg. symbol-function 'car doesn't return list.
+ ;;
+ (listp (symbol-function symbol))
+ (eq test-val
+ (funcall (or test-func 'car)
+ (symbol-function symbol))))
+ symbol
+ nil))
+
+;;; ----------------------------------------------------------------------
+;;; `indirect-function' unfortunately returns the symbol-function, not
+;;; the symbol name of the last function in the chain
+;;;
+(defun ti::defalias-p (symbol)
+ "If function SYMBOL is alias, return it's truename. Otw Return nil."
+ (let* (sym
+ prev
+ ret)
+
+ (if (or (sequencep symbol) ;lambda form ?
+ (not (symbolp symbol))
+ (not (fboundp symbol)))
+ nil
+ (setq sym (symbol-function symbol))
+ (if (not (symbolp sym))
+ nil
+ (while (and (symbolp sym) ;was alias, go into nesting levels
+ (fboundp sym)) ;must be function or user made mistake
+ (setq prev sym)
+ (setq sym (symbol-function sym)))
+ (setq ret prev)))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::subrp-p (symbol)
+ "Test if function SYMBOL is built-in function.
+Emacs default test (subrp 'move-to-column) returns nil, but according to
+the documentation string that function is built-in. This function also
+checks the documentation string."
+ (when (and symbol
+ (fboundp symbol))
+ (or (subrp (symbol-function symbol))
+ (string-match
+ "built-in"
+ (or (documentation-property symbol 'variable-documentation)
+ "")))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::defmacro-p (symbol)
+ "Test if function SYMBOL is in fact macro, created with defmacro.
+
+Return:
+ symbol this can be truename of the function if it was aliased
+ nil"
+ (ti::function-car-test symbol 'macro))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::autoload-p (symbol)
+ "Test if function SYMBOL is in its autoload form.
+Works with aliased symbols too.
+
+Return:
+ symbol this can be truename of the function if it was aliased
+ nil"
+ ;; Get the REAL name if it is alias or use the func's SYMBOL name
+ (let* ((func (or (ti::defalias-p symbol) symbol)))
+ (ti::function-car-test func 'autoload)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::autoload-file (symbol)
+ "Return autoload filename of function SYMBOL.
+You already have to have tested the symbol with `ti::autoload-p'
+or otherwise result from this function is undefined.
+
+Return:
+ string Name of the library where symbol autolaod point to."
+ ;; Get the REAL name if it is alias or use the func's SYMBOL name
+ (let* ((doc (prin1-to-string (symbol-function symbol))))
+ (when (and (stringp doc)
+ (string-match "autoload[ \t\"]+\\([^\"\r\n)]+\\)" doc))
+ (match-string 1 doc))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::lambda-p (symbol)
+ "Test if function SYMBOL was created with defsubst or is in lambda form.
+
+Return:
+ symbol this can be truename of the function if it was aliased
+ nil"
+ (ti::function-car-test symbol 'lambda))
+
+;;}}}
+
+(defun ti::compatibility-advice-setup ()
+ "Define compatibility advices for function that have changed."
+ ;; Try to avoid loading advice.el.
+ ;; The tests from tinylib-ad.el are duplicated here.
+ (let ((msg ""))
+ (if (and
+ (ti::emacs-p)
+ (not (ti::emacs-p "20.2")))
+ (setq msg
+ (concat
+ msg
+ "Tinylibm.el: tinylib-ad.el load reason: 1\n")))
+
+ (if (and (fboundp 'define-key-after) ;; Emacs function
+ (not
+ (string-match
+ "optional"
+ (or (ti::function-args-p 'define-key-after) ""))))
+ (setq
+ msg
+ (concat
+ msg
+ "Tinylibm.el: tinylib-ad.el load reason: define-key-after\n")))
+
+ (if (and
+ (not
+ (string-match "noerr" (or (ti::function-args-p 'require) ""))))
+ (setq msg
+ (concat
+ msg
+ "Tinylibm.el: tinylib-ad.el load reason: require\n")))
+
+ (if (and
+ (ti::win32-p)
+ ;; It is unlikely that these are not in path, so this should not
+ ;; fail.
+ (let ((exec-path exec-path))
+ (push "c:/windows" exec-path)
+ (push "c:/winnt" exec-path)
+ (null (or (executable-find "command")
+ (executable-find "cmd")))))
+ (setq
+ msg
+ (concat
+ msg
+ "Tinylibm.el: tinylib-ad.el load reason: executable-find\n")))
+
+ (when (and (fboundp 'read-char-exclusive)
+ (not (string-match
+ "prompt"
+ (or (ti::function-args-p 'read-char-exclusive) ""))))
+ (setq
+ msg
+ (concat
+ msg
+ "Tinylibm.el: tinylib-ad.el load reason: read-char-exclusive")))
+
+ (when (or (assoc "-debug-init" command-switch-alist)
+ (assoc "--debug-init" command-switch-alist))
+ (message msg))
+
+ (when t ;; Enaled now.
+ ;; 2000-01-05 If compiled this file in Win32 XEmacs 21.2.32
+ ;; All the problems started. Make sure this is NOT compiled.
+ (let ((path (locate-library "tinylib-ad.elc")))
+ (when (and (stringp path)
+ (string-match "\\.elc$" path))
+ (delete-file path)
+ (message "\
+ ** tinylibm.el: It is not recommend to compile tinylib-ad.el.
+ compiled file deleted %s" path))))
+
+ ;; Backward compatible functions
+ ;;
+ ;; #todo: EFS does something to `require' function. Should it be loaded
+ ;; first in XEmacs?
+ (if (and (string-match "reason: require" msg)
+ (ti::xemacs-p)
+ (require 'efs))
+
+ (unless (string= "" msg)
+ (require 'tinylib-ad)))))
+
+(ti::compatibility-advice-setup)
+
+(eval-when-compile
+ (when (and (ti::xemacs-p)
+ (or (< emacs-major-version 20)
+ (and (eq emacs-major-version 20)
+ (< emacs-minor-version 3))))
+ (message "\
+tinylib.el: ** Ignore 'variable G3000' warnings. Corrected in XEmacs 20.3")))
+
+;;}}}
+
+;;{{{ variables
+
+(defconst ti:m-debug-buffer "*ti::d!!*"
+ "*Debug buffer where to write. Make a wrapper to use function ti::d!!
+In your programs, like:
+
+ (defvar my-package-:debug nil
+ \"Debug. On/off.\")
+
+ (defvar my-package-:debug-buffer \"*my-package*\"
+ \"Debug record buffer.\")
+
+ (defmacro my-package-debug (&rest args)
+ \"Record debug info.\"
+ (`
+ (let* ( ;; write data to package private buffer.
+ (ti:m-debug-buffer my-package-:debug-buffer))
+ (if my-package-:debug
+ (ti::d!! (,@ args))))))
+
+ ;; this is how you use the debug capability in functions.
+ ;; You must enable debug with (setq my-package-:debug t)
+ ;;
+ (defun my-package-some-function ()
+ ;; ... code
+ (my-package-debug \"here\" var1 win1ptr buffer \"\\n\" )
+ ;; ... code)")
+
+;;}}}
+
+;;{{{ setup: version
+
+(defconst tinylibm-version
+ (substring "$Revision: 2.91 $" 11 16)
+ "Latest version number.")
+
+(defconst tinylibm-version-id
+ "$Id: tinylibm.el,v 2.91 2007/05/07 10:50:07 jaalto Exp $"
+ "Latest modification time and version number.")
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylibm-version (&optional arg)
+ "Show version information. ARG will instruct to print message to echo area."
+ (interactive "P")
+ (ti::package-version-info "tinylibm.el" arg))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylibm-submit-bug-report ()
+ "Submit bug report."
+ (interactive)
+ (ti::package-submit-bug-report
+ "tinylibm.el"
+ tinylibm-version-id
+ '(tinylibm-version-id)))
+
+;;}}}
+;;{{{ code: small FORMS
+
+;;; - To see what the'll become use for example:
+;;; (macroexpand '(decf x))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro-maybe ti::definteractive (&rest body)
+ "Define simple anonymous interactive function.
+Function can take one optional argument 'arg'.
+Very useful place where you can use this function is when you
+want to define simple key functions
+
+ (global-set-key
+ \"\\C-cc\"
+ (ti::definteractive
+ (message \"You gave arg: %s\" (ti::prefix-arg-to-text arg))))"
+ (` (function (lambda (&optional arg) (interactive "P") (,@ body)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'nafboundp 'lisp-indent-function 2)
+(defmacro ti::fboundp-check-autoload (function re &rest body)
+ "Execute body if certain condition is true.
+
+a) If not FUNCTION is not bound.
+
+OR
+
+a) function is bound in autoload state and
+b) function's autoload definition matches regular expression RE
+
+In short. Do BODY only if the autoload refer to file
+matching RE. This is useful, if you define your own function that does
+not exist in current Emacs, but may exist in newer releases. Suppose
+following situation.
+
+ (if (ti::xemacs-p)
+ ;; Make a forward declaration. Say it's in library
+ (autoload 'run-at-time \"tinylibxe\"))
+
+in file tinylibxe.el:
+
+ (ti::fboundp-check-autoload 'run-at-time \"tinylibxe\"
+
+ ;; XEmacs does not have this, but it somebody made it autoload.
+ ;; The autoload refers to us, so we define the function.
+ ;; If the autoload referred somewhere else, then this form doesn't
+ ;; take in effect. Somebody else has actiated the autoload definition.
+ ;;
+ ...)"
+ (` (cond
+ ((or (and (fboundp (, function))
+ (ti::autoload-p (, function))
+ (string-match
+ (, re )
+ (nth 1 (symbol-function (, function)))))
+ (not (fboundp (, function))))
+ (,@ body)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'ti::narrow-safe 'lisp-indent-function 2)
+(put 'ti::narrow-safe 'edebug-form-spec '(body))
+(defmacro ti::narrow-safe (beg end &rest body)
+ "Narrow temprarily to BEG END and do BODY.
+This FORM preserves restriction and excursion with one command."
+ (` (save-excursion
+ (save-restriction
+ (narrow-to-region (, beg) (, end))
+ (,@ body)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'ti::narrow-to-paragraph 'lisp-indent-function 0)
+(put 'ti::narrow-to-paragraph 'edebug-form-spec '(body))
+(defmacro ti::narrow-to-paragraph (&rest body)
+ "Narrow to paragraph. Point must be already inside a paragraph."
+ (`
+ (let* (beg)
+ (when (re-search-backward "^[ \t]*$" nil t)
+ (forward-line 1)
+ (setq beg (point))
+ (when (re-search-forward "^[ \t]*$" nil t)
+ (ti::narrow-safe beg (point)
+ (,@ body)))))))
+
+;;; ----------------------------------------------------------------------
+;;; Note that nconc works only if the initial
+;;; list is non-empty, that's why we have to initialize it in the
+;;; first time with if.
+;;;
+(defmacro ti::nconc (list x)
+ "Add to LIST element X. Like nconc, but can also add to empty list.
+Using `nconc' is faster than `append'"
+ (` (setq (, list)
+ (nconc (, list) (list (, x))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;; (1 2) (cdr el) --> (2) ,this is list
+;;; (1) (cdr el) --> nil ,this too
+;;; (1 . 2) (cdr el) --> 2 ,listp returns nil
+;;;
+(defsubst ti::consp (elt)
+ "Test if ELT is in _really_ in format (X . X)."
+ (and (consp elt) ;must be some '(...) form
+ (null (listp (cdr elt)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::listp (list)
+ "Test if the there _really_ is elements in the LIST.
+A nil is not accepted as a true list."
+ (and (not (null list))
+ (listp list)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'ti::when-package 'lisp-indent-function 2)
+(put 'ti::when-package 'edebug-form-spec '(body))
+(defmacro ti::when-package (feature &optional package &rest body)
+ "If FEATURE is present or if PACKAGE exist along `load-path' do BODY.
+
+ (when-package 'browse-url nil
+ (autoload 'browse-url-at-mouse \"browse-url\" \"\" t))"
+ (`
+ (when (or (and (, feature)
+ (featurep (, feature)))
+ (locate-library (or (, package)
+ (symbol-name (, feature)))))
+ (progn
+ (,@ body)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'ti::with-require 'lisp-indent-function 2)
+(put 'ti::with-require 'edebug-form-spec '(body))
+(defmacro ti::with-require (feature &optional filename &rest body)
+ "Load FEATURE from FILENAME and execute BODY if feature is present.
+E.g. try loading a package and only if load succeeds, execute BODY.
+
+ (with-feature 'browse-url nil
+ ;;; Setting the variables etc)"
+ (`
+ (when (require (, feature) (, filename) 'noerr)
+ (,@ body))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'ti::with-time-this 'lisp-indent-function 1)
+(put 'ti::with-time-this 'edebug-form-spec '(body))
+(defmacro ti::with-time-this (function &rest body)
+ "Run FUNCTION after executing BODY and time execution.
+Float time value in seconds is sent to FUNCTION.
+
+ (ti::with-time-this '(lambda (time) (message \"Secs %f\" time))
+ (sit-for 4))."
+ (`
+ (let* ((Time-A (current-time))
+ Time-B
+ Time-Diff)
+ (prog1
+ (progn (,@ body)))
+ (setq Time-B (current-time))
+ (setq Time-Diff (ti::date-time-difference Time-B Time-A 'float))
+ (funcall (, function) Time-Diff))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'ti::with-coding-system-raw-text 'lisp-indent-function 0)
+(put 'ti::with-coding-system-raw-text 'edebug-form-spec '(body))
+(defmacro ti::with-coding-system-raw-text (&rest body)
+ "Bind `coding-system-for-write' to Unix style raw write during BODY."
+ ;; #todo: 'raw-text is for Emacs, is this different in XEmacs?
+ (` (let* ((coding-system-for-write 'raw-text))
+ (,@ body))))
+
+;;}}}
+;;{{{ small ones
+
+;;; ----------------------------------------------------------------------
+;;; Great add to comint processess.
+;;;
+(defsubst ti::process-mark (&optional buffer)
+ "Return process mark for current buffer or optional BUFFER.
+If there is no process mark, return nil."
+ (let* ((proc (get-buffer-process
+ (or buffer
+ (current-buffer)))))
+ (if proc
+ (process-mark proc))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro ti::verb ()
+ "Setq variable 'verb'.
+The variable is set If interactive flag is set or if 'verb' variable is set.
+This is usually the verbosity flag that allows printing messages.
+
+Purpose:
+
+ The 'verb' is meant to be used in function when it decides if
+ should print verbose messages. This is different that using
+ simple (interactive-p) test, because (interactive-p) is only set
+ if the function is really called interactively. For complete
+ description why (interactive-p) est alone is not always the solution
+ refer to ftp://cs.uta.fi/pub/ssjaaa/ema-code.html under heading
+ that discusses about 'funtion and displaying messages'
+
+Note:
+
+ You have to define variable 'verb' prior calling this macro,
+ preferably in function argument definition list.
+
+Example:
+
+ (defun my-func (arg1 arg2 &optional verb)
+ (interactive
+ ...do something, ask parameters)
+ (ti::verb) ;; set verbose if user calls us interactively
+ (if verb
+ (message 1))
+ ..code
+ (if verb
+ (message 2)))"
+ (`
+ (setq verb (or verb (interactive-p)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::pmin ()
+ "Go to `point-min'."
+ (goto-char (point-min)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::pmax ()
+ "Go to `point-max'."
+ (goto-char (point-max)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro-maybe int-to-float (nbr)
+ "Convert integer NBR to float."
+ (` (read (concat (int-to-string (, nbr)) ".0"))))
+
+;;; ----------------------------------------------------------------------
+;;; see also: (dotimes (var 5) ..
+;;;
+(put 'ti::dotimes 'lisp-indent-function 3)
+(defmacro ti::dotimes (var beg end &rest body)
+ "Loop using VAR from BEG to END and do BODY."
+ (` (loop for (, var) from (, beg) to (, end)
+ do
+ (progn
+ (,@ body)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro ti::funcall (func-sym &rest args)
+ "Call FUNC-SYM with ARGS. Like funcall, but quiet byte compiler.
+
+The full story:
+
+ Byte Compiler isn't very smart when it comes to knowing if
+ symbols exist or not. If you have following statement in your function,
+ it still complaints that the function \"is not known\"
+
+ (if (fboundp 'some-non-existing-func)
+ (some-non-existing-func arg1 arg2 ...))
+
+ instead use:
+
+ (if (fboundp 'some-non-existing-func)
+ (ti::funcall 'some-non-existing-func arg1 arg2 ...)
+
+ to get rid of the unnecessary warning.
+
+Warning:
+
+ You _cannot_ use ti::funcall if the function is in autoload state, because
+ `symbol-function' doesn't return a function to call. Rearrange
+ code so that you do (require 'package) or (ti::autoload-p func) test before
+ using ti::funcall."
+ (`
+ (let* ((func (, func-sym)))
+ (when (fboundp (, func-sym))
+ (apply func (,@ args) nil)))))
+;;; Old
+;;; (apply (symbol-function (, func-sym)) (,@ args) nil)
+
+;;; ----------------------------------------------------------------------
+;;; Emacs distribution, sun-fns.el -- Jeff Peck
+;;;
+(defun-maybe logtest (x y)
+ "Tinylibm: True if any bits set in X are also set in Y.
+Just like the Common Lisp function of the same name."
+ (not (zerop (logand x y))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun-maybe bin-string-to-int (8bit-string)
+ "Convert 8BIT-STRING string to integer."
+ (let* ((list '(128 64 32 16 8 4 2 1))
+ (i 0)
+ (int 0))
+ (while (< i 8)
+ (if (not (string= "0" (substring 8bit-string i (1+ i))))
+ (setq int (+ int (nth i list) )))
+ (incf i))
+ int))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun-maybe int-to-bin-string (n &optional length)
+ "Convert integer N to bit string (LENGTH, default 8)."
+ (let* ((i 0)
+ (len (or length 8))
+ (s (make-string len ?0)))
+ (while (< i len)
+ (if (not (zerop (logand n (ash 1 i))))
+ (aset s (- len (1+ i)) ?1))
+ (setq i (1+ i)))
+ s))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun-maybe int-to-hex-string (n &optional separator pad)
+ "Convert integer N to hex string. SEPARATOR between hunks is \"\".
+PAD says to padd hex string with leading zeroes."
+ (or separator
+ (setq separator ""))
+ (mapconcat
+ (function (lambda (x)
+ (setq x (format "%X" (logand x 255)))
+ (if (= 1 (length x))
+ (concat "0" x) x)))
+ (list (ash n -24)
+ (ash n -16)
+ (ash n -8)
+ n)
+ separator))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun-maybe int-to-oct-string (n &optional separator)
+ "Convert integer N into Octal. SEPARATOR between hunks is \"\"."
+ (or separator
+ (setq separator ""))
+ (mapconcat
+ (function (lambda (x)
+ (setq x (format "%o" (logand x 511)))
+ (if (= 1 (length x)) (concat "00" x)
+ (if (= 2 (length x)) (concat "0" x) x))))
+ (list (ash n -27) (ash n -18) (ash n -9) n)
+ separator))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun radix (str base)
+ "Convert STR according to BASE."
+ (let ((chars "0123456789abcdefghijklmnopqrstuvwxyz")
+ (case-fold-search t)
+ (n 0)
+ i)
+ (mapcar '(lambda (c)
+ (setq i (string-match (make-string 1 c) chars))
+ (if (>= (or i 65536) base)
+ (error "%c illegal in base %d" c base))
+ (setq n (+ (* n base) i)))
+ (append str nil))
+ n))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun-maybe bin-to-int (str)
+ "Convert STR into binary."
+ (radix str 2))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun-maybe oct-to-int (str)
+ "Convert STR into octal."
+ (radix str 8))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun hex-to-int (str)
+ "Convert STR into hex."
+ (if (string-match "\\`0x" str)
+ (setq str (substring str 2)))
+ (radix str 16))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun-maybe int-to-net (float)
+ "Decode packed FLOAT 32 bit IP addresses."
+ (format "%d.%d.%d.%d"
+ (truncate (% float 256))
+ (truncate (% (/ float 256.0) 256))
+ (truncate (% (/ float (* 256.0 256.0)) 256))
+ (truncate (% (/ float (* 256.0 256.0 256.0)) 256))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun-maybe rmac (string)
+ "Decode STRING x-mac-creator and x-mac-type numbers."
+ (if (numberp string)
+ (setq string (format "%X" string)))
+ (let ((i 0)
+ (r ""))
+ (while (< i (length string))
+ (setq r (concat
+ r
+ (make-string
+ 1
+ ;; EWas call to 'rhex'
+ (hex-to-int (concat (make-string 1 (aref string i))
+ (make-string 1 (aref string (1+ i)))))))
+ i (+ i 2)))
+ r))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun-maybe ctime (time)
+ "Print a time_t TIME."
+ (if (and (stringp time) (string-match "\\`[0-9]+\\'" time))
+ (setq time (string-to-number (concat time ".0"))))
+ (let* ((top (floor (/ time (ash 1 16))))
+ ;; (bot (floor (mod time (1- (ash 1 16)))))
+ (bot (floor (- time (* (ash 1 16) (float top))))))
+ (current-time-string (cons top bot))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst rand0 (n)
+ "Random number in [0 .. N]."
+ (cond
+ ((<= n 0)
+ 0)
+ (t
+ (abs (% (random) n)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst-maybe rand1 (n)
+ "Random number [1 .. N]."
+ (1+ (rand0 n)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun-maybe randij (i j)
+ "Random number [I .. J]."
+ (cond
+ ((< i j) (+ i (rand0 (1+ (- j i)))))
+ ((= i j) i)
+ ((> i j) (+ j (rand0 (1+ (- i j)))))
+ (t
+ (error "randij wierdness %s %s"
+ (ti::string-value i)
+ (ti::string-value j)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::string-value (x)
+ "Return a string with some reasonable print-representation of X.
+If X is an integer, it is interpreted as an integer rather than
+a character: (ti::string-value 65) ==> \"65\" not \"A\"."
+ (cond
+ ((stringp x) x)
+ ((symbolp x) (symbol-name x))
+ ((numberp x) (int-to-string x))
+ (t (prin1-to-string x))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::prin1-mapconcat (separator &rest args)
+ "Cats elements separated by single space or with SEPARATOR.
+The ARGS can be anything.
+
+Example:
+ (print1cat nil buffer frame overlay list)"
+ (let* ((ret ""))
+ (or separator
+ (setq separator " "))
+
+ (mapcar
+ (function
+ (lambda (x)
+ (setq ret
+ (concat
+ ret
+
+ (cond
+ ((integerp x)
+ (format
+ (concat "%d" separator)
+ x))
+
+ ((stringp x)
+ (format
+ (concat "%s" separator)
+ x))
+
+ ((symbolp x)
+ (format
+ (concat "'%s" separator )
+ x))
+
+ ((and (not (null x))
+ (listp x))
+ (prin1-to-string
+ (eval ;; -expression
+ (quote x))))
+ (t
+ (format
+ (concat "%s" separator)
+ x)))))))
+ args)
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;; - The world's oldest way to debug program by inserting breakpoints...
+;;;
+(defmacro ti::d! (&rest args)
+ "Debug. Show any ARGS and wait for keypress."
+ (` (save-excursion
+ (save-match-data
+ (read-from-minibuffer (ti::prin1-mapconcat "|" (,@ args)))))))
+
+;;; ----------------------------------------------------------------------
+;;; - This logs to buffer, when you can't display values, e.g. in loop
+;;; or while you're in minibuffer and reading input.
+;;; - see tinydiff.el how to use this productively.
+;;;
+(defmacro ti::d!! (&rest args)
+ "Stream debug. Record any information in ARGS to debug buffer.
+References:
+ `ti:m-debug-buffer'"
+ (`
+ (save-excursion
+ (ti::append-to-buffer
+ (get-buffer-create ti:m-debug-buffer)
+ (save-match-data
+ (ti::prin1-mapconcat "|" (,@ args)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::string-left (str count)
+ "Use STR and read COUNT chars from left.
+If the COUNT exeeds string length or is zero, whole string is returned."
+ (if (> count 0)
+ (substring str 0 (min (length str) count))
+ str))
+
+;;; ----------------------------------------------------------------------
+;;; - You can do this with negative argument to substring, but if you exceed
+;;; the string len, substring will barf and quit with error.
+;;; - This one will never call 'error'.
+;;;
+(defsubst ti::string-right (str count)
+ "Use STR and read COUNT chars from right.
+If the COUNT exeeds string length or is zero, whole string is returned."
+ (let* ((pos (- (length str) count)))
+ (if (> pos 0)
+ (substring str (- 0 count))
+ str)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::string-match-case (re str &optional case-fold start)
+ "Do local case sensitive match.
+Input:
+ RE See `string-match'
+ STR See `string-match'
+ CASE-FOLD Value of `case-fold-search', nil means sensitive.
+ START See `string-match'"
+ (let ((case-fold-search case-fold))
+ (string-match re str start)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::month-list ()
+ "Return LIST: month names in short format."
+ (list "Jan" "Feb" "Mar" "Apr" "May" "Jun"
+ "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::month-list-regexp (&optional cat-str)
+ "Return month regexp separated by ' \\\\|' or CAT-STR.
+There is intentional space, since short month name is supposed to
+follow something else."
+ (let* ((ret
+ (mapconcat 'concat (ti::month-list) (or cat-str " \\|"))))
+ ;; The last item must be handled separately
+ (if (null cat-str)
+ (concat ret " "))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::month-mm-alist () ;mm = month first
+ "Short month names in alist form: ((\"Jan\" 1) ..)."
+ '( ("Jan" . 1) ("Feb" . 2) ("Mar" . 3)
+ ("Apr" . 4) ("May" . 5) ("Jun" . 6)
+ ("Jul" . 7) ("Aug" . 8) ("Sep" . 9)
+ ("Oct" . 10) ("Nov" . 11) ("Dec" . 12)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::month-nn-alist () ;nn = nbr first
+ "Short month names in alist form: ((1 \"Jan\") ..)."
+ '( (1 . "Jan") (2 . "Feb") (3 . "Mar")
+ (4 . "Apr") (5 . "May") (6 . "Jun")
+ (7 . "Jul") (8 . "Aug") (9 . "Sep")
+ (10 . "Oct") (11 . "Nov") (12 . "Dec")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::month-to-number (month &optional zero-padded)
+ "Convert MONTH, 3 character initcap month name e.g. `Jan' to number."
+ (let ((nbr (cdr-safe (assoc month (ti::month-mm-alist)))))
+ (if zero-padded
+ (format "%02d" nbr)
+ nbr)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::month-to-0number (month)
+ "Convert MONTH, 3 character capitalized month name e.g. `Jan' to 01."
+ (format "%02d" (cdr (assoc month (ti::month-mm-alist)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::number-to-month (number)
+ "Convert NUMBER to month, 3 character capitalized name e.g. `Jan'."
+ (cdr-safe (assoc number (ti::month-nn-alist))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::date-eu-list ()
+ "Return list: European date list."
+ '("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun"))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::date-us-list ()
+ "Return list: US date list."
+ '("Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat"))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::date-list-regexp (&optional cat-str)
+ "Return date regexp combined with CAT-STR.
+There is intentional SPACE after each date.
+
+Input:
+ CAT-STR default is \" \\\\|\""
+ (let* ((ret
+ (mapconcat 'concat (ti::date-eu-list) (or cat-str " \\|"))))
+ ;; The last item must be handled separately
+ (if (null cat-str)
+ (concat ret " "))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;; In XEmacs20, you can't use following
+;;; (memq ch '(?a ?b ?c ?d ?e ?f)), because 'eq' test against
+;;; characters is wrong.
+;;;
+;;; Neither is this format recommended.
+;;; (memq (char-int ch) (mapcar 'char-int '(?a ?b ?c ?d ?e ?f)))
+;;;
+;;; cl's (member* ch '(?a ?b) :test 'char=)
+;;;
+(defsubst ti::char-in-list-case (char list)
+ "If CHAR can be found in LIST, return a pointer to it.
+The match is case sensitive."
+ (when char
+ (let* (case-fold-search)
+ (member* char list :test 'char=))))
+
+;;; ----------------------------------------------------------------------
+;;; #todo: read-char-exclusive?
+
+(defsubst ti::read-char-safe (&optional prompt)
+ "Wait for character until given and ignore all other events with PROMPT.
+The `read-char' command chokes if mouse is moved while reading input.
+This function returns 'ignore if the `read-char' couldn't read answer.
+Otherwise it returns normal character.
+
+Note:
+
+ The cursor is not in the echo area when character is read. This
+ may be confusing to user if you read multiple characters.
+
+References:
+
+ `ti::read-char-safe-until'
+ `read-char-exclusive'
+
+Return:
+
+ ch character
+ 'ignore if read failed due to non-char event."
+ (condition-case nil
+ (progn
+ (message (or prompt "")) ;prevent echoing keycodes...
+ (discard-input) ;this is a must before we read
+
+ ;; char-int
+ ;; Emacs: this is no-op
+ ;; XEmacs19.14: char-int doesn't exist.
+ ;; XEmacs20: read-char has changed, it does not return
+ ;; int, but a character type, and we need conversion
+
+ (read-char))
+ (error
+ 'ignore)))
+
+;;; ----------------------------------------------------------------------
+;;; Note: see function `read-char-exclusive' in never Emacs versions, 19.29+
+;;; Hm, It does not implement LIST of choices to accept.
+;;;
+(defun ti::read-char-safe-until (&optional prompt list)
+ "Read character until given. Discards any events that are not characters.
+
+Input:
+
+ PROMPT text displayed when asking for character
+ LIST list of character choices. The prompting won't stop until one of
+ the list memebers has been selected.
+
+Return:
+
+ character character type"
+ (let* (ch)
+ (cond
+ ((null list)
+ (while (symbolp (setq ch (ti::read-char-safe prompt)))))
+ (list
+ ;; Check args or we're thrown on planetary ride, which never ends
+ (if (or (not (ti::listp list))
+ ;; eshell-2.4.1/esh-mode.el mistakenly defines characterp
+ ;; make sure this function is always correct.
+ (prog1 nil
+ (ti::compat-character-define-macro 'characterp 'integerp))
+ (not (characterp (car list))))
+ (error "Invalid list, must contain character in LIST %s" list))
+ ;; We don't have to do character conversion, because they are
+ ;; treated as ints
+ (while (or (symbolp (setq ch (ti::read-char-safe prompt)))
+ (null ch)
+ (not (ti::char-in-list-case ch list))))))
+ (message "")
+ ch))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::remove-properties (string)
+ "Remove properties from STRING. Modifies STRING permanently.
+Return:
+ string with no properties."
+ (when (stringp string)
+ (set-text-properties 0 (length string) nil string)
+ string))
+
+;;; ----------------------------------------------------------------------
+;;; - this is from fsf-translate-keys.el
+;;;
+(defmacro ti::applycar (function-form list-form)
+ "Like mapcar, but does (apply FUNCTION-FORM (car LIST-FORM)).
+Instead of (funcall FUNCTION (car LIST)). This is very useful for
+invoking some function with many different sets of arguments.
+
+Examples:
+
+ (ti::applycar 'global-set-key
+ '(
+ ([f12] repeat-complex-command) ; Again L2
+ ([f14] undo) ; Undo L4
+ ([f16] copy-region-as-kill) ; Copy L6
+ ([f18] yank) ; Paste L8
+ ([f20] kill-region))) ; Cut L10
+
+ --> (nil nil nil nil nil) ;; global - set - key returns 'nil
+
+ (ti::applycar (lambda (a b) (list b a)) ;; swaps arguments
+ '((1 2)(3 4)))
+
+ --> ((2 1) (4 3))"
+ (let ((spec-name (gensym)))
+ (` (mapcar (lambda ((, spec-name))
+ (apply (, function-form) (, spec-name)) )
+ (, list-form) ))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::add-command-line-arg (arg &optional func)
+ "Add ARG into `command-switch-alist' if it's not already there.
+This inhibits argument to be treated as filename.
+
+Optional FUNC is called when arg is found. Default FUNC used is 'ignore."
+ ;; make sure it's not there already
+ (or (assoc arg command-switch-alist)
+ (setq command-switch-alist
+ (cons (cons arg (or func 'ignore))
+ command-switch-alist))))
+
+;;}}}
+;;{{{ tests; small ones
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::buffer-modified-p (&optional buffer)
+ "Same as `buffer-modified-p' but acceps arg BUFFER."
+ (if (null buffer)
+ (buffer-modified-p)
+ (with-current-buffer buffer
+ (buffer-modified-p))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::buffer-minibuffer-1-p ()
+ "Test if current buffer is minibuffer."
+ (window-minibuffer-p (selected-window)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::buffer-minibuffer-p (&optional buffer)
+ "Check if BUFFER is minibuffer. Defaults to current buffer."
+ (cond
+ ((and buffer
+ (buffer-live-p buffer))
+ (with-current-buffer buffer
+ (ti::buffer-minibuffer-1-p)))
+ ((null buffer)
+ (ti::buffer-minibuffer-1-p))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::first-line-p ()
+ "Check if cursor is at first line"
+ (save-excursion
+ (beginning-of-line)
+ (bobp)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::last-line-p ()
+ "Check if cursor is at last line"
+ (save-excursion
+ (end-of-line)
+ (eobp)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::buffer-narrowed-p ()
+ "Check if buffer is narrowed."
+ (not (eq 1 (point-min))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::buffer-empty-p (&optional buffer)
+ "Check if BUFFER is empty.
+Buffer is considered empty if
+
+a) real `point-min' == `point-max'
+b) or it contains only whitespace characters.
+
+Return:
+
+ nil buffer contains something
+ t it is empty.
+ 'empty contains only whitespace"
+ (with-current-buffer (or buffer (current-buffer))
+ (if (eq (point-min-marker) (point-max-marker))
+ t
+ (ti::pmin)
+ (if (re-search-forward "[^ \n\t]" nil t)
+ nil
+ 'empty))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::ck-maybe-activate (&optional type mode message)
+ "Activate keybinding conversion if used Emacs needs it.
+Call `ti::ck-advice-control' with parameter mode if key conversion needed.
+This ensures that binding work in any Emacs (XEmacs and Emacs).
+If you only use STRING bindings only use string notation
+
+ (global-set-key \"\\C-c\\C-f\" ...)
+
+then you don't need this function.
+
+TYPE
+
+ Informs how you have written the keybindings. The 'xemacs binding
+ type is already supported by 19.33+ Emacs releases, but if you want your
+ packages be backward compatible you want to call this functions prior
+ bind definitions. Note: if you call this function with parameter
+ 'xemacs and ey definitions being bound are done in Emacs that supports
+ XEmacs style bindings, this function is no-op.
+
+ # The Control-a binding is stylistically exploded due to
+ # checkdoc.el
+ #
+ 'emacs Your bindings are like [?\\C - a] and [f10]
+ 'emacs-mouse You use Emacs specific binding [mouse-1]
+ 'xemacs Your bindings are like [(control ?a)] and [(f10)]
+ 'xemacs-mouse You use XEmacs specific binding [(button1)]
+
+MODE
+
+ nil You pass this argument bfore you start defining keys
+ 'disable You pass this, when you have finished.
+
+MESSAGE
+
+ Message you want to display if conversion is activated.
+
+Example:
+
+ (ti::ck-maybe-activate 'emacs) ;; turn conversion on in Xemacs
+ (define-key [f1] 'xxx-function-call)
+ <other key definitions ...>
+ (ti::ck-maybe-activate 'emacs 'disable) ;; conversion off
+
+Recommendation:
+
+ It is recommended that you write using the 'xemacs style, which
+ is also supported in later Emacs releases 19.30+. If you do so,
+ then calling this function is no-op in those Emacsen that support
+ XEmacs style and you save the call to tinyck.el package.
+
+Return:
+
+ t conversion activated
+ nil"
+ (let* ((emacs-major (ti::emacs-p))
+ (common (or (ti::xemacs-p)
+ (eq 20 emacs-major)
+ (and
+ ;; 19.34 Added XEmacs styled binding support
+ (eq 19 emacs-major)
+ (> emacs-minor-version 33)))))
+
+ ;; If there is mouse button bindings, then we have to use the conversion.
+ ;; Turn off "compatibility" flag between Emacs and XEmacs
+
+ (if (memq type '(xemacs-mouse emacs-mouse))
+ (setq common nil))
+
+;;; (eval-and-compile (ti::d! type common emacs-major message))
+
+ (unless common
+ (cond
+ ((memq type '(xemacs xemacs-mouse))
+ (when (ti::emacs-p) ;XEmacs bindings and we're in Emacs
+ (if message (message message))
+ (ti::ck-advice-control mode)
+ t))
+ ((memq type '(emacs emacs-mouse))
+ (when (ti::xemacs-p) ;Emacs bindings and we're in XEmacs
+ (if message (message message))
+ (ti::ck-advice-control mode)
+ t))
+ (t
+ (error "Unknown type %s" type mode))))))
+
+;;; ----------------------------------------------------------------------
+;;; See register.el::insert-register
+;;;
+(defsubst ti::register-live-p (char)
+ "Test if register CHAR contain valid window configuration or mark."
+ (let ((val (get-register char)))
+ (if (or (consp val) ;window config
+ (and (markerp val) ;mark
+ (marker-buffer val))) ;not killed, reverted
+ t
+ nil)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::file-dos-p ()
+ "Check if there is anywhere \\r$ in the buffer."
+ (save-excursion
+ (ti::pmin)
+ (re-search-forward "\r$" nil t)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::space-p (char)
+ "Return t if character CHAR is space or tab."
+ (or (char= char ?\t)
+ (char= char ?\ )))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::compat-face-p (face-symbol)
+ "XEmacs ad Emacs compatibility, Check if the FACE-SYMBOL exists."
+ (cond
+ ((fboundp 'find-face)
+ (ti::funcall 'find-face face-symbol))
+ ((fboundp 'face-list)
+ (memq face-symbol (ti::funcall 'face-list)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::color-type ()
+ "Read Frame background and return `background-mode: 'dark 'light."
+ ;; (frame-parameter 'display-type)
+ ;; (frame-parameters (selected-frame))
+ ;; We can't read frame information when we have no visible window.
+ (frame-parameter (selected-frame) 'background-mode))
+
+;;; ----------------------------------------------------------------------
+;;; Emacs 21.3+ includes this, but is it not the same as here
+;;; (color-supported-p COLOR FRAME &optional BACKGROUND-P)
+(defun ti::colors-supported-p ()
+ "Check if colours can be used (that thay can be displayed)."
+ (cond
+ ((ti::emacs-p)
+ (or ;; (and (fboundp 'x-display-color-p)
+ ;; (ti::funcall 'x-display-color-p))
+ (ti::compat-window-system) ;; Under 21, no colors in tty
+ (> emacs-major-version 20)))
+ ((ti::xemacs-p)
+ (or (and (fboundp 'device-class)
+ ;; x-display-color-p can only be called in X, otw gives error
+ (eq 'color (ti::funcall 'device-class)))
+ ;; #todo: Can I consider font-lock support for TTY as
+ ;; color support? Here I assume yes.
+ (> emacs-major-version 19) ;XEmacs 20+ does tty
+ (and (eq emacs-major-version 19) ;> 19.15 does too
+ (> emacs-minor-version 14))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::color-lighter (color &optional percentage)
+ "From base COLOR, make it integer PERCENTAGE, default 5, lighter."
+ (or percentage
+ (setq percentage 5))
+ (let* ((components (x-color-values color))
+ (new-components
+ (mapcar (lambda (comp)
+ (setq comp (/ comp 256))
+ (incf comp (/ (* percentage 256) 100))
+ (when (< comp 0)
+ (setq comp 0))
+ (if (> comp 255)
+ (setq comp 255))
+ comp)
+ components)))
+ (apply 'format "#%02x%02x%02x" new-components)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::overlay-supported-p ()
+ "Check if overlays are supported."
+ (or (ti::emacs-p)
+ ;; XEmacs has overlay emulation package, but only the 20.x
+ ;; version works right.
+ (and (ti::xemacs-p "20.0" )
+ (or (featurep 'overlay)
+ (load "overlay" 'noerr))))) ;; will return t if load was ok
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::idle-timer-supported-p ()
+ "Check if reliable idle timers are supported."
+ (and (fboundp 'run-with-idle-timer)
+ (or (ti::emacs-p) ;; Idle timers work in all Emacs versions Win32/Unix
+ ;; Only work in XEmacs under 21.2+
+ (ti::xemacs-p "21.2"))))
+
+;;}}}
+;;{{{ misc, matching
+
+;;; - The functions must be here, because defsubsts must be defined
+;;; before used
+
+(eval-and-compile
+
+;;; ----------------------------------------------------------------------
+;;; The old replace-match doesn't have support for subexpressions.
+;;; 19.28: (replace-match NEWTEXT &optional FIXEDCASE LITERAL STRING)
+;;; 19.34: (replace-match NEWTEXT &optional FIXEDCASE LITERAL STRING SUBEXP)
+;;;
+ (defun ti::replace-match (level &optional replace string)
+ "Kill match from buffer at submatch LEVEL or replace with REPLACE.
+Point sits after the replaced or killed area.
+
+Input:
+
+ LEVEL Replace submatch position. 0 is full match
+ REPLACE [optional] The replce string
+ STRING [optional] If match was against string, supply the string here,
+ like in (ti::replace-match 1 replace str)
+Return:
+
+ t action taken
+ nil if match at LEVEL doesn't exist.
+ str if string was given"
+ (if (null string)
+ (cond
+ ((match-end level)
+ (delete-region (match-beginning level) (match-end level))
+ ;; I think emacs has bug, because cursor does not sit at
+ ;; match-beginning if I delete that region, instead it is off +1
+ ;; --> force it to right place
+ (and replace
+ (goto-char (match-beginning level))
+ (insert replace))))
+
+ (when (match-end level) ;Handle string case
+ (concat
+ (substring string 0 (match-beginning level))
+ (if replace replace "")
+ (substring string (match-end level))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+ (defsubst ti::buffer-kill-control-characters ()
+ "Kill all control characters from the buffer."
+ (interactive)
+ (save-excursion
+ (ti::pmin)
+ ;; Excludes tab,ff,cr,lf.
+ (while (re-search-forward "[\000-\010\016-\037]+" nil t)
+ (ti::replace-match 0))))
+
+;;; ----------------------------------------------------------------------
+;;;
+ (defsubst ti::string-match (re level str)
+ "Return RE match at LEVEL from STR. Nil if no match at level."
+ (if (string-match re str)
+ (match-string level str)))
+
+;;; ----------------------------------------------------------------------
+;;;
+ (defsubst ti::buffer-match (re level)
+ "Return string matching RE from _buffer_ at LEVEL. Use `looking-at'.
+Nil if no match at level."
+ (if (looking-at re)
+ (match-string level)))
+
+ ) ;; eval-and-compile
+
+;;}}}
+;;{{{ tests cont'd
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::selective-display-line-p ()
+ "Check if this line is collapsed with selective display.
+Note: `selective-display' variable is usually t and the line contains \\r."
+ (save-excursion
+ (beginning-of-line)
+ (looking-at ".*\r")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::bool-p (var)
+ "Test if VAR is nil or t."
+ (or (eq var nil) (eq var t)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro ti::print-p (ch)
+ "Determines if character CH can be printed normally.
+CH can be anything and this function won't choke. The \\t \\r \\n and \\f
+codes are considered printable.
+
+Return:
+
+ t
+ nil"
+ (` (if (and (not (null (, ch))) ;it must not be nil
+ (or (ti::char-in-list-case (, ch) '(?\t ?\n ?\r ?\f))
+ ;; esh-mode.el makes wrong definition of
+ ;; `char-int'. Fix it.
+ (prog1 t
+ (ti::compat-character-define-macro 'char-int 'identity))
+ (and
+ (> (char-int (, ch)) 31)
+ (< (char-int (, ch)) 127))))
+ t nil)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::char-case-p (char)
+ "Check if character is uppercase or lowercase.
+
+Return:
+ t uppercase
+ nil lowercase
+ nbr if character isn't in set [A-Za-z] it returns CHAR."
+ (cond
+ ((and (>= (char-int char) 97) (<= (char-int char) 122))
+ nil)
+ ((and (>= (char-int char) 65) (<= (char-int char) 90))
+ t)
+ (t
+ char)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::nil-p (var)
+ "Test if VAR is empty.
+Variable with only whitespaces [ \\f\\t\\r\\n]* is considered empty too.
+
+Example:
+ (if (ti::nil-p (setq answer (read-from-minibuffer \"give dime? \")))
+ (message \"No fruit juice for you then.\"))"
+ (or (eq nil var)
+ (and (stringp var)
+ (or (string= var "")
+ (not (string-match "[^ \t\f\r\n]" var))))))
+
+;;; ----------------------------------------------------------------------
+;;; #todo: XEmacs: pos-visible-in-window-p ?
+(defsubst ti::window-pmin-visible-p ()
+ "Check if the `point-min' is visible in current window."
+ (eq (window-start) (point-min)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro ti::window-pmax-visible-p ()
+ "Check if the `point-max' is visible in current window."
+ (eq (window-end) (point-max)))
+
+;;; ----------------------------------------------------------------------
+;;; Window pmin == the area of buffer that user sees, top line
+;;;
+(defun ti::window-pmax-line-p ()
+ "Check if cursor is on the same line as window's `point-max'."
+ (let (point)
+ (save-excursion
+ (beginning-of-line)
+ (setq point (point))
+ (goto-char (window-end))
+ ;; a) if the last line DOES NOT exceed the window len; then the
+ ;; (window-end) is in next unvisible line. --> backward char
+ ;; brings it to previous line
+ ;; b) if the last line exceed the window len; then the
+ ;; (window-end) puts cursor at the last line. --> backward-char
+ ;; is no-op.
+ (backward-char 1)
+ (beginning-of-line)
+ (eq (point) point))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::window-pmin-line-p ()
+ "Check if cursor is on the same line as window's `point-min'."
+ (save-excursion
+ (beginning-of-line)
+ ;; The 1- is due to fact that there is NEWLINE, where C-e command
+ ;; does not ever go.
+ (eq (point) (window-start))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::window-pmax-line-bol (&optional eol-point)
+ "Return window's last line's beginnning of point or EOL-POINT."
+ (save-excursion
+ ;; This is past of visible window, that why we go up one line
+ (goto-char (window-end))
+ (backward-char 1)
+ (if eol-point
+ (end-of-line)
+ (beginning-of-line))
+ (point)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::window-middle-line ()
+ "Computes middle line nbr in current window."
+ (let* ((win-min (count-lines (point-min) (window-start)))
+ (win-max (count-lines (point-min) (window-end)))
+ (middle (+ win-min (/ (1+ (- win-max win-min)) 2))))
+ middle))
+
+;;; ----------------------------------------------------------------------
+;;; Ideas from eldoc.el
+;;;
+(defun ti::no-action-in-progress-p (mode)
+ "Return t if there is no action currently in progress.
+This means that following cases indicate that action is in progress
+and it should not be interfered.
+
+o if cursor is in the minibuffer
+o keyboard macro is executing
+
+Input MODE
+
+ 'timer
+ This says that the function that calls us is currently run
+ by an timer functin (19.34+)
+
+ 'post-command
+ Same as above; but this time calling command is running in post hook.
+
+This function is usually called from background processes that are
+run by timers or post-command*hook functions when they want to print
+something in the echo area."
+ (and
+ (not executing-kbd-macro)
+ ;; Having this mode operate in an active minibuffer/echo area causes
+ ;; interference with what's going on there.
+ (not cursor-in-echo-area)
+ ;; Somehow this isn't quite doing what I want. If tested with C-x
+ ;; C-f open, it still goes on loading while this function should
+ ;; tell "user is in minibuffer"
+ (not (eq (selected-window) (minibuffer-window)))
+ ;; This has been disabled because user may move away from the
+ ;; minibuffer but the minibuffer still stays active there. -->
+ ;; the previous test already tells if user is really doing
+ ;; something in minibuffer
+;;; (not (minibuffer-window-active-p (minibuffer-window)))
+ (sit-for 0.2)
+ (cond
+ ((eq mode 'timer)
+ ;; If this-command is non-nil while running via an idle
+ ;; timer, we're still in the middle of executing a command,
+ ;; e.g. a query-replace where it would be annoying to
+ ;; overwrite the echo area.
+ (and (not this-command)
+ (symbolp last-command)))
+ ((eq mode 'post-command)
+ ;; If this-command is non-nil while running via an idle
+ ;; timer, we're still in the middle of executing a command,
+ ;; e.g. a query-replace where it would be annoying to
+ ;; overwrite the echo area.
+ (and (symbolp this-command)
+ (sit-for 0.3))))))
+
+;;}}}
+;;{{{ line
+
+;;; ----------------------------------------------------------------------
+;;; Should return the same as goto-line, does it always ?
+;;;
+(defun ti::current-line-number (&optional pmin)
+ "Return current line number from the beginning of buffer.
+If ti::pmin is non-nil the `point-min' is used for starting point, this
+is useful e.g. for narrowed case. Normally returns true line number.
+
+This function counts the number of \\n chartacters, so it will
+return right count even in folding/outline buffers where selective
+display is used. Using command `count-lines' would return false value.
+
+Lines are counted from 1..x"
+ ;; - always use line beginning as reference
+ ;; - The count-lines returns 0 for 1st line --> 1+
+ (1+ (count-char-in-region
+ (if pmin
+ (point-min)
+ (point-min-marker))
+ (line-beginning-position)
+ ?\n)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::read-current-line (&optional point)
+ "Retun whole line or portion of line, starting from POINT to the eol."
+ (save-excursion
+ (if point
+ (goto-char point))
+ (buffer-substring
+ (if point (point)
+ (line-beginning-position))
+ (line-end-position))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(eval-and-compile
+ (defsubst ti::line-length (&optional point)
+ "Length of current line. Optionally from POINT."
+ (save-excursion
+ (if point (goto-char point))
+ (end-of-line)
+ (current-column))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::line-wrap-p ()
+ "Check if line wraps. ie. line is longer that current window."
+ (> (ti::line-length) (nth 2 (window-edges))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::re-search-check (re &optional level start-form read)
+ "Check whole buffer for regexp RE.
+
+Input:
+
+ RE regexp to search
+ LEVEL which sublevel in regexp to match, default is 0
+ START-FORM form yielding starting point of search. Default is `point-min'
+ READ read the match instead of returning point
+
+Return:
+
+ start point of match at level.
+ string
+ nil)"
+ (save-excursion
+ (if start-form
+ (goto-char (eval start-form))
+ (ti::pmin))
+ (when (re-search-forward re nil t)
+ (if read
+ (match-string (or level 0))
+ (match-beginning (or level 0))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::re-search-point-list (regexp-list &optional pos-function end)
+ "Return list of points that were found using REGEXP-LIST.
+Input:
+ REGEXP-LIST List of regexps
+ POS-FUNCTION is used to position the point if regexp was found.
+ The point used is read after POS-FUNCTION.
+ END max search point."
+ (let* (list)
+ (dolist (re regexp-list)
+ (save-excursion
+ (when (re-search-forward re end t)
+ (if pos-function (funcall pos-function))
+ (push (point) list))))
+ list))
+
+;;}}}
+
+;;{{{ Special lists, assoc
+
+;;; ----------------------------------------------------------------------
+;;; Many times you want to have data structure with some KEY
+;;;
+(defmacro ti::assoc-append-inside (func key list add)
+ "Add to the ASSOC list new ELT.
+List must be in format, K = key, E = element.
+ ( (K . (E E) (K . (E E)) .. )
+
+Input:
+
+ FUNC 'assq or 'assoc or any other to get inner list
+ KEY key
+ LIST list
+ ADD element to add
+
+Example:
+
+ (setq list '( (1 . (a b)) (2 . (c d))))
+ (ti::assoc-append-inside 'assq 1 list 'x)
+
+ -->
+ '( (1 . (a b x)) (2 . (c d))))"
+ (`
+ (let* (EL-T
+ LIS-T)
+ (if (not (setq EL-T (funcall (, func) (, key) (, list))))
+ (push (cons (, key) (list (, add))) (, list))
+ (setq LIS-T (cdr EL-T))
+ (push (, add) LIS-T)
+ (setcdr EL-T LIS-T)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::assoc-replace-maybe-add (target-list-sym list &optional remove)
+ "Set TARGET-LIST-SYM entry to LIST of pairs (STRING . CDR-ELT).
+If the LIST's STRING is found, replace CDR-ELT of TARGET-LIST-SYM.
+If no STRING found, add new one to the beginning of TARGET-LIST-SYM.
+
+Input:
+
+ TARGET-LIST-SYM Is assoc list, e.g.
+ `auto-mode-alist' or `interpreter-mode-alist'
+ LIST Is assoc list that are used in replacing or adding.
+ Similar to target-list-sym: ((STRING . SYM) ...)
+ REMOVE Instead of adding or modifying, remove items.
+
+Examples:
+
+ ;; This will redefine .el and .h definitions
+ ;; in `auto-mode-alist'
+
+ (ti::assoc-replace-maybe-add
+ 'auto-mode-alist
+ '((\"\\.el\\'\" . lisp-mode)
+ (\"\\.h\\'\" . c++-mode)))
+
+Return:
+
+ nil Nothing done
+ t Something done."
+ (let* (regexp
+ cdr-elt
+ ret
+ copy)
+ ;; 1. We try to find the regexp. This may change from emacs to emacs
+ ;; 2. If it is found (same as in previous emacs release), then change
+ ;; "in place"
+ ;; 3. Prepend new member to the list to be sure that we get the
+ ;; control over file name specification. If function is later called
+ ;; again (reloading emacs settings), then control goes to case (2)
+ ;; and we won't be prepending more cells to the list.
+
+ (unless (ti::listp (car list))
+ (error "Need LIST '( (STRING . SYM) )"))
+
+ (cond
+ (remove
+ (dolist (elt (symbol-value target-list-sym))
+ (setq regexp (car elt))
+ (unless (assoc regexp list)
+ (setq ret t)
+ (push elt copy)))
+ (if (and ret copy)
+ (set target-list-sym (copy-alist copy))))
+ (t
+ (setq ret t)
+ (dolist (elt list)
+ ;; The ELT is cons: (REGEXP . CDR-ELT)
+ (setq regexp (car elt) cdr-elt (cdr elt))
+ ;; Is the regexp there already (the assoc makes the lookup)
+ (cond
+ ((setq elt (assoc regexp (symbol-value target-list-sym)))
+ (setcdr elt cdr-elt))
+ (t
+ (set target-list-sym
+ (cons
+ (cons regexp cdr-elt)
+ (symbol-value target-list-sym))))))))
+ ret))
+
+;;}}}
+;;{{{ list
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'ti::let-transform-nil 'edebug-form-spec '(body))
+(put 'ti::let-transform-nil 'lisp-indent-function 1)
+(defmacro* ti::let-transform-nil ((&rest vars) &body body)
+ "Wrap list of VARS inside `let' and set all value to nil.
+This macro could be used to set e.g. hook values to temporarily
+nil.
+
+ (defvar my-hook-list '(find-file-hooks write-fil-hooks))
+
+ (defun my-test ()
+ (ti::let-transform-nil my-hook-list
+ ... do something, the hooks are now suppressed.
+ ...))
+
+That is efectively save as you would have written:
+
+ (defun my-test ()
+ (let (find-file-hooks
+ write-fil-hooks)
+ ... do something, the hooks are now suppressed.
+ ...))"
+ ;; If VARS is a variable, assume we wanted its value.
+ ;; otherwise, we just take it as a literal list.
+ ;; This means that both (ti::let-transform-nil (a b) ...)
+ ;; and (ti::let-transform-nil foo ...) work (assuming foo is boundp).
+ ;;
+ ;; This would also work:
+ ;;
+ ;; (defmacro my-let (symbols &rest body)
+ ;; `(progv ,symbols ,(make-list (length symbols) nil)
+ ;; ,@body))
+ ;;
+ (ignore-errors
+ (setq vars (symbol-value vars)))
+ `(let ,vars
+ ,@body))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::list-make (single-or-list)
+ "Converts SINGLE-OR-LIST into list.
+If argument is already a list this macro is no-op."
+ (if (listp single-or-list)
+ single-or-list
+ (list single-or-list)))
+
+;;; ----------------------------------------------------------------------
+;;; - unfortunately recursion is quite slow, but this is
+;;; exceptional example!
+;;;
+;;; (defun list-flatten (l)
+;;; (cond ((consp l) (append (flatten (car l)) (flatten (cdr l))))
+;;; ((null l) l)
+;;; (t (list l))))
+;;;
+(defun ti::list-flatten (l)
+ "Flatten list L."
+ (let (result stack)
+ (while (or stack l)
+ (if l
+ (if (consp l)
+ (setq stack (cons (cdr l) stack) l (car l))
+ (setq result (cons l result) l nil))
+ (setq l (car stack)
+ stack (cdr stack))))
+ (nreverse result)))
+
+;;; ----------------------------------------------------------------------
+;;; #todo : should this use prin1-to-string, before extarcting elements,
+;;; any toughts ?
+;;;
+(defun ti::list-join (list &optional join-str)
+ "Joins string LIST with JOIN-STR, whic defaults to space."
+ (let* (ret
+ (ch (or join-str " ")))
+ (while list
+ (setq ret (concat (or ret "") (car list)))
+ (setq list (cdr list))
+ (if list ;only if still elements
+ (setq ret (concat ret ch))))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::list-to-assoc-menu (list)
+ "Converts string or number items in LIST into assoc menu.
+Items are numbered starting from 0.
+
+'(1 2 \"a\" \"b\") --> '((\"1\" . 1) (\"2\" . 2) (\"a\" . 3) (\"b\" . 4))
+
+This is useful, if you call x popup menu or completion. For example:
+
+(completing-read \"complete number: \"
+ (ti::list-to-assoc-menu '(111 222 333 444)))"
+ (let* ((i 0)
+ ret)
+ (dolist (elt list)
+ (if (integerp elt)
+ (setq elt (int-to-string elt)))
+ (push (cons elt i) ret)
+ (incf i))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::list-to-cons (list)
+ "Turn list to paired cons list '(1 2 3 4) --> '((1 . 2) (3 .4))."
+ (let* (ret)
+ (while list
+ (push (cons (pop list) (pop list)) ret))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::list-remove-successive (list function)
+ "Remove succesive same elements from LIST.
+
+Input:
+
+ LIST list
+ FUNCTION accept Arg1 and Arg2 in list, should return non-nil
+ if elements are the same. Arg1 and Arg2 are taken
+ as 'car' in the list.
+
+Example:
+
+ (ti::list-remove-successive '(1 1 2 2 3) 'eq)
+ --> '(1 2 3)
+ (ti::list-remove-successive '(\"1\" \"1\" \"2\" \"2\" \"3\") 'string=)
+ --> '(\"1\" \"2\" \"3\")"
+ (let* (new-list
+ prev)
+ (dolist (elt list)
+ (unless (funcall function prev elt)
+ (setq prev elt) ;prev value
+ (push elt new-list)))
+ (nreverse new-list)))
+
+;;}}}
+;;{{{ list
+
+;;; ----------------------------------------------------------------------
+;;; This is very useful when contruction interactive calls
+;;; (interactive
+;;; (ti::list-merge-elements
+;;; (region-beginning)
+;;; (region-end)
+;;; (funcall get-3-arg-list) ;; this returns '(arg1 arg2 arg3)
+;;; ))
+;;;
+;;; --> (1 100 arg1 arg2 arg3)
+;;;
+(defun ti::list-merge-elements (&rest args)
+ "Merge single elements, ARGS, and one dimensional lists to one list.
+Example:
+ (ti::list-merge-elements 1 2 'some '(type here))
+ -->
+ '(1 2 some type here)"
+ (let* (ret)
+ (dolist (elt args)
+ (if (ti::listp elt)
+ (dolist (x elt) (push x ret))
+ (push elt ret)))
+ (nreverse ret)))
+
+;;; ----------------------------------------------------------------------
+;;; - Ever struggled with peeking the lists..?
+;;; - I have, and printing the contents of auto-mode-alist into
+;;; the buffer is very easy with this.
+;;; - Should be default emacs function.
+;;;
+(defun ti::list-print (list)
+ "Insert content of LIST into current point."
+ (interactive "XLisp symbol, list name: ")
+ (mapcar
+ (function
+ (lambda (x) (insert (ti::string-value x) "\n")))
+ list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::list-to-string (list &optional separator)
+ "Convert LIST into string. Optional SEPARATOR defaults to \" \".
+
+Input:
+
+ LIST '(\"str\" \"str\" ...)
+ separator ' '
+
+Return:
+ str"
+ (mapconcat
+ (function identity) ;returns "as is"
+ list
+ (or separator " ")))
+
+;;; ----------------------------------------------------------------------
+;;; This enables you to access previous and next element easily.
+;;;
+(defun ti::list-elt-position (list arg &optional test-form)
+ "Return position 0..x in list.
+
+Input:
+
+ LIST list
+ ARG this position in list is sought
+ TEST-FORM defaults to 'equal, you can use ARG and LIST in the
+ test form. Example: '(string= (car list) arg)
+
+Return:
+ nil ,no ARG in list"
+ (let* ((i 0)
+ ret)
+ (while list
+ (if (if test-form
+ (eval test-form)
+ (equal (car list) arg))
+ (setq ret i list nil)
+ (incf i)
+ (setq list (cdr list))))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::list-find (table arg &optional test-function all-matches)
+ "Loops through TABLE until element matching ARG is found.
+
+Input:
+
+ TEST-FUNCTION defaults to (string-match (caar element) arg)
+ and the supposed list is assumed to be:
+ '( (\"REGEXP\" ANY_DATA) ..)
+
+ ALL-MATCHES flag, if non-nil return list of matches.
+
+You can refer to these items in the test-form
+
+ arg Argument as passed.
+ element current item beeing compared, also the actual element
+ stored to list if match return t. Defaults to (car table)
+
+Examples:
+
+ (defconst my-list '((\"1\" \"a\") (\"2\" \"b\")))
+
+ ;; This is like using 'assoc'
+
+ (ti::list-find my-list \"1\")
+ --> (\"1\" \"a\")
+
+ ;; Do match against member 2
+
+ (ti::list-find my-list \"b\" '(string-match (nth 1 element) arg))
+ --> (\"2\" \"b\")
+
+ ;; This is little tricky, we search all '.fi' sites, and then
+ ;; remove all whitespaces around the items.
+
+ (defconst my-list2 '(\" foo@a.fi \" \"Bar <man@b.fi> \" \"gee@c.uk \"))
+
+ (ti::list-find my-list2 \"[.]fi\"
+ '(and
+ (string-match arg element)
+ (setq element (ti::string-remove-whitespace element)))
+ 'all-matches)
+
+ --> (\"foo@a.fi\" \"Bar <man@b.fi>\")
+
+Return:
+
+ nil
+ element single element
+ list list is returned if all-items is non-nil"
+ (let* (ret)
+ (dolist (element table)
+ (when (if test-function
+ (funcall test-function arg element)
+ (string-match (car element) arg))
+ (if all-matches ;how to put results ?
+ (ti::nconc ret element)
+ (setq ret element)
+ (return))))
+ ret))
+
+;;}}}
+;;{{{ misc, window, frame, events, popup
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::non-dedicated-frame (&optional win)
+ "Return some non-dedicated frame. The current frame is looked from WIN."
+ (if (window-dedicated-p (selected-window))
+ (car (ti::window-frame-list nil nil win))
+ ;; current frame
+ (window-frame (get-buffer-window (current-buffer)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::select-frame-non-dedicated ()
+ "Move to some non dedicated frame if current frame (window) is dedicated.
+E.g. you can't call `find-file', `switch-to-buffer' in dedicated frame."
+ (if (window-dedicated-p (selected-window))
+ (raise-frame (select-frame (car (ti::window-frame-list))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro ti::byte-compile-defun-compiled-p (function-symbol)
+ "Check if FUNCTION-SYMBOL is byte compiled."
+ ;; byte-code-function-p is marked obsolete in 19.14
+ ;; compiled-function-p is an obsolete in 19.34
+ (if (ti::emacs-p)
+ (` (byte-code-function-p (symbol-function (, function-symbol))))
+ (` (compiled-function-p (symbol-function (, function-symbol))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro ti::byte-compile-defun-maybe (defun-list)
+ "Byte compile `DEFUN-LIST only if not currently byte compiling.
+If you have highly important functions that must be as fast as possible
+no matter how the package is loaded you would do this:
+
+ (defun function1 () ...)
+ (defun function2 () ...)
+
+ ;; At the end of file
+ (ti::byte-compile-defun-maybe '(function1 function2))
+
+Now if package is loaded in .el format, this will trigger byte compiling
+those functions. If the package is currently beeing byte compiled, then
+the code does nothing. Note: loading package always causes byte compiling
+the functions although they may already be byte compiled. This will not
+do much harm."
+ (`
+ (eval-and-compile
+ ;; If not package compiltion in progress....
+ ;;
+ (unless (byte-compiling-files-p)
+ (dolist (function (, defun-list))
+ (byte-compile function) )))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro ti::package-use-dynamic-compilation ()
+ "Turn on dynamic compilation in current buffer.
+Add this statement to the beginning of file:
+
+ (eval-when-compile (ti::package-use-dynamic-compilation))"
+ (`
+ (progn
+ (when (boundp 'byte-compile-dynamic)
+ (make-local-variable 'byte-compile-dynamic)
+ (defvar byte-compile-dynamic) ;; silence byte compiler
+ (set 'byte-compile-dynamic t))
+ (when (boundp 'byte-compile-dynamic-docstring)
+ ;; In 19.34 this is t by default
+ (make-local-variable 'byte-compile-dynamic-docstring)
+ (defvar byte-compile-dynamic-docstring) ;; silence byte compiler
+ (set 'byte-compile-dynamic-docstring t)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::function-autoload-file (function)
+ "Return filename where autoload FUNCTION refers to"
+ (let* ((str (prin1-to-string (symbol-function function))))
+ (when (and str
+ (string-match "autoload[ \t\\]+\"\\([^\\\"]+\\)" str))
+ (match-string 1 str))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro ti::package-require-for-emacs (emacs xemacs &rest body)
+ "EMACS and XEMACS package compatibility. Evaluate BODY.
+E.g. `timer' in Emacs and 'itimer in XEmacs
+Recommended usage: (eval-and-compile (ti::package-require-for-emacs ...))."
+ (`
+ (progn
+ (if (ti::emacs-p)
+ (unless (featurep (, emacs))
+ (require (, emacs))
+ (,@ body))
+ (unless (featurep (, xemacs))
+ (require (, xemacs))
+ (,@ body) )))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro ti::package-require-view ()
+ "Emacs and XEmacs compatibility. Load view package."
+ (`
+ (if (ti::xemacs-p "20")
+ (require 'view-less)
+ (require 'view))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro ti::package-package-require-timer ()
+ "Emacs and XEmacs compatibility. Load view package."
+ (`
+ (if (ti::xemacs-p)
+ (require 'itimer)
+ (require 'timer))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro ti::package-require-mail-abbrevs ()
+ "Emacs and XEmacs compatibility. Load mail abbrevs package.
+Recommended usage: (eval-and-compile (use-mail-abbrevs))"
+ (`
+ (ti::package-require-for-emacs
+ 'mailabbrev
+ 'mail-abbrevs
+ (when (fboundp 'mail-abbrevs-setup) ;; Emacs
+ (ti::funcall 'mail-abbrevs-setup)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro ti::use-file-compression ()
+ "Activate jka-compr.el."
+ (` (cond
+ ((or (featurep 'jka-compr)
+ (featurep 'crypt++))) ;That's ok then.
+ ((and (featurep 'vm)
+ (require 'crypt++ nil 'noerr)))
+ ((featurep 'vm)
+ (error "\
+** Tinylibm: VM and compression was requested but no 'crypt++ feature provided.
+** Tinylibm: Visit ftp://ftp.cs.umb.edu/pub/misc/.
+** Tinylibm: Cannot deduce to jka-compr,
+** Tinylibm: because it has been previously reported that VM is not
+** Tinylibm: compatible with jka-compr. (1999-02 up till Emacs 20.3"))
+ (t ;Last chance
+ (require 'jka-compr)
+ (if (fboundp 'jka-compr-install)
+ (jka-compr-install)))))) ;New Emacs and XEmacs releases need this
+
+;;; ----------------------------------------------------------------------
+;;; #todo: what to do with .zip or other files?
+;;;
+(defun ti::use-file-compression-maybe (file)
+ "Activate file compression if FILE name contains magic .gz .Z etc."
+ (when (stringp file)
+ (cond
+ ((string-match "\\.gz$\\|\\.[Zz]$\\|\\.bz2$" file)
+ (if (fboundp 'auto-compression-mode) ;; New Emacs: jka-compr.el
+ (ti::funcall 'auto-compression-mode 1)
+ (ti::use-file-compression))))))
+
+;;}}}
+;;{{{ misc
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::push-definition (symbol &optional func-flag)
+ "Push current definition of SYMBOL to stack.
+If FUNC-FLAG is non-nil, then push function definition.
+
+Stack is at kept in property 'definition-stack"
+ (if func-flag
+ (push (symbol-function symbol) (get symbol 'definition-stack))
+ (push (symbol-value symbol) (get symbol 'definition-stack))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::pop-definition (symbol &optional func-flag)
+ "Retrieve previous definition of SYMBOL from stack.
+If FUNC-FLAG is non-nil, then pop function definition.
+
+Stack is at kept in property 'definition-stack"
+ (if func-flag
+ (setf (symbol-function symbol) (pop (get symbol 'definition-stack)))
+ (setf (symbol-value symbol) (pop (get symbol 'definition-stack)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::use-prefix-key (map key)
+ "Define to MAP a prefix KEY. If KEY is not keymap, allocate the key.
+Return KEY's original binding."
+ (if (not (keymapp (lookup-key map key)))
+ (prog1 ;Make it available
+ (lookup-key map key)
+ (define-key map key nil))))
+
+;;; ----------------------------------------------------------------------
+;;; I use this to change the BIG letter maps to `low' letter maps
+;;;
+(defun ti::swap-keys-if-not-keymap (sym old-key new-key)
+ "In keymap SYM, swap OLD-KEY and NEW-KEY only _if_ NEW-KEY is not a keymap.
+
+Example:
+
+ Suppose you have Gnus map 'A' and you don't like to type
+ uppercase letters. You want to change the keymap 'A' to 'a'. Here is
+ the command. Notice that this executes only once, because after the
+ function is called the \"a\" NEW-KEY is the keymap of 'A' now. You
+ can safely use this function within hooks for that reason.
+
+ (ti::swap-keys-if-not-keymap \"A\" \"a\")"
+ (when (ti::emacs-p) ;; Keymaps in XEmacs are not lists
+ (let* ((keymap (symbol-value sym))
+ (new-cdr (lookup-key keymap new-key)) ;; may be function too
+ (old-cdr (lookup-key keymap old-key)))
+ (when nil ;; disabled
+ (ti::d!! sym
+ new-key new-cdr (fboundp new-cdr)
+ "\n OLD:" old-key
+ old-cdr
+ "\n TEST"
+ (keymapp new-cdr)
+ (fboundp new-cdr)))
+ (when (or (not (keymapp new-cdr)) ;Already moved
+ (null new-cdr)
+ (and new-cdr
+ (fboundp new-cdr)
+ (not (keymapp (symbol-function new-cdr)))))
+ ;; make the swap
+ (define-key keymap new-key old-cdr)
+ (define-key keymap old-key new-cdr)
+ (set sym (copy-keymap keymap))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro ti::define-buffer-local-keymap ()
+ "Copy current local keymap and execute `use-local-map'.
+After that your commands with `local-set-key' are buffer local."
+ (use-local-map
+ (copy-keymap (or (current-local-map) (make-sparse-keymap)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro ti::define-key-if-free (map key object &optional callback)
+ "Put key to map if key is not assigned already.
+
+Key can be assigned if
+
+o slot is nil
+o slot has function 'ignore
+o slot has already object
+
+Any other case generates error: the slot is already occupied.
+
+You normally call this function from package that want's to define
+e.g. function keys permanently and if there is already user definition
+you can stop right there and print message.
+
+Input:
+
+ MAP map where to define the key e.g. `global-map'
+ KEY key e.g. [f10]
+ OBJECT assin object to key.
+ CALLBACK on error call function CALLBACK with argument KEY and the
+ result of `lookup-key'.
+
+Example:
+
+ (ti::define-key-if-free global-map [f10]
+ 'xxx-func 'xxx-define-key-error)
+
+ (defun xxx-define-key-error (key def)
+ (error
+ (format \"package xxx: key %s is already occupied with %s\"
+ \"Please use manual customization.\"
+ key def)))"
+ (`
+ (let ((def (lookup-key (, map) (, key) )))
+ ;; Lookup key returns NBR if the sequence of keys exceed
+ ;; the last keymap prefix
+ ;; C-cck --> C-cc is undefined, so there is no C-c c map yet
+
+ (if (or (eq def (, object))
+ (memq def '(nil ignore))
+ (integerp def))
+ (define-key (, map) (, key ) (, object))
+ (if (, callback)
+ (funcall (, callback) (, key ) def)
+ (error
+ (format "Already occupied, key: %s slot content: %s "
+ (, key)
+ (prin1-to-string def))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::define-in-function-keymap (list)
+ "Move key definition according to LIST '((FROM TO) (FROM TO) ..)
+This function remap each key FROM to produce TO key instead.
+
+Example:
+
+ You're in terminal where tab key produces `kp-tab' and not the normal `tab'.
+ You verified this by looking at the \\[view-lossage]. You want that key
+ to give key code `tab' to Emacs:
+
+ (ti::define-in-function-keymap
+ '(([kp-tab] [?\t])
+ ([C-kp-tab] [C-tab])
+ ([S-kp-tab] [S-tab])
+ ([A-kp-tab] [A-tab])
+ ([C-S-kp-tab] [C-S-tab])))
+
+ Note: The global binging of FROM key is set to nil in order to remap
+ to take effect. Do not define FROM key globally after this."
+ (dolist (elt list)
+ (when (and (car elt) (nth 1 elt))
+ (define-key function-key-map (car elt) (nth 1 elt)) ;; Alt
+ (define-key global-map (car elt) nil))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro ti::copy-key-definition (map to-key from-key)
+ "Put to MAP a TO-KEY that is bound to FROM-KEY.
+You can use this function e.g. in minor modes, where when minor
+mode is turned on, it moves some key definitions to somewhere
+else. For example if minor mode wants to take over PgUp and PgDown
+keys, but preserve their original menaing under some other key,
+it could copy the function calls to sme other key like
+control-PgUp and control-PgDown.
+
+Example:
+
+ ;; move PgUp/Down under Control key. Preserve their original
+ ;; function that may not be simple scroll-down!
+
+ (copy-key-function map [C-prior] [prior])
+ (copy-key-function [C-next] [prior])
+
+ ;; Now occupy minor map definition
+
+ (define-key [prior] 'minor-mode-function)"
+ (`
+ (define-key (, map) (, to-key)
+ (or (and (current-local-map)
+ (lookup-key (current-local-map) (, from-key)))
+ (lookup-key global-map (, from-key)) ))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::beginning-of-defun-point (&optional end)
+ "Search function beginning or END. Point is preserved. No errors.
+Return:
+ point
+ nil not found"
+ (save-excursion
+ (ignore-errors
+ (if end
+ (end-of-defun)
+ (beginning-of-defun))
+ (point) )))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::digit-length (arg)
+ "Return number of digits in ARG which must be either number or string.
+If ARG is string, the length of string is returned."
+ (let ((val arg))
+ (if (integerp arg)
+ (setq val (int-to-string arg)))
+ (length val)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::add-hook-fix ()
+ "Arrange some write file hooks to correct order. Support crypt++.el"
+ (let* ((crypt-w (memq 'crypt-write-file-hook write-file-hooks)))
+
+ (when crypt-w ;; Crypt present
+ (let* ((crypt-f (memq 'crypt-find-file-hook find-file-hooks))
+ (crypt-n (memq 'find-file-not-found-hooks
+ find-file-not-found-hooks )))
+ (when (not (null (cdr crypt-w))) ;; Not in the end of the hook
+ (remove-hook 'crypt-write-file-hook 'write-file-hooks)
+ (add-hook 'crypt-write-file-hook 'write-file-hooks 'append))
+
+ (when (not (null (cdr (reverse crypt-f)))) ;; Not at the beginning
+ (remove-hook 'crypt-find-file-hook 'find-file-hooks)
+ (add-hook 'crypt-find-file-hook 'find-file-hooks 'append))
+
+ (when (not (null (cdr (reverse crypt-n)))) ;; Not at the beginning
+ (remove-hook 'find-file-not-found-hooks 'find-file-hooks)
+ (add-hook 'find-file-not-found-hooks 'find-file-hooks 'append))))))
+
+;;; ----------------------------------------------------------------------
+;;; - add-hook should accept many parameters...
+;;;
+(defun ti::add-hooks
+ (hook-or-list single-or-list &optional remove append check)
+ "Run `add-hook' to insert every element in HOOK-OR-LIST to SINGLE-OR-LIST.
+
+Notes:
+
+ Thic function calls `ti::add-hook-fix` if the hook in question
+ is `write-file-hooks' (Crypt support)
+
+Remember:
+
+ `add-hook' call creates a hook variable if it doesn't exist.
+
+Input:
+
+ HOOK-OR-LIST hook symbol, or list of hook symbols
+ LIST single function or list of functions
+ REMOVE flag, if non-nil run `remove-hook' instead.
+ APPEND parameter to `add-hook'
+ CHECK run ´boundp' check before trying to add to a hook.
+ Only if variable exists, run `add-hook' or `remove-hook'
+
+Example:
+
+ ;; Add 2 functions to 2 hooks
+
+ (ti::add-hooks '(mode1-hook mode2-hook) '(hook1 hook2))"
+ (let* ((list (ti::list-make single-or-list))
+ (hlist (ti::list-make hook-or-list)))
+ (dolist (hook hlist)
+ (if (eq hook 'write-file-hooks)
+ ;; Arrange some write file hooks to correct order (crypt.el)
+ (ti::add-hook-fix))
+ (dolist (x list)
+ (when (or (null check)
+ (and check
+ (boundp hook)))
+ (if remove
+ (remove-hook hook x)
+ (add-hook hook x append)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun-maybe subst-char-with-string (string &optional char to-string)
+ "In STRING, converts CHAR with TO-STRING.
+Default is to convert all tabs in STRING with spaces."
+ (let* ((len (length string))
+ (i 0)
+ elt
+ ret)
+ (cond
+ ((not (and char to-string))
+ (with-temp-buffer
+ (insert string)
+ (untabify (point-min) (point-max))
+ (setq ret (buffer-string))))
+ (t
+ (while (< i len)
+ (setq elt (char-to-string (aref string i)))
+ (if (char= char (aref string i))
+ (setq elt to-string))
+ (setq ret (concat ret elt))
+ (incf i))))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::prefix-arg-to-text (arg)
+ "Return a string describing the current prefix argument ARG."
+ (cond
+ ((null arg) "")
+ ((integerp arg) (int-to-string arg))
+ ((eq '- arg) "C-u - ")
+ ((integerp arg) (format "C-u %d " current-prefix-arg))
+ (t
+ (apply 'concat (make-list (round (log (car arg) 4)) "C-u ")))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro ti::keep-lower-order (var1 var2)
+ "Keep VAR1 < VAR2."
+ (` (let ((MiN (min (, var1) (, var2)))
+ (MaX (max (, var1) (, var2))))
+ (setq (, var1) MiN)
+ (setq (, var2) MaX))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro ti::bool-toggle (var &optional arg)
+ "Toggle VAR according to ARG like mode would do.
+Usefull for for functions that use arg 0/-1 = off, 1 = on, nil = toggle.
+Minor modes behave this way.
+
+VAR is set to following values when ARG is:
+ arg 0/-1 VAR -> nil
+ arg nbr VAR -> t
+ arg nil VAR -> not(var) toggles variable"
+ (`
+ ;; The `let' is mandatory. XEmacs byte compiler will not allow
+ ;; expanding the variable in numeric context. If we used
+ ;;
+ ;; (and (integerp (, arg))
+ ;; (< (, arg) 1))
+ ;;
+ ;; That would compile into this (when optional ARG is nil)
+ ;;
+ ;; (and (integerp nil)
+ ;; (< nil 1)) ;; <= Byte compiler error
+ ;;
+ ;; The message from XEmacs 21.5 would say:
+ ;; ** evaluating (< nil 1): (wrong-type-argument number-char-or-marker-p nil)
+ ;;
+ (let ((toggle (, arg)))
+ (setq (, var)
+ (cond
+ ((and (integerp toggle)
+ (< toggle 1)) ;Any negative value or 0
+ nil)
+ ((integerp toggle) ;Any positive value
+ t)
+ ((null toggle)
+ (if (null (, var))
+ t
+ nil))
+ (t
+ nil))))))
+
+;;}}}
+
+;;{{{ buffers, variables
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro ti::compat-load-user-init-file ()
+ "Emacs and XEmacs compatibility."
+ (cond
+ ((boundp 'load-user-init-file-p)
+ (intern "load-user-init-file-p"))
+ ((boundp 'init-file-user)
+ (intern "init-file-user"))
+ (t
+ (error "Unknown Emacs."))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::compat-Info-directory-list-symbol ()
+ "Emacs and XEmacs compatibility. Return symbol."
+ (cond
+ ((boundp 'Info-directory-list) ;; XEmacs
+ (intern "Info-directory-list"))
+ ((boundp 'Info-default-directory-list)
+ (intern "Info-default-directory-list"))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::compat-Info-directory-list ()
+ "Emacs and XEmacs compatibility. Return value."
+ (symbol-value (ti::compat-Info-directory-list-symbol)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::buffer-pointer-of-info ()
+ "Return Emacs or XEmacs *info* buffer."
+ ;; This buffer should have been defvar'd in Emacs
+ (get-buffer "*info*"))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::buffer-pointer-of-messages ()
+ "Return Emacs or XEmacs MESSAGE buffer."
+ ;; The buffer name should be in variable and not hard coded
+ ;; Bad desing from Emacs folks...
+ ;;
+ ;; The following is not used, because it's not strictly accurate:
+ ;;
+ ;; (or (get-buffer "*Messages*")
+ ;; (get-buffer " *Message-Log*"))
+ ;;
+ ;; An emacs type is tested because the buffer name is exactly that
+ ;;
+ (if (ti::emacs-p)
+ (get-buffer "*Messages*")
+ (get-buffer " *Message-Log*")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::last-message-line ()
+ "Return last line from message buffer."
+ (let* ((buffer (ti::buffer-pointer-of-messages)))
+ (when buffer
+ (with-current-buffer buffer
+ (ti::pmax)
+ (re-search-backward "[^\t\n ]" nil t)
+ (ti::read-current-line)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro ti::dolist-buffer-list
+ (test-form &optional temp-buf exclude-form &rest action-form)
+ "Return list of buffer names matching TEST-FORM.
+
+If optional TEMP-BUF is non-nil, every buffer is searched.
+Normally following buffers are ignored.
+- Temporary buffers which start with character asterisk '*'
+- Invisible buffers which start with space ' '
+
+Optional EXCLUDE can also be given, which excludes buffers from
+matched ones.
+
+If optional ACTION-FORM is given executes forms for every matched buffer.
+At the moment of eval the `set-buffer' is already done.
+
+Input:
+
+ TEST-FORM regexp or form to get matching buffers.
+ TEMP-BUF flag. Non-nil allows scanning temp buffers too
+ EXCLUDE-FORM regexp or form -- against matched ones
+ ACTION-FORM if exist, eval this for every buffer.
+
+Internal variables that you can refer to:
+
+ buffer the current buffer pointer
+
+Return:
+
+ list (buffer-name buffer-name ..)
+
+Examples:
+
+ ;; Get all buffers matching \"cc\"
+ (ti::dolist-buffer-list \"cc\")
+
+ ;; Get all buffers in `dired-mode'
+ (ti::dolist-buffer-list '(eq major-mode 'dired-mode))
+"
+ (`
+ (let* (OK
+ BN
+ return-list)
+ (dolist (buffer (buffer-list))
+ (setq BN (buffer-name buffer))
+ (when (stringp BN) ;it's killed if no name
+ (with-current-buffer buffer
+ (when (, test-form)
+ (setq OK t)
+ (when (, exclude-form)
+ (setq OK nil))
+ (when OK
+ (if (and (null (, temp-buf))
+ (string-match "^[* ]" BN))
+ nil
+ (push BN return-list)
+ (,@ action-form)))))))
+ return-list)))
+
+;;; ----------------------------------------------------------------------
+;;; Emacs erase-buffer doesn't take arguments
+;;;
+(defun ti::erase-buffer (&optional buffers)
+ "Clear list of BUFFERS. Buffer existense is not checked."
+ (setq buffers (or (ti::list-make buffers)
+ (list (current-buffer))))
+ (save-current-buffer
+ (dolist (elt buffers)
+ (set-buffer elt)
+ (erase-buffer))))
+
+;;; ----------------------------------------------------------------------
+;;; - The buffer is *not* cleared by default, only put to consistent state
+;;;
+(defun ti::temp-buffer (&optional buffer clear)
+ "Create and reset temporary BUFFER.
+Remove read-only. Buffer name is \"*tmp*\" by default.
+Put buffer to `fundamental-mode' and remove any narrowing and `font-lock-mode'.
+if CLEAR is non-nil, delete old buffer content.
+
+Return:
+ buffer pointer"
+ (let* ((buffer
+ (let (font-lock-mode ;Handles defer-lock and fast-lock too
+ lazy-lock-mode
+ global-font-lock-mode)
+ ;; Old Emacs doesn't have these, ByteComp silencer
+ ;; This buffer doesn't need to know about font-lock.
+ (if font-lock-mode (setq font-lock-mode nil))
+ (if lazy-lock-mode (setq lazy-lock-mode nil))
+ (if global-font-lock-mode (setq global-font-lock-mode nil))
+ (get-buffer-create (or buffer "*tmp*"))))
+ (sym 'font-lock-mode)
+ (sym-lazy 'lazy-lock-mode))
+
+ (with-current-buffer buffer
+ (unless (eq major-mode 'fundamental-mode)
+ (fundamental-mode)) ;No fancy modes here
+
+ (setq buffer-read-only nil)
+
+ ;; Defconst used instead of setq due to old Emacs, where
+ ;; these variables have not been defined.
+ ;; `sym' just foold ByteCompiler again... (`set' would whine otw)
+
+ (if (boundp sym) ;Exist; okay then ...
+ (set sym nil)) ;Keep documentation
+
+ (if (boundp sym-lazy)
+ (set sym-lazy nil))
+
+ ;; - This call has been commented for now, because it prints
+ ;; unecessary message every time it's beeing called.
+ ;; - Besides the modified flag is not much used for "star",tmp, buffers
+ ;;
+ ;; (set-buffer-modified-p nil)
+
+ ;; - We don't check the possible narrowing. Just go and widen
+
+ (widen)
+ (if clear
+ (erase-buffer)))
+ buffer))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::append-to-buffer (buffer string &optional beg-flag)
+ "Append to BUFFER a STRING. If BEG-FLAG is non-nil, prepend to buffer."
+ (with-current-buffer buffer
+ (if beg-flag
+ (ti::pmin)
+ (ti::pmax))
+ (insert string)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::set-buffer-safe (buffer)
+ "Execute `set-buffer' if BUFFER exists. Does not signal any error.
+Return
+ buffer pointer if `set-buffer' executed
+ nil buffer does not exist"
+ (if (buffer-live-p (get-buffer buffer))
+ (set-buffer buffer)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::kill-buffer-safe (buffer)
+ "Do `kill-buffer' only if BUFFER exists. Does not signal any error.
+The buffer is killed, even if modified.
+Return:
+ t killed
+ nil no such buffer"
+ (save-current-buffer
+ (when (ti::set-buffer-safe buffer)
+ (set-buffer-modified-p nil) ;No confirmation when we kill it
+ (kill-buffer buffer))))
+
+;;}}}
+;;{{{ hash table
+
+;;; #todo: rename to `obarray' functions or get rid of these and use cl hash
+
+;;; These are normally calld hash tables, or Emacs says they are obarrays.
+;;; whatever...
+;;;
+;;; The idea is to store uniq ITEMS into vectors, like filenames.
+;;; Then each filename can have properties, like rcs version number,
+;;; locker, date of creation etc.
+
+;;; ----------------------------------------------------------------------
+;;; - just setting the hash to nil; does not kil the contents of hash.
+;;; For top security like passwords; each element must be zeroed.
+;;;
+(defun-maybe cl-clrhash-paranoid (hash)
+ "Clear HASH by filling every item and then calling `cl-clrhash'.
+This should clear memory location contents."
+ (cl-maphash
+ (lambda (k v)
+ (fillarray v ?\0)) ;; propably faster
+;;; (loop for i from 0 to (1- (length v))
+;;; do (aset v i ?\0))
+ hash)
+ (cl-clrhash hash))
+
+;;; ----------------------------------------------------------------------
+;;; File: elisp, Node: Creating Symbols
+;;; - In Emacs Lisp, an obarray is actually a vector
+;;; - In an empty obarray, every element is 0
+;;; - lengths one less than a power of two
+;;;
+(defmacro ti::vector-table-init (table &optional size init-val)
+ "Clears vector TABLE. Default SIZE is 128 buckets. INIT-VAL defaults to 0."
+ (` (setq (, table) (make-vector (or (, size) 127) (or (, init-val) 0)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro ti::vector-table-get (table item &optional allocate)
+ "Read vector TABLE and return ITEM. ALLOCATE if ITEM does not exist."
+ (` (if (, allocate)
+ (intern (, item) (, table))
+ (intern-soft (, item) (, table)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::vector-table-property (table item prop &optional put-value force-set)
+ "In vector TABLE and ITEM, get or put property PROP.
+
+Input:
+
+ TABLE hash table
+ ITEM If ITEM is not allocated bucket, signal error.
+ PROP property symbol
+ PUT-VALUE value to put. If this is non-nil value is stored.
+ FORCE-SET flag, if non-nil then put anything that was in put-value
+ E.g. value nil can be stored this way."
+ (let* (sym)
+ (if (null (setq sym (ti::vector-table-get table item)))
+ (error "No bucket found for item. [item not in table] %s" item)
+ (if (or put-value force-set)
+ (put sym prop put-value)
+ (get sym prop)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro ti::vector-table-clear (table)
+ "Delete all values assicated to interned symbols in TABLE.
+If possible, unintern all symbols."
+ (` (progn
+ (mapatoms
+ (lambda (atom)
+ (setplist atom nil)
+ ;; 19.34
+ (when (fboundp 'unintern)
+ (ti::funcall 'unintern atom (, table))))
+ (, table))
+ (unless (fboundp 'unintern) ;Old way
+ (ti::vector-table-init (, table) (length (, table))))
+ (, table))))
+
+;;}}}
+
+;;{{{ file
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::expand-file-name-tilde-in-string (string)
+ "Expand ~ referenced in string."
+ ;; #todo: Not quite right, because XEmacs can be build under Win32/Cygwin
+ ;; and ~user would be valid.
+ (unless (ti::win32-p)
+ (while (string-match "\\(~[^ \n\t\\/]+\\)" string)
+ (setq string
+ (replace-match
+ (expand-file-name (match-string 1 string))
+ nil nil string))))
+ string)
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::file-name-path-p (file)
+ "Check if file looks like a pathname, which includes slash or backslash."
+ (string-match "[\\/]" file))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::file-name-path-absolute-p (file)
+ "Check if file looks like a absolute pathname."
+ (or (string-match "^[a-z]:[\\/]" file) ;; win32
+ (string-match "^[/~]" file))) ;; Unix
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::directory-move (from to)
+ "Move directory FROM TO. Relies on `mv' command. Return command results."
+ (with-temp-buffer
+ (let ((mv (or (executable-find "mv")
+ (error "TinyLib: `mv' command not found."))))
+ (call-process mv nil (current-buffer) nil
+ (expand-file-name from)
+ (expand-file-name to)))
+ (buffer-string)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::write-file-with-wrapper (file)
+ "Write file, possibly compressed. Crypt++ compatibility.
+Bind `crypt-auto-write-buffer' to t for Crypt++."
+ (let* ((crypt-auto-write-buffer t)
+ (buffer (find-buffer-visiting file))
+ load)
+ (unless crypt-auto-write-buffer ;Bytecomp silencer
+ (setq crypt-auto-write-buffer nil))
+
+ ;; In XEmacs, if there is buffer visiting with the same filename,
+ ;; the user is prompted. Try to avoid it.
+ ;; If there is buffer and it is not modified, kill it
+ ;; and reload. Otherwise call normal write file.
+
+ (when buffer
+ (with-current-buffer buffer
+ (if (not (buffer-modified-p))
+ (setq load t)
+ (pop-to-buffer buffer)
+ (error "\
+Tinylibm: Can't write to file. Modified buffer with the same name in Emacs."))))
+
+ ;; I tried to RENAME buffer-name and set buffer-file-name to
+ ;; something else, but XEmacs still thinks that the buffer
+ ;; is saved with original name and asks from user permission.
+ ;;
+ ;; There is nothing left to do but kill the buffer and reload it.
+ ;; --> this unfortunately doesn't preserve markers.
+ ;; I would have wanted to use `revert-buffer' instead.
+ ;;
+ ;; If someone knows how to fool XEmacs to think buffer is
+ ;; under some other name/file, let me know.
+
+ (when load
+ (kill-buffer buffer))
+
+ (write-file file)
+
+ (if load
+ (find-file-noselect file))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'ti::load-file-with-wrapper 'lisp-indent-function 0)
+(defmacro ti::load-file-with-wrapper (file)
+ "Load possibly compressed lisp file. Crypt++ support."
+ (`
+ (if (not (featurep 'crypt++))
+ (load-file file) ;jka-compr handles this.
+ (ti::file-eval file))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'ti::write-file-binary-macro 'lisp-indent-function 0)
+(defmacro ti::write-file-as-is-macro (&rest body)
+ "Write file without any coding conversions."
+ (`
+ (let* ((buffer-file-coding-system 'no-conversion)) ;; #todo: XEmacs?
+ (,@ body))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::directory-list (dir)
+ "Return all directories under DIR."
+ (let (list)
+ (dolist (elt (directory-files dir 'full))
+ (when (and (file-directory-p elt)
+ (not (string-match "[\\/]\\.\\.?$" elt)))
+ (push elt list)))
+ list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'ti::directory-recursive-macro 'lisp-indent-function 1)
+(put 'ti::directory-recursive-macro 'edebug-form-spec '(body))
+(defmacro ti::directory-recursive-macro (directory &rest body)
+ "Start from DIRECTORY and run BODY recursively in each directories.
+
+Following variables are set during BODY:
+
+`dir' Directrory name
+`dir-list' All directories under `dir'."
+ (`
+ (flet ((recurse
+ (dir)
+ (let* ((dir-list (ti::directory-list dir)))
+ (,@ body)
+ (when dir-list
+ (dolist (elt dir-list)
+ (recurse elt))))))
+ (recurse (, directory)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::file-name-remote-p (file)
+ "Check if file looks like remote FILE. (ange-ftp)."
+ (string-match "^[^ \t]+@[^ \t]+:" file))
+
+;;; ----------------------------------------------------------------------
+;;; (ti::file-name-backward-slashes "/cygdrive/f/test")
+;;; (ti::file-name-backward-slashes "//f/test")
+;;; (ti::file-name-backward-slashes "//f")
+;;;
+(defun ti::file-name-backward-slashes (file)
+ "Convert FILE to use baskward slashes, like dos format."
+ (when file
+ (setq file (subst-char-in-string ?/ ?\\ file))
+
+ ;; handle cygwin paths as well
+ ;; //e/old-syntax B19 and B20
+ ;; /cygdrive/e/new-syntax V1.1+
+
+ (while (when (string-match
+ "\\(\\([\\]cygdrive[\\]\\|[\\][\\]\\)\\([a-z]\\)\\)[\\]?.*"
+ file)
+ (setq file (replace-match (concat (match-string 3 file) ":")
+ nil nil file 1))))
+ file))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::file-name-forward-slashes (file)
+ "Convert FILE slashes to unix format."
+ (if file
+ (subst-char-in-string ?\\ ?/ file)))
+
+;;; ----------------------------------------------------------------------
+;;; (ti::file-name-forward-slashes-cygwin "f:/filename")
+;;;
+(defsubst ti::file-name-forward-slashes-cygwin (file)
+ "Convert Win32 F:\\filename to /cygdrive/drive-letter/filename."
+ (when file
+ (setq file (ti::file-name-forward-slashes file))
+ (while (when (string-match "\\(\\([a-zA-Z]\\):\\)\\([\\/].*\\)" file)
+ (setq file (replace-match (concat "/cygdrive/"
+ (downcase
+ (match-string 2 file)))
+ 'no-alter-case
+ nil file 1))))
+ file))
+
+;;; ----------------------------------------------------------------------
+;;; The lisp primitive call isn't very descriptive. This short
+;;; macro looks better in code.
+;;;
+(defsubst ti::file-changed-on-disk-p (&optional buffer)
+ "Check if BUFFER's file has recently changed on disk."
+ (not (verify-visited-file-modtime
+ (or (current-buffer) buffer))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::file-mode-make-read-only (mode)
+ "Make MODE bit user read-only."
+ (logand mode 383))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::file-mode-make-read-only-all (mode)
+ "Make MODE bit read-only to all."
+ (logand mode 292)) ;444oct
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::file-mode-make-writable (mode)
+ "Raise MODE bit's write flag."
+ (logior mode 128))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::file-mode-make-executable (mode)
+ "Raise MODE bit's executable flag."
+ (logior mode 64)) ;oct 100
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::file-mode-protect (file &optional mode)
+ "Set FILE modes to -rw------- or if MODE is non-nil to -r--------."
+ (interactive)
+ (cond
+ (mode (set-file-modes file 256)) ;; 400oct
+ (t (set-file-modes file 384)))) ;; 600oct
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::file-toggle-read-write (mode)
+ "Toggle MODE bit's user write flag."
+ (if (eq 0 (logand mode 128)) ;-r-------- , 400 oct, 256 dec
+ (ti::file-mode-make-writable mode) ;R --> W 200
+ (ti::file-mode-make-read-only mode))) ;W --> R, 577
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::file-owned-p (file)
+ "Test if current `user-uid' [uid] owns the FILE."
+ (eq (user-uid) (nth 2 (file-attributes file))))
+
+;;; ----------------------------------------------------------------------
+;;; - If you own the file, you can turn on the write flag..
+;;;
+(defsubst ti::file-modify-p (file)
+ "Test if we can modify FILE. It must be file, not dir, owned by us."
+ (and (file-exists-p file)
+ (ti::file-owned-p file)))
+
+;;; ----------------------------------------------------------------------
+;;; - I do this so often that a macro is handy
+;;;
+(defsubst ti::file-find-file-p (file)
+ "Check if FILE is loadable, like C-x C-f. Non-string args are accepted too.
+The FILE is not expanded."
+ (and (stringp file)
+ (file-readable-p file)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::file-read-only-p (file)
+ "Check if FILE is read only.
+Only checks if there is no +w flags,other flags are not checked.
+
+E.g. you may have permissions ---x------ which this function
+reports as read-only, bcause there is no +w flags on."
+ (let (modes)
+ (if (not (file-exists-p file))
+ (error "No file '%s'" file)
+ (if (null (setq modes (file-modes file)))
+ (error "File modes failed?")
+
+ ;; 222oct is 146dec "--w--w--w" if any of these write flags
+ ;; is on, then this returns true.
+
+ (if (eq 0 (setq modes (logand modes 146)))
+ t
+ nil)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::file-name-run-real-handler (caller-sym operation args)
+ "You can call this function only from `file-name-handler-alist' handler.
+See Info page Node: Magic File Names.
+
+Input:
+
+ CALLER-SYM the caller's function symbol
+ OPERATION handler operation, see info page.
+ ARGS in &rest form"
+ (let ((inhibit-file-name-handlers
+ ;; Prevent infinite loop, don't call my-handler again.
+ (cons caller-sym
+ (and (eq inhibit-file-name-operation operation)
+ inhibit-file-name-handlers)))
+ (inhibit-file-name-operation operation))
+ (apply operation args)))
+
+;;; ----------------------------------------------------------------------
+;;; See also insert-file-contents-literally
+;;;
+;;; - The problem with "loading into emacs" is that all kinds of hooks
+;;; are run, e.g. folding and outline might get activated when the file is
+;;; loaded. E.g. if we do eval, it can't see the functions if they are
+;;; behind selective display.
+
+(defun ti::find-file-literally (file &optional buffer verb)
+ "Like `find-file' but disable everything which might affect loading.
+No hooks are run, no other special setups.
+
+If there existed same file, the buffer name will reflect the file name
+with letters \"<2>\" or so.
+
+Input:
+
+ FILE file to load
+ BUFFER optional buffer where to insert the file
+ VERB displays buffer. This is on when called interactively.
+
+Return:
+
+ buffer pointer"
+ (interactive "fFind file: ")
+ (let* ( ;; This mode does not run any hooks.
+ (default-major-mode 'fundamental-mode)
+ ;; This makes sure we truly load the file.
+ ;; If there were that file in emacs, emacs won't load it.
+ (fn (file-name-nondirectory file))
+ ;; Prohibit emacs from doing anything fancy while
+ ;; we load the file
+ enable-local-eval
+ ;; jka doen't use this, but crypt++ does. Prevent running mode hooks
+ ;; etc.
+ (find-file-hooks (if (featurep 'crypt++) '(crypt-find-file-hook)))
+ tmp)
+ (ti::verb)
+ (or buffer
+ (setq buffer (generate-new-buffer fn)))
+ (if (featurep 'crypt++)
+ (progn (with-current-buffer (setq tmp (find-file-noselect file))
+ (copy-to-buffer buffer (point-min) (point-max)))
+ (ti::kill-buffer-safe tmp))
+ (with-current-buffer buffer
+ (insert-file-contents file)))
+ (with-current-buffer buffer
+ (if verb
+ (switch-to-buffer buffer))
+ (set-buffer-modified-p nil)
+ (setq buffer-file-name (expand-file-name file)))
+ buffer))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::file-eval (file)
+ "Like `load-file', but read FILE and eval it in temporary buffer.
+
+The advantage over `load-file' is that physical loading also uncompresses
+the file if there is proper elisp package to handle it, thus your elisp
+can be in any file *form* that packages allow for loading."
+ (let* (buffer)
+ (setq buffer (ti::find-file-literally file))
+ (with-current-buffer buffer
+ (if (and (ti::xemacs-p) ;XEmacs compatibility
+ (fboundp 'eval-buffer))
+ (ti::funcall 'eval-buffer)
+ (ti::funcall 'eval-current-buffer)))
+ (kill-buffer buffer)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::directory-writable-p (file-or-dir)
+ "Check if FILE-OR-DIR is writable."
+ (let* ((dir (file-name-directory (expand-file-name file-or-dir)))
+ (file "#9#_%")
+ (fn (concat dir file)))
+ (if (not (stringp file))
+ (error "invalid arg"))
+ (file-writable-p fn)))
+
+;;; ----------------------------------------------------------------------
+;;; - When removing temporary files; I don't care if they succeed or not
+;;;
+(defun ti::file-delete-safe (files)
+ "Deletes file or list of FILES. Read only files are chmod'd to writable.
+All errors are ignored."
+ (let* ((list (ti::list-make files))
+ mods)
+ (dolist (file list)
+ (ignore-errors
+ (when (file-exists-p file)
+ (setq mods (ti::file-mode-make-writable (file-modes file)))
+ (set-file-modes file mods)
+ (delete-file (car list)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::temp-directory ()
+ "Return temporary directory."
+ (or (getenv "TEMPDIR")
+ (getenv "TMPDIR")
+ (and (boundp 'temporary-file-directory) ;; Emacs var
+ (let ((val (symbol-value 'temporary-file-directory)))
+ (when (and (stringp val)
+ (file-directory-p val))
+ val)))
+ (and (file-directory-p "c:/temp") "c:/temp")
+ (and (file-directory-p "/tmp") "/tmp")
+ (and (file-directory-p "/temp") "/temp")
+ (error
+ "Tinylib: Cannot suggest temporary directory. Set TEMPDIR.")))
+
+;;; ----------------------------------------------------------------------
+;;; - The buffer is *not* cleared, only put to consistent state
+;;;
+(defun ti::temp-file (file &optional find-temp-dir)
+ "Prepare temporary FILE for use. Delete old file with the same name.
+Ensure you have write permission to the file.
+Aborts with error if can't prepare the conditions to use FILE.
+
+Input:
+
+ FILE
+ FIND-TEMP-DIR Flag, Use /tmp or system (win32) specific tmp dir
+ Any path in FILE is replaced with temp dir."
+ (let (dir)
+ (when find-temp-dir
+ (setq dir (ti::temp-directory))
+ (setq file (ti::file-make-path dir (file-name-nondirectory file))))
+
+ (if (file-exists-p file)
+ (delete-file file)
+ ;; See if the we have permissions to dir to write this new file ?
+ (if (not (file-writable-p file))
+ (error "Can't write to file")))
+ file))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::pop-to-buffer-or-window (buffer &optional point)
+ "Like `pop-to-buffer' BUFFER and POINT, but find any visible window."
+ (let* (win)
+ (setq win (get-buffer-window buffer t))
+ (if (null win)
+ (pop-to-buffer buffer)
+ (raise-frame (window-frame win))
+ (select-frame (window-frame win))
+ (select-window win)
+ (if point
+ (goto-char point)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::find-file-or-window (file &optional line must-exist other-win)
+ "Visit FILE and LINE.
+If there already is window for the file, pop to it. Otherwise
+behave like `find-file'.
+
+Input:
+
+ FILE filename
+ LINE line nuumber where to position point
+ MUST-EXIST Flag, if non-nil, return nil if file does not exist
+ either in disk or in Emacs.
+ OTHER-WIN display in other window."
+ (let* ((buffer (or (find-buffer-visiting file)
+ (get-buffer file)
+
+ ;; We may have mistakenly grabbed 'cd' command and
+ ;; stucked it with buffers name.
+ ;; /users/foo/*scratch* --> *scratch*
+
+ (get-buffer (file-name-nondirectory file))))
+
+ ;; If buffer exists and is diplayed in another frame, use it.
+
+ (win (and buffer (get-buffer-window buffer t))))
+
+ (unless (and buffer win)
+ (when (or (file-exists-p file)
+ (null must-exist)) ;Not exist, but still ok
+ (ti::select-frame-non-dedicated) ;Can't do find file otherwise
+ (setq buffer
+ (find-file-noselect file))))
+
+ (when buffer
+ (if other-win
+ (display-buffer buffer)
+ (ti::pop-to-buffer-or-window buffer))
+ (select-window (get-buffer-window buffer))
+ (if line
+ (goto-line line)))
+
+ buffer))
+
+;;}}}
+;;{{{ mouse
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::mouse-point (&optional event)
+ "Return mouse's working point. Optional EVENT is a mouse click."
+ (if (or mouse-yank-at-point
+ (null event))
+ (point)
+ (if (ti::xemacs-p)
+ (point)
+ (ti::funcall 'posn-point (ti::funcall 'event-start event)))))
+
+;;}}}
+;;{{{ special: i-macros for interactive
+
+;;; #todo: rethink i-macros someday. Are they necessary?
+
+;;; You put these macros inside 'interactive'
+;;;
+;;; (defun test (beg end)
+;;; (interactive (tipgp-i-region-ask-macro))
+;;; ;; code continues
+;;; )
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::i-macro-region-ask (&optional prompt)
+ "Macro, usually called from 'interactive' command.
+Ask to include whole buffer with PROMPT if region is not selected. If there is
+no region given, signal error.
+
+Return:
+ '(beg end)"
+ (cond
+ ((region-active-p)
+ (list (region-beginning) (region-end)))
+ ((y-or-n-p
+ (or
+ prompt
+ "Hmmm.. no region selected. Use whole buffer? "))
+ (list (point-min) (point-max)))
+ (t
+ (error "No region."))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'ti::i-macro-region-body 'lisp-indent-function 0)
+(defmacro ti::i-macro-region-body (&rest body)
+ "Macro, usually called from 'interactive' command.
+Return selected region and execute BODY. Signal error if
+region is not selected.
+
+Return:
+ '(beg end BODY-return-value)"
+ (`
+ (if (null (region-active-p))
+ (error "No region selected.")
+ (list
+ (region-beginning)
+ (region-end)
+ (,@ body)))))
+
+;;}}}
+;;{{{ FORMS: special
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'ti::with-unix-shell-environment 'lisp-indent-function 0)
+(put 'ti::with-unix-shell-environment 'edebug-form-spec '(body))
+(defmacro ti::with-unix-shell-environment (&rest body)
+ "Run BODY in Unix like shell. In Win32, this means using Cygwin.
+This form does not guarrantee the environment if there isn't none.
+
+Variable `shell-file-name' is bound locally to new value."
+ (`
+ (let ((shell-file-name shell-file-name))
+ ;; In cygwin, programs like zgrep and egrep are
+ ;; shell scripts, which cannot be called (they should be .exe)
+ ;; in Win32, when cmdproxy.exe is used.
+ ;;
+ ;; Try to change the context if user has Cygwin.
+ (when (ti::win32-p)
+ (let ((cygwin (ti::win32-cygwin-p)))
+ (setq shell-file-name (format "%s/bin/bash.exe" cygwin))))
+ (,@ body))))
+
+;;; ----------------------------------------------------------------------
+;;; so that I can keep the URL link in one place.
+;;;
+(put 'ti::package-defgroup-tiny 'lisp-indent-function 3)
+(defmacro ti::package-defgroup-tiny (symbol prefix group &optional doc)
+ "Define defcustom.el group for tiny* files.
+
+Input:
+
+ SYMBOL The package's defgroup name
+ PREFIX Package's variable prefix
+ GROUP The upper level custom group where SYMBOL belong
+ (e.g. extenstions).
+ DOC Group documentation string."
+ (`
+ (defgroup (, symbol) nil
+ (, doc)
+
+ ;; You could also use (url-link "mailto:foo.bar@example.com")
+
+ :link '(url-link :tag "Update site"
+ "http://nongnu.org/projects/emacs-tiny-tools/")
+ :prefix (symbol-name (quote (, prefix)))
+ :group (quote (, group))
+
+ ;; Now define custom contact function when you click link
+
+ :link '(link
+ :tag "Contact maintainer"
+ :func-args (list
+ (symbol-name (quote (, prefix)))
+ (symbol-name (quote (, symbol))))
+ :action ti::package-tiny-defgroup-mail))))
+
+;;; ----------------------------------------------------------------------
+;;; This would actually belong to ti::package-defgroup-tiny
+;;;
+;;; The following autoload tells that function exists (used in function)
+;;;
+(eval-when-compile
+ ;; For some reason Emacs 19.30 doesn't see :func-args
+ ;; as class parameter if compiled without custom? Hm. Any ideas,
+ ;; how to tell that it is not a variable?
+ ;;
+ (when (and (not (fboundp 'widget-get))
+ (and (ti::emacs-p)
+ (eq emacs-minor-version 30)))
+ (message "\n\
+tinylibm.el: ** ignore following byte compiler message if you see it
+ ** 'reference to free variable :func-args'")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::package-tiny-defgroup-mail (widget &rest ignore)
+ "Called from defcustom/defgroup with WIDGET and IGNORE rest args.
+Send mail to tiny* package maintainer. Read keyword :func-args
+which should hold elements
+
+ '(list PACKAGE-PREFIX PACKAGE-NAME) ;; nth 0 \"list\" is ignored.
+
+The PACKAGE-PREFIX is in format \"xxx-:\" where a contact function
+name `PACKAGE-PREFIX-submit-bug-report' is derived."
+
+ ;; Due to ti::funcall, functions must not be in autoload state.
+
+ (require 'wid-edit)
+
+ (let* ((args (ti::funcall 'widget-get widget ':func-args)) ;; #TODO
+ (arg1 (eval (nth 1 args)))
+ (arg2 (nth 2 args))
+
+ ;; from variable pfx "tipgp-:" --> to function prefix "tipgp-"
+ (pfx (substring arg1 0 (1- (length arg1))))
+ (func (concat pfx "submit-bug-report"))
+ sym)
+ (if (setq sym (intern-soft func))
+ (call-interactively sym)
+ (message "Can't find contact function %s. Load %s.el first."
+ func (concat (downcase arg2) ".el"))
+ nil)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'ti::grep-output-parse-macro 'lisp-indent-function 1)
+(put 'ti::grep-output-parse-macro 'edebug-form-spec '(body))
+(defmacro ti::grep-output-parse-macro (buffer &rest body)
+ "In current buffer, run BODY for every 'grep' line.
+Point is set to point-min. The BODY must not change BUFFER's point.
+
+Following variables are bound during loop (lowercase variable names):
+
+ cd GREP-DIR
+ GREP-FILE:GREP-LINE:GREP-DATA
+
+This means that you can say this in BODY.
+
+ (setq absolute (concat grep-dir grep-file))"
+ (` (with-current-buffer (, buffer)
+ (save-excursion
+ (ti::pmin)
+ (let ((grep-dir (and (looking-at "^cd +\\(.*\\)")
+ (match-string 1)))
+ grep-file
+ grep-line
+ grep-data)
+ (while (re-search-forward
+ "^\\([^:\r\n]+\\):\\([0-9]+\\):\\(.*\\)" nil t)
+ (setq grep-file (match-string 1)
+ grep-line (match-string 2)
+ grep-data (match-string 3))
+
+ (when grep-line
+ (setq grep-line (string-to-int grep-line)))
+
+ (beginning-of-line)
+ ;; skip over
+ ;;
+ ;; cd /usr/lib/perl5/5.6.1/pods/
+ ;; grep finished (matches found) at Tue Jul 23 17:39:21
+ ;;
+ (unless (looking-at "^cd \\|^[^ \t\n\r]+ +finished")
+ (,@ body))
+ (forward-line 1)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'ti::occur-macro 'lisp-indent-function 2)
+(put 'ti::occur-macro 'edebug-form-spec '(body))
+(defmacro ti::occur-macro (re &optional hook &rest body)
+ "Run occur with RE starting from `point-min' and call HOOK after BODY.
+
+Execute BODY after occur statement in occur buffer.
+Run HOOK in occur buffer last; this arg can also be nil if there is no hook."
+ (`
+ (progn
+ (save-excursion ;save user's active point
+ (ti::pmin)
+ (occur (, re)))
+ (pop-to-buffer "*Occur*")
+ (,@ body)
+ (ti::pmin)
+ (if (, hook)
+ (run-hooks (quote (, hook)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun-maybe shell-command-to-string (command)
+ "Returns shell COMMAND's ouput as string. Tinylibm."
+ (with-temp-buffer
+ (shell-command command (current-buffer))
+ (buffer-string)))
+
+;;; ----------------------------------------------------------------------
+;;; #todo: should use help-mode ?
+;;;
+(put 'ti::momentary-output-macro 'lisp-indent-function 3)
+(put 'ti::momentary-output-macro 'edebug-form-spec '(body))
+(defmacro ti::momentary-output-macro
+ (buffer &optional echo-msg win1 &rest body)
+ "Momentarily execute body in buffer.
+You normally use this to display messages to user.
+Buffer is buried after this form finishes.
+
+The output is accomplished using `with-output-to-temp-buffer', so
+you have to use 'princ' to write output.
+
+Input:
+
+ BUFFER string
+ ECHO-MSG displayed at echo area. If nil, default message is used.
+ WIN1 flag, if non-nil, occupie full window
+ BODY rest of the Lisp code.
+
+Example:
+
+ (ti::momentary-output-macro
+ \"*notes*\" \"howdy! Press some key\" nil
+ (princ \"This is the message\"))"
+ (`
+ (save-excursion
+ (save-window-excursion
+ (with-output-to-temp-buffer (, buffer)
+ (,@ body))
+ (select-window (get-buffer-window (, buffer)))
+ (if (, win1)
+ (delete-other-windows (get-buffer-window (, buffer))))
+ (ti::read-char-safe-until
+ (or (, echo-msg) "Press something to delete window."))
+ (bury-buffer (, buffer))))))
+
+;;; ----------------------------------------------------------------------
+;;; - Sometimes you just want to switch buffer temporarily and
+;;; set point to somewhere else, like scroll a buffer
+;;;
+(put 'ti::save-excursion-macro 'lisp-indent-function 0)
+(put 'ti::save-excursion-macro 'edebug-form-spec '(body))
+(defmacro ti::save-excursion-macro (&rest body)
+ "Like `save-excursion` BODY, but return to original window.
+No other values are preserved. Also the `select-window'
+is executed if the original buffer had `window-live-p'. (ie. it was visible)
+
+Use this if you want to e.g. scroll some buffer."
+ (`
+ (let* ((oRig-Buf (current-buffer))
+ (oRig-Win (get-buffer-window oRig-Buf)))
+ (prog1
+ (progn
+ (,@ body))
+ (set-buffer oRig-Buf) ;restore buffer.
+ (when (and (windowp oRig-Win) ;no window visible
+ (window-live-p oRig-Win))
+ ;; and the visible window
+ (select-window oRig-Win))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'ti::save-with-marker-macro 'lisp-indent-function 0)
+(put 'ti::save-with-marker-macro 'edebug-form-spec '(body))
+(defmacro ti::save-with-marker-macro (&rest body)
+ "Save the line position by using the marker and execute BODY.
+Marker is assigned to current position. Caution: If you delete text where the
+marker is, there is no way to set the previous point. In this case the
+results are undefined.
+
+Notes:
+
+ Make sure you don't insert to immediate marker position, because
+ markers moves along with the text!"
+ (`
+ (let* ((MarK (point-marker)))
+ (prog1
+ (progn (,@ body))
+ (when (marker-position MarK)
+ (goto-char (marker-position MarK)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'ti::save-line-column-macro 'lisp-indent-function 2)
+(put 'ti::save-line-column-macro 'edebug-form-spec '(body))
+(defmacro ti::save-line-column-macro (fail-form col-form &rest body)
+ "Save line and column position.
+When you kill/add lines from buffer, you cannot normally save the current
+point with `save-excursion', since the point no longer is the
+same spot or it may be have been deleted.
+
+This macro saves the position by remembering line and column position.
+
+Call:
+
+ (fail-form col-form &rest body)
+
+Error conditions:
+
+ If the line position cannot be preserved, Then FAIL-FORM is evaled: it can
+ put the cursor at desired place.
+
+ If column position cannot be preserved COL-FORM is evaled.
+
+Example:
+
+ ;; 1st and 2nd forms act like no-ops after erase buffer command
+ (ti::save-line-column-macro nil nil (erase-buffer))
+
+ ;; 1st: Put cursor at the be.g. of buffer when failure.
+ ;; 2nd: If col is missed, put cursor at be.g. of line
+ ;; 3rd: The form executed is all the rest of the lines
+
+ (ti::save-line-column-macro
+ (goto-char (point-min))
+ (beginning-of-line)
+ (flush-lines \"*\\.txt\"))
+
+Return:
+
+ Last value returned by BODY"
+ (` (let* ((SLC-sLc-col (current-column)) ;prevent variable suicide
+ (SLC-sLc-line (ti::current-line-number)))
+ (prog1
+ (progn (,@ body))
+ (goto-line SLC-sLc-line)
+ (move-to-column SLC-sLc-col)
+ (cond
+ ((not (eq (ti::current-line-number) SLC-sLc-line))
+ (, fail-form))
+ ((not (eq (current-column) SLC-sLc-col))
+ (, col-form) ))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'ti::widen-safe 'lisp-indent-function 0)
+(put 'ti::widen-safe 'edebug-form-spec '(body))
+(defmacro ti::widen-safe (&rest body)
+ "(&rest body) Widen buffer end execute BODY.
+Preserves possible narrowing when done.
+
+The BODY is not protected against errors or surrounded by `save-excursion'
+
+Return:
+
+ last value of BODY"
+ (` (let ((BeG (point-min-marker))
+ (EnD (point-max-marker))
+ (EnD-max (point-max))
+ EnD-wmax
+ ReT)
+ (unwind-protect
+ (progn
+ (widen)
+ (setq EnD-wmax (point-max))
+ (setq ReT (progn (,@ body))))
+ (with-current-buffer (marker-buffer BeG)
+ ;; what about after widen ? Were we in narrow mode ?
+ (if (not (= EnD-wmax EnD-max))
+ (narrow-to-region BeG EnD))
+
+ (if (null ReT) ;no-op, Silence XEmacs 19.14 ByteComp.
+ (setq ReT nil))
+
+ ReT)))))
+
+;;}}}
+;;{{{ misc
+
+;;; ----------------------------------------------------------------------
+;;;
+(eval-and-compile
+ (defun ti::package-config-file-directory-default ()
+ "Determine default configuration file directory.
+The preferred locations are ~/elisp/config ~/lisp/config
+~/elisp ~/lisp ~/tmp and last ~/.
+
+In XEmacs ~/.xemacs/config is preferred first."
+ (dolist (dir (list
+ (if (ti::xemacs-p)
+ "~/.xeamcs/config"
+ nil)
+ "~/.emacs.d/config"
+ "~/elisp/config"
+ "~/lisp/config"
+ "~/tmp"
+ "~"
+ ;; Last resort if this is Win32 Emacs and
+ ;; HOME is not set ("~" did not expand)
+ "/cygdrive/c"
+ "c:/"))
+ (when (and (stringp dir)
+ (file-directory-p dir))
+ (return dir)))))
+
+(defvar tinylib-:package-config-file-directory
+ (ti::package-config-file-directory-default)
+ "*Directory where to save configuration files.")
+
+(defvar tinylib-:package-config-file-prefix "emacs-config-"
+ "*Prefix to add to configuration files. Default 'emacs-config-'.")
+
+(defun ti::package-config-file-prefix (&optional file &optional os emacs)
+ "Return directory and prefix with config FILE optionally for OS and EMACS
+
+The default value is currenly combination of
+`tinylib-:package-config-file-directory' and
+`tinylib-:package-config-file-prefix'
+
+In packages, when defining a config file location, it is usually wanted
+that all packages save configuration files to the same location, so that it
+it not needed to configure each packages' files manually. The following
+code shows how package can define the configuration files in a bad and good
+manner:
+
+ ;; Bad name. Traditional dot-something in User's root (HOME)
+
+ (defvar xxx-config-file \"~/.something\")
+
+ ;; A much better way
+
+ (defvar xxx-config-file (package-config-file-prefix \".something\"))
+
+Input:
+
+ Sometimes the configuration file needs operating system
+ version (OS) and Emacs version. Supply non-nil (t) values for these if you
+ need exactly a specific file for Win32/Unix and for XEmacs/Emacs."
+ (when tinylib-:package-config-file-directory
+ (unless (file-exists-p tinylib-:package-config-file-directory)
+ (error "`tinylib-:package-config-file-directory' %s does not exist."
+ tinylib-:package-config-file-directory))
+ (format "%s%s%s%s%s"
+ (file-name-as-directory tinylib-:package-config-file-directory)
+ tinylib-:package-config-file-prefix
+ (if os
+ (if (ti::win32-p)
+ "win32-"
+ "unix-")
+ "")
+ (if emacs
+ (format "%s-%s-"
+ (if (ti::emacs-p) "emacs" "xemacs")
+ (ti::emacs-version-number-as-string))
+ "")
+ (or file ""))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'ti::overlay-require-macro 'lisp-indent-function 0)
+(put 'ti::overlay-require-macro 'edebug-form-spec '(body))
+(defmacro ti::overlay-require-macro (&rest body)
+ "Try to load overlay support or run BODY.
+Overlays are Emacs thingies, XEmacs uses extents. In XEmacs
+the overlay support is tested by loading package overlay.el and if it
+fails, then BODY is run.
+
+Example usage:
+
+ (eval-and-compile
+ (ti::overlay-require-macro
+ (message \"*** package.el: Your Emacs doesn't have overlay support.\")
+ (error \"Compilation aborted.\")))"
+ (` (progn
+ (when (and (ti::xemacs-p)
+ ;; No overlay functions?.
+ (not (fboundp 'overlays-at)))
+ (load "overlay" 'noerr)) ;; has no provide statement
+ (or (fboundp 'overlays-at) ;; Did it define this function?
+ (progn
+ (,@ body))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::pp-variable-list (list &optional buffer def-token)
+ "Print LIST of variables to BUFFER. DEF-TOKEN defaults to `defconst'."
+ (let* (val)
+
+ (or buffer
+ (setq buffer (current-buffer)))
+
+ (or def-token
+ (setq def-token "defconst"))
+
+ (dolist (sym list)
+ (unless (symbolp sym)
+ (error "List member is not symbol %s" sym))
+ (setq val (symbol-value sym))
+ (insert (format "\n\n(%s %s\n" def-token (symbol-name sym)))
+ (cond
+ ((numberp val)
+ (insert val))
+ ((stringp val)
+ (insert (format "\"%s\"" val)))
+ ((ti::bool-p val)
+ (insert (symbol-name val)))
+ ((and (symbolp val)
+ (fboundp val))
+ (insert "(function " (symbol-name val) ")"))
+ ((symbolp val)
+ (insert "'" (symbol-name val)))
+ ((listp
+ (insert "'" (pp val))))
+ (t
+ (error "unknown content of stream" sym val)))
+ (insert ")"))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::write-file-variable-state (file desc list &optional fast-save bup)
+ "Save package state to FILE.
+
+Input:
+
+ FILE filename
+ DESC One line description string for the file.
+ LIST List of variable symbols whose content to save to FILE.
+
+ FAST-SAVE The default `pp' function used to stream out the contents
+ of the listp variables is extremely slow if your variables
+ contain lot of data. This flag instructs to use alternative,
+ much faster, but not pretty on output, method.
+
+ BUP If non-nil, allow making backup. The default is no backup."
+ (with-temp-buffer
+ (let ((backup-inhibited (if bup nil t)))
+ (insert ";; @(#) " file " -- " desc "\n"
+ ";; Date: "
+ (ti::date-standard-date 'short)
+ "\n\n")
+ (if (not fast-save)
+ (ti::pp-variable-list list)
+ (dolist (var list)
+ (insert (format "\n\n(defconst %s\n" (symbol-name var)))
+ ;; While `pp' would have nicely formatted the value, It's
+ ;; unbearable SLOW for 3000 file cache list.
+ ;; `prin1-to-string' is 10 times faster.
+ (insert "'" (prin1-to-string (symbol-value var)) ")\n")))
+ (insert (format "\n\n;; end of %s\n" file))
+ ;; prohibit Crypt++ from asking confirmation
+ (ti::write-file-with-wrapper file))))
+
+;;}}}
+
+(provide 'tinylibm)
+
+;;; tinylibm.el ends here
--- /dev/null
+;;; tinylibmail.el --- Library of mail related functions
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 1995-2007 Jari Aalto
+;; Keywords: extensions
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program, call M-x tinylibmail-version.
+;; Look at the code with folding.el
+
+;; COPYRIGHT NOTICE
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;;; Install:
+
+;; ........................................................ &t-install ...
+;; Put this file on your Emacs-Lisp load path, add following into your
+;; ~/.emacs startup file
+;;
+;; (require 'tinylibm)
+;;
+;; No, there is no mistake here. The 'm' lib contains all autoloads
+;; to this package.
+
+;;}}}
+;;{{{ Documentation
+
+;;; Commentary:
+
+;;
+;; o This is library. Package itself does nothing.
+;; o Collection of functions to deal with Mail/News specific tasks.
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+;;{{{ setup: -- require
+
+;;; ....................................................... &v-require ...
+
+(require 'tinylibm)
+(require 'sendmail) ;; mail-header-separator
+
+(eval-and-compile
+ (defvar mail-abbrevs) ;Silence ByteCompiler
+ (defvar mail-aliases)
+ (defvar rmail-current-message nil)
+ (cond
+ ((ti::xemacs-p)
+ (autoload 'build-mail-aliases "mail-abbrevs"))
+ (t
+ (autoload 'mail-abbrevs-setup "mailabbrev")
+ (autoload 'build-mail-aliases "mailalias")
+ (autoload 'build-mail-abbrevs "mailabbrev")))
+ (autoload 'rmail-msgbeg "rmail")
+ (autoload 'rmail-msgend "rmail")
+ (autoload 'gnus-group-get-parameter "gnus"))
+
+(eval-when-compile
+ (ti::package-use-dynamic-compilation))
+
+;;}}}
+;;{{{ setup: -- private
+
+;;; ......................................................... &v-hooks ...
+
+(defvar ti:mail-load-hook nil
+ "Hook that is run when package is loaded.")
+
+;;; ....................................................... &v-private ...
+
+(defvar ti:mail-ret nil
+ "Global return value of this package.")
+
+(defvar ti:mail-mail-buffer " *ti::mail-mail*"
+ "*Temporary mail buffer name.")
+
+;; Variables could be modified. defsubst makes them persistent
+
+(defsubst ti::mail-pgp-signature-begin-line ()
+ "Signature start line."
+ "-----BEGIN PGP SIGNATURE-----")
+
+(defsubst ti::mail-pgp-signature-end-line ()
+ "Signature end line."
+ "-----END PGP SIGNATURE-----")
+
+;; Signed message has:
+;;
+;; -----BEGIN PGP SIGNED MESSAGE-----
+;; -----BEGIN PGP SIGNATURE-----
+;; -----END PGP SIGNATURE-----
+
+(defsubst ti::mail-pgp-signed-begin-line ()
+ "Text for start of PGP signed messages."
+ "-----BEGIN PGP SIGNED MESSAGE-----")
+
+(defsubst ti::mail-pgp-signed-end-line ()
+ "Text for start of PGP signed messages."
+ (ti::mail-pgp-signature-end-line))
+
+(defsubst ti::mail-pgp-pkey-begin-line ()
+ "PGP public key begin line."
+ "-----BEGIN PGP PUBLIC KEY BLOCK-----")
+
+(defsubst ti::mail-pgp-pkey-end-line ()
+ "PGP public key end line."
+ "-----END PGP PUBLIC KEY BLOCK-----")
+
+(defsubst ti::mail-pgp-msg-begin-line ()
+ "PGP message, typically base64 signed, begin line."
+ "-----BEGIN PGP MESSAGE-----")
+
+(defsubst ti::mail-pgp-msg-end-line ()
+ "PGP message, typically base64 signed, end line."
+ "-----END PGP MESSAGE-----")
+
+(defsubst ti::mail-pgp-any-pgp-line-regexp (&optional anchor-left)
+ "Return regexp that match any pgp TAG.
+If ANCHOR-LEFT is non-nil; the regexp will contains left ^ anchor."
+ ;; The lines can be broken, when there is encrypted/signed message
+ ;; NOTE: there is no anchor by default; because sometimes use may have
+ ;; indented the whole PGP block (e.g. in his web page or in .doc file)
+
+ (concat
+ (if anchor-left "^" "")
+ "- -----\\(BEGIN\\|END\\) PGP.*-----"
+ "\\|"
+ (if anchor-left "^" "")
+ "-----\\(BEGIN\\|END\\) PGP.*-----"))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::mail-ip-raw-p (ip)
+ "Check raw nnn.nnn.nnn.nnn IP."
+ (string-match "^[0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+$" ip))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::mail-ip-top-level-domain (host)
+ "Convert HOST a.b.c => b.c domain.
+If HOST is raw numeric IP, do nothing."
+ (cond
+ ((ti::mail-ip-raw-p host)
+ host)
+ ((or (string-match "\\.\\([^.]+\\.[^.]+\\)$" host)
+ (string-match "^\\([^.]+\\.[^.]+\\)$" host))
+ (match-string 1 host))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::mail-ip-3-level-domain (host)
+ "Convert HOST a.b.c.d => b.c.d domain."
+ (when (string-match "\\.\\([^.]+\\.[^.]+\\.[^.]+\\)$" host)
+ (match-string 1 host)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::mail-ip-cleanup (word)
+ "Clean WORD to format 'aa.bb.cc'. Remove offending characters.
+Remove all characters up till @: this@email.com => email.com
+Remove all not(alphanumeric, dash, dot) charcters.
+
+For example a word at point may include anything:
+
+ <bb.com> \"bb.com\" this@bb.com
+
+All of the above will become:
+
+ bb.com"
+ (and word
+ (replace-regexp-in-string
+ "[^a-z0-9-.]" ""
+ (replace-regexp-in-string "^.*@" "" word))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-ip-at-point-1 ()
+ "Read only word containing characters [-.a-zA-z0-9]."
+ (let (beg
+ word)
+ ;; depending where the point is, from this word different part
+ ;; is read: foo.com[1.2.3.4]
+ ;; | |
+ ;; (1) (2)
+ (save-excursion
+ (skip-chars-backward "-.a-zA-Z0-9")
+ (setq beg (point))
+ (skip-chars-forward "-.a-zA-Z0-9")
+ (unless (eq beg (point))
+ (buffer-substring beg (point))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-ip-at-point ()
+ "Read domain ip IP name at point."
+ (let* ((word (ti::mail-ip-at-point-1)))
+ (when (not (ti::nil-p word))
+ ;; foo.com[1.2.3.4]
+ (setq word (ti::mail-ip-cleanup word))
+ (if (ti::mail-ip-raw-p word)
+ word
+ (ti::mail-ip-top-level-domain word)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::mail-news-group () ;ding & gnus compatible
+ "Return newsgroup name if group exists."
+ (if (boundp 'gnus-newsgroup-name)
+ (symbol-value 'gnus-newsgroup-name)))
+
+;;; ........................................................ &v-public ...
+;;; User configurable -- but not recommended.
+
+;; See gnus.el or gnus-msg.el gnus-required-headers
+;; The 'in-reply-to is for mail messages (additional)
+
+(defconst ti:mail-required-headers
+ '(from date newsgroups subject path message-id in-reply-to references)
+ "*All required fields that RFC977 and RFC1036 requires.
+Make sure symbol names are all in lowercase.")
+
+(defvar ti:mail-parse-name-not-accept
+ (concat
+ "[A-Z][/][A-Z]" ;company division PMR/TMS ?
+ "\\|^[A-Z]+\\'" ;all in capitals
+ "\\|^[-]$" ;single '-' word
+ "\\|[.0-9]" ;maybe phone number ?
+ "\\|com\\|org\\|edu")
+ "*Regexp to exclude non-valid people names.
+We can't be sure that the names are really good names when we parse the
+senders From field. Let's see an example
+
+ \"Person Someone p. nnn-nnn-nnn\"
+
+There obviously isn't 3rd name, it's used for phone abbrev. And the last
+word is the actual phone number.
+
+This regexp tells which word matches are false name hits.
+In this example it'd leave:
+ \"Person Someone\"
+
+See `ti::mail-parse-name'")
+
+;;}}}
+;;{{{ setup: -- version
+
+(defconst tinylibmail-version (substring "$Revision: 2.68 $" 11 16)
+ "Latest version number.")
+
+(defconst tinylibmail-version-id
+ "$Id: tinylibmail.el,v 2.68 2007/05/07 10:50:08 jaalto Exp $"
+ "Latest modification time and version number.")
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylibmail-version (&optional arg)
+ "Show version information. ARG tell to print message in echo area only."
+ (interactive "P")
+ (ti::package-version-info "tinylibmail.el" arg))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylibmail-submit-feedback ()
+ "Submit suggestions, error corrections, impressions, anything..."
+ (interactive)
+ (ti::package-submit-feedback "tinylibmail.el"))
+
+;;}}}
+;;{{{ misc
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-signature-p ()
+ "Return beginning of line point if \\n-- *\\n is found.
+The de facto, while not standardized by any RFC signature separator
+it \\n-- \\n. The trailing whitespace is very unfortunate evolution
+to separate signatures from message digests \\n--\\n.
+
+This function accepts trailing spaces or just n\\--\\n"
+ (let* ((point (point))) ;avoid save-excursion.
+ (ti::pmin)
+ (prog1 (if (re-search-forward "\n-- *\n" nil t)
+ (1+ (match-beginning 0)))
+ (goto-char point))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-body-empty-p ()
+ "Check if there is nothing in the body or if whole buffer is empty."
+ (save-excursion
+ (ti::mail-text-start 'move)
+ (eq (point) (point-max))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-body-clear ()
+ "Delete message body."
+ (ti::mail-text-start 'move)
+ (delete-region (point) (point-max)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'ti::mail-set-region 'lisp-indent-function 1)
+(put 'ti::mail-set-region 'edebug-form-spec '(body))
+(defmacro ti::mail-set-region (beg end)
+ "Set BEG END to whole buffer if they don't have value."
+ (`
+ (progn
+ (or (, beg)
+ (setq (, beg) (ti::mail-text-start)))
+ (or (, end)
+ (setq (, end) (point-max))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'ti::mail-point-in-header-macro 'lisp-indent-function 0)
+(put 'ti::mail-point-in-header-macro 'edebug-form-spec '(body))
+(defmacro ti::mail-point-in-header-macro (&rest body)
+ "Run BODY only if point is inside mail header area."
+ (`
+ (when (< (point) (ti::mail-text-start))
+ (,@ body))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-message-length ()
+ "Return message's body length, not including the headers.
+The message length is measured be counting character between the
+BODY begin and BODY end. Any amount of whitespaces around the body is
+skipped.
+
+Exceptions:
+
+ The start point defaults to `point-min' if body can't be found.
+
+ If there is PGP signed block, then the body length is the text inside
+ PGP signed block, not the original message body.
+
+ Signed headers are also skipped.
+
+ -----BEGIN PGP SIGNED MESSAGE-----
+
+ ## < signed headers begin mark \\n##
+ Subject: some subject
+ Reply-to: somewhere
+ < empty space ends headers
+ Hi, I swanted to tell you... < BODY BEGIN IS HERE"
+ (let* ((end (ti::mail-pgp-signed-conventional-p))
+ beg)
+ (save-excursion
+ (cond
+ ((and end
+ (null (ti::mail-pgp-signature-detached-p)))
+ ;; Do not count empty lines at the end of body
+ (goto-char end) (skip-chars-backward " \t\n") (setq end (point))
+ (ti::pmin)
+ (re-search-forward (ti::mail-pgp-signed-begin-line))
+ (forward-line 1)
+ ;; now we're inside BODY of text, but it's not that simple yet. User
+ ;; may have signed headers and they are inserterted into body
+ ;; like this:
+ ;;
+ ;; -----BEGIN PGP SIGNED MESSAGE-----
+ ;;
+ ;; ##
+ ;; Subject: See this ma!
+ ;;
+ ;; Body text starts here.
+ ;;
+ ;; Note, there is no spaces, becasue the body is trimmed
+ (when (looking-at "\n##\n")
+ (goto-char (match-end 0))
+ (re-search-forward "^$"))
+ ;; Ignore leading spaces
+ (skip-chars-forward " \t\n")
+ (- end (point)))
+ (t
+ (ti::mail-text-start 'move)
+ (skip-chars-forward " \t\n") (setq beg (point))
+ (goto-char (point-max))
+ (if (eq beg (point)) ;Empty buffer
+ 0
+ (skip-chars-backward " \t\n") (setq end (point))
+ (- (point) beg)))))))
+
+;;; ----------------------------------------------------------------------
+;;; #todo: this is old function and should be removed.
+;;;
+(defun ti::mail-get-2re (re str)
+ "Use RE and match STR. Return list ('' '') if not matched."
+ (let ((m1 "")
+ (m2 ""))
+ (if (eq nil (string-match re str))
+ t ;do nothing, not matched
+ (if (match-end 1)
+ (setq m1 (substring str (match-beginning 1)
+ (match-end 1))))
+ (if (match-end 2)
+ (setq m2 (substring str (match-beginning 2)
+ (match-end 2)))))
+ (list m1 m2)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-required-headers ()
+ "Return standard RFC header required when posting.
+
+References:
+
+ `ti:mail-required-headers'
+ `gnus-required-headers'
+
+Return:
+
+ list '(header-name-symbol .. )
+ nil gnus not loaded ?"
+ (cond
+ ((listp ti:mail-required-headers)
+ ti:mail-required-headers)
+ ((boundp 'gnus-required-headers)
+ (symbol-value 'gnus-required-headers))
+ (t
+ nil)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-mail-mode-p ()
+ "Check if some mail MUA mode is tuned on this buffer: RMAIL, VM, MH ..."
+ (string-match
+ "^\\(vm-\\|rmail-\\|mh-\\|gnus-article-\\|message\\).*mode"
+ (symbol-name major-mode)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-mailbox-p ()
+ "Check if two first lines look like Berkeley mailbox format."
+ (save-excursion
+ (ti::pmin)
+ ;; From foo@some.com Wed Dec 19 19:19:41 2001
+ ;; Received: from some.com ([000.22.68.000])
+ (and (looking-at "^\\(From:?\\|Return-Path:\\) .*@")
+ (forward-line 1)
+ (not (eobp))
+ (looking-at "^[a-zA-Z-]+:[ \t]+[^ \r\r\n]"))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-mail-p ()
+ "Check if first line contain left flushed header 'Header:'.
+This is a sign that current buffer is in mail-like.
+You should also check the mode name to get more reliable results."
+ (or (memq major-mode '(message-mode mail-mode))
+ (save-excursion
+ (ti::pmin)
+ (looking-at "^[-A-Za-z0-9][-A-Za-z0-9]+:"))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-header-area-size ()
+ "Count size of header area.
+This function can only be called from a buffer that has
+`mail-header-separator'. Function count the characters in the header area.
+You can use this information to determine if the headers have been
+changed after the last check.
+
+Return:
+
+ nbr
+ nil can't find `mail-header-separator'"
+ (save-excursion
+ (ti::pmin)
+ (when (re-search-forward (regexp-quote mail-header-separator) nil t)
+ (- (point) (point-min)))))
+
+;;; ----------------------------------------------------------------------
+;;; - This is suitable for RMAIL, GNUS and for individual buffers
+;;; holding mail or news messages.
+;;;
+(defun ti::mail-hmax (&optional move noerr)
+ "Search max point of header, optionally MOVE and NOERR.
+Order is: `mail-header-separator' or find all \"Headers:\" and then
+return next line after them. The header must start at `point-min'.
+
+If no point can be found, return `point-min'."
+ (let ((point (point-min)))
+ (when (ti::mail-mail-p)
+ (save-excursion
+ (ti::pmin)
+ ;; VM's "t" key shows all headers, including the
+ ;; "From xxxx"foo.com" line which is not actual header, because
+ ;; it has no colon. Skip ovber it if we see it.
+ (if (looking-at "From")
+ (forward-line 1))
+ ;; GNUS 4 sets the mail-header-separator to "" ??
+ (if (and (not (ti::nil-p mail-header-separator))
+ (re-search-forward (regexp-quote mail-header-separator) nil t))
+ (setq point (match-beginning 0))
+ ;; Header:
+ ;; Continuing line here
+ ;; Header2:
+ (while (and (looking-at "^[0-9a-zA-z-]+:")
+ (progn
+ (end-of-line)
+ (not (eobp))))
+ ;; If this function doesn't move anuy more, then the headers
+ ;; have ended.
+ (if (null (ti::mail-next-field-start 'move))
+ (forward-line 1))
+ (setq point (point))))))
+ (if (and move point)
+ (goto-char point))
+ point))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-text-start (&optional move)
+ "Return starting point or text in BODY. Optionally MOVE to it.
+If buffer is not mail-like, then return `point-min'.
+
+References:
+ `mail-header-separator'"
+ (let ((re (regexp-quote mail-header-separator))
+ (point (point-min)))
+ (when (ti::mail-mail-p)
+ (cond
+ ((save-excursion ;Do we find the separator?
+ (ti::pmin)
+ (when (re-search-forward re nil t)
+ (forward-line 1)
+ (setq point (point)))))
+ ((setq point (ti::mail-hmax))
+ (save-excursion
+ (goto-char point)
+ (forward-line 1)
+ (setq point (point))) )
+ (t
+ (error "Can't find position.")))
+ (if (eq point (point-min)) ;Not found
+ (error "mail-header-separator not found or headers not found.")))
+ (if (and move point)
+ (goto-char point))
+ point))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-point-at-header-p ()
+ "Return non-nil if point is at HEADER area of mail."
+ (< (point) (ti::mail-text-start)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-point-at-body-p ()
+ "Return non-nil if point is at BODY of mail."
+ (not (ti::mail-point-at-header-p)))
+
+;;; ----------------------------------------------------------------------
+;;; - Many std emacs dist. functions work so that you have to narrow
+;;; to headers before you can call the functions.
+;;;
+(defun ti::mail-narrow (&optional text)
+ "Narrows to the headers only. Optionally to TEXT portion."
+ (if text
+ (narrow-to-region (ti::mail-text-start 'move) (point-max))
+ (narrow-to-region (point-min) (ti::mail-hmax))))
+
+;;; ----------------------------------------------------------------------
+;;; - This is for both GNUS and RMAIL
+;;;
+(defun ti::mail-mail-buffer-name ()
+ "Find original mail buffer whether in GNUS or in RMAIL.
+
+Return:
+
+ string buffer name
+ nil if not exist."
+
+ ;; It's amazing that GNUS uses pointers and RMAIL uses string ...
+ (let ((buffer (if (boundp 'mail-reply-buffer)
+ (symbol-value 'mail-reply-buffer))))
+ (cond ;what is the mail YANK buffer name?
+ ((stringp buffer)
+ buffer)
+ ((and (not (null buffer))
+ (bufferp buffer))
+ (buffer-name buffer))
+ (t
+ nil))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-generate-buffer-name (&rest ignore)
+ "Rename the *mail* buffer to \"*mail* SENDER\". IGNORE args.
+You can install this function e.g. into
+`my-message-generate-new-buffers' or `mail-setup-hook'"
+ (interactive "Pbuffer name: ")
+ (let ((to (if (string= (buffer-name) " *gnus article copy*") ;; See gnus-msg.el
+ (mail-fetch-field "From")
+ (mail-fetch-field "To")))
+ (str "*mail*"))
+ (unless (ti::nil-p to)
+ (cond
+ ((setq str (ti::string-match "\\([^@<]+\\)," 1 to))
+ (setq str (concat str ", ...")))
+ ((setq str (ti::string-match "\\([^@<]+\\)" 1 to)))
+ (t
+ (setq str to)))
+
+ (setq str (replace-regexp-in-string "['\"]" "" str)) ;remove extra cruft
+
+ (setq str
+ (concat
+ (if (ti::mail-news-buffer-p)
+ "*post* "
+ "*mail* ")
+ str)))
+ str))
+
+;;; ----------------------------------------------------------------------
+;;; - The idea is to find three fields and see what they contain,
+;;; and do they exist?
+;;; - What's the use of this function? Well, when you post an article
+;;; or mail it, you can call this function from some of those
+;;; posting hooks to determine what to do with the buffer.
+;;;
+;;; - code lines disabled now so that it buffer can be checked any time
+
+(defun ti::mail-mail-simple-p ()
+ "Check if buffer contain headers belonging to simple \\[mail].
+You can call this only once, just after the buffer is initially created"
+ (require 'mail-utils)
+ (let* ((sub (mail-fetch-field "Subject"))
+ ;; mail-fetch-field doesn't return nil if field is empty.
+ (to (mail-fetch-field "to"))
+ (news (mail-fetch-field "Newsgroups")))
+ ;; When you're replying to message in NEWS, RMAIL, the SUBJ and
+ ;; TO fields are already filled.
+ ;;
+ ;; That's why you can only call this function once.
+ ;; When you use C-x m, and fill the fields, there is no way
+ ;; to detect afterwards if the mail buffer was simple mail or not
+
+ (cond
+ ((or (string-match "news" (symbol-name 'major-mode))
+ news)
+ nil)
+ ((and (ti::nil-p sub)
+ (ti::nil-p to))
+ t))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-to-list-p ()
+ "Check if message is meant to be sent to a mailing list.
+In GNUS you need to add Group parameter `to-list' containing address
+to mailing list or otherwise Group is not considered mailing list."
+ (when (featurep 'gnus)
+ (let* ((group (ti::mail-news-group)))
+ (when (stringp group)
+ (gnus-group-get-parameter group 'to-list) ))))
+
+;;}}}
+;;{{{ macros: VM, RMAIL, GNUS
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'ti::mail-vm-macro 'lisp-indent-function 0)
+(put 'ti::mail-vm-macro 'edebug-form-spec '(body))
+(defmacro ti::mail-vm-macro (&rest body)
+ "Do BODY in VM's active buffer.
+The `save-excursion' -- set buffer form is executed."
+ (`
+ (let* ((BuffeR-S (when (boundp 'vm-mail-buffer)
+ (symbol-value 'vm-mail-buffer))))
+ (if (or (null BuffeR-S)
+ (not (buffer-live-p (get-buffer BuffeR-S))))
+ (error "vm-mail-buffer invalid")
+ (with-current-buffer BuffeR-S
+ (,@ body))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'ti::mail-mh-macro 'lisp-indent-function 0)
+(put 'ti::mail-mh-macro 'edebug-form-spec '(body))
+(defmacro ti::mail-mh-macro (&rest body)
+ "Do BODY in MH's active buffer.
+The `save-excursion' -- set buffer form is executed."
+ (`
+ (let* ((BuffeR-S (when (boundp 'mh-show-buffer)
+ (symbol-value 'mh-show-buffer))))
+ (if (or (null BuffeR-S)
+ (not (buffer-live-p (get-buffer BuffeR-S))))
+ (error "mh-show-buffer invalid")
+ (with-current-buffer BuffeR-S
+ (,@ body))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'ti::mail-gnus-macro 'lisp-indent-function 0)
+(put 'ti::mail-gnus-macro 'edebug-form-spec '(body))
+(defmacro ti::mail-gnus-macro (&rest body)
+ "Do BODY in Gnus `gnus-article-buffer' if it exists.
+The `save-excursion' -- set buffer form is executed."
+ (`
+ (let* ((BuffeR-S (when (boundp 'gnus-article-buffer)
+ (symbol-value 'gnus-article-buffer))))
+ (if (or (null BuffeR-S)
+ (not (buffer-live-p (get-buffer BuffeR-S))))
+ (error "gnus-article-buffer invalid")
+ (with-current-buffer BuffeR-S
+ (,@ body))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'ti::mail-rmail-macro 'lisp-indent-function 0)
+(put 'ti::mail-rmail-macro 'edebug-form-spec '(body))
+(defmacro ti::mail-rmail-macro (&rest body)
+ "Do BODY in RMAIL's active buffer. You have be in RMAIL summary."
+ (`
+ (let* ((BuffeR-R
+ ;; This variable is available in Rmail-summary
+ ;;
+ (or (if (boundp 'rmail-buffer) (symbol-value 'rmail-buffer))
+ (get-buffer "RMAIL"))))
+ (if (or (null BuffeR-R)
+ (not (buffer-live-p (get-buffer BuffeR-R))))
+ (error "rmail-buffer buffer invalid")
+ (with-current-buffer BuffeR-R
+ (,@ body))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'ti::mail-rmail-do-message-macro 'lisp-indent-function 2)
+(put 'ti::mail-rmail-do-message-macro 'edebug-form-spec '(body))
+(defmacro ti::mail-rmail-do-message-macro (nbr mode &rest body)
+ "Go to message without showing it and execute body.
+Must be in RMAIL buffer already.
+
+Input:
+ NBR message number, like `rmail-current-message'
+ MODE if non-nil then the area narrows to full stored message
+ with original headers. If nil, then area narrows to displayed
+ message.
+ BODY forms to execute in are narrowed to message."
+ (`
+ (let ((beg (rmail-msgbeg (, nbr)))
+ (end (rmail-msgend (, nbr))))
+ (save-window-excursion
+ (ti::widen-safe
+ (goto-char beg)
+ (forward-line 1)
+ (if (null (, mode))
+ (search-forward "\n*** EOOH ***\n" end t))
+ (narrow-to-region (point) end)
+ (goto-char (point-min))
+ (,@ body))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-rmail-copy-message (&optional nbr separate)
+ "Copy message NBR with header. Defaults to `rmail-current-message'.
+Current buffer must me in RMAIL already.
+
+Input:
+
+ NBR message number
+ SEPARATE if non-nil, then the headers and message body are returned
+ separately in format (hdr-string . body-string)
+
+Return:
+
+ string
+ list see mode."
+ (interactive)
+ (let* (beg
+ end
+ hdr
+ ret)
+ (setq nbr (or nbr rmail-current-message)
+ beg (rmail-msgbeg nbr)
+ end (rmail-msgend nbr))
+
+ (or (integerp nbr)
+ (error "NBR %s" nbr))
+ ;; The BEG isn't exactly the message beginning, skip 3 lines,
+ ;; also don't copy the original heades only.
+ ;;
+ ;; \1f\f
+ ;; 1, answered,,
+ ;; Summary-line: 23-Mar #Please Help Yourself, Help Ot...
+ ;; <ORIGINAL HEADERS>
+ ;;
+ ;; *** EOOH ***
+ ;; <HEADERS SHOWN IN RMAIL>
+ ;;
+ ;; <MESSAGE BODY>
+ (ti::widen-safe
+ (goto-char beg) (forward-line 3)
+ (setq beg (point))
+ (re-search-forward "^[ \t]*$")
+ (setq hdr (buffer-substring beg (point)))
+ ;; Already sitting at empty line, move away.
+ (forward-line 1)
+ (re-search-forward "^[ \t]*$")
+ (setq beg (point))
+ ;; Now make HDR + BODY of message
+ (if separate
+ (setq ret (cons hdr (buffer-substring beg end)))
+ (setq ret (concat hdr (buffer-substring beg end)))))
+ ret))
+
+;;}}}
+
+;;{{{ PGP general, tests
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-pgp-v3xx-p ()
+ "Check if X-Pgp v3.xx header signing is in use.
+It should have VALUE = KEYWORD; statement."
+ (save-excursion
+ (ti::pmin)
+ (when (re-search-forward "X-Pgp-signed" nil t)
+ (forward-line 1)
+ ;;
+ ;; KEYWORD=VALUE;
+ (looking-at "^[ \t]+.*=.*;"))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-pgp-p ()
+ "Check if buffer contain PGP. It must have left flushed regexp:
+\"^-----BEGIN.*PGP +\\(SIGNATURE\\|SIGNED\\\\|MESSAGE)\", otherwise this
+string may be inside quoted text.
+
+If there is X-pgp-sig.*: header, then it's also considered PGP message."
+ (let ((max (ti::mail-hmax))) ;headers ?
+ ;; if headers was found use that.
+
+ (setq max (if (eq (point-min) max)
+ nil
+ max))
+ (save-excursion
+ (ti::pmin)
+ (or (let (case-fold-search)
+ (re-search-forward
+ "^-----BEGIN PGP \\(SIGNATURE\\|SIGNED\\|MESSAGE\\)"
+ nil t))
+ (progn
+ ;; The New PGP in headers standard.
+ (re-search-forward "^X-Pgp-Sig.*:" max t))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-pgp-signed-conventional-p ()
+ "Return t if message is conventionally signed."
+ (save-excursion (ti::pmin) (ti::mail-pgp-re-search 'sig)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-pgp-signature-detached-p ()
+ "Return (beg . end) if there is detached signature."
+ (let* ((point (point))
+ beg
+ end)
+ (prog1 (save-excursion
+ (ti::pmin)
+ (unless (ti::mail-pgp-re-search 'msg) ;Must not exist
+ (and (setq beg (ti::mail-pgp-re-search 'sig))
+ (setq end (ti::mail-pgp-re-search 'sige))
+ (cons beg end))))
+ (goto-char point))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-pgp-signed-conventional-multi-p ()
+ "Return t if message is signed conventionally multiple times."
+ (save-excursion
+ (ti::pmin)
+ (ti::mail-pgp-re-search 'sig 'move)
+ (forward-line 1)
+ (ti::mail-pgp-re-search 'sig 'move)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-pgp-signed-xpgp-p ()
+ "Return t if message is X-pgp signed.
+There may be X-Pgp headers, but if the message is already
+verified, that removes the signature around encrypted
+message \"- -----BEGIN PGP MESSAGE-----\"
+ --> \"-----BEGIN PGP MESSAGE-----\"
+In this case the message is no more in signed format,
+but in encrypted format."
+ (and (ti::mail-pgp-headers-p)
+ ;; See documentation above
+ (save-excursion
+ (ti::pmin)
+ (null (re-search-forward
+ (concat "^" (ti::mail-pgp-msg-begin-line))
+ nil t)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-pgp-signed-p ()
+ "Return t is message is conventionally or X-pgp signed."
+ (or (ti::mail-pgp-signed-xpgp-p)
+ (ti::mail-pgp-signed-conventional-p)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-pgp-public-key-p (&optional point)
+ "Find public key delimiter from current point forward or using POINT."
+ (save-excursion
+ (goto-char (or point (point)))
+ (re-search-forward (ti::mail-pgp-pkey-begin-line) nil t)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-pgp-remail-p ()
+ "Check if This is remailer message."
+ (save-excursion
+ (ti::pmin)
+ (re-search-forward "[:#][:#]+\nReply-To" nil t)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-pgp-comment-file-p (&optional point)
+ "You can send binary files with base64 signing.
+This function checks if comment block has have words 'File: FILE '.
+
+Example:
+
+ -----BEGIN PGP MESSAGE-----
+ Version: 2.6.3ia
+ Comment: Base64 signed. File: tm.tar uncompresses to approx. 20K
+
+Input:
+
+ POINT search start point
+
+Return:
+
+ nil
+ file"
+ (save-excursion
+ (if point (goto-char point))
+ (when (re-search-forward "^Comment:.*File:? +\\([^ \t,]+\\)" nil t)
+ (match-string 1))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-pgp-encrypted-p (&optional check-pgp-dash-line)
+ "Check if there is encrypted PGP message.
+It must have left flushed tag. The start point of match is returned.
+The following tag will tell if if the message is encrypted.
+
+ ::
+ Encrypted: PGP
+
+Input:
+
+ CHECK-PGP-DASH-LINE if the tag is not found, message _could_ be signed
+ if there is -----BEGIN PGP MESSAGE----- tag.
+ When this flag is non-nil, it also checks this
+ case. Beware: message could be base64 signed too,
+ so the encrypted-p test may not be exactly right."
+ (save-excursion
+ (ti::pmin)
+ (if (re-search-forward "::[ \t]*\nEncrypted:[ \t]*PGP" nil t)
+ (match-beginning 0)
+ (when check-pgp-dash-line
+ (ti::pmin)
+ (car-safe (ti::mail-pgp-block-area 'msg))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-pgp-normal-p (&optional point)
+ "Check if there is any PGP in current buffer from POINT forward.
+The beginning point of PGP is returned."
+ ;; Must find at least two lines, maybe BEG and END
+ (let ((re (ti::mail-pgp-any-pgp-line-regexp 'acnhor))
+ ret)
+ (save-excursion
+ (ti::pmin)
+ (when (re-search-forward re nil t)
+ (setq ret (match-beginning 0))
+ (if (null (re-search-forward re nil t))
+ (setq ret nil)))
+ ret)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-pgp-headers-p ()
+ "Return t if PGP information is in headers.
+Searches string 'X-Pgp-Signed:' and return end of match or nil."
+ (let ((psig "^X-Pgp-Signed:")
+ (hmax (ti::mail-hmax)))
+ (save-excursion
+ (ti::pmin)
+ (re-search-forward psig hmax t))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-pgp-re (str)
+ "Add possible beginning anchor if STR doesn't have one."
+ (if (not (char= (aref str 0) ?^))
+ (concat "^" str)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-pgp-block-area-kill-forward (mode &optional move)
+ "Search PGP block forward and kill it. If no block found, do nothing.
+
+Input:
+ MODE choices are explained in `ti::mail-pgp-block-area'.
+ MOVE if non-nil, move to killed region begin point."
+ (let* (reg)
+ (when (setq reg (ti::mail-pgp-block-area mode))
+ (delete-region (car reg) (cdr reg))
+ (when move (goto-char (car reg))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-pgp-block-area (mode &optional inside max nstrict)
+ "Return (beg . end) of PGP block from current point forward.
+
+Input:
+ MODE nil search signed start line..
+ 'sig search signature start instead.
+ 'signed search signed message area
+ 'pkey search public key block start instead.
+ 'msg search for pgp base64 signed \"message\"
+ 'any go to `point-min' and search beginning of any
+ PGP line, then go to the end of buffer and search
+ backward any PGP line. The lines must not be at
+ same position. This gives you the whole PGP
+ region.
+
+ INSIDE if non-nil, beg and end are 'inside' without the PGP tags.
+ MAX max point to search
+ NSTRICT If non-nil; then the pgp bounds must not be left flushed,
+ but can contains \"- -\".
+Return:
+ (beg . end)
+ nil"
+ (let ((re1
+ (cond
+ ((null mode) (ti::mail-pgp-signed-begin-line))
+ ((eq 'sig mode) (ti::mail-pgp-signature-begin-line))
+ ((eq 'pkey mode) (ti::mail-pgp-pkey-begin-line))
+ ((eq 'msg mode) (ti::mail-pgp-msg-begin-line))
+ ((eq 'any mode) (ti::mail-pgp-any-pgp-line-regexp (not nstrict)))
+ ((eq 'signed mode) (ti::mail-pgp-signed-begin-line))
+ (t
+ (error "unknown mode"))))
+ (re2
+ (cond
+ ((null mode) (ti::mail-pgp-signed-end-line))
+ ((eq 'sig mode) (ti::mail-pgp-signature-end-line))
+ ((eq 'pkey mode) (ti::mail-pgp-pkey-end-line))
+ ((eq 'msg mode) (ti::mail-pgp-msg-end-line))
+ ((eq 'signed mode) (ti::mail-pgp-signed-end-line))))
+ ret
+ beg
+ end)
+ (save-excursion
+ (cond
+ ((eq mode 'any)
+
+ (when (re-search-forward re1 max t)
+ (setq beg (match-beginning 0))
+ (when (re-search-forward re1 max t)
+ (beginning-of-line)
+ (when (not (eq beg (point)))
+ (forward-line 1)
+ (setq ret (cons beg (point)))))))
+ (t
+ (if nstrict
+ (setq re1 (concat "^-? ?" re1)
+ re2 (concat "^-? ?" re2))
+ (setq re1 (concat "^" re1)
+ re2 (concat "^" re2)))
+ (when (re-search-forward re1 max t)
+ (if inside
+ (forward-line 1)
+ (beginning-of-line))
+ (setq beg (point))
+
+ (when (re-search-forward re2 max t)
+ (if inside
+ (beginning-of-line)
+ (forward-line 1))
+
+ (setq end (point))
+ (setq ret (cons beg end)))))))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-pgp-re-search (&optional mode move end no-anchor)
+ "Re-search-forward to find -----BEGIN.*SIGNED.
+
+Input:
+ MODE nil search signed start line.
+ 'sig search signature start.
+ 'sige search signature block end.
+ 'pkey search public key block start.
+ 'pkeye search public key block end.
+ 'msg search for pgp base64 signed \"message\"
+ This also finds conventionally crypted tag.
+ 'kid search for 'Key for user ID: '
+ 'kpub search for 'pub 512/47141D35 1996/06/03 ...'
+ note: match level 1 matches 0x code 47141D35
+ MOVE flag non-nil moves point to found point
+ END flag use `match-end' instead of math-beginning.
+ NO-ANCHOR flag non-nil disables using '^' anchor.
+
+Return:
+ point ,beginning of line
+ nil ,if not found"
+ (let ((re (cond
+ ((null mode) (ti::mail-pgp-signed-begin-line))
+ ((eq 'sig mode) (ti::mail-pgp-signature-begin-line))
+ ((eq 'sige mode) (ti::mail-pgp-signature-end-line))
+ ((eq 'pkey mode) (ti::mail-pgp-pkey-begin-line))
+ ((eq 'pkeye mode) (ti::mail-pgp-pkey-end-line))
+ ((eq 'msg mode) (ti::mail-pgp-msg-begin-line))
+ ((eq 'kid mode) "Key for user ID: ")
+ ((eq 'kpub mode)
+ "pub[ \t]+[0-9]+/\\([A-Z0-9]\\)+[ \t]+.*/.*/[0-9]")
+ (t
+ (error "unknown mode"))))
+ point)
+ (when (and (null no-anchor)
+ (not (memq mode '(kid))))
+ ;; suppose encrypted and signed message
+ ;; - -----END PGP MESSAGE-----
+ ;;
+ (setq re (concat "^-? ?" re)))
+ (save-excursion
+ (if (or (looking-at re)
+ (re-search-forward re nil t))
+ (if end
+ (setq point (match-end 0))
+ (setq point (match-beginning 0)))))
+ (if (and move point)
+ (goto-char point))
+ point))
+
+;;}}}
+;;{{{ PGP misc
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-pgp-exe-version-string (&optional exe-file-location)
+ "Call pgp/gpg executable to find out its version number.
+EXE-FILE-LOCATION defaults to \"pgp\" but can also be absolute path."
+ (with-temp-buffer
+ (call-process (or exe-file-location "pgp")
+ nil
+ (current-buffer)
+ nil
+ ;; - With PGP will say "illegal option", but will print
+ ;; the logo screen.
+ ;; - With GPG will print logo screen.
+ "--help")
+ (ti::pmin)
+ (when (or (re-search-forward
+ "Pretty Good Privacy(tm) +\\([^\r\n ]+\\)" nil t)
+ (re-search-forward
+ "gpg (GnuPG) +\\([^\r\n ]+\\)" nil t))
+ (match-string 1))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-pgp-data-type ()
+ "Examine pgp data packet type by searching _forward_.
+Return:
+ 'base64 'pgp 'conventional or nil"
+ (let ((re (ti::mail-pgp-any-pgp-line-regexp 'anchor))
+ char)
+ (save-excursion
+ (when (and (re-search-forward re nil t)
+ (re-search-forward "^$" nil t))
+ ;; #todo: Check first character. Actually we should check bit mask...
+ ;;
+ ;; -----BEGIN PGP MESSAGE-----
+ ;; Version: 2.6.2
+ ;; Comment: Encrypted by xxx
+ ;;
+ ;; hEwDYCggxO/bFq0
+ (forward-line 1)
+ (setq char (following-char))
+ (cond
+ ((char= char ?p) 'conventional)
+ ((char= char ?h) 'pgp)
+ ((char= char ?o) 'base64))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-pgp-trim-buffer ()
+ "Trim buffer: pgp blocks are left flushed and junk around them is removed."
+ (let ((stat t)
+ region)
+ (save-excursion
+ (ti::pmin)
+ (while (and stat
+ (setq region (ti::mail-pgp-block-area 'any)))
+
+ (when (setq stat (ti::mail-pgp-chop-region (car region) (cdr region)))
+ (goto-char (cdr stat)))))))
+
+;;; ----------------------------------------------------------------------
+;;; - This is needed after finger or http call to clean up all unnecessary
+;;; tags around the PGP key.
+;;;
+(defun ti::mail-pgp-chop-region (beg end)
+ "Delete junk around BEG END from pgp public key block.
+Area BEG END that correspond to pgp begin and end
+lines (call `ti::mail-pgp-block-area' with argument 'any),
+then we chop the public key region so that only the pgp area
+is left without additional garbage.
+
+Return
+ (beg .end) the canonilized area of PGP block
+
+Example:
+
+<PRE>
+<SAMP> -----BEGIN PGP PUBLIC KEY BLOCK-----</SAMP>
+<SAMP> Version: 2.6.3ia</SAMP>
+</PRE>
+<PRE>
+<SAMP> mQBNAzGzQ2MAAAECAM4p2THKCpNjYXDLpsg4sLHyEiNxJwQuEYfipdTj</SAMP>
+<SAMP> p5CPHN+0LkphcmkgQWFsdG8sIEZpbmxhbmQgPGphcmkuYWFsdG9AbnRj</SAMP>
+<SAMP> LmNvbT6JAFUDBRAxs0O+wLrt1UcUHTUBAbMhAf9Qgh6EznEcY2OUOIPg</SAMP>
+<SAMP> =46gx</SAMP>
+<SAMP> -----END PGP PUBLIC KEY BLOCK-----</SAMP>
+
+This is converted into
+
+-----BEGIN PGP PUBLIC KEY BLOCK-----
+Version: 2.6.3ia</SAMP>
+
+mQBNAzGzQ2MAAAECAM4p2THKCpNjYXDLpsg4sLHyEiNxJwQuEYfipdTj
+p5CPHN+0LkphcmkgQWFsdG8sIEZpbmxhbmQgPGphcmkuYWFsdG9AbnRj
+LmNvbT6JAFUDBRAxs0O+wLrt1UcUHTUBAbMhAf9Qgh6EznEcY2OUOIPg
+=46gx
+-----END PGP PUBLIC KEY BLOCK-----"
+ (save-excursion
+ (goto-char beg) (beginning-of-line)
+ (ti::narrow-safe (point) (progn
+ (goto-char end)
+ (end-of-line)
+ (point))
+ (ti::buffer-fill-region-spaces (point-min) (point-max))
+ (ti::pmin)
+ (re-search-forward "-----END")
+ (goto-char (match-beginning 0))
+ (if (> (current-column) 0) ;Nothing to do, it's left flushed
+ (delete-rectangle (point-min) (point)))
+ (ti::pmin)
+ (ti::buffer-replace-regexp "<.*$" 0 "")
+ ;; Because the last line does not have newline, the
+ ;; previous regexp doesn't match. Fix the last line too.
+ (goto-char (point-max))
+ (beginning-of-line)
+ (let (case-fold-search) ;be sensitive
+ ;; -----END PGP PUBLIC KEY BLOCK-----
+ (if (and (looking-at ".*[A-Z]-----\\(.*\\)")
+ (match-end 1))
+ (ti::replace-match 1)))
+ (setq beg (point-min)
+ end (point-max))))
+ (cons beg end))
+
+;;}}}
+;;{{{ PGP signed headers
+
+;;; ...................................................... &pgp-header ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-pgp-header-kill-in-body ()
+ "Kill headers that are inserted into the body of message.
+If there is no headers, this function does nothing.
+
+--text follows this line-- [or empty line after headers]
+##<no spaces>
+Header1: content
+Header2: content
+<empty line>
+BODY"
+ (let* (beg)
+ (save-excursion
+ (ti::mail-text-start 'move)
+ (setq beg (point))
+ (when (and (looking-at "^##\n")
+ (re-search-forward "^$" nil t))
+ (delete-region beg (point))))))
+
+;;}}}
+;;{{{ PGP ASCII armor
+
+;;; ....................................................... &pgp-armor ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-pgp-data-char-to-int (char)
+ "Process PGP ascii armor data.
+Input is ASCII armor CHAR (as one string). Function return respective int."
+ (let* ((table (concat "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
+ "abcdefghijklmnopqrstuvwxyz0123456789+/"))
+ case-fold-search
+ str)
+ (if (null (setq str (ti::string-match
+ (concat ".*" (regexp-quote char)) 0 table)))
+ (error "Armor char is invalid %s " char)
+ (1- (length str)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-pgp-data-string-to-bin-string (string)
+ "Process PGP ascii armor data.
+Convert quoted printable ASCII armor STRING into binary string."
+ (let* ((len (length string))
+ (i 0)
+ (ret "")
+ ch
+ int
+ bin)
+ (while (< i len)
+ (setq ch (substring string i (1+ i)))
+ (setq int (inline (ti::mail-pgp-data-char-to-int ch)))
+ (setq bin (inline (int-to-bin-string int 6)))
+ (setq ret (concat ret bin))
+ (incf i))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-pgp-data-bin-string-to-int-list(string)
+ "Process PGP ascii armor data.
+Convert 8bit binary byte string \"000001...\" into list of ints."
+ (let* ((len (/ (length string) 8))
+ (i 0)
+ ret
+ bin
+ int)
+ (while (< i len)
+ (setq bin (substring string (* i 8) (+ 8 (* i 8))))
+ (setq int (inline (bin-string-to-int bin)))
+ (incf i)
+ (push int ret))
+ (nreverse ret)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::mail-pgp-data-ascii-armor-convert (string)
+ "Convert PGP ascii armor STRING(quoted printable) into list of ints."
+ (ti::mail-pgp-data-bin-string-to-int-list
+ (ti::mail-pgp-data-string-to-bin-string string)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-pgp-data-study-ctb-byte (int)
+ "From single INT, examine the PGP CTB structure.
+Return
+ nil ,input was not CTB byte
+ '(ctb-type length-field)
+ ctb-type is
+ 'enc (pgp encrypted message)
+ 'signed (signed message)
+ 'secring (secret keyring)
+ 'pring (public keyring)
+ 'base64 (base 64 signed)
+ 'crypt (conventionally crypted)
+ 'raw (raw literal plaintext)
+ 'trust (keyring trust packet)
+ 'uid (user id packet)
+ 'comment (comment packet)
+ 'unknown (none of the above...)
+
+ length is
+ nil no length, unknown length
+ 1 2 4 byte packet length"
+ (let* ((length-mask 3) ;; 00000011b
+ (type-mask 60) ;; 00111100b
+ (ctb-mask 128) ;; 10000000b
+ (table
+ '((1 . enc)
+ (2 . signed)
+ (5 . secring)
+ (6 . pring)
+ (8 . comp)
+ (9 . crypt)
+ (11 . raw)
+ (12 . trust)
+ (13 . uid)
+ (14 . comment)))
+ (type 'unknown)
+ val
+ ret)
+ (when (logand int ctb-mask)
+
+ ;; shift to the right 2 bits
+
+ (when (setq val (assq (lsh (logand int type-mask) -2) table))
+ (setq type (cdr val)))
+
+ (setq val (logand int length-mask))
+ (cond
+ ((eq 0 val) (setq val 1))
+ ((eq 1 val) (setq val 2))
+ ((eq 1 val) (setq val 4))
+ ((eq 3 val) (setq val nil)))
+ (setq ret (cons type val)))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::mail-pgp-stream-study-1-ver (int)
+ "Return pgp version string from stream INT."
+ (cond
+ ((eq 2 int) "2.5")
+ ((eq 3 int) "2.6")
+ (t (error "Invalid Data format."))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'ti::mail-pgp-stream-study-1-key-id 'lisp-indent-function 1)
+(put 'ti::mail-pgp-stream-study-1-key-id 'edebug-form-spec '(body))
+(defmacro ti::mail-pgp-stream-study-1-key-id (stream result)
+ "Read MSB and LSB key-id from STREAM to RESULT.
+STREAM will be advanced during read."
+ (`
+ (let* ((i 0))
+ (while (< i 4)
+ (setq (, result) (concat (or (, result) "")
+ (format "%02x" (car (, stream))))
+ (, stream) (cdr (, stream))
+ i (1+ i)))
+ (setq (, result) (upcase (, result))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-pgp-stream-study-1-time (stream)
+ "Read TIME from STREAM to RESULT."
+ (let* (val1
+ val2)
+ ;; There must be easier way to do, but right now it goes like this
+ ;; '(51 158 95 145)
+ ;; --> hex 339E 5F91
+ ;; --> int 13214 24464 which is in (current-time) format
+ ;;
+
+ (setq val1 (hexl-hex-string-to-integer
+ (concat
+ (int-to-hex-string (car stream))
+ (int-to-hex-string (car (cdr stream)))))
+
+ stream (cdr (cdr stream))
+ val2 (hexl-hex-string-to-integer
+ (concat
+ (int-to-hex-string (car stream))
+ (int-to-hex-string (car (cdr stream))))))
+ (ti::date-standard-date nil (list val1 val2))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-pgp-stream-study-enc (length stream)
+ "Study the 'enc packet, which has known LENGTH.
+STREAM is list of ints, minimum 11 integers, 13 is the full 'enc packet.
+
+Return:
+ '(version-string
+ key-msb-hex-string
+ key-lsb-hex-string
+
+ rsa-algorithm ;; nil if stream is not long enough
+ rsa-int (encrypted integer)) ;; nil if stream is not long enough."
+ (let* ((msb "")
+ (lsb "")
+ ver
+ val
+ rsa-alg
+ rsa-int)
+ ;; Skip to begin of real data
+ ;; CTB LENGTH VERSION KEY-MSB KEY-LSB
+ ;; 1byte 1-4bytes 1byte 4bytes 4bytes
+ (setq stream (nthcdr (1+ length) stream))
+ (setq val (car stream) stream (cdr stream))
+ (setq ver (ti::mail-pgp-stream-study-1-ver val))
+ (ti::mail-pgp-stream-study-1-key-id stream msb)
+ (ti::mail-pgp-stream-study-1-key-id stream lsb)
+ (setq rsa-alg (car stream)
+ rsa-int (cadr stream))
+ (list ver msb lsb rsa-alg rsa-int)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-pgp-stream-study-signed (length stream)
+ "Study the 'sign packet, which has known LENGTH. STREAM is list of ints.
+
+Return:
+
+ '(version-string
+ md-length
+ sig-class
+ timestamp
+
+ key-msb-hex-string
+ key-lsb-hex-string
+
+ alg-rsa ;; nil if stream is not long enough
+ alg-md5 ;; nil if ...
+ digest '(int int);; nil if ...
+
+ rsa-algorithm ;; nil if stream is not long enough
+ rsa-int (encrypted integer) ;; nil if stream is not long enough)"
+ (let* ((msb "")
+ (lsb "")
+ ver
+ md-length
+ sig-class
+ timestamp
+ alg-rsa
+ alg-md5
+ digest)
+ ;; Skip to begin of real data
+ ;; CTB LENGTH VERSION KEY-MSB KEY-LSB
+ ;; 1byte 1-4bytes 1byte 4bytes 4bytes
+
+ (setq stream (nthcdr (1+ length) stream))
+ (setq ver (ti::mail-pgp-stream-study-1-ver (car stream))
+ stream (cdr stream)
+ md-length (car stream)
+ stream (cdr stream)
+ sig-class (car stream)
+ stream (cdr stream))
+ (setq timestamp
+ (ti::mail-pgp-stream-study-1-time stream))
+ (setq stream (nthcdr 4 stream))
+ (ti::mail-pgp-stream-study-1-key-id stream msb)
+ (ti::mail-pgp-stream-study-1-key-id stream lsb)
+ (setq alg-rsa (car stream)
+ stream (cdr stream)
+ alg-md5 (car stream)
+ stream (cdr stream)
+ digest (list (car stream) (car (cdr stream))))
+ (list ver md-length sig-class timestamp msb lsb
+ alg-rsa alg-md5 digest)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-pgp-stream-study-pring (length stream)
+ "Study the 'pring packet, which has known LENGTH. STREAM is list of ints.
+
+Return:
+
+ '(version-string
+ timestamp
+ key-msb-hex-string
+ key-lsb-hex-string)"
+ (let* ((msb "")
+ (lsb "")
+ ver
+ timestamp
+ validity)
+ ;; Skip to begin of real data
+ ;; CTB LENGTH VERSION TIME VALIDITY RSA-ALG
+ ;; 1byte 1-4bytes 1byte 4bytes 2bytes 1byte
+ (setq stream (nthcdr (1+ length) stream))
+ (setq ver (ti::mail-pgp-stream-study-1-ver (car stream))
+ stream (cdr stream))
+ (setq timestamp
+ (ti::mail-pgp-stream-study-1-time stream))
+ (setq stream (nthcdr 4 stream)
+ validity (car stream)
+ stream (cdr stream))
+ ;; PGP format spec is not clear enough here!
+ ;; Don't know where the User ID is...
+;;; (ti::mail-pgp-stream-study-1-key-id stream msb)
+;;; (ti::mail-pgp-stream-study-1-key-id stream lsb)
+ (list ver timestamp validity msb lsb)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-pgp-stream-study (ctb stream)
+ "Study PGP data.
+
+Input:
+
+ CTB in format `ti::mail-pgp-data-study-ctb-byte'
+ STREAM dearmored int stream (list of ints including ctb-byte)
+
+Return:
+
+ LIST depends on the ctb, see conversion functions."
+ (let* ((type (car ctb))
+ (len (cdr ctb)))
+
+;;; (ti::d! type)
+ (cond
+ ((eq type 'enc)
+ (ti::mail-pgp-stream-study-enc len stream))
+ ((eq type 'signed)
+ (ti::mail-pgp-stream-study-signed len stream))
+ ((eq type 'base64)
+ ;; #todo
+ nil)
+ ((eq type 'crypt)
+ ;; #todo
+ nil)
+ ((eq type 'pring)
+ (ti::mail-pgp-stream-study-pring len stream)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-pgp-stream-forward-xpgp ()
+ "If there is X-Pgp-Signed field, goto signature stream."
+ (let* ((point (ti::mail-pgp-headers-p)))
+ (when point
+ (goto-char point)
+ ;; must exist, this call dies if not found
+ (re-search-forward "Signature[ \t]*=[ \t\n\"]+"))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-pgp-stream-forward (&optional any)
+ "Find PGP data stream block start forward. PGP block must be left flushed.
+
+Input:
+
+ ANY if non-nil, then find any stream (not necessarily left flushed)
+
+Return:
+
+ point cursor is placed in front of stream
+ nil If there is no PGP stream block, do nothing."
+ (let* ((beg (ti::mail-pgp-msg-begin-line))
+ (sig (ti::mail-pgp-signature-begin-line))
+ (pkey (ti::mail-pgp-pkey-begin-line))
+ (re (concat (if any "" "^") "-----BEGIN"))
+ (point (point))
+ (loop t)
+ col
+ ret)
+ ;; base64
+ ;; -----BEGIN PGP MESSAGE-----
+ ;; Version: 2.6.3ia
+ ;;
+ ;; owEBbACT/4kAVQMFATOb
+
+ ;; normal signature
+ ;; -----BEGIN PGP SIGNATURE-----
+ ;; Version: 2.6.3ia
+ ;; Charset: noconv
+ ;;
+ ;; iQBVAwUBM55fkcC67dVHFB01AQGnHwIAqe2OfkdcnQviGzCmy3KddnsE8uFkAeaV
+
+ ;; conventional crypt
+ ;; -----BEGIN PGP MESSAGE-----
+ ;; Version: 2.6.3ia
+ ;;
+ ;; pgAAACN9WXlrJFURU5Xgi+YyN
+
+ ;; encrypted
+ ;; -----BEGIN PGP MESSAGE-----
+ ;; Version: 2.6.3ia
+ ;;
+ ;; hEwDwLrt1UcUHTUBAf9
+ ;;
+
+ ;; Extracted public key
+ ;; -----BEGIN PGP PUBLIC KEY BLOCK-----
+ ;; Version: 2.6.3ia
+ ;;
+ ;; mQBNAzOW770AAAECANDkXBfEbJk0gW41o52nLiktpThcBY+BMQCY5zyGCyUIbrDp
+ (while (and loop (re-search-forward re nil t))
+ (goto-char (match-beginning 0))
+
+ (when (or (looking-at beg)
+ (looking-at sig)
+ (looking-at pkey))
+ (setq col (current-column))
+ (when (re-search-forward "^[ \t]*$" nil t)
+ (setq loop nil)
+ (forward-line 1)
+ (move-to-column col)
+ (setq ret (point))))
+ (if loop
+ (end-of-line))) ;wrong match, Continue search
+ (unless ret
+ ;; none found, return to original position.
+ (goto-char point))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-pgp-stream-forward-and-study (&optional search any)
+ "Find PGP data stream forward and study it.
+
+If normal search fails, then find X-Pgp-Signed field's first
+data stream.
+
+Input:
+
+ SEARCH if non-nil, then search PGP starting from `point-min' if
+ forward lookup fails.
+ ANY if non-nil, find also non-left flushed stream.
+
+Return:
+
+ '(CTB . (INFO-LIST)) the CTB type and data for CTB
+ nil no stream found forward."
+ (interactive)
+ (let* ((point (point))
+ ctb
+ line
+ list
+ data
+ ret)
+ (when (or (ti::mail-pgp-stream-forward any)
+ (and search
+ (ti::pmin)
+ (ti::mail-pgp-stream-forward any))
+ (ti::mail-pgp-stream-forward-xpgp))
+ ;; Will match all base64 characters (approx.)
+ (setq line (ti::buffer-match "[^ \t\n\"\']+" 0)
+ list (ti::mail-pgp-data-ascii-armor-convert line)
+ ctb (ti::mail-pgp-data-study-ctb-byte (car list))
+ data (ti::mail-pgp-stream-study ctb list))
+ (setq ret (cons (car ctb) data)))
+ (unless ret (goto-char point)) ;Nothing found, return to point
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-pgp-stream-forward-info (&optional search any)
+ "Find PGP data stream and read some information. Return string.
+
+Input:
+
+ SEARCH if non-nil, then search PGP starting from `point-min' if
+ forward lookup fails.
+ ANY if non-nil, find also non-left flushed stream."
+ (let* (ver
+ time key-id
+ data
+ type
+ ret)
+ (when (setq data (ti::mail-pgp-stream-forward-and-study search any))
+ (setq type (car data))
+ (cond
+ ((eq type 'signed)
+ (setq ver (ti::mail-pgp-stream-data-elt data 'ver)
+ time (ti::mail-pgp-stream-data-elt data 'time)
+ key-id (ti::mail-pgp-stream-data-elt data 'key-id))
+ (setq ret (format "Signed by 0x%s %s [v%s.x]" key-id time ver)))
+ ((eq type 'enc)
+ (setq ver (ti::mail-pgp-stream-data-elt data 'ver)
+ key-id (ti::mail-pgp-stream-data-elt data 'key-id))
+ (setq ret (format "Encrypted to 0x%s [v%s.x]" key-id ver)))
+ ((eq type 'pring)
+ (setq ver (ti::mail-pgp-stream-data-elt data 'ver)
+ time (ti::mail-pgp-stream-data-elt data 'time))
+ (setq ret (format "Public key %s [v%s.x]" time ver)))))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-pgp-stream-data-elt (data elt)
+ "Study DATA and Return packet ELT.
+DATA must be in the format of `ti::mail-pgp-stream-forward-and-study'
+ELT can be 'ver 'time 'key-id"
+ (let* ((type (car data))
+ (pos (assq
+ elt
+ (nth
+ 1
+ (assq type
+ '(
+ (signed ((ver 0) (time 3) (key-id 5)))
+ (pring ((ver 0) (time 1) (key-id 4)))
+ (enc ((ver 0) (key-id 2))) ;No TIME field
+ ;; #todo, not ready
+ (base64 ((ver 0) (time 3) (key-id 5)))
+ (crypt ((ver 0) (time 3) (key-id 5)))))))))
+ (if (null pos)
+ (error "Wrong specification %s %s %s" type elt data)
+ (nth (nth 1 pos) (cdr data)))))
+
+;;; Test suite with live data: first ASCII armor bytes
+;;
+;; (setq list (ti::mail-pgp-data-ascii-armor-convert "hEwDwLrt1UcUHTUBA"))
+;; (setq ctb (ti::mail-pgp-data-study-ctb-byte (car list)))
+;; (setq data (ti::mail-pgp-stream-study ctb list))
+
+;; Sig data
+;; (setq s "iQBVAwUBM55fkcC67dVHFB01AQGnHwIAqe2OfkdcnQviGzCmy3KddnsE8uFkAeaV")
+;;
+;; (setq list (ti::mail-pgp-data-ascii-armor-convert s))
+;; (setq ctb (ti::mail-pgp-data-study-ctb-byte (car list)))
+;; (setq data (ti::mail-pgp-stream-study ctb list))
+
+;;}}}
+;;{{{ PGP key info
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-pgpk-id-lines-in-region (beg end)
+ "Search all lines in BEG END matching pgp -kvc and -kx lines.
+
+Option -kvc
+
+ pub 1024/01234567 1997/05/01 Mar Bar <Bar@bar.com>
+
+Option -kx
+
+ Key for user ID: Mr. Bar <bar@bar.com>
+ 1024-bit key, key ID 01234567, created 1997/05/01
+
+And return list of those lines."
+ (let ((l1
+ (ti::buffer-grep-lines
+ "pub[ \t:]+[0-9]+/[A-Z0-9]+[ \t:]+.*/.*/[0-9]" beg end))
+ (l2 (ti::buffer-grep-lines "[0-9]-bit key, Key ID " beg end)))
+ (cond
+ ((and l1 l2) (ti::list-merge-elements l1 l2))
+ (l1 l1)
+ (l2 l2))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-pgpk-id-0x-lines-in-region (beg end)
+ "Call `ti::mail-pgpk-id-lines-in-region' on BEG END, return only Key HEX ids."
+ (let* (ret)
+ (dolist (line (ti::mail-pgpk-id-lines-in-region beg end))
+ (when (stringp line)
+ (push
+ (or
+ (ti::string-match "pub[ \t]+[0-9]+/\\([^ \t]+\\)" 1 line)
+ (ti::string-match "Key ID \\([0-9A-F]+\\)" 1 line))
+ ret)))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-pgpk-public-get-region (&optional beg end buffer relax)
+ "Get all keys in BEG END from BUFFER and build list of key data.
+The blocks searched are in following format.
+
+ Key for user ID: Mr. Foo <foo@example.com>
+ 512-bit key, key ID 123456789, created 1996/06/03
+ Also known as: Mr Foo <bar@bar.com>
+
+ -----BEGIN PGP PUBLIC KEY BLOCK-----
+ [...]
+ -----END PGP PUBLIC KEY BLOCK-----
+
+Note1:
+
+ If there _no_ 'Key for user ID:' string in the buffer, this function
+ can't find the public key block while it may be there. It is
+ assumed that each p-key block is _preceded_ by that string.
+
+ All anonymous p-key block are skipped.
+
+Note2:
+
+ If there are two sequential key-id strings, like
+ Key for user ID: <<A
+ Key for user ID: <<B
+ -----BEGIN PGP PUBLIC KEY BLOCK-----
+
+ The p-key block in the list for A will be nil.
+
+Note3:
+
+ If RELAX argument is non-nil, then the 'Key for user ID:'
+ must not exit. Only the Public key tags are searched.
+
+ Recommended way of informing public keys is however displaying
+ full public key information and not just PK block
+
+Return:
+
+ '((KEY-ID-STRING PUBLIC-KEY_BLOCK)"
+ (let ((opt (if relax 'pkey 'kid))
+ id
+ block
+ region
+ ret
+ max)
+ (with-current-buffer (or buffer (current-buffer))
+ (ti::narrow-safe (or beg (point-min)) (or end (point-max))
+ (ti::pmin)
+ (while (ti::mail-pgp-re-search opt 'move)
+ (setq id (ti::read-current-line))
+
+ ;; If there are two
+ ;; Key for user ID:
+ ;; Key for user ID:
+ ;;
+ ;; And there is no public key between these two, set the
+ ;; search limit to stop to next Key-id line.
+ (setq max
+ (save-excursion
+ (end-of-line)
+ (setq max (ti::mail-pgp-re-search 'kid))))
+;;; (ti::d! ">>" id ">>" max (ti::mail-pgp-block-area 'pkey nil max))
+ (cond
+ ((setq region (ti::mail-pgp-block-area 'pkey nil max))
+ (setq block (buffer-substring (car region) (cdr region)))
+ (goto-char (cdr region)))
+ (t
+ ;; Continue search
+ (end-of-line)))
+ (push (list id block) ret)
+ (setq id nil block nil))))
+ (nreverse ret)))
+
+;;}}}
+;;{{{ PGP signature info
+
+;;; ................................................... &pgp-signature ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-pgp-signature-remove (&optional add no-cnv)
+ "Remove PGP signature (and headers that have included in there).
+Below, only lines 7 and 8 are left in buffer.
+
+ 1 -----BEGIN PGP SIGNED MESSAGE----
+ 2
+ 3 ## << Header start mark
+ 4 Header1: content
+ 5 Header2: Content
+ 6 << space here
+ 7 test
+ 8
+ 9 -----BEGIN PGP SIGNATURE-----
+
+With ADD flag
+
+ The tag lines are reassembled and point sits at the beginning of line 6
+ and whitespaces around (email) buffer text are deleted.
+ If tag lines are found while ADD, this function does nothing.
+
+With NO-CNV
+
+ When removing signature, do not convert '- -' back into '-'.
+ Eg. If message is encrypted and signed; it is not desirable to
+ do this conversion if you just want to strip out the signature to Xpgp.
+ The '- -' lines must stay there."
+ (let* ((beg (save-excursion (ti::pmin) (ti::mail-pgp-re-search))))
+ (cond
+ ((and add (null beg))
+ (ti::mail-trim-buffer)
+ (ti::mail-text-start 'move)
+ (insert (ti::mail-pgp-signed-begin-line) "\n\n")
+ (ti::pmax)
+ (insert "\n" (ti::mail-pgp-signature-begin-line) "\n"))
+ ((null add)
+ ;; there is one thing to fix first, PGP converts lines that have
+ ;; double '--' at front
+ ;;
+ ;; --text follows
+ ;; -->
+ ;; - --text follows
+ ;;
+ ;; Let's correct those lines too.
+ (when (null no-cnv)
+ (save-excursion (ti::buffer-replace-regexp "^- -" 0 "-")))
+ (when beg ;Thre is regular PGP sig
+ ;; note: We don't trim BODY here, we only remove
+ ;; the pgp tag lines. The receiving end should do
+ ;; the trimming. (we save one function call)
+ (goto-char beg) ;One newline at beg
+ (ti::buffer-kill-line 'del 2) ;TWO lines; important
+ ;; Kill included headers
+ (when (and (looking-at "##\n.*: ")
+ (re-search-forward "^$" nil t))
+ (delete-region beg (1+ (point))))
+
+ (when (and (prog1 (setq beg (ti::mail-pgp-re-search 'sig 'move))
+ (ti::buffer-kill-line))
+ (ti::mail-pgp-re-search 'sige 'move))
+ (forward-line 1)
+ (delete-region beg (point))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'ti::mail-pgp-signature-normal-do-region 'lisp-indent-function 0)
+(put 'ti::mail-pgp-signature-normal-do-region 'edebug-form-spec '(body))
+(defmacro ti::mail-pgp-signature-normal-do-region (&rest body)
+ "Execute BODY and calculate pgp signature region.
+In the macro you can use following variables:
+
+ `limits' (area-beg . area-end)
+ `area-beg'
+ `area-and'
+
+This macro does nothing if there is no normal PGP signature."
+ (`
+ (let (limits
+ area-beg
+ area-end)
+ (setq limits (ti::mail-pgp-block-area 'sig))
+ (when limits
+ ;; Set values
+ (setq area-beg (car limits)
+ area-end (cdr limits))
+ ;; If these are no used in BODY: no-op Quiet XE ByteCompiler
+ (if (null area-beg) (setq area-beg nil))
+ (if (null area-end) (setq area-end nil))
+ (,@ body)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::mail-get-article-buffer ()
+ "Do `set-buffer' to *Article* if it exists. Return nil if no buffer."
+ (if (boundp 'gnus-article-buffer)
+ (symbol-value 'gnus-article-buffer)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'ti::mail-with-article-buffer 'lisp-indent-function 0)
+(put 'ti::mail-with-article-buffer 'edebug-form-spec '(body))
+(defmacro ti::mail-with-article-buffer (&rest body)
+ "Run BODY in *Article* buffer if it exists."
+ (`
+ (let* ((buffer (ti::mail-get-article-buffer)))
+ (when (buffer-live-p buffer)
+ (with-current-buffer buffer
+ (,@ body))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-pgp-signature-normal-info ()
+ "Return signature information from normal PGP format.
+Return:
+ ((beg . end) (fld fld ..) (signarure-data sig ..))"
+ (let (sig-list
+ info-list
+ ret)
+ (ti::mail-pgp-signature-normal-do-region
+ (save-excursion
+ (goto-char area-beg)
+ (forward-line 1)
+ ;; Here are the comments and other PGP headers
+ (while (looking-at "^[^ \t]+:+ .*")
+ (ti::nconc info-list (ti::read-current-line))
+ (forward-line 1))
+ ;; Here is the signature itself
+ (while (not (>= (point) (cdr limits)))
+ (if (looking-at "^[^ \t\n]+$")
+ (ti::nconc sig-list (match-string 0)))
+ (forward-line 1))
+ (setq ret (list limits info-list sig-list))))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-pgp-sig-header-info-v2xx ()
+ "Return signature information from X-pgp v2.xx headers.
+
+Reads format:
+
+X-Pgp-Comment: Processed by TinyPgp.el 1.56
+X-Pgp-Version: 2.6.3ia
+X-Pgp-Charset: noconv
+X-Pgp-Signed:
+ iQBVAwUBMoijBMC67dVHFB01AQGf3QH/dmgc47fx1tvHYPcuKWIz0Fe7HnWXmd63
+ 3IBA6vhSqzbUT4nkKL2QJQX/0Z8I9dkmOahSQNKvU/7qsB9Iw8JwpQ==
+ =9yu9
+
+Return:
+ ((beg . end) (fld fld ..) (signature-data sig ..))"
+ (let* ((case-fold-search t)
+ (pbase "X-Pgp-")
+ (p-re (concat "^" pbase)) ;pgp regexp for hdrs
+ (psig (concat p-re "Signed:"))
+ (fld-re (concat
+ p-re
+ "\\(Version:\\|Charset:\\|Comment:\\|Signed:\\)"))
+ (hmax (ti::mail-hmax))
+ val
+ sig-list
+ info-list
+ beg
+ end
+ ret)
+ (save-excursion
+ (ti::pmin)
+ (while (and
+ hmax
+ (< (point) hmax) ;those fwl-line calls may go past...
+ (re-search-forward fld-re hmax t))
+ (beginning-of-line)
+ (if (null beg) ;record it NOW
+ (setq beg (point)))
+ (cond
+ ((looking-at (concat psig "[ \t]*\\([^ \t\n]*\\)"))
+ ;; Is this the signature itself ? Special handling,
+ ;; because spreads multiple lines.
+ (setq val (ti::remove-properties (match-string 1)))
+ (if (not (string= "" val))
+ (ti::nconc sig-list val))
+ (forward-line 1)
+ (while (looking-at "^[ \t]+\\([^ \t\n]+\\)")
+ (ti::nconc sig-list (ti::remove-properties (match-string 1)))
+ (forward-line 1)))
+ ;; Nope, some additional PGP header
+ (t
+ (ti::nconc info-list (ti::remove-properties (ti::read-current-line)))))
+ ;; Because there is already one while loop that says fwd-line,
+ ;; we don't want to go furher if it stopped us.
+ (if (looking-at (concat p-re "\\|^\t+"))
+ (forward-line 1)))
+ (beginning-of-line)
+ (setq end (point)))
+
+ (if sig-list
+ (setq ret (list (cons beg end) info-list sig-list)))
+
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-pgp-signature-header-info-v3xx ()
+ "Return signature information from X-pgp v3.xx headers.
+
+Return:
+ '((nil . nil)
+ (\"Version: x.x.x\" \"Charset: xxxx\" ...)
+ (signature-string sig-string ..))"
+ (let ((field (ti::remove-properties (ti::mail-get-field "X-Pgp-signed")))
+ info-list
+ sig-list
+ elt
+ list)
+ (when field
+ (setq list (ti::mail-mime-parse-header field 'downcase))
+ ;; Push adds to the front of list, so beware order of elements
+ (if (setq elt (assoc "signature" list))
+ (setq sig-list (cdr elt)))
+ (if (setq elt (assoc "comment" list))
+ (push (concat "Comment: " (car (cdr elt))) info-list))
+ (if (setq elt (assoc "charset" list))
+ (push (concat "Charset: " (car (cdr elt))) info-list))
+ (if (setq elt (assoc "version" list))
+ (push (concat "Version: " (car (cdr elt))) info-list ))
+ (if info-list
+ (list (cons nil nil) info-list sig-list)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-pgp-signature-header-info ()
+ "Return X-pgp header info if X-Pgp header exist."
+ (if (ti::mail-pgp-v3xx-p)
+ (ti::mail-pgp-signature-header-info-v3xx)
+ (ti::mail-pgp-sig-header-info-v2xx)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-mime-parse-header (header-string &optional downcase)
+ "Parse Variable=value HEADER-STRING like and optionally DOWNCASE keywords.
+
+Header-this: var1=value2; var2= val2; var3=\"starts here \"
+ \" continues here\"; var4= v1,v2,v3;
+
+The VAL returned is different for continued string. It is a list of
+individual parts in the parsed. In this case the whole returned value
+would be:
+
+'((var1 . (val1))
+ (var2 . (val2))
+ (var3 . (\"starts here \" \" continues here\"))
+ (var4 . (\" v1,v2,v3\")))
+
+Return:
+ ((var . VAL) (var . VAL) ..)"
+ (let ((tag-re "^[ \t]*\\([^ \t\n]+\\)[ \t\"]*=")
+ (val-re "[ \t\"]*\\([^\n\"]+\\)")
+ (buffer (ti::temp-buffer "*tmp*" 'clear))
+ name
+ val
+ ret)
+ (with-current-buffer buffer
+ (insert header-string)
+ ;; put into same line
+ (ti::pmin) (ti::buffer-replace-regexp "[ \t]*;[ \t]*" 0 "\n")
+ ;; Okay now it's in canonical format. First
+ ;; pick up signature, then delete it and parse other fields.
+ ;; Version=2.6.3ia
+ ;; Charset=noconv
+ (ti::pmin)
+ (while (re-search-forward tag-re nil t)
+ (setq name (match-string 1) val nil)
+ (cond
+ ((looking-at val-re) ;VALUE at the same line
+ (ti::nconc val (match-string 1))
+ (forward-line 1))
+ (t
+ ;; Multiline
+ (while (progn (forward-line 1)
+ (looking-at val-re))
+ (ti::nconc val (match-string 1)))))
+ (if downcase
+ (setq name (downcase name)))
+ (push (cons name val) ret)))
+ (nreverse ret)))
+
+;;}}}
+;;{{{ PGP public key
+
+;;; ........................................................ &pgp-pkey ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-pgp-pkey-read (&optional raw kill-file)
+ "Read public key block from current point forward. Point is moved.
+
+Input:
+
+ RAW If non-nil, return only raw public key block.
+ KILL-FILE if non-nil, kill temporary file after statement
+ 'Key extracted to file ...' Once the file is killed the
+ message will be removed from buffer."
+ (let* (beg
+ end
+ file
+ ret)
+ ;; No temp files are left on disk
+ ;; Remove also the file message from buffer before we read the
+ ;; content.
+ ;;
+ ;; Extracting from key ring: '/users/xxx/.pgp/pubring.pgp',\
+ ;; userid "xxx".
+ ;;
+ ;; Key for user ID: <xxx@some.fi>
+ ;; 512-bit key, key ID 8125CAAA, created 1997/06/05
+ ;;
+ ;; -----BEGIN PGP PUBLIC KEY BLOCK-----
+ (when (and kill-file
+ (re-search-forward "Key extracted to file.*'\\(.*\\)'" nil t))
+ (setq file (match-string 1))
+ (ti::buffer-kill-line)
+ (ti::file-delete-safe file))
+ (goto-char (point))
+ (when (re-search-forward (ti::mail-pgp-pkey-begin-line) nil t)
+ (re-search-backward "Key for user ID:") (beginning-of-line)
+ (when raw
+ (re-search-forward "^-----BEGIN")
+ (beginning-of-line))
+ (setq beg (point))
+ (when (ti::mail-pgp-re-search 'pkeye 'move)
+ (forward-line 1)
+ (setq end (point)))
+ (when (and beg end)
+ (setq ret (buffer-substring beg end))))
+ ret))
+
+;;}}}
+;;{{{ PGP remail
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-pgpr-close ()
+ "Close reply block by adding '**' to the end.
+If there already is '**', do nothing."
+ (save-excursion
+ (ti::pmax)
+ ;; Remailers need "**" at the end of encrypted block
+ (if (not (re-search-backward "^\\*\\*" nil t))
+ (insert "\n**\n"))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-pgpr-anonymize-headers (mode &optional no-ins arg1 arg2 hash)
+ "Destroy header information according to mode and move it to message body.
+This function does nothing if first line is not header.
+
+Input:
+
+ MODE 'move-to-body moves, all headers to body
+ 'move-to-body-maybe, all headers to body only if
+ there is not already hash marks.
+ arg1 is used for subject defaults to 'dummy'
+ arg2 is used for organisation defaults to 'dummy'
+
+ NO-INS Do not insert the hash headers into body, but return them
+ as list instead.
+
+ ARG1 ARG2 used by MODE
+
+ HASH Use hash marks string other that \"##\"
+
+Return:
+
+ list"
+ (let ((hlist '("In-reply-to"
+ "Organization"
+ "Subject"))
+ (empty " dummy")
+ (full-string "")
+ done
+ ptr
+ list
+ str
+ ret)
+ (setq hash (or hash "##")
+ arg1 (or arg1 empty)
+ arg2 (or arg2 empty))
+ (save-excursion
+ (when (ti::mail-mail-p)
+ (cond
+ ((memq mode '(move-to-body move-to-body-maybe))
+ ;; First check if hash mark is already there
+ ;; If mode is "maybe" we don't add new headers.
+ ;;
+ ;; The regexp matches to the end of line, because you may have
+ ;; quoted the message
+ ;;
+ ;; jerry> ##
+ ;; jerry> Subject: this here
+ (ti::pmin)
+ (unless (and (eq mode 'move-to-body-maybe)
+ (re-search-forward (concat hash "[ \t]*$") nil t))
+ (setq ptr hlist)
+ (dolist (elt ptr)
+ (setq str (ti::mail-get-field elt))
+ (when (and str (not (string= empty str)))
+ (setq elt (format "%s: %s\n" elt str))
+ (push elt list)
+ ;; so that we can match against this later
+ ;;
+ (setq full-string (concat full-string elt))))
+ (ti::mail-text-start 'move)
+ (when list
+ (setq ret list done t)
+ (unless no-ins
+ ;; Remailer hash mark
+ (insert hash "\n"))))
+ ;; Anonymize some headers
+ (if arg1
+ (ti::mail-kill-field "^subject" arg1))
+ (if arg2
+ (ti::mail-kill-field "^organization" arg2))
+ (when (and done (null no-ins))
+ (dolist (elt list)
+ ;; Copy headers inside message
+ (insert elt))))
+ (t
+ (error "Invalid mode [%s]" mode)))))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-pgpr-reply-type (property-string)
+ "Return remailer reply block type from PROPERTY-STRING.
+The 'post' type is not checked, because it relates to Usenet
+and can be mixed with other types."
+ (if (string-match "cpunk\\|eric\\|penet" property-string)
+ (match-string 0 property-string)))
+
+;;; ----------------------------------------------------------------------
+;;; used to be: cpunk Request-Remailing-To
+;;; but nowadays instructions say "Anon-To"
+;;;
+(defun ti::mail-pgpr-block (mode &optional type email key latent)
+ "Return remailer header string defined by mode.
+be sure to have <> in the email, which defaults to `user-mail-address'.
+
+Input:
+
+ MODE 'epgp -- return encrypted pgp tag.
+ 'post -- return simple Newsgroup post block. 'email'
+ contains the address of post remailer.
+ If there is not enough
+ parameters, say for 'tk, the previous one is used: 't
+
+ TYPE cpunk Anon-To
+ eric Anon-Send-To
+ penet X-Anon-To
+ post Anon-Post-To Usenet
+
+ EMAIL Parameter for type
+ KEY Parameter for type
+ LATENT Parameter for type"
+ (let* ((reply
+ (cond
+ ((string= type "cpunk") "Anon-To")
+ ((string= type "eric") "Anon-To")
+ ((string= type "penet") "X-Anon-To")
+ ((string= type "post") "Anon-Post-To")
+ ((memq mode '(epgp post))) ;Ok; skip
+ ((error "Unknown type '%s'" type)))))
+ (setq email (or email user-mail-address))
+ (cond
+ ((equal mode 'epgp)
+ "::\nEncrypted: PGP\n\n")
+ ((equal mode 'post)
+ (concat
+ "::\n"
+ "Anon-Post-To: " (or email (error "invalid args.")) "\n"
+ "Cutmarks: --\n"))
+ ((and (stringp email) (stringp key) (stringp latent))
+ (format "::\n%s: %s\nEncrypt-Key: %s\nLatent-Time: %s\n"
+ reply email key latent))
+ ((and (stringp email) (stringp latent))
+ (format "::\n%s: %s\nLatent-Time: %s\n" reply email latent))
+ ((and (stringp email) (stringp key))
+ (format "::\n%s: %s\nEncrypt-Key: %s\n" reply email key))
+ ((or (stringp email))
+ (format "::\n%s: %s\n" reply email))
+ (t
+ (error "Wrong args '%s' '%s'" mode type )))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-pgpr-reply-block (pgp-email)
+ "Return reply block header.
+Should be inserted just before PGP crypted message to PGP-EMAIL."
+ (format "Reply-Block:\n::\nAnon-To: %s\n\n" pgp-email))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-pgpr-parse-levien-list (&optional buffer control-list)
+ "Parse remailer list finger <remailer-list@kiwi.cs.berkeley.edu>.
+The parsing starts from current point forward.
+
+Input:
+
+ BUFFER defaults to current buffer
+ CONTROL-LIST '(remailer-alias (prop-no-list) [(prop-add-list)])
+ This control list says 'if REGEXP matches the
+ email address, remove all properties listed in
+ prop-no-list and add all properties listed in
+ prop-add-list.
+
+ So, if you're sure that the levien-list has some
+ faulty entries, e.g. say remailer@replay.com doesn't
+ have feature 'ek' although levien list contains that,
+ your control-list is like this. The ek property
+ is removed even if the list says otherwise.
+
+ '(\"replay\" '(\"ek\"))
+
+Return:
+
+ '((alias remailer property_string (property property ...))
+ (alias remailer property_string (p p p ..)))
+
+ The properties are sorted: cpunk mix pgp..."
+ (let ((re (concat
+ "^[ \t]*$remailer{[\"']\\(.*\\)[\"']}.*=[ \t]*[\"']"
+ "<\\(.*\\)>[ \t]+\\(.*\\)[\"']"))
+ a
+ r
+ p
+ blocks
+ ret
+ elem
+ list)
+ ;; The list is in Perl hash array format in case you're interested...
+ (with-current-buffer (or buffer (current-buffer))
+ (while (re-search-forward re nil t)
+ (setq a (match-string 1)
+ r (match-string 2)
+ p (match-string 3))
+ (setq blocks (split-string p))
+ (setq blocks (sort blocks 'string<))
+ (when (and control-list
+ (setq elem (assoc a control-list)))
+ (setq list (nth 1 elem))
+ (dolist (elt list)
+ (setq blocks (delete elt blocks)))
+ (setq list (nth 2 elem))
+ (dolist (elt list) (push elt blocks))
+ ;; We used this now, remove from list
+ (setq control-list (delete elem control-list))
+ (setq p (mapconcat 'concat blocks " ")))
+ ;; features In alphabetic order
+ (setq p (mapconcat 'concat blocks " "))
+ (push (list a r p blocks) ret)))
+ ret))
+
+;;}}}
+
+;;{{{ email addresses
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-email-make-anti-spam-address (email)
+ "Make an anti-spam address from EMAIL."
+ (let* ((add [ "uce"
+ "ube"
+ "spam"
+ "commercials"
+ "advertisements"
+ "ads"
+ "junk"
+ "garbage"
+ ])
+ (base ["no"
+ "stop"
+ "die"
+ "hang"
+ "anti.address"
+ "yuck"
+ "dislike"
+ "go-away"
+ "stay-away"
+ "delete"
+ "nothanks"
+ "erase"
+ "zap-this"
+ "wipe-this"
+ "exterminate"
+ "ignore"
+ "bypass"
+ "keep-out"
+ "keep-away"
+ "none"
+ "nada"
+ "zero"
+ "not-any"
+ "zelt"
+ "no-thank-you"
+ "remove-this"
+ "rip-off-this"
+ "disregard"
+ "throw-away"
+ ])
+ (vec (vector
+ (concat
+ (elt (shuffle-vector base ) 1)
+ "-"
+ (elt (shuffle-vector add) 1))
+ (concat
+ (elt (shuffle-vector add) 1)
+ "-"
+ (elt (shuffle-vector base ) 1))))
+ (this (elt (shuffle-vector vec) 0))
+ login
+ domain)
+ (string-match "\\(.*\\)@\\(.*\\)" email)
+ (setq login (match-string 1 email)
+ domain (match-string 2 email))
+ (format "%s%s%s"
+ login
+ (if (zerop (randij 0 1))
+ (concat "." this "@")
+ (concat "@" this "."))
+ domain)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-email-domain (string)
+ "Return only the top level domain name from email STRING.
+xx.yy..domain.com --> domain.com
+xx.domain.co.uk --> domain.co.uk"
+ (cond
+ ;; This match tries to catch those domains that don't have 3 parts,
+ ;;
+ ;; aa.bb.co.uk
+ ;; |
+ ;; We expect this part to be longer than 2 characters
+
+ ((string-match "[^.][^.][^.]+\\.\\(..\\|...\\)$" string)
+ (match-string 0 string))
+ ;; This is domain that requires 3 parts: co.uk or au jp
+ ((string-match "[^.]+\\.[^.]+\\.\\(..\\|...\\)$" string)
+ (match-string 0 string))
+ ((string-match "[^@]+$" string)
+ (match-string 0 string))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-email-domain-canonilize (list)
+ "Canonilize list of addresses to top level domain names only
+Eg: '(\"aa.foo.com\" \"bb.foo.com\") --> '(\"foo.com\")"
+ (let* (ret
+ domain)
+ (dolist (elt list)
+ (setq domain (ti::mail-email-domain elt))
+ (add-to-list 'ret domain))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-email-find-region (&optional beg end no-dupes)
+ "Find all email addresses within region BEG END (defaults to buffer).
+The email addresses must contain @. Surrounding <> characters are removed.
+
+Input:
+
+ BEG region start; defaults to `point-min'
+ END region end; defaults to `point-min'
+ NO-DUPES flag; if non-nil then cache only unique entries."
+ (let (list
+ elt)
+ (save-excursion
+ (setq beg (or beg (point-min))
+ end (or end (point-max)))
+ (ti::keep-lower-order beg end)
+ (goto-char beg)
+ ;; Intangible text property case:
+ ;; - When you do a limited search and cursor land somewhere in
+ ;; intangible char, it immediately slides to next char
+ ;; position. Like if you'd do
+ ;;
+ ;; (progn (goto-char 10) (point))
+ ;; --> 20
+ ;;
+ ;; This is not suprise, if point 10 had intangible text until
+ ;; 19th pos. If there were no intangible text in point 10,
+ ;; the result would be expected 10.
+ (while (and (<= (point) end) ;; intangible test
+ (re-search-forward
+ "[^ '\",:<\t\n(]+@[^ '\">:,\t\n)]+"
+ end
+ t))
+ (setq elt (ti::remove-properties (match-string 0)))
+
+ (if (and (stringp elt)
+ (or (or (null no-dupes)
+ (not (member elt list)))))
+ (push elt list)))
+ list)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-email-from-string (string)
+ "Return list of email addresses from STRING.
+The addresses must have @ character. Surrounding <> characters are removed.
+If STRING is nil this function does nothing."
+ ;; Using buffer is faster that reading string
+ (when string
+ (with-temp-buffer
+ (insert string)
+ (ti::mail-email-find-region))))
+
+;;}}}
+;;{{{ parsing
+
+;;; ......................................................... &parsing ...
+
+;;; ----------------------------------------------------------------------
+;;; (ti::mail-test-parse-name)
+;;;
+(defun ti::mail-test-parse-name ()
+ "This is a test function, do not call from programs.
+
+Because the `ti::mail-parse-name' is quite complicated,
+and slightest modification may render it, this functions tests
+that the old functionality is preserved in spite of changes."
+ (let (list
+ e1
+ e2
+ stat
+ ptr)
+ (setq list
+ '("<jdoe@examole.com> (Finland, pgp id 512/47141D35)"
+ "(Rune Juntti[FRONTEC Pajala]) <jdoe@example.se>"
+ "shahramn@wv.mentorg.com (jdoe@example.com)"
+ "(jdoe@example.com)"
+ "Jerome Santini <doe@this-example.here.com>"
+ "jdoe@example.com (Harry Halladay - EDS St. Louis)"
+ "jdoe@example.com (Ake Stenhoff TM/PMD 83442 3003)"
+ "CEO-executive this here jdoe@example.com"
+ "JDOE <\"VAX::SOME@example.com\""
+ "\"VAX::LOGIN\"@example.com"
+ "john.doe@example.com"
+ "John=Doe%aoa.rdt%OS.DC@example.com"
+ "jdoe@example.com (John Doe)"
+ "\"/G=Name/S=Surname/OU=comlab/O=oxford/PRMD=UK.AC/ADMD= /C=GB/\"@example.fi\""
+ "\"wayne (w.d.) bell\" <jdoe@example>"
+ "John doe <example@example.com>"
+ "\"Joseph B. Ottinger\" <j.doe@example.com>"
+ "\"Name Foo puh. 111 600\" <LOGIN@example.com>"
+ "\"stephane (s.) boucher\" <jdoe@example.com>"
+ "jdoe@example.com (J.D \"John\" Doe)"
+ "jd@example-com (J.D doe)"
+ "doe@example.com \(John Doe\)"
+ "jdoe@example.com \(John D. Doe\)"
+ "\"J. doe Ph.d \" jdoe@john.doe.example.com"
+ "\"John D. Doe\" <foo@example.com>"))
+ (setq ptr list)
+ (dolist (n ptr)
+ (setq stat (ti::mail-parse-name n))
+ (setq e1 (nth 0 stat)) (setq e2 (nth 1 stat))
+ (read-from-minibuffer (concat "TEST>>" e1 "," e2 "<")))))
+
+;;; ----------------------------------------------------------------------
+;;; (ti::mail-t-parse-name)
+;;;
+(defun ti::mail-parse-name (line)
+ "Try to parse various formats of 'From:' fields.
+Supposes that the 'From:' keyword is removed from the LINE.
+
+Return:
+ list '(firstname surname)
+ nil if cannot parse both"
+ (let* ((re-A "[-a-zA-Z0-9.{|]")
+ (re-AG (concat "\\(" re-A "+\\)"))
+
+ ;; 'From: Mr-CEO John Doe <jdoe@example.com'
+ (fs-re2 (concat re-AG " +" re-AG))
+
+ ;; 'USER <\"CLUSTER::VAX\@site.cm\"'
+ (fs-vax (concat "^" re-AG "[ \t<\"]+[A-Z]+::" re-AG))
+
+ ;; '\"CLUSTER::LOGIN\"@example.com'
+ ;; This is incomplete Name, it does not contain NAMES at all, but
+ ;; we consider mail name as surname. The first group-RE is dummy.
+ (fs-vax2 (concat re-AG "::" re-AG))
+
+ ;; 'Job.Ganzevoort@cwi.nl', where person's name is complete
+ ;; address
+ (fs-fse (concat re-AG "\\." re-AG "@" ))
+
+ ;; matches gateway-type addresses
+ ;; 'Marla=Bush%aoa.rdt%OS.DC@Ban-Gate.AoA.DHHS.EDU'
+ (gtw-re1 (concat re-AG "=" re-AG "%" ))
+
+ (q-no-re ti:mail-parse-name-not-accept)
+
+ (mail (or (ti::mail-parse-email line) ""))
+ (account (if (= 2 (length mail))
+ (nth 0 mail)
+ "#@$@#$@#$")) ;just some dummy
+
+ fn
+ sn ;first, surname
+ pick
+ w
+ w1
+ w2
+ D ;debug
+ beg
+ end
+ beg1
+ end1
+ beg2
+ end2
+ tmp
+ list)
+
+ (if D
+ (setq D D)) ;XE 19.14 ByteComp silencer, no-op
+
+ (catch 'found
+
+ ;; It's most important that the match test are made IN THIS ORDER
+ ;; - Quote test cannot precede vax name test.
+ ;; - Try most restrictive first.
+
+ ;; ..............................................................
+ ;; VAX is identified by "::" marks
+
+ (when (string-match "::" line)
+ (setq list (ti::mail-get-2re fs-vax line))
+ (when (not (string= "" (nth 0 list)))
+ (setq D "vax1")
+ (throw 'found t))
+ (setq list (ti::mail-get-2re fs-vax2 line))
+ (when (not (string= "" (nth 0 list)))
+ (setq D "vax2")
+ (throw 'found t)))
+
+ ;; ............................................................
+ ;; Try gateway addresses, rare, but seen in net still
+
+ (when (string-match "%" line)
+ (setq list (ti::mail-get-2re gtw-re1 line))
+ (when (not (string= "" (nth 0 list)))
+ (setq D "gtw1")
+ (throw 'found t)))
+
+ ;; X.400 address
+
+ (when (string-match "/G=\\(.*\\)/S=\\([^/]+\\).*C=" line)
+ (setq fn (match-string 1 line)
+ sn (match-string 2 line))
+ (when (and fn sn)
+ (setq list (list fn sn) D "gateX400")
+ (throw 'found t)))
+
+ ;; .................................................................
+ ;; foo.bar@example.com
+
+ (when (string-match fs-fse line)
+ (setq list (ti::mail-get-2re fs-fse line))
+ (when (not (string= "" (nth 0 list)))
+ (setq D "mike.gordon")
+ (throw 'found t)))
+
+ ;; ............................................................
+ ;; And the rest , is there paren or "" somewhere ?
+ ;;
+
+ ;; If this is a full email string Joe@foo.com
+ ;; then get only the first part.
+
+ (when (and (setq tmp (ti::string-match "^\\([^ \t]+\\)[@%][^ \t]+$" 1 line))
+ (setq tmp (ti::string-match re-AG 1 tmp)))
+ (setq D "email")
+ (setq list (list tmp ""))
+ (throw 'found t))
+
+ ;; - if we get multiple match "stephane (s.) boucher" ,
+ ;; (L.G. \"Ted\" Stern) , pick the one that's longer.
+
+ (if (string-match "\"\\(.*\\)\"" line)
+ (setq beg1 (match-beginning 1) end1 (match-end 1)))
+
+ (if (string-match "[(]\\(.*\\)[)]" line)
+ (setq beg2 (match-beginning 1) end2 (match-end 1)))
+
+ (cond
+ ((and beg1 beg2)
+ (if (> (- end1 beg1) (- end2 beg2))
+ (setq beg beg1 end end1)
+ (setq beg beg2 end end2)))
+ (beg1
+ (setq beg beg1 end end1))
+ (beg2
+ (setq beg beg2 end end2)))
+
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ...
+
+ (cond
+ (beg
+ ;; - Get list of words into W
+ ;; - Someone wrote M. "Mack" Monroe, so the " is included
+ ;; in words separate list
+ ;; - The latter picks only NON-ABBREVIATED names, non-phones..
+ ;; M. "Mack" Monroe --> Mack Monroe
+ ;;
+
+ (setq pick (substring line beg end))
+ (setq w (split-string pick "[][@%. \"]+"))
+
+ (setq D "standard")
+;;; (ti::d! "w-1" w)
+
+ (let ((case-fold-search nil)) ;case is important !!
+ (setq w ;returned word list
+ (ti::list-find
+ w
+ q-no-re
+ (function
+ (lambda (arg elt)
+ (not (string-match arg elt))))
+ 'all-items)))
+
+;;; (ti::d! "w-2" w)
+
+ (cond
+ ((> (length w) 2) ;too much abbrev names
+ ;; pick first and account or last word
+
+;;; (setq W w AC account)
+
+ (setq w1 (nth 0 w) w2 (nth (1-(length w)) w) )
+
+ (setq tmp (ti::list-find
+ w account
+ (function
+ (lambda (arg elt)
+ (string-match elt arg)))))
+
+ (if tmp ;account name found
+ (setq w2 tmp))
+
+ (setq list (list w1 w2)))
+
+ ((= 2 (length w))
+ (setq w1 (nth 0 w) w2 (nth 1 w))
+ (setq list (list w1 w2)))
+
+ ((eq 1 (length w))
+ (setq list w))
+
+ (t
+ nil))
+
+ (if list
+ (throw 'found t))))
+
+ ;; .................................................................
+
+ (setq list (ti::mail-get-2re fs-re2 line))
+ (when (not (string= "" (nth 0 list)))
+ (setq D "2.1")
+ (throw 'found t))) ;; Catch end
+
+;;; (ti::d! "parsed" D list)
+
+ ;; what should we return ?
+ (if (and (string= (nth 0 list) "")
+ (string= (nth 1 list) ""))
+ nil
+ list)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-parse-email (line)
+ "Try to parse various formats of 'From:' field from LINE.
+Input is full LINE, possibly containing 'From' keyword.
+
+Return:
+
+ list '(usrname site)
+ nil if cannot parse."
+ (let* (account
+ site
+ tmp
+
+ ;; '.' is for firstname & surname combination
+ ;; '=' is for gateway form
+ ;; '|{' are scandinavian characters in name
+ ;; '+' Believe or not, but I just saw account name like
+ ;; "Stephen M. Lacy" <sl31+@andrew.cmu.edu>
+
+ (A "[-a-zA-Z|{0-9_=.+]+") ; alphabet
+ (As "[-a-zA-Z0-9.%]+") ; site name
+
+ ;; Note that username can have scandinavian {| marks
+ ;; Normal site name
+ ;; o Simon.Marshall@mail.bar.foo.fi (Simon Marshall)
+ (re1 (concat "\\(" A "\\)@\\(" As "\\)" ))
+
+ ;; Marla=Bush%aoa.rdt%OS.DC@Ban-Gate.AoA.DHHS.EDU
+ (re2 (concat "\\(" A "\\)\\(%" As "\\)" ))
+
+ ;; VAX address <"TNCLUS::TSYVANEN"@mailer.foo.fi>
+ (re-vax (concat "\\(\"" A "::" A "\"\\)@\\(" As "\\)" ))
+ em ; email
+
+ ;; "/G=Jamie/S=Lokier/OU=comlab/O=oxford/PRMD=UK.AC...
+ (re-x400
+ (concat "/G=\\([^/]+\\)/S=\\([^/]+\\)" ;fn sn
+ "/OU=\\([^/]+\\)/O=\\([^/]+\\)"
+ "/PRMD=\\([^/]+\\)")))
+ (catch 'found
+;;; (setq LINE line RE re-x400)
+
+ (if (null (string-match re-x400 line)) nil
+ (setq account (concat (match-string 1 line) "." (match-string 2 line)))
+ (setq site (concat (match-string 3 line) "." (match-string 4 line)))
+
+ ;; Now switch the last items PRMD=UK.AC --> ac.uk
+ (setq tmp (match-string 5 line))
+ (setq tmp (split-string tmp "[.]"))
+ (setq site (downcase (concat site "." (nth 1 tmp) "." (nth 0 tmp))))
+ (setq em (list account site))
+ (throw 'found t))
+
+ (setq em (ti::mail-get-2re re-x400 line))
+ (if (not (string= "" (nth 0 em))) (throw 'found t))
+
+ (setq em (ti::mail-get-2re re1 line))
+ (if (not (string= "" (nth 0 em))) (throw 'found t))
+
+ (setq em (ti::mail-get-2re re2 line))
+ (if (not (string= "" (nth 0 em))) (throw 'found t))
+
+ (setq em (ti::mail-get-2re re-vax line))
+ (if (not (string= "" (nth 0 em))) (throw 'found t)))
+
+ (if (< (length (nth 0 em)) 1)
+ (setq em nil))
+ em))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-parse-received-regexp-list ()
+ "Return list of regexps that match `Received:' header content.
+The Return ed list content is
+
+'((3 (re re re ..))
+ (2 (re re re ..))
+ (1 (re re re ..)))
+
+Where the number indicated how many submatches can be read. E.g. Number
+3 means, 3 submatches."
+ (let* ((from "[ \t]+from")
+ (spc "[ \t\r\n]*")
+ (spc+ "[ \t\r\n]+")
+ (W "[^][(){} \t\n]+") ;;word
+ (word (concat "\\(" W "\\)")) ;;capturing word
+ (S "[[({]+") ;;start
+ (E "[])}]+") ;;end
+
+ ;; mail.compuserve.com (mail.compuserve.com (209.5.81.86))
+ ;; mail.msss.v.com [atl.asd.com [234.454.54]]
+
+ (re-word31
+ (concat from
+ spc word
+ spc S spc word
+ spc S spc word spc
+ E))
+
+ ;; Received: from [209.151.131.35] (HELO mx04.hotmail.com)
+ ;; by elysium.ca (CommuniGate Pro SMTP 3.5)
+
+ (re-word32
+ (concat from
+ spc+ S word E ;; from [209.151.131.35]
+ spc+ S W spc+ word E ;; (HELO mx04.hotmail.com)
+ spc+ "by" spc+ word))
+
+ ;; from hdn86-021.hil.compuserve.com(206.175.97.21) by
+
+ (re-word2a
+ (concat from
+ spc word
+ spc S spc word
+ spc E))
+
+ ;; Propably faked received header?
+ ;;
+ ;; from usinet cziegle (1Cust144.tnt1.coeur-dalene.id.da.uu.net
+ ;; [208.254.107.144]) by ns.peace1.co.jp
+
+ (re-word2b
+ (concat from
+ "[^([{]+"
+ S spc word spc
+ S spc word spc
+ E))
+
+ ;; Received: from usa.net - 206.133.11.158 by
+ ;; ciudad.com.ar with Microsoft SMTPSVC; Mon, 2 Feb 1998 21:03:25
+
+ (re-word2c
+ (concat from
+ spc word spc+ "-"
+ spc+ word spc+ "by"))
+
+ ;; Received: from foo by relay1.UU.NET with SMTP
+ ;; (peer crosschecked as: 1Cust185.tnt10.nyc3.da.uu.net
+ ;; [153.37.131.185])
+
+ (re-word2d
+ (concat from
+ spc word spc "by"
+ spc word spc "with"))
+
+ ;; from [206.102.180.52] by springfield.k12.il.us with ESMTP
+
+ (re-word2e
+ (concat from
+ spc S word E spc "by"
+ spc word spc "with"))
+
+ ;; Received: by SERVER02 with Internet Mail Service (5.5.2650.21)
+ ;; id <FVLHVM1Q>; Thu, 28 Feb 2002 16:26:29 -0500
+
+ (re-word11
+ (concat spc+ "by" spc+ W spc+ "with" spc+ W spc+ W spc+ W
+ spc+ S word E))
+
+ ;; from papaguena.upc.es by rita.upc.es
+
+ (re-word12 (concat from spc word spc "by" )))
+ (list
+ (list 3 (list re-word31
+ re-word32))
+ (list 2 (list re-word2a
+ re-word2b
+ re-word2c
+ re-word2d
+ re-word2e))
+ (list 1 (list re-word11
+ re-word12)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-parse-received-line (regexp-list)
+ "Parse all `Received:' IPs from current line with REGEXP-LIST.
+The point must be placed just after the colon in header:
+
+ Received:-!-
+
+The -!- indicates the location of point."
+ (let* (candidates)
+ (catch 'done
+ (dolist (elt regexp-list)
+ (multiple-value-bind (submatch-max regexp-list)
+ elt
+ (dolist (regexp regexp-list)
+ (when (looking-at regexp)
+ (dotimes (count submatch-max) ;; starts counting from 0
+ (push (match-string (1+ count)) candidates))
+ ;; Regexp-list
+ (throw 'done t))))))
+ (nreverse candidates)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-parse-received-string-smtp (string)
+ "Parse SMTP field from 'Received:' STRING."
+ ;; from 111.npgco.com (HELO NAZ-AZPIRE1) (24.121.15.77)
+ (when (string-match
+ (concat
+ "\\<from[ \t\r\n]+[^ \t\r\n]+[ \t\r\n]+"
+ "(\\" ;; BEGIN
+ "([^()]+)" ;; First paren, required
+ "\\([ \t\r\n]+" ;; Second, optional
+ "([^()]+)\\)*"
+ "\\)") ;; END capture
+ string)
+ (let* ((str (match-string 1 string))
+ (list (list str))
+ ret)
+ (if (string-match " " str)
+ (setq list (split-string str)))
+ (dolist (elt list)
+ (push (replace-regexp-in-string "\\[\\|\\]\\|[()\r\n]" "" elt)
+ ret))
+ (nreverse ret))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::mail-parse-received-string-clean (string)
+ "Remove () and newlines from STRING."
+ (replace-regexp-in-string "[()\r\n]" "" string))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::mail-parse-received-string-from (string)
+ "Parse 'from' field from 'Received:' STRING."
+ (when (string-match "\\<from[ \t\r\n]+\\([^ \t\r\n]+\\)" string)
+ ;; from cm-24-121-15-77.flagstaff.az.npgco.com (HELO NAZ-AZPIRE1)
+ (match-string 1 string)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::mail-parse-received-string-by (string)
+ "Parse 'from' field from 'Received:' STRING."
+ (when (string-match "\\<by[ \t\r\n]+\\([^ \t\r\n]+\\)" string)
+ (match-string 1 string)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::mail-parse-received-string-smtp-id (string)
+ "Parse 'from' field from 'Received:' STRING."
+ (cond
+ ((string-match
+ "[ \t\r\n]+id[ \t\r\n]+\\([^ ;\t\r\n]+\\)" string)
+ (match-string 1 string))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::mail-parse-received-string-for (string)
+ "Parse 'from' field from 'Received:' STRING."
+ (when (string-match "\\<for[ \t\r\n]+\\([^ ;\t\r\n]+\\)" string)
+ (match-string 1 string)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::mail-parse-received-string-date (string)
+ "Parse 'from' field from 'Received:' STRING."
+ (when (string-match
+ "^.+;[ \t\r\n]+\\(.+[^ \t\r\n]\\)" string)
+ (match-string 1 string)))
+
+;;; ----------------------------------------------------------------------
+;;; (ti::mail-parse-date-string "Thu, 18 Jul 1996 12:18:06 -0600")
+;;; (ti::mail-parse-date-string "21 Aug 2003 20:41:15 -0000")
+(defun ti::mail-parse-date-string (date)
+ "Parse DATE notation.
+Recognized format are:
+
+ Thu, 18 Jul 1996 12:18:06 -0600
+ 21 Aug 2003 20:41:15 -0000
+
+The timezone value is optional.
+
+Returns alist;
+
+ '(weekday
+ dd
+ mon
+ mm ;; numeric string, like \"07\" for \"Jul\"
+ yyyy
+ HH
+ MM
+ SS
+ tz)"
+ (cond
+ ((string-match
+ (concat "^[ \t\r\n]*"
+ "\\([A-Z]..\\),?[ \t\r\n]+"
+ "\\([0-9]+\\)[ \t\r\n]+"
+ "\\([A-Z]..\\)[ \t\r\n]+"
+ "\\([0-9][0-9][0-9][0-9]\\)[ \t\r\n]+"
+ "\\([0-9][0-9]\\):"
+ "\\([0-9][0-9]\\):"
+ "\\([0-9][0-9]\\)"
+ "[ \t]*\\(.*\\)")
+ date)
+ (list
+ (match-string 1 date)
+ (format "%02d" (string-to-int (match-string 2 date)))
+ (match-string 3 date)
+ (format "%02d"
+ (ti::month-to-number (match-string 3 date)))
+ (match-string 4 date)
+ (match-string 5 date)
+ (match-string 6 date)
+ (match-string 7 date)
+ (match-string 8 date)))
+ ((string-match
+ (concat
+ "^[ \t\r\n]*"
+ "\\([0-9][0-9]?\\)[ \t\r\n]+"
+ "\\([A-Z]..\\)[ \t\r\n]+"
+ "\\([0-9][0-9][0-9][0-9]\\)[ \t\r\n]+"
+ "\\([0-9][0-9]\\):"
+ "\\([0-9][0-9]\\):"
+ "\\([0-9][0-9]\\)"
+ "[ \t]*\\(.*\\)")
+ date)
+ (list
+ nil
+ (match-string 1 date)
+ (match-string 2 date)
+ (format "%02d"
+ (ti::month-to-number (match-string 2 date)))
+ (match-string 3 date)
+ (match-string 4 date)
+ (match-string 5 date)
+ (match-string 6 date)
+ (match-string 7 date)))))
+
+;;; ----------------------------------------------------------------------
+;;; (ti::mail-parse-date-string-iso8601 "Thu, 18 Jul 1996 12:18:06 -0600")
+(defun ti::mail-parse-date-string-iso8601 (date &optional tz)
+ "Parse DATE. See supported values in `ti::mail-parse-date-string'.
+Return ISO 8601 date
+
+ YYYY-MM-DD HH:MM:SS
+
+If TZ is non-nil, add timezone information to the end."
+ (interactive)
+ (multiple-value-bind
+ (dd
+ mm
+ yyyy
+ HH
+ MM
+ SS
+ tzone)
+ (ti::mail-parse-date-string date)
+ (format "%s-%s-%s %s:%s:%s%s"
+ yyyy mm dd HH MM SS (if tzone
+ (or tz "")
+ ""))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-parse-received-string (string)
+ "Parse 'Received:' Header STRING.
+From this STRING
+
+ Received: from host1 (host2 [ww.xx.yy.zz]) by host3
+ (8.7.5/8.7.3) with SMTP id MAA04298; Thu, 18 Jul 1996 12:18:06 -0600
+
+Return list:
+
+ '((from . HOST1)
+ (smtp . (HOST2 ...))
+ (by . HOST3)
+ (smtp-id . ID)
+ (for . FOR)
+ (date . DATE))
+
+The `cdr' of a key may be nil if no value was found.
+
+References:
+
+ `ti::with-mail-received-heade'."
+ (list
+ (cons 'from (ti::mail-parse-received-string-from string))
+ (cons 'smtp (ti::mail-parse-received-string-smtp string))
+ (cons 'by (ti::mail-parse-received-string-by string))
+ (cons 'smtp-id (ti::mail-parse-received-string-smtp-id string))
+ (cons 'for (ti::mail-parse-received-string-for string))
+ (cons 'date (ti::mail-parse-received-string-date string))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-parse-received (&optional not-matching no-dupes)
+ "Search all 'Receive:' fields and read site names followed by 'from' 'by'.
+Duplicate entries are not added.
+
+Point must be at the beginning of headers to search, and
+point is advanced.
+
+It is possible to can this function to find out from where the mail
+originated and send complaint to postmasters of all those sites.
+
+Input:
+
+ NOT-MATCHING string, If read entry matches this regexp it is not included in
+ returned list
+ NO-DUPES flag, if non-nil then do not include duplicate addresses.
+
+Return:
+
+ '((IP IP IP) (IP IP) ..) as they appear in Received fields.
+
+Received headers explained:
+
+ Received: from host1 (host2 [ww.xx.yy.zz]) by host3
+ (8.7.5/8.7.3) with SMTP id MAA04298; Thu, 18 Jul 1996 12:18:06 -0600
+
+ This Shows four pieces of useful information (reading from back to front,
+ in order of decreasing reliability):
+
+ - The host that added the Received line (host3)
+ - The IP address of the incoming SMTP connection (ww.xx.yy.zz)
+ - The reverse-DNS lookup of that IP address (host2)
+ - The name of the sender used in the SMTP HELO command at the
+ time of connection.
+
+Real examples:
+
+Received: from mailhost.worldnet.att.net ([206.85.117.127])
+ by mtigwc02.worldnet.att.net (post.office MTA v2.0 0613 )
+ with SMTP id AAD8244; Sun, 23 Mar 1997 23:03:10 +0000
+Received: from mail.msss.v.com [atl.asd.com [234.454.54]]
+ by mediabrokers.cobracomm.com (8.8.5/8.6.5) with
+ SMTP id GAA07901 for <box17@mediabrokers.cobracomm.com>"
+ (let* ((regexp-list (ti::mail-parse-received-regexp-list))
+ ret
+ candidates
+ ip-elt
+ ip-all-list)
+
+ (while (re-search-forward "^Received:" nil t)
+ (setq ip-elt nil)
+ (setq candidates (ti::mail-parse-received-line regexp-list))
+
+ (dolist (elt candidates)
+ (when (and (stringp elt)
+ (string-match "\\." elt) ;;from PAPAGUENA, require dot(.)
+ ;; Is exclude in effect?
+ (or (null not-matching)
+ (not (string-match not-matching elt)))
+ (if no-dupes
+ (not (member elt ip-all-list))
+ t))
+ ;; 1) mailhost@inet.com --> inet.com
+ ;; 2) remove some garbage from string
+
+ (setq elt (replace-regexp-in-string ".*@" "" elt))
+ (setq elt (replace-regexp-in-string "[]()\n]" "" elt))
+
+;;; (ti::d! elt)
+
+ (if no-dupes
+ (push elt ip-all-list)) ;Needed for duplicate checking
+
+ (push elt ip-elt)))
+ (if ip-elt
+ (push ip-elt ret)))
+ (nreverse ret)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'ti::with-mail-received-header 'edebug-form-spec '(body))
+(put 'ti::with-mail-received-header 'lisp-indent-function 1)
+(defmacro ti::with-mail-received-header (string &rest body)
+ "With Mail 'received:' heading in STRING, run BODY.
+For this STRING
+
+ Received: from host1 (host2 [ww.xx.yy.zz]) by host3
+ (8.7.5/8.7.3) with SMTP id MAA04298; Thu, 18 Jul 1996 12:18:06 -0600
+
+The following access variables are available within BODY:
+
+ received-header-data
+ from => host1
+ smtp => '(host2 ww.xx.yy.zz)
+ smtp-id => MAA04298
+ by => host3
+ for => host1
+ date => Thu, 18 Jul 1996 12:18:06 -0600
+
+Note:
+
+ Any of the variables may be nil, if no value found.
+
+References:
+
+ See functions ti::mail-parse-received-string-*
+ and `ti::mail-parse-received-string'."
+ `(let ((received-header-data (ti::mail-parse-received-string ,string)))
+ (symbol-macrolet ((from (cdr (assq 'from received-header-data)))
+ (smtp (cdr (assq 'smtp received-header-data)))
+ (by (cdr (assq 'by received-header-data)))
+ (smtp-id (cdr (assq 'smtp-id received-header-data)))
+ (for (cdr (assq 'for received-header-data)))
+ (date (cdr (assq 'date received-header-data))))
+ ,@body)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-whois-parse-cleanup (string)
+ "Remove indentation and extra whitescape from STRING."
+ ;; Remove indentation
+ (ti::string-remove-whitespace
+ (replace-regexp-in-string
+ "[\r\n][ \t]+" "\n"
+ (replace-regexp-in-string "[ \t][ \t]+" " " string))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-whois-parse-paragraph (regexp &optional end-regexp)
+ "Whois: Parse pragraph for the first REGEXP to END-REGEXP.
+See `ti::mail-whois-parse'."
+ (when (re-search-forward regexp nil 'noerr)
+ (let ((beg (match-beginning 0)))
+ (if (null end-regexp)
+ (forward-paragraph)
+ (re-search-forward end-regexp)
+ (beginning-of-line))
+ (ti::mail-whois-parse-cleanup
+ (buffer-substring beg (1- (point)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-whois-parse-referral ()
+ "Parse referral if any. See `ti::mail-whois-parse'."
+ (let ((point (point)))
+ (cond
+ ((and (goto-char point)
+ (re-search-forward
+ ;; Found a referral to example.com
+ "^[ \t]*Found.*referral to \\([^ \t\r\n]+[a-z]\\)"
+ nil 'noerr))
+ (match-string 1))
+ ((and (goto-char point)
+ (re-search-forward
+ ;; Referral URL: http://example.com
+ "^[ \t]*referral[ \t]+URL:[ \]*\\([^ \t\r\n]+\\)"
+ nil 'noerr))
+ (match-string 1)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-whois-parse-email ()
+ "Whois: Parse unique email addresses from buffer.
+See `ti::mail-whois-parse'."
+ ;; mailto:abuse@foo.com
+ ;; trouble: Spam: <mailto:abuse@foo.com>
+ ;; changed: 20030912 <migration@foo.com>
+ (let ((kill-regexp
+ (concat
+ "E?-?mail:[ \t]*"
+ "\\|\\(mailto\\|changed\\|updated\\):"
+ "\\|\\<[0-9]+\\>"))<
+ line
+ email
+ desc
+ seen
+ ret)
+ (while (re-search-forward
+ (concat
+ "^[ \t]*.*[ ,;/\t]"
+ "\\([^/,;<> \t\r\n]+@[^/,;<> \t\r\n]+\\)")
+ nil 'noerr)
+ ;; There is only one email at a line
+ (setq email
+ (replace-regexp-in-string
+ "mailto:" ""
+ (match-string 1)))
+ (unless (member email seen)
+ (push email seen)
+ (setq line (ti::buffer-read-line))
+ ;; Remove that email from it
+ (when (setq desc (replace-regexp-in-string
+ (regexp-quote email) "" line))
+ (setq desc
+ (ti::string-remove-whitespace
+ (replace-regexp-in-string
+ "," " "
+ (replace-regexp-in-string
+ kill-regexp ""
+ (replace-regexp-in-string
+ "[ \t][ \t]+" " " desc))))))
+ (if (and desc
+ (ti::nil-p desc))
+ (setq desc nil))
+ (push
+ (list (if desc
+ (format "%s <%s>"
+ desc
+ email)
+ email)
+ email
+ desc)
+ ret)))
+ ;; preserve order
+ (nreverse ret)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::mail-whois-parse-paragraph-end-condition ()
+ "Whois parse. See `ti::mail-whois-parse'."
+ (concat
+ "^[ \t]*\\(.+:[ \t]*[\r\n]"
+ "\\|.*last update"
+ "\\|.*servers in listed order\\)"))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-whois-parse-registrant-1 ()
+ "See `ti::mail-whois-parse-registrant'."
+ (ti::mail-whois-parse-paragraph
+ "^[ \t]*Registra\\(r\\|nt\\):.*[\r\n]+[ \t]*"
+ (ti::mail-whois-parse-paragraph-end-condition)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-whois-parse-registrant-organization ()
+ "See `ti::mail-whois-parse-registrant'."
+ (ti::mail-whois-parse-paragraph
+ "^[ \t]*Organi[zs]ation:[ \t]*[\r\n]+[ \t]*"
+ (ti::mail-whois-parse-paragraph-end-condition)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-whois-parse-registrant-organization-2 ()
+ "See `ti::mail-whois-parse-registrant'."
+ ;; OrgName: AT&T WorldNet Services
+ ;; OrgID: ATTW
+ ;; Address: 400 Interpace Parkway
+ ;; City: Parsippany
+ ;; StateProv: NJ
+ ;; PostalCode: 07054
+ ;; Country: US
+ ;;
+ ;; ...
+ ;;
+ ;; # ARIN WHOIS database, last updated 2003-08-25 19:15
+ ;; # Enter ? for additional hints on searching ARIN's WHOIS database.
+ (ti::mail-whois-parse-paragraph
+ "^OrgName:.*[\r\n]OrgID:"
+ "^[ \t]*$"))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-whois-parse-registrant-domain ()
+ "See `ti::mail-whois-parse-registrant'."
+ ;; domain: AHA.RU
+ ;; type: CORPORATE
+ ;; descr: Mr. Postman BBS
+ ;; admin-o: ZENON-ORG-RIPN
+ ;; nserver: dns1.zenon.net.
+ ;; nserver: dns2.zenon.net.
+ ;; created: 1996.10.01
+ ;; state: Delegated till 2003.11.01
+ ;; changed: 1998.08.11
+ ;; mnt-by: ZENON-MNT-RIPN
+ ;; source: RIPN
+ (ti::mail-whois-parse-paragraph
+ (concat
+ "^domain:[ \t]+[a-z].*\\.[a-z0-9].+[ \t\r\n]"
+ ;;Licensee:
+ ;; Name: Belgacom Skynet DnsMasters
+ ;; Company: Belgacom Skynet SA/NV
+ "\\|^Licensee:[ \t]*$")
+ "^[ \t]*$"))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-whois-parse-registrant ()
+ "Whois: Parse registrant from buffer. See `ti::mail-whois-parse'."
+ (let ((point (point))
+ ret)
+ (flet ((search (func)
+ (goto-char point)
+ (funcall func)))
+ (dolist (func '(ti::mail-whois-parse-registrant-1
+ ti::mail-whois-parse-registrant-domain
+ ti::mail-whois-parse-registrant-organization
+ ti::mail-whois-parse-registrant-organization-2))
+ (when (setq ret (search func))
+ (return ret))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-whois-parse-tech ()
+ "Whois: Parse tech from buffer. See `ti::mail-whois-parse'."
+ (let ((point (point)))
+ (or (ti::mail-whois-parse-paragraph
+ "^[ \t]*.*Technical Contact.*:"
+ (ti::mail-whois-parse-paragraph-end-condition))
+ (cond
+ ((and (goto-char point)
+ (re-search-forward ":\\(.*tech.*@.*\\)" nil 'noerr))
+ (ti::mail-whois-parse-cleanup
+ (match-string 1)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-whois-parse-zone ()
+ "Whois: Parse zone from buffer. See `ti::mail-whois-parse'."
+ (let ((point (point)))
+ (or (ti::mail-whois-parse-paragraph
+ "^[ \t]*.*Zone Contact.*:"
+ (ti::mail-whois-parse-paragraph-end-condition))
+ (cond
+ ((and (goto-char point)
+ (re-search-forward ":\\(.*zone.*@.*\\)" nil 'noerr))
+ (ti::mail-whois-parse-cleanup
+ (match-string 1)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;; It the response is like this, there is no information
+;;; about the created, expires
+;;;
+;;; # ARIN WHOIS database, last updated 2003-08-25 19:15
+;;; # Enter ? for additional hints on searching ARIN's WHOIS database.
+;;;
+(defun ti::mail-whois-parse-records ()
+ "Whois: Parse records from buffer. See `ti::mail-whois-parse'.
+Values examined are: expires, created and updated."
+ (let* ((date-info
+ (list
+ ;; 10-Aug-1998
+ (list
+ (concat
+ "\\("
+ "\\([0-9][0-9]?\\)"
+ "-\\([A-Z][a-z][a-z]\\)"
+ "-\\([0-9][0-9][0-9][0-9]\\)"
+ "\\)")
+ ;; day month year
+ '(3 4 5))
+ ;; 10-08-1998
+ (list
+ (concat
+ "\\("
+ "\\([0-9][0-9]?\\)"
+ "-\\([0-9][0-9]?\\)"
+ "-\\([0-9][0-9][0-9][0-9]\\)"
+ "\\)")
+ '(3 4 5))
+ ;; Mon, Aug 10, 1998
+ (list
+ (concat
+ "\\("
+ "[A-Z][a-z][a-z],[ \t]*"
+ "\\([A-Z][a-z][a-z]\\)[ \t]+" ;; Mon
+ "\\([0-9]+\\)[ \t]*,[ \t]*" ;; day
+ "\\([0-9][0-9][0-9][0-9]\\)" ;; year
+ "\\)")
+ '(4 3 5))
+ (list
+ (concat
+ ;; 2003-08-25 19:15
+ "\\("
+ "\\([0-9][0-9][0-9][0-9]\\)"
+ "-\\([0-9][0-9]\\)"
+ "-\\([0-9][0-9]\\)"
+ "[ \t]+[0-9][0-9]:[0-9][0-9]"
+ "\\)")
+ '(5 4 3))
+ (list
+ (concat
+ ;; 1998.08.11
+ "\\("
+ "\\([0-9][0-9][0-9][0-9]\\)"
+ "[.]\\([0-9][0-9]\\)"
+ "[.]\\([0-9][0-9]\\)"
+ "\\)")
+ '(5 4 3))
+ (list
+ (concat
+ ;; changed: 20001107 15:03:09
+ ;; changed: registdom@tin.it 20030403
+ ;;
+ "\\(\\([0-9][0-9][0-9][0-9]\\)"
+ "\\([0-9][0-9]\\)"
+ "\\([0-9][0-9]\\)"
+ "\\)")))
+ '(5 4 3))
+
+ (search (list
+ (list
+ 'expires
+ (concat
+ "\\("
+ "^[ \t]*Record[ \t]+expires[ \t]+on[ \t]+"
+ "\\|^[ \t]*Expires[ \t]+on"
+ "\\|^expire:[^\r\n0-9]+"
+ "\\|^[ \t]*expiration date:[ \t]+"
+ "\\)"))
+ (list
+ 'created
+ (concat
+ "\\("
+ "^[ \t]*Record[ \t]+created[ \t]+on[ \t]+"
+ "\\|^[ \t]*Created[ \t]+on.*[ \t]+"
+ "\\|^created:[^\r\n0-9]+"
+ "\\|^[ \t]*creation date:[ \t]+"
+ "\\)"))
+ (list
+ 'updated
+ (concat
+ "\\("
+ "^.*last.*updated?[ \t]+on[ \t]+"
+ "\\|^[ \t]*updated date:[ \t]+"
+ "\\|^changed:[^\r\n0-9]+"
+ "\\)"))))
+ (beg (point))
+ ret)
+ (dolist (elt search)
+ (multiple-value-bind (type line)
+ elt
+ (dolist (date-data date-info)
+ (multiple-value-bind (regexp pos-list)
+ date-data
+ (setq regexp (concat line regexp))
+ ;; The order of the fields can be anything, start over
+ ;; every time from the same point
+ (goto-char beg)
+ (when (re-search-forward regexp nil 'noerr)
+ (multiple-value-bind (raw day month year)
+ (list
+ (match-string 2)
+ (match-string (nth 0 pos-list))
+ (match-string (nth 1 pos-list))
+ (match-string (nth 2 pos-list)))
+ (if (eq 3 (length month))
+ (setq month (ti::month-to-number
+ (capitalize month)
+ 'zero)))
+ (push (list
+ type
+ (list (format "%s-%s-%s" year month day)
+ raw))
+ ret))
+ (return))))))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-whois-parse-servers ()
+ "Whois: Parse servers from buffer. See `ti::mail-whois-parse'."
+ (when (re-search-forward "^[ \t]*Domain servers" nil t)
+ (forward-line 1)
+ (let ((beg (point))
+ (end (progn
+ (forward-paragraph)
+ (point))))
+ (let (ret)
+ (goto-char beg)
+ ;; Domain servers in listed order:
+ ;;
+ ;; NS1.GALLERYHOSTING.NET 209.19.90.117
+ ;; GHZ.DDAHL.COM 209.19.90.118
+ ;;
+ (while (re-search-forward
+ (concat
+ "^[ \t]+"
+ "\\([^ \t\r\n]+\\.[^ \t\r\n]+\\)"
+ "[ \t]+"
+ "\\([^ \t\r\n]+\\.[^ \t\r\n]+\\)")
+ end 'noerr)
+ (push (list (downcase (match-string 1))
+ (match-string 2))
+ ret))
+ ;; Domain servers in listed order:
+ ;;
+ ;; Name Server: ns1.dr-parkingservices.com
+ ;; Name Server: ns2.dr-parkingservices.com
+ ;;
+ (unless ret
+ (goto-char beg)
+ (while (re-search-forward
+ (concat
+ "^[ \t]+Name[ \t]+Server:"
+ "[ \t]+"
+ "\\([^ \t\r\n]+\\.[^ \t\r\n]+\\)")
+ end 'noerr)
+ (push (list (downcase (match-string 1)) nil)
+ ret)))
+ ret))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-whois-parse-admin ()
+ "Whois: Parse Administrative Contact from buffer.
+See `ti::mail-whois-parse'."
+ (let ((point (point)))
+ (cond
+ ((and (goto-char point)
+ (re-search-forward "^[ \t]*Administrative Contact:" nil 'noerr))
+ (forward-line 1)
+ (let ((beg (point)))
+ ;; Search "Technical Contact:"
+ (when (re-search-forward "^[ \t]*.+:[ \t]*$" nil 'noerr)
+ (ti::mail-whois-parse-cleanup
+ (buffer-substring
+ beg (1- (line-beginning-position)))))))
+ ((and (goto-char point)
+ (re-search-forward ":\\(.*admin.*@.*\\)" nil 'noerr))
+ (ti::mail-whois-parse-cleanup
+ (match-string 1))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-whois-error-p (string)
+ "Check if Whois call failed by examining STRING"
+ (not (string-match
+ (concat
+ "registra\\(nt\\|r\\):"
+ ;; domain: AHA.RU
+ ;; type: CORPORATE
+ ;; descr: Mr. Postman BBS
+ ;; admin-o: ZENON-ORG-RIPN
+ ;; nserver: dns1.zenon.net.
+ ;; nserver: dns2.zenon.net.
+ ;; created: 1996.10.01
+ ;; state: Delegated till 2003.11.01
+ ;; changed: 1998.08.11
+ ;; mnt-by: ZENON-MNT-RIPN
+ ;; source: RIPN
+ ;;
+ ;; domain: siemens.at
+ ;; descr: [organization]:Siemens AG
+ ;; descr: [street address]:Siemensstr. 92
+ ;;
+ "\\|^domain:[ \t]+[a-z].*\\..*[\n\r]"
+ "\\(type\\|descr\\):"
+ "\\|^address:.*[^ \t\r\n]"
+ ;;
+ "\\|^# ARIN WHOIS database")
+ string)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-whois-parse (string)
+ "Parse whois output STRING.
+
+Return:
+
+ '((email . ((ADDED EMAIL REST) ;; ADDED is \"REST <EMAIL>\"
+ ...))
+ (registrant . STRING)
+ (admin . STRING)
+ (tech . STRING)
+ (records . ((expires DATE-ISO RAW-DATE)
+ (created DATE-ISO RAW-DATE)
+ (updated DATE-ISO RAW-DATE))
+ (servers . ((host ip)
+ ...)))
+
+Note:
+
+ All the keys, like 'admin', are present in returned list, but any of the
+ `cdr' values or their components may be nil, if no value was found.
+
+ Do not relay in the order of these fields. They may change
+ any time. Instead access the list entry with `assq'.
+
+References:
+
+ See functions ti::mail-whois-parse-*
+ and macro `ti::with-mail-whois'."
+ (with-temp-buffer
+ (insert string)
+ (ti::buffer-text-properties-wipe)
+ (let* ((referral (progn (ti::pmin)
+ (ti::mail-whois-parse-referral)))
+ (email (progn (ti::pmin)
+ (ti::mail-whois-parse-email)))
+ (registrant (progn (ti::pmin)
+ (ti::mail-whois-parse-registrant)))
+ (admin (progn (ti::pmin)
+ (ti::mail-whois-parse-admin)))
+ (tech (progn (ti::pmin)
+ (ti::mail-whois-parse-tech)))
+ (zone (progn (ti::pmin)
+ (ti::mail-whois-parse-zone)))
+ (records (progn (ti::pmin)
+ (ti::mail-whois-parse-records)))
+ (servers (progn (ti::pmin)
+ (ti::mail-whois-parse-servers))))
+ (unless (and
+ registrant)
+ (error "TinyLibMail: Cannot parse Whois string %s" string))
+ (list
+ (cons 'referral referral)
+ (cons 'email email)
+ (cons 'registrant registrant)
+ (cons 'admin admin)
+ (cons 'tech tech)
+ (cons 'zone zone)
+ (cons 'records records)
+ (cons 'servers servers)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'ti::with-mail-whois 'edebug-form-spec '(body))
+(put 'ti::with-mail-whois 'lisp-indent-function 1)
+(defmacro ti::with-mail-whois (string &rest body)
+ "For full ´whois' output STRING run BODY.
+
+The following access variables are available within BODY. Any
+of the values may be nil.
+
+ email
+ admin Administrative Contact
+ tech Technical Contact
+ zone Zone Contact
+ records
+ servers Domain servers
+
+References:
+
+ `ti::mail-whois-parse'."
+ `(let ((whois-data (ti::mail-whois-parse ,string)))
+ (symbol-macrolet (
+ (referral (cdr (assq 'referral whois-data)))
+ (registrant (cdr (assq 'registrant whois-data)))
+ (email (cdr (assq 'email whois-data)))
+ (admin (cdr (assq 'admin whois-data)))
+ (tech (cdr (assq 'tech whois-data)))
+ (zone (cdr (assq 'zone whois-data)))
+ (records (cdr (assq 'records whois-data)))
+ (servers (cdr (assq 'servers whois-data))))
+ ,@body)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;; Registrant:
+;;; David L. Dahl (DDAHL-DOM)
+;;; PO BOX
+;;; Chicago, IL 60657
+;;; US
+;;;
+;;; Domain Name: DDAHL.COM
+;;;
+;;; Administrative Contact:
+;;; Dahl, David (DD4553) ddahl@DDAHL.COM
+;;; 3450 N. Lakeshore Dr. #2605
+;;; Chicago, IL 60657
+;;; US
+;;; 773-934-1738 fax: 847-746-8841
+;;; Technical Contact:
+;;; Network Solutions, Inc.(HOST-ORG) customerservice@networksolutions.com
+;;; 21355 Ridgetop Circle
+;;; Dulles, VA 20166
+;;; US
+;;; 1-888-642-9675 fax: 123 123 1234
+;;;
+;;; Record expires on 31-Mar-2005.
+;;; Record created on 18-Sep-2002.
+;;; Database last updated on 23-Aug-2003 04:47:44 EDT.
+;;;
+;;; Domain servers in listed order:
+;;;
+;;; NS1.GALLERYHOSTING.NET 209.19.90.117
+;;; GHZ.DDAHL.COM 209.19.90.118
+;;; WWW.CONDOSYSTEMS.COM 64.202.114.20
+;;;
+;;;
+(defun ti::mail-whois (site &optional options verb bin)
+ "Call `whois' and return results.
+Web interface is at http://www.internic.net/whois.html
+
+Input:
+
+ site Top level domain. Make sure you have called
+ ´ti::mail-ip-top-level-domain' first.
+ OPTIONS list, additional options. E.g. -h HOST
+ VERB flag, if non-nil print verbose messages. (Recommended)
+ BIN Location of the binary."
+ (let* ((path (or bin
+ (get 'ti::mail-whois 'binary)
+ (executable-find "whois")
+ (error "No `whois' binary found.")))
+ args)
+ (put 'ti::mail-whois 'binary path)
+ (when (and options
+ (not (ti::listp options)))
+ (error "OPTIONS must be a list."))
+ (when (string-match "\\.[0-9][0-9]?[0-9]?$\\|\\.[a-z][a-z][a-z]*$" site)
+ (setq args options)
+ (push site args)
+ (if verb
+ (message "TinylibMail: whois %s ..." site))
+ (with-temp-buffer
+ (apply 'call-process
+ path
+ nil ;; input
+ '(t t) ;; mix stdout and stderr
+ nil ;; display
+ args)
+ (if verb
+ (message "TinylibMail: whois %s ...done." site))
+ (buffer-string)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-nslookup-parse ()
+ "Parse nslookup output in current buffer forward.
+
+Buffer contains:
+
+ Non-authoritative answer:
+ Server: this.server.com
+ Address: nnnn.nnn.nnn.nnn
+
+ Name: NAME.ANSWER.COM
+ Addresses: NNN.NNN.NNN.NNN,NNN.NNN.NNN.NNN
+
+Return:
+
+'(NAME.ANSWER.COM (NNN.NNN.NNN.NNN NNN.NNN.NNN.NNN ..))."
+ (let* (name
+ ip-list
+ (re "[ \t]+\\([^ \t\r\n]+\\)")
+ (name-regexp (concat "name:" re))
+ (regexp1 (concat "address:" re))
+ (regexp2 "addresses:[ \t]+\\([^\r\n]+\\)"))
+ (when (re-search-forward "^[ \t]*$" nil t)
+ (forward-line 1)
+ (when (re-search-forward name-regexp nil t)
+ (setq name (match-string 1))
+ (cond
+ ((re-search-forward regexp1 nil t)
+ (setq ip-list (list (match-string 1))))
+ ((re-search-forward regexp2 nil t)
+ (let ((ip (match-string 1)))
+ (setq ip-list
+ (if (not (string-match "," ip))
+ (list ip)
+ (list (split-string ip "[ \t,]+")))))))))
+ (if ip-list
+ (list name ip-list))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;; % nslookup 204.253.213.3
+;;; Name Server: example.com
+;;; Address: 131.228.134.50
+;;;
+;;; Name: librum.sourcery.com
+;;; Address: 204.253.213.3
+;;;
+;;; Can also have string:
+;;;
+;;; *** No address information is available for "mktg@inet.com"
+;;;
+;;; NOTE: There may be "Addresses:"
+;;; =========================================================
+;;;
+;;; Server: ns3.tpo.fi
+;;; Address: 212.63.10.250
+;;;
+;;; Name: yahoo.com
+;;; Addresses: 216.115.109.6, 216.115.109.7
+;;;
+(defun ti::mail-nslookup (ip &optional options verb bin)
+ "Run `nslookup' for IP.
+
+Note:
+
+ If IP address does not match 2-3 alphabetic character or max 3 digits
+ at the end, then the address is not checked at all. It is immediately
+ discarded.
+
+Input:
+
+ IP numeric on normal site address.
+ OPTIONS list, additional options. E.g. -query=any
+ VERB flag, if non-nil print verbose messages. (Recommended)
+ BIN Location of the binary
+
+Return:
+
+ '(name . address)
+
+If nslookup fails, the return value is '(ORIG-IP nil)"
+ (let* ( ;; It's faster to use absolute pathname.
+ ;;
+ (path (or bin
+ (get 'ti::mail-nslookup 'binary)
+ (executable-find "nslookup")
+ (error "No `nslookup' binary found.")))
+ args)
+ (put 'ti::mail-nslookup 'binary path)
+ (when (and options
+ (not (ti::listp options)))
+ (error "OPTIONS must be a list."))
+ (with-temp-buffer
+ (when verb
+ (message "TinylibMail: nslookup %s ..." ip))
+ (when (string-match
+ "\\.[0-9][0-9]?[0-9]?$\\|\\.[a-z][a-z][a-z]*$" ip)
+ (setq args options)
+ (push ip args)
+ (apply 'call-process
+ path
+ nil ;; input
+ '(t t) ;; mix stdout and stderr
+ nil ;; display
+ args))
+ (when verb
+ (message "TinylibMail: nslookup %s ...done." ip))
+ (unless (ti::re-search-check "No address information")
+ (ti::pmin)
+ (ti::mail-nslookup-parse)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'ti::with-mail-nslookup 'edebug-form-spec '(body))
+(put 'ti::with-mail-nslookup 'lisp-indent-function 1)
+(defmacro ti::with-mail-nslookup (data &rest body)
+ "with resault of `ti::mail-nslookup' DATA '(ip (ip ...)) run BODY.
+The following variables are available during looping within BODY:
+
+ ip-name ip-found."
+ `(multiple-value-bind (ip-name ip-list)
+ (list
+ (car ,data)
+ (cdr ,data))
+ (dolist (ip-found ip-list)
+ ,@body)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-dig (ip &optional options verb bin)
+ "Run `dig' for IP.
+
+Note:
+
+ If IP address does not match 2-3 alphabetic character or max 3 digits
+ at the end, then the address is not checked at all. It is immediately
+ discarded.
+
+Input:
+
+ IP numeric on normal site address.
+ OPTIONS list, additional options. E.g. -query=any
+ VERB flag, if non-nil print verbose messages. (Recommended)
+ BIN Location of the binary
+
+Return:
+
+ '(name . address)
+
+If nslookup fails, the return value is '(ORIG-IP nil)"
+ (let* ( ;; It's faster to use absolute pathname.
+ ;;
+ (path (or bin
+ (get 'ti::mail-dig 'binary)
+ (executable-find "dig")
+ (error "No `nslookup' binary found.")))
+ args)
+ (put 'ti::mail-dig 'binary path)
+ (when (and options
+ (not (ti::listp options)))
+ (error "OPTIONS must be a list."))
+ (with-temp-buffer
+ (when verb
+ (message "TinylibMail: dig %s ..." ip))
+ (when (string-match
+ "\\.[0-9][0-9]?[0-9]?$\\|\\.[a-z][a-z][a-z]*$" ip)
+ (setq args options)
+ (push ip args)
+ (apply 'call-process
+ path
+ nil ;; input
+ '(t t) ;; mix stdout and stderr
+ nil ;; display
+ args))
+ (when verb
+ (message "TinylibMail: dig %s ...done." ip))
+ (buffer-string))))
+
+;;}}}
+;;{{{ misc
+
+;;; ............................................................ &misc ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-get-buffer (&optional mode-list)
+ "Return open mail buffer if one exists.
+MODE-LIST is the search order precedence. It can take values
+'mail-mode 'message-mode and any
+other valid mail like modes.
+
+Example:
+
+ ;; Return some mail-mode buffer. If there is none, then
+ ;; return some message-mode buffer.
+
+ (ti::mail-get-buffer '(mail-mode message-mode))"
+ (let* (list
+ buffer)
+ (or mode-list
+ (setq mode-list '(mail-mode message-mode mh-letter-mode)))
+ (dolist (buffer (buffer-list))
+ (with-current-buffer buffer
+ (dolist (mode mode-list)
+ (when (eq major-mode mode)
+
+ ;; We keep the separate mode in the plist
+ ;;
+ ;; LIST: plist 'MODE1 --> '(buffer buffer ...)
+ ;; : plist 'MODE2 --> '(buffer buffer ...)
+
+ (setq list (get 'list mode)) ;Read current list
+ (push (current-buffer) list) ;Add one
+ ;; And update plist
+ (put 'list mode list)))))
+
+ ;; Step through mode lists and return first buffer
+
+ (dolist (mode mode-list)
+ (when (setq buffer (car-safe (get 'list mode)))
+ (return)))
+ buffer))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-signature-insert-break (&optional point)
+ "Insert RFC signature break to current point or POINT if no sig break exist.
+According to RFC there must be \"-- \\n\" before signature. The extra space
+separates the signature from e.g. digest messages that come with \"--\\n\"
+
+We try to find this string forward and it is not there we add one."
+ (save-excursion
+ (if point (goto-char point))
+ (if (null (re-search-forward "^-- \n" nil t))
+ (insert "-- \n"))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-yank (&optional prefix)
+ "Yank message to current point and add optional PREFIX. GNUS/RMAIL."
+ (let* (p
+ (yb (ti::mail-mail-buffer-name)) ;where is the yank buffer ?
+
+ ;; See this mail is called from GNUS
+ ;;
+ ;; - If GNUS isn't loaded, set buf name to nil
+
+ (gnus-buf (and (boundp 'gnus-article-buffer)
+ (symbol-value 'gnus-article-buffer)))
+
+ ;; Test if gnus-reply; the buffers are the same
+
+ (gnus-r (and gnus-buf
+ (string= gnus-buf yb))))
+ (save-excursion
+ (setq p (point))
+
+ ;; (mail-yank-original '(4)) ; mimic C-u C-c C-y == no indent
+ ;; - bypass all, see sendmail::mail-yank-original
+ ;; this is more robust, and runs no extra hooks
+ ;; - If in GNUS, the buffer will be *Article*, which is
+ ;; narrowed to headers...widen the buffer before yanking.
+
+ (if (null gnus-r)
+ (progn ; normal mail
+ (mail-yank-original '(4)))
+ (save-excursion (set-buffer yb) (widen))
+ (insert-buffer yb))
+ (ti::pmax)
+ (delete-blank-lines)
+ (if prefix
+ (string-rectangle p (point-max) prefix)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-trim-buffer ()
+ "Trim email message so that there are no trailing white spaces.
+- at the beginning of message
+- at the end of each line
+- at the end of message.
+
+If cannot find text start point, uses `point-min'. The point is not preserved.
+
+Return:
+ t there is no text. All white spaces were removed
+ nil trimming done."
+ (let ((beg (ti::mail-text-start))
+ ret)
+ (goto-char beg)
+ (ti::buffer-replace-regexp "[ \t]+$" 0 "") ;right hand spaces (ragged lines)
+ (goto-char beg)
+
+ ;; Beginning of email message
+
+ (ti::buffer-trim-blanks beg (point-max))
+ (ti::buffer-delete-until-non-empty-line nil beg)
+
+ (ti::buffer-delete-until-non-empty-line 'backward (point-max))
+ (forward-line 1)
+
+ ;; Any text left ? Signing empty file is not sensible...
+
+ (if (eq (point) beg)
+ (setq ret t)
+ ;; Note: User may write message "123" to the body, but we must
+ ;; require final newline every time: "123\n", the trim
+ ;; command will remove any exeessive newlines.
+ (ti::pmax)
+ (if (not (char= (preceding-char) ?\n))
+ (insert "\n")))
+ ret))
+
+;;}}}
+
+;;{{{ fields, headers
+
+;;; .......................................................... &fields ...
+
+(defsubst ti::mail-field-space-count (field-name &optional field-value )
+ "Check how many spaces is at the beginning of field.
+Input:
+
+ FIELD-NAME If given, fetch FIELD-NAME like 'to' and check it's value.
+ FIELD-VALUE If given, use this string as field content. Argument
+ FIELD-NAME is ignored.
+
+Return
+
+ N Number of space."
+ (or field-value
+ (and (or (stringp field-name) (error "Missing field-name"))
+ (setq field-value (ti::mail-get-field field-name)))
+ (error "No field"))
+ (and field-value
+ (length (ti::string-match "^[^ ]*\\( +\\)" 1 field-value))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-field-start (field-re &optional move max)
+ "Return starting point of FIELD-RE or nil. Optionally MOVE to it.
+
+Supposes that field has following format, the cursor -!- position
+signifies returned point.
+
+ field:-!-
+
+Input:
+
+ FIELD-RE field regexp
+ MOVE should we move to found point? (beginning-of-line)
+ MAX search until MAX point"
+ (let (ret)
+ (save-excursion
+ (ti::pmin)
+ (when (re-search-forward field-re max t)
+ (beginning-of-line)
+ (when (re-search-forward ":" max t)
+ (setq ret (point)))))
+ (if (and move ret)
+ (goto-char ret))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-next-field-start (&optional move back max)
+ "Return starting point of next field or nil. Optionally move to field.
+
+Note:
+
+ If you're somewhere else than inside header area, the return value
+ is not defined.
+
+Input:
+
+ MOVE move to point
+ BACK move backward (field start)
+ MAX search until this point. PLEASE USE THIS TO LIMIT SEARCH
+
+Return:
+
+ point
+ nil"
+ (let ((func (if back 're-search-backward 're-search-forward))
+ opoint
+ point
+ ret)
+ (save-excursion
+ (if (null back)
+ (end-of-line))
+
+ (if (and (bobp) back) ;first field
+ (setq ret (point))
+
+ ;; Next line must have text, otherwise the headers have ended
+ ;; alredy
+ ;;
+ ;; Header1:
+ ;; Header2:
+ ;;
+ ;; BODY-OF-TEXT
+
+ (cond
+ ((save-excursion
+ (forward-line 1)
+ (looking-at ".*[a-zA-Z0-9]"))
+ (setq opoint (point))
+
+ ;; In the last field, the previsu regexp skips too much,
+ ;; see where the cursor (*) is. We search backward if possible
+ ;; to find header separator (empty line)
+ ;;
+ ;; Header:
+ ;; last header text
+ ;;
+ ;; *BODY
+
+ (when (progn
+ (when (and (setq point (funcall func "^[^ \t]" max t))
+ (eq func 're-search-forward))
+ (goto-char opoint) ;Try again
+ (if (re-search-forward "^$" nil t)
+ ;; no, it was further ahead, use previous search pos
+ (if (< (point) point)
+ (setq point (point)))))
+ point)
+ (goto-char point)
+ (beginning-of-line)
+ (setq ret (point))))
+ (t
+ ;; Hm, next line is empty line, not a field for us any more.
+ nil))))
+
+ (if (and move ret)
+ (goto-char ret))
+
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::mail-field-string-wrap (string)
+ "Wrap i.e. delete embedded newlines in string.
+
+X-My: one line
+ two line
+ three line.
+
+=>
+
+X-My: one line two line three line."
+ (replace-regexp-in-string "[\r\n][ \t]+" " " string))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::mail-field-string-p (string)
+ "Check if string starts with Field:
+Subexpression 1 contains field name and 2 contains rest."
+ (string-match "^\\([A-Z][^:]+\\):\\(.*\\)" string))
+
+;;; ----------------------------------------------------------------------
+;;; #todo:
+(defun ti::mail-field-line-p ()
+ "Return `field' name if the bginning of line contains 'NNNN:'."
+ (let ((str (buffer-substring
+ (line-beginning-position)
+ (line-end-position))))
+ (when (ti::mail-field-string-p str)
+ (match-string 1 str))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-field-read-line-at-point (&optional wrap)
+ "Read whole header field at point. Field may continue in separate line.
+Point -!- must be at the beginning line of field.
+
+X-More: this is one line-!-
+ That is wrapped to send
+ and even third.
+
+If WRAP is non-nil, call `ti::mail-field-string-wrap'."
+ (let ((beg (line-beginning-position))
+ (end (ti::mail-next-field-start)))
+ (when (and beg end)
+ (let ((line (buffer-substring beg (1- end))))
+ (if wrap
+ (ti::mail-field-string-wrap line)
+ line)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-field-read-fuzzy (&optional wrap)
+ "Read whole header field at point.
+The point can be anywhere in the field.
+If WRAP is non-nil, call `ti::mail-field-string-wrap'."
+ (save-excursion
+ (beginning-of-line)
+ (unless (ti::mail-field-line-p)
+ (ti::mail-next-field-start 'move 'back))
+ (ti::mail-field-read-line-at-point wrap)))
+
+;;; ----------------------------------------------------------------------
+;;; #todo:
+(defun ti::mail-current-field-name ()
+ "Return name of field at current point or nil."
+ (save-excursion
+ (when (or (not (bolp))
+ (and (bolp)
+ ;; Newly opened line - continuation of e.g. To: field.
+ (looking-at "^[ \t]*$")))
+ (ti::mail-next-field-start 'move 'back))
+ (ti::mail-field-line-p)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-field-email-send-p (&optional header-regexp)
+ "Check if point is at field To, Cc or Bcc"
+ (let ((field (ti::mail-current-field-name)))
+ (when (and field
+ (string-match
+ (or header-regexp
+ "^\\(to\\|cc\\|bcc\\)$")
+ field))
+ field)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-field-email-address-p ()
+ "Check if point is at field To, Cc, Bcc, From, Sender."
+ (ti::mail-field-email-send-p
+ "^\\(to\\|cc\\|bcc\\|from\\|sender\\)$"))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-kill-field-in-body (list)
+ "Kill LIST of field that are inserted into body of message."
+ (ti::narrow-safe (ti::mail-text-start) (point-max)
+ (dolist (header list)
+ (ti::mail-kill-field header))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-kill-field (field-re &optional replace-str)
+ "Delete header field. Remember to supply Anchor '^' in FIELD-RE.
+
+Input:
+
+ FIELD-RE any regexp matching a line
+ REPLACE-STR replace field content with this
+
+Return:
+
+ t field changed or killed
+ nil nothing done [field not exist]"
+ (let ((hdr-end (ti::mail-hmax))
+ beg
+ end)
+
+ (when hdr-end
+ (if replace-str
+ (setq replace-str (ti::string-verify-ends replace-str " " nil 'beg)))
+
+ (save-excursion
+ (when (and (setq beg (ti::mail-field-start field-re 'move))
+ (setq end (ti::mail-next-field-start))
+ (<= end hdr-end))
+;;; (setq F field-re B beg E end)
+ (if replace-str
+ (progn
+ (delete-region beg end)
+ (insert (concat replace-str "\n")))
+ (beginning-of-line)
+ (delete-region (point) end)
+ t))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-get-field-1 (field)
+ "Read FIELD by finding regexp matching '^FIELD:'.
+Starting searching from the beginning of buffer. You are encouraged to call
+this function instead of `ti::mail-get-field' if you want to get the
+field information fast e.g. in `post-command-hook'.
+
+This function is not as reliable as `ti::mail-get-field', because
+the search is not limited to header area, but for regular headers
+you can use this function safely."
+ (let ((re (format "^%s:" field))
+ beg
+ end)
+ (save-excursion
+ (ti::pmin)
+ (if (and (re-search-forward re nil t)
+ (setq beg (point)
+ end (ti::mail-next-field-start)))
+ (buffer-substring beg (1- end))))))
+
+;;; ----------------------------------------------------------------------
+;;; - This is almost the same as mail-utils.el/mail-fetch-field,
+;;; but offers more control. It can get citated fields too, if
+;;; ANY parameter is non-nil.
+;;; - And it returns _strict_ content of the field, fetch-field strips
+;;; spaces away.
+;;;
+(defun ti::mail-get-field (field &optional any mode)
+ "Return field content.
+
+Input:
+
+ FIELD field name without anchor '^' and char ':'
+ ANY return any field. When non-nil, drops anchor ^
+ from the ^field: criteria
+ MODE nil read the field as is, returning all chars
+ after the ':'
+ t If field has only spaces, Return nil
+ 'pure Include header name as well as content.
+
+Return:
+
+ nil or contents of field."
+ (let ((case-fold-search t) ;ignore case = t
+ (re (if any
+ (concat field ":") ; pick first one met
+ (concat "^" field ":"))) ; require STRICT HEADER
+
+ (hmax (if any nil (ti::mail-text-start)))
+ beg
+ end
+ ret)
+ (save-excursion
+ (when (and (setq beg (ti::mail-field-start re 'move hmax))
+ (setq end (ti::mail-next-field-start nil nil hmax)))
+ (when (and (eq mode 'pure)
+ (looking-at "[\t ]*[^\n\t ]+")) ;not empty
+ (beginning-of-line)
+ (setq beg (point)))
+ (setq ret (buffer-substring beg (1- end)))))
+ (when (and mode
+ (stringp ret)
+ (string-match "^[ \t\n\r]*\\'" ret))
+ (setq ret nil))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;; - If you want simple filed adding to your mail, then have a look
+;;; at this instead:
+;;;
+;;; (defconst my-mail-info-string "Emacs RMAIL in 19.28")
+;;; (setq mail-default-headers
+;;; (concat
+;;; "X-info: " my-mail-info-string "\n"))
+;;;
+(defun ti::mail-add-field (field text &optional look-field mode replace)
+ "Add FIELD and puts TEXT into it.
+If field already exist, replaces field text.
+By default, field is added to the end of header.
+
+Input:
+
+ FIELD string, like \"To\".
+ TEXT \\n at end is optional. _No_ colon and _no_ spaces.
+ LOOK-FIELD new field will be added after this. _No_ colon at end.
+ if MODE is non-nil, field is added before this field
+
+ If there is no LOOK-FIELD, nothing is done and nil
+ is returned.
+
+ MODE see look-field
+ REPLACE if non-nil Any previous field is removed. You probably
+ want to set this flag to non-nil if you only want unique
+ field names.
+
+Return:
+
+ t something done
+ nil nothing done, maybe look-field doesn't exist ?"
+ (let* ((field-re (concat "^" field ":")))
+ (save-excursion
+ (cond
+ (look-field
+ (if replace
+ (ti::mail-kill-field field-re)) ;Remove
+ (when (and look-field
+ (ti::mail-field-start (concat "^" look-field) 'move))
+ (unless mode ;use only forward
+ (ti::mail-next-field-start 'move mode))
+ (beginning-of-line)
+ (insert (concat field ": " text))
+ t))
+ (t ;add to the end
+ (if (mail-fetch-field field)
+ (ti::mail-kill-field field-re text)
+ (mail-position-on-field field)
+ (insert text))
+ t)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-add-to-field-string (field string &optional look-field sep )
+ "Find FIELD and add STRING to the. Field is created if it does not exist.
+
+Input:
+
+ FIELD string WITHOUT colon, anchor or spaces.
+ STRING added text
+ LOOK-FIELD field name. If Field does not exist, add field after this field.
+ See `ti::mail-add-field'
+ SEP defaults to comma and space."
+ (or sep
+ (setq sep ", "))
+
+ (save-excursion
+ (ti::pmin)
+ (let ((content (mail-fetch-field field)))
+ (if (ti::nil-p content)
+ (ti::mail-add-field field string look-field)
+ (re-search-forward (concat "^" field ":"))
+ (ti::mail-next-field-start 'move)
+ (skip-chars-backward " \n\t")
+ (insert sep string)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-kill-field-elt (re &optional field)
+ "Kill all elts matching RE from FIELD, which defaults to cc.
+Elements are supposed to be separated by commas.
+
+Example:
+
+ To: him@example.com
+ CC: me@example.com, you@example.com
+
+ ;; If called with this
+
+ (ti::mail-kill-field-elt \"me\")
+ --> To: him@example.com
+ --> CC: you@example.com
+
+ ;; If called with this; all elts are matched and thus the
+ ;; field is removed
+
+ (ti::mail-kill-field-elt \".\")
+ --> To: him@example.com"
+ (let* (flag
+ str
+ fld)
+ (setq field (or field "CC"))
+
+ (when (setq fld (ti::mail-get-field field))
+ ;; remove spread lines
+
+ (setq fld (replace-regexp-in-string "[\n\f\t ]+" "" fld))
+ (setq fld (split-string fld "[,]+")) ; divide into items
+
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... remove items . .
+
+ (setq fld
+ (ti::list-find fld re
+ (function
+ (lambda (arg elt)
+ (not (string-match arg elt))))
+ 'all-items))
+
+ ;; ... ... ... ... ... ... ... ... ... ... ... . build up string . .
+
+ (dolist (elt fld)
+ (if (null flag)
+ (setq flag t ;done 1st line
+ str (concat " " elt))
+ (setq str (concat
+ str ", " elt
+ (if (> (+ (length str) (length elt)) 70)
+ "\n " "")))))
+
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... write new fld . .
+ (if str
+ (ti::mail-kill-field (concat "^" field) str) ;replace
+ ;; Remove whole field, all entries were discarded.
+ ;;
+ (ti::mail-kill-field (concat "^" field))))))
+
+;;; ----------------------------------------------------------------------
+;;; - This is mainly for converting your mail to anon post by
+;;; removing any headers you might have added.
+;;;
+(defun ti::mail-kill-non-rfc-fields (&optional list)
+ "Kill all non RFC fields unless LIST (HEADER-NAME-SYMBOL .. ) list is given.
+
+References
+ `ti::mail-required-headers' ,default rfc headers"
+ (let ((ptr (or list
+ (ti::mail-required-headers)
+ (error "(ti::mail-required-headers) returned nil")))
+ (case-fold-search t)
+ fld
+ list)
+ ;; First we gather all valid headers to list
+ (dolist (elt ptr)
+ (setq fld (symbol-name elt))
+ (when (setq elt (ti::mail-get-field fld))
+ (ti::nconc list (format "%s:%s" (capitalize fld) elt))))
+ ;; Now we kill all headers and yank the valid ones back.
+ (ti::mail-hmax 'move)
+ (delete-region (point-min) (point))
+ (setq ptr list)
+ (dolist (elt ptr)
+ (insert elt "\n"))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-get-all-email-addresses
+ (&optional field-list abbrev-alist no-expand)
+ "Return all email addresses from FIELD-LIST.
+
+Input:
+
+ FIELD-LIST Eg. '(\"To\" \"CC\"). Default is To CC and BCC.
+ ABBREV-ALIST see function `ti::mail-abbrev-expand-mail-aliases'
+ NO-EXPAND if non-nil, Do not expand addresses on current buffer.
+
+Return:
+ '(str str ..) notice that there may be \"\" empty strings"
+ (let ((buffer (if no-expand
+ (generate-new-buffer "*tmp*")
+ (current-buffer)))
+ str
+ mems
+ field
+ ret)
+ (unwind-protect
+ (progn
+ (or field-list (setq field-list '("To" "CC" "BCC")))
+
+ (when no-expand
+ (dolist (fld field-list)
+ (setq str
+ (concat (or str "")
+ (ti::mail-get-field fld nil 'pure)
+ "\n"))))
+
+ (with-current-buffer buffer
+ (if str (insert str))
+
+ (ti::save-with-marker-macro
+ (ti::mail-abbrev-expand-mail-aliases
+ (point-min)
+ (if str
+ (point-max)
+ (ti::mail-hmax))
+ abbrev-alist))
+
+;;; (pop-to-buffer (current-buffer)) (ti::d! "MT:ABB" field-list)
+
+ (dolist (elt field-list)
+ (when (setq field (mail-fetch-field elt))
+ (setq mems (split-string field "[,\n]+")) ;members ?
+;;; (ti::d! elt field mems)
+ (dolist (mem mems)
+ (unless (ti::nil-p mem)
+ (push mem ret))))))) ;; with-current + progn
+ ;; make sure temp buffer is removed.
+
+ (if no-expand
+ (kill-buffer buffer)))
+ (nreverse ret)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-set-recipients (to-list &optional cc-list cc-flag)
+ "Compose current mail message to TO-LIST and add info about CC-LIST.
+
+Input:
+
+ TO-LIST List of real recipients.
+ CC-LIST List of additional recipients that are put to
+ X-Cc-Info. These are not actual CC members.
+ CC-FLAG Treat CC-LIST as actual recipients. This is like combining
+ TO-LIST and CC-LIST. No X-Cc-Info field is added."
+ (when cc-flag
+ (setq to-list (ti::list-merge-elements to-list cc-list)
+ cc-list nil))
+
+ (ti::mail-kill-field "^To")
+ (ti::mail-kill-field "^CC")
+ (ti::mail-kill-field "^X-Cc-Info")
+
+ (ti::mail-add-field "To" (pop to-list))
+ (when to-list
+ (ti::mail-add-field "Cc" (mapconcat 'concat to-list ",")))
+
+ (when cc-list
+ (ti::mail-add-field
+ "X-Cc-Info"
+ (concat "Additional recipient(s)\n "
+ (mapconcat 'concat cc-list ",")))))
+
+;;}}}
+;;{{{ News, articles
+
+;;; ............................................................ &News ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-news-buffer-p ()
+ "Check if current buffer is news post, followup or the like."
+ (interactive)
+ (cond
+ ((and (eq major-mode 'message-mode) (fboundp 'message-news-p))
+ (ti::funcall 'message-news-p))
+ ((and (eq major-mode 'message-mode) (boundp 'message-this-is-news))
+ (symbol-value 'message-this-is-news))
+ ((string-match "news" (symbol-name major-mode)))
+ (t
+ ;; Gnus keeps it in 'message-mode', so search this header then
+ (save-excursion
+ (ti::pmin)
+ (re-search-forward "Newsgroups\\|References:\\|Gcc:" nil t)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-article-regexp-read-line (re &optional level)
+ "Switch to article buffer; match RE at LEVEL and return match."
+ (let (line)
+ (or level
+ (setq level (or level 0)))
+ (ti::mail-with-article-buffer
+ (ti::pmin)
+ (if (re-search-forward re nil t)
+ (setq line (match-string level))))
+ line))
+
+;;; ----------------------------------------------------------------------
+;;; - This is useful if you use same hook for both
+;;; regular mail posting AND for gnuis posting.
+;;; - It makes it possible to decicede inside hook, which post
+;;; type this is. Eg. setting extra headers for NEWS and not
+;;; different for regular Mail
+;;;
+(defun ti::mail-news-reply-p ()
+ "Return type of message being composed.
+This function is meaningful _only_ when you use it inside
+some GNUS or mail hook. The buffer must be current mail buffer.
+
+Return:
+ 'news news
+ nil"
+ (let* ((mode (symbol-name major-mode))
+
+ ;; GNUS might not be loaded in this emacs
+ (gnus-buf (if (boundp 'gnus-article-buffer)
+ ;; normally name is "Article"
+ (symbol-value 'gnus-article-buffer)
+ ""))
+
+ (mail-buf (ti::mail-mail-buffer-name)) ;YANK buffer name?
+
+ ;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ GNUS
+ ;; - Detect news posting mode. The mail program uses
+ ;; YANK from the gnus buffer "*Article*" So we can detect
+ ;; if this is gnus post
+ ;; - gnus 'news-mail-reply-->rnewspost.el
+
+ (gnus (string= gnus-buf mail-buf))
+
+ (news-mode (or gnus
+ (string-match "news" mode)
+ (save-excursion ;Gnus
+ (ti::pmin)
+ (re-search-forward "^References:" nil t)))))
+ (if news-mode
+ 'news)))
+
+;;}}}
+;;{{{ anon.penet.fi anon-nymserver.com
+
+;;; ............................................................ &anon ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-anon-penet-p (email)
+ "Check if EMAIL is penet anon address."
+ (string-match "[an][an][0-9]+@.*penet.fi" email))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-anon-penet-to-p ()
+ "Check if the TO: field contain anon.penet.fi address.
+
+Return:
+ nil
+ email if it's anon address."
+ (let ((to (ti::mail-get-field "to")))
+ (if (and to (ti::mail-anon-penet-p to))
+ to nil)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-nymserver-email-convert (email &optional na-mode)
+ "Convert penet EMAIL address.
+
+If NA-MODE is nil: do 'an' conversion
+ anXXX@example.com --> anXXX
+ naXXX@example.com --> anXXX
+ VANITY@example.com --> VANITY@example.com
+ VANITY.an@example.com --> VANITY@example.com
+ VANITY.na@example.com --> VANITY@example.com
+
+If NA-MODE is non-nil:
+ Then do opposite 'na' conversion"
+ (cond
+ (na-mode
+ (if (string-match "\\(an\\)[0-9]+@\\|\\.\\(an\\)@" email)
+ (setq email (ti::replace-match 1 "na" email))
+ ;; the email is VANITY@example.com
+ (if (string-match "\\(.*\\)\\(@.*\\)" email)
+ (setq email (concat
+ (match-string 1 email) ".na"
+ (match-string 2 email))))))
+ (t
+ (cond
+ ((string-match "\\(na\\)[0-9]+@" email)
+ (setq email (ti::replace-match 1 "an" email)))
+ ((string-match "\\(\\.na\\)@" email)
+ (setq email (ti::replace-match 1 "" email))))))
+ email)
+
+;;}}}
+;;{{{ mime
+
+;;; ............................................................ &mime ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::mail-mime-tm-featurep-p ()
+ "TM. Check if MIME is loaded."
+ (and (featurep 'mime-setup)
+ (not (featurep 'semi-setup))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::mail-mime-semi-featurep-p ()
+ "SEMI. Check if MIME is loaded."
+ (featurep 'semi-setup))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::mail-mime-feature-p ()
+ "MIME. Check if TM/ or SEMI is available."
+ (or (ti::mail-mime-tm-featurep-p)
+ (ti::mail-mime-semi-featurep-p)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::mail-mime-tm-edit-p ()
+ "TM. Check if mime edit is active."
+ (and (boundp 'mime/editor-mode-flag)
+ (symbol-value 'mime/editor-mode-flag)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::mail-mime-semi-edit-p ()
+ "SEMI. Check if mime edit is active."
+ (and (boundp 'mime-edit-mode-flag)
+ (symbol-value 'mime-edit-mode-flag)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'ti::mail-mime-tm-edit-mode-macro 'lisp-indent-function 0)
+(put 'ti::mail-mime-tm-edit-mode-macro 'edebug-form-spec '(body))
+(defmacro ti::mail-mime-tm-edit-mode-macro (&rest body)
+ "TM. Run body If mime edit mode is active in current buffer."
+ (`
+ (when (and (ti::mail-mime-tm-featurep-p) (ti::mail-mime-tm-edit-p))
+ (,@ body))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'ti::mail-mime-semi-edit-mode-macro 'lisp-indent-function 0)
+(put 'ti::mail-mime-semi-edit-mode-macro 'edebug-form-spec '(body))
+(defmacro ti::mail-mime-semi-edit-mode-macro (&rest body)
+ "SEMI. Run body If mime edit mode is active in current buffer."
+ (`
+ (when (and (ti::mail-mime-semi-featurep-p) (ti::mail-mime-semi-edit-p))
+ (,@ body))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'ti::mail-mime-funcall-0-macro 'lisp-indent-function 1)
+(put 'ti::mail-mime-funcall-0-macro 'edebug-form-spec '(body))
+(defmacro ti::mail-mime-funcall-0-macro (func-tm func-semi)
+ "Call function FUNC-TM or FUNC-SEMI with no arguments."
+ (`
+ (cond
+ ((and (ti::mail-mime-tm-featurep-p) (ti::mail-mime-tm-edit-p))
+ (ti::funcall (, func-tm))
+ t)
+ ((and (ti::mail-mime-semi-featurep-p) (ti::mail-mime-semi-edit-p))
+ (ti::funcall (, func-semi))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'ti::mail-mime-funcall-2-macro 'lisp-indent-function 3)
+(put 'ti::mail-mime-funcall-2-macro 'edebug-form-spec '(body))
+(defmacro ti::mail-mime-funcall-2-macro (func-tm func-semi arg1 arg2)
+ "Call function FUNC-TM or FUNC-SEMI with ARG1 ARG2."
+ (`
+ (cond
+ ((and (ti::mail-mime-tm-featurep-p) (ti::mail-mime-tm-edit-p))
+ (ti::funcall (, func-tm) (, arg1) (, arg2))
+ t)
+ ((and (ti::mail-mime-semi-featurep-p) (ti::mail-mime-semi-edit-p))
+ (ti::funcall (, func-semi) (, arg1) (, arg2))
+ t))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-mime-turn-on-mode ()
+ "Turn on MIME mode. Do nothing if mime is not available.
+Return t if mime was supported."
+ (interactive)
+ (cond
+ ((ti::mail-mime-tm-featurep-p)
+ (unless (ti::mail-mime-tm-edit-p)
+ (ti::funcall 'mime/editor-mode))
+ t)
+ ((ti::mail-mime-semi-featurep-p)
+ (unless (ti::mail-mime-semi-edit-p)
+ (ti::funcall 'mime-edit-mode))
+ t)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-mime-turn-off-mode ()
+ "Turn off MIME mode. Do nothing if mime is not available.
+Return t if mime was supported."
+ (interactive)
+ (cond
+ ((ti::mail-mime-tm-featurep-p)
+ (when (ti::mail-mime-tm-edit-p)
+ (ti::funcall 'mime-editor/exit))
+ t)
+ ((ti::mail-mime-semi-featurep-p)
+ (when (ti::mail-mime-semi-edit-p)
+ (ti::funcall 'mime-edit-exit))
+ t)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-mime-sign-region (&optional beg end)
+ "MIME. Enclose region BEG END as signed.
+Input:
+
+BEG Defaults to mail beginning or buffer beginning.
+END Defualts to `point-max'
+
+Return:
+
+nil if mime is not available.
+"
+ (interactive)
+ (ti::mail-set-region beg end)
+ (ti::mail-mime-funcall-2-macro
+ 'mime-editor/enclose-signed-region
+ 'mime-edit-enclose-pgp-signed-region
+ beg
+ end))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-mime-encrypt-region (&optional beg end)
+ "MIME. Enclose region BEG END as encrypted
+Input:
+
+BEG Defaults to mail beginning or buffer beginning.
+END Defualts to `point-max'
+
+Return:
+
+nil if mime is not available.
+"
+ (interactive)
+ (ti::mail-set-region beg end)
+ (ti::mail-mime-funcall-2-macro
+ 'mime-editor/enclose-encrypted-region
+ 'mime-edit-enclose-pgp-encrypted-region
+ beg
+ end))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'ti::mail-mime-tm-split-macro 'lisp-indent-function 0)
+(put 'ti::mail-mime-tm-split-macro 'edebug-form-spec '(body))
+(defmacro ti::mail-mime-tm-split-macro (&rest body)
+ "TM. Define variables `split' `max' `parts' and run BODY if TM active.
+You have to use variables `max' and `parts' otherwise you don't need this macro."
+ (`
+ (when (boundp 'mime-editor/split-message)
+ (let* ((split (symbol-value 'mime-editor/split-message))
+ (max (symbol-value 'mime-editor/message-default-max-lines))
+ (lines (count-lines (point-min) (point-max)))
+ (parts (1+ (/ lines max))))
+ (if (null split)
+ (setq split nil)) ; No-op Bytecomp silencer
+ (,@ body)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-mime-maybe-p ()
+ "Check if buffer possibly contain MIME sections.
+if there is boundary string in header or if the TM -mime tags
+'-[[' are found from buffer, then it's considered mime."
+ (or (ti::mail-mime-p)
+ (save-excursion
+ (cond
+ ((featurep 'tm-edit) ;TM.el
+ ;; TM puth these markes to MIME section; Try to find one.
+ ;; This can be only found if the mimi-edit mode is not
+ ;; yet exited. Upon exit the message will match true
+ ;; MIME (ti::mail-mime-p).
+ (ti::re-search-check (concat "^" (regexp-quote "--[["))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-mime-p ()
+ "Check if buffer has mime message. You probably want `ti::mail-mime-maybe-p'.
+It must contain boundary field in the headers and the boundary
+must be found from the message body itself.
+Only the header is not enough to say it's a composed mime mail.
+
+Content-Type: ...
+ boundary=\"Multipart_Thu_Sep_19_12:46:36_1996-1\"
+ ^^^^^^^^^
+
+This text must be found after the headers until the MIME criteria is
+satisfied."
+ (interactive)
+ (let ((field (ti::mail-get-field "Content-Type" 'any))
+ re)
+ (when (and field
+ ;; Content-Type field may not include "boundary"
+ ;; --> it's not multipart mime.
+ (setq re (ti::string-match ".*boundary=.\\(.*\\)\"" 1 field)))
+ (setq re (regexp-quote re))
+ ;; start finding the boundary text after the headers.
+ (save-excursion
+ (ti::pmin) (re-search-forward re) ;This is the header, ignore it
+ (forward-line 1)
+ (re-search-forward re nil t)))))
+
+;;; ----------------------------------------------------------------------
+;;; #todo: not tested
+;;;
+(defun ti::mail-mime-qp-decode(from to)
+ "Mime. Decode quoted-printable from region between FROM and TO."
+ (save-excursion
+ (goto-char from)
+ (while (search-forward "=" to t)
+ (cond ((char= (following-char) ?\n)
+ (delete-char -1)
+ (delete-char 1))
+ ((looking-at "[0-9A-F][0-9A-F]")
+ (delete-char -1)
+ (insert (hexl-hex-string-to-integer
+ (buffer-substring (point) (+ 2 (point)))))
+ (delete-char 2))
+ ((message "Malformed MIME quoted-printable message"))))))
+
+;;; ----------------------------------------------------------------------
+;;; (add-hook 'vm-select-message-hook 'ti::mail-mime-prepare-qp)
+;;;
+(defun ti::mail-qp-mime-prepare ()
+ "Mime. Unquote quoted-printable from mail buffers.
+Searches for tag:
+
+content-transfer-encoding: quoted-printable"
+ (interactive)
+ (save-excursion
+ (let ((case-fold-search t)
+ (type (mail-fetch-field "content-transfer-encoding"))
+ buffer-read-only)
+ (cond
+ ((and (stringp type)
+ (string-match "quoted-printable" type))
+ (ti::pmin)
+
+ (search-forward "\n\n" nil 'move)
+ (message "MIME Unquoting printable...")
+ (ti::mail-mime-qp-decode (point) (point-max))
+ (message "MIME Unquoting printable...done"))))))
+
+;;}}}
+
+;;{{{ Mail sending
+
+;;; .................................................... &mail-sending ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-plugged-p ()
+ "Check if computer is on-line. This function relies on Gnus."
+ (when (boundp 'gnus-plugged)
+ (symbol-value 'gnus-plugged)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-sendmail-reset-send-hooks ()
+ "Make `mail-send-hook' et al. buffer local and set to nil."
+ (dolist (sym '(mail-send-hook
+ message-send-hook
+ mh-before-send-letter-hook))
+ (when (boundp sym)
+ (make-local-hook sym)
+ (set sym nil))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'ti::mail-sendmail-pure-env-macro 'lisp-indent-function 0)
+(put 'ti::mail-sendmail-pure-env-macro 'edebug-form-spec '(body))
+(defmacro ti::mail-sendmail-pure-env-macro (&rest body)
+ "Reset all mail/message hooks/vars locally to nil and run BODY."
+ (`
+ (let* (message-setup-hook
+ message-mode-hook
+ mail-mode-hook
+ mail-setup-hook
+ mail-archive-file-name
+ mail-default-headers
+ mail-default-reply-to)
+ ;; byteComp silencer: "Not used variables."
+ (if mail-mode-hook (setq mail-mode-hook nil))
+ (if mail-setup-hook (setq mail-setup-hook nil))
+ (if mail-archive-file-name (setq mail-archive-file-name nil))
+ (if mail-default-headers (setq mail-default-headers nil))
+ (if mail-default-reply-to (setq mail-default-reply-to nil))
+ (,@ body))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'ti::mail-sendmail-macro-1 'lisp-indent-function 3)
+(put 'ti::mail-sendmail-macro-1 'edebug-form-spec '(body))
+(defmacro ti::mail-sendmail-macro-1 (to subject send &rest body)
+ "See `ti::mail-sendmail-macro' instead. This is low level function."
+ (`
+ (progn
+ (ti::mail-sendmail-pure-env-macro
+ ;; to subject in-reply-to cc replybuffer actions
+ ;;
+ (mail-setup (, to) (, subject) nil nil nil nil)
+ (mail-mode)
+ (ti::mail-kill-field "^fcc")
+ (ti::mail-text-start 'move)
+ (,@ body)
+ (ti::pmin)
+ (ti::kill-buffer-safe " sendmail temp") ;See sendmail-send-it
+ (when (, send)
+ (mail-send-and-exit nil))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'ti::mail-sendmail-macro 'lisp-indent-function 3)
+(put 'ti::mail-sendmail-macro 'edebug-form-spec '(body))
+(defmacro ti::mail-sendmail-macro (to subject send &rest body)
+ "Send / construct mail according to parameters.
+Use TO, SUBJECT and If SEND if non-nil, send mail after BODY finishes.
+
+Point is at the beginning of body.
+
+Note:
+
+ `mail-mode-hook' `mail-setup-hook' `mail-archive-file-name'
+ `mail-default-headers'
+
+ are set to nil. If you need these, please copy them before calling this
+ macro and restore their values in BODY, possibly calling
+ and using them as sendmail normally would.
+
+ The hooks are set to nil so that mail buffer is created fast and
+ that nothing causes trouble when mail buffer is ready."
+ (`
+ (let* ((BuffeR (ti::temp-buffer ti:mail-mail-buffer 'clear)))
+ (save-window-excursion
+ (with-current-buffer BuffeR
+ (ti::mail-sendmail-macro-1
+ (, to)
+ (, subject)
+ (, send)
+ (,@ body)))))))
+
+;;}}}
+
+;;{{{ Abbrevs: XEmacs and Emacs
+
+;;; ......................................................... &abbrevs ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-abbrev-table ()
+ "XEmacs and Emacs Compatibility, Return mail abbrev hash table."
+ (ti::package-require-mail-abbrevs)
+ (cond
+ ((ti::emacs-p)
+
+ (if mail-abbrevs
+ (ti::funcall 'mail-abbrevs-setup))
+
+ (or mail-abbrevs
+ (progn
+ (build-mail-aliases)
+ mail-abbrevs)
+ mail-aliases))
+ (t
+ ;; in Emacs this is a list, in XEmacs this is a HASH
+ (or mail-aliases
+ (progn
+ (condition-case err
+ (build-mail-aliases)
+ (error
+ ;; See mail-abbrev.el
+ (when (get-buffer "mailrc")
+ (pop-to-buffer (get-buffer "mailrc")))
+ (error err)))
+ mail-aliases)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-abbrev-expand-mail-aliases (beg end &optional alias-alist)
+ "Expand aliases in region BEG END.
+Please Cache results from `ti::mail-abbrev-get-alist' and
+use the result as argument ALIAS-ALIST. Otherwise aliases are always
+reuild from scratch."
+ (interactive "*r")
+ (let* (mb
+ me
+ word
+ exp)
+ (cond
+ ((and (require 'mailalias nil 'noerr) ;Emacs Feature only
+ (fboundp 'expand-mail-aliases))
+ (ti::funcall 'expand-mail-aliases beg end))
+
+ (t ;Too bad, this is much slower
+ (unless alias-alist
+ (setq alias-alist (ti::mail-abbrev-get-alist)))
+
+ (save-restriction
+ (narrow-to-region beg end) (ti::pmin)
+ (while (re-search-forward
+ "^[ \t]+\\|^[ \t]*[\n,][ \t]*\\|:[ \t]*" nil t)
+ (when (setq word (ti::buffer-match"[^ \t,\n]+" 0))
+
+ (setq mb (match-beginning 0)
+ me (match-end 0))
+
+ ;; Do not count field names, like "CC:" words
+ (when (and (not (string-match ":$" word))
+ ;; Is this abbrev ?
+ (setq exp (assoc word alias-alist)))
+ (setq exp (cdr exp)) ; Change alias to expansion
+ (delete-region mb me)
+ (insert exp)
+
+ ;; This isn't very smart formatting, the layout
+ ;; is so that each expansion is on it's own line,
+ ;; no fancy lining up things -- Mail me back
+ ;; with diff to this code if you code nicer one.
+
+ (when (looking-at "[ \t]*,") ;put on separate lines
+ (goto-char (match-end 0))
+ (when (not (looking-at "[ \t]*$"))
+ (insert "\n\t")
+ (beginning-of-line)))))))))))
+
+;;; ----------------------------------------------------------------------
+;;; See mailabbrev.el how to build your abbrevs.
+;;;
+(defun ti::mail-abbrev-get-alist (&optional expand-until)
+ "Return alist of all `mail-abbrevs'.
+Build the abbrev table from your ~/.mailrc with command
+\\[build-mail-abbrevs]. The following parameter is _not_ yet functional.
+
+Input:
+ EXPAND-UNTIL expand until the RH elt is pure email.
+
+Return:
+ '((ABBREV-STRING . EXPANDED-STRING) (A . E) ..)"
+ (let* (
+ (pre-abbrev-expand-hook nil) ;; prevent recursion
+ (mail-abbrev-aliases-need-to-be-resolved t)
+ table
+ exp-list
+ elt)
+
+ ;; XEmacs 19.14 no-op for ByteCompiler
+
+ (unless mail-abbrev-aliases-need-to-be-resolved
+ (setq mail-abbrev-aliases-need-to-be-resolved nil))
+
+ (setq table (ti::mail-abbrev-table))
+
+ (cond
+ ((listp table) ;; mail-aliases is already in (A . S) form
+ (setq exp-list table))
+ (t ;Vector
+ ;; We have to expand abbrevs by hand because XEmacs doesn't
+ ;; parse them like emacs mail-alias
+
+ (when table
+ (let ((tmp (generate-new-buffer "*ti::mail-abbrev*")))
+ (with-current-buffer tmp
+ (setq local-abbrev-table table)
+
+ (mapatoms
+ (function
+ (lambda (x)
+ (setq elt (prin1-to-string (identity x)))
+ (when (not (string= "0" elt)) ;abbrev in this slot?
+ (insert elt)
+ (end-of-line)
+
+ ;; 2000-09-03
+ ;; BBDB does some voodoo with the abbrevs by
+ ;; setting the function cell, and sometimes calling
+ ;; expand-abbrev by BBDB blessed abbrev gives error.
+ ;; --> Don't bother with the error, since the
+ ;; abbrevs is correctly expanded, but BBDB cries about
+ ;; "wrong marker" or something.
+
+ (condition-case err
+ (expand-abbrev)
+ (error
+ (message
+ (concat
+ "tinylibmail: `expand-abbrev' signalled ERROR `%s'"
+ " while expanding `%s'")
+ (prin1-to-string err)
+ elt)))
+ (push (cons (symbol-name x) (ti::read-current-line)) exp-list)
+ (end-of-line)
+ (insert "\n"))))
+ table))
+ (kill-buffer tmp))))) ;; cond
+ exp-list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::mail-mail-abbrevs-email-list (&optional abbrev-alist)
+ "Build email list of abbrevs; optionally use ABBREV-ALIST.
+Only entries in this format in ~/.mailrc are returned. There must be
+no \",\" chained lists in the line.
+
+ alias[spaces]some[spaces]user@address.xx
+
+Input:
+
+ '((\"abbrev\" . \"expansion\") (A . E) ..)
+
+Return:
+
+ '(email email ...)"
+ (let* (str
+ email
+ list)
+ (dolist (elt
+ (or abbrev-alist (ti::mail-abbrev-get-alist)))
+ (setq str (cdr elt))
+ (when (null (string-match "," str)) ;filter out multiple mail lists
+ (setq email (ti::string-match "\\([^< \t]+@[^> \t\n]+\\)" 0 str))
+ (if email
+ (push str list))))
+ ;; retain order
+ (nreverse list)))
+
+;;}}}
+
+;;{{{ provide
+
+(provide 'tinylibmail)
+(run-hooks 'ti:mail-load-hook)
+
+;;}}}
+
+;;; tinylibmail.el ends here
--- /dev/null
+;;; tinylibmenu.el --- Library for echo-area menu
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 1996-2007 Jari Aalto
+;; Keywords: extensions
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program, call M-x ti::menu-version.
+;; Look at the code with folding.el
+
+;; COPYRIGHT NOTICE
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;; ....................................................... &t-install ...
+;; Put this file on your Emacs-Lisp load path, add following into your
+;; ~/.emacs startup file
+;;
+;; (require 'tinylibmenu)
+;;
+;; Or use autoload, which is prefered. Your ~/.emacs loads faster
+;;
+;; (autoload 'ti::menu-menu-default "tinylibmenu" "" t)
+;;
+;; To bring up the menu (or menus), bind the main function into some key.
+;; This s only a demonstration. Configure your own menus using the
+;; example in this file.
+;;
+;; (global-set-key "\C-cM" 'ti::menu-menu-default)
+;;
+;; Make sure you have defined the variables `my-menu1' and `my-menu2'
+;; which hold the menu information.
+;;
+;; If you have any questions, use this function to contact author
+;;
+;; M-x ti::menu-submit-bug-report
+
+;;}}}
+;;{{{ docs
+
+;;; Commentary:
+
+;; Overview of features
+;;
+;; o This package is a library.
+;; Store key bindings behind echo area menu, which is similar to
+;; menu bar.
+;; o Regular Emacs user can also put less used binding to guided
+;; echo menu by just defining couple of menu variables.
+;;
+;; Customizing menus
+;;
+;; If some package defines echo area menus and you only want to make
+;; small modifications and not to copy the whole 'defvar MENU' to your
+;; .emacs, you can use following functions to manipulate the menu
+;; items
+;;
+;; ti::menu-add
+;; ti::menu-set-doc-string
+;;
+;; For example, if there is menu item:
+;;
+;; (defconst my-menu-sample
+;; '("?)help, 1)test1, 2)test2"
+;; ((?1 . ( (some-menu-test1 1 2 3)))
+;; (?2 . ( (some-menu-test2 1 2 3))))))
+;;
+;; and you don't like keybinding '?2'. You first delete the menu item,
+;; then add yours and lastly you update the doc string that is printed
+;; in echo area. Here is how you do all these three steps.
+;;
+;; (ti::menu-add 'my-menu-sample ?2 nil 'delete)
+;; (ti::menu-add 'my-menu-sample ?t '( (my-test 1 2 3)))
+;; (ti::menu-set-doc-string 'my-menu-sample
+;; "?)help, 1)test1, t)myTest")
+;;
+;; And the modified menu looks like this
+;;
+;; (defconst my-menu-sample
+;; '("?)help, 1)test1, t)myTest"
+;; ((?1 . ( (some-menu-test1 1 2 3)))
+;; (?t . ( (my-test2 1 2 3))))))
+;;
+;; If you want to replace _many_ commands from the menu, it is lot
+;; easier if you copy the menu `defvar' and make direct changes there.
+;; If you want to make it all with lisp, here is example which
+;; replaces 2 items from the menu
+;;
+;; (mapcar
+;; '(lambda (x)
+;; (let ((key (car x)))
+;; (ti::menu-add
+;; 'ti::menu-:menu-sample nil 'delete) ;; Remove old
+;; ;; Add new
+;; (ti::menu-add 'ti::menu-:menu-sample key (cdr x))))
+;; '((?1 . ( (my-1 1 2 3))) ;; New menu item replacements
+;; (?2 . ( (my-2 1 2 3)))))
+;;
+;; (ti::menu-set-doc-string
+;; 'ti::menu-:menu-sample "?)help, 1)my1 2)my2")
+;;
+;; Having a test run
+;;
+;; The easiest way to get a hold on the echo menu is that you try it.
+;; Follow these steps. Then you're ready to make your own menus.
+;;
+;; . Load this file. M-x load-library tinylibmenu.el
+;; . Start menu with `M-x' `ti::menu-menu-default'
+;; . Press key `?' or `h' to get help and `q' to quit menu.
+;; . Try offered choices
+
+;;; Change Log:
+
+;;; Code:
+
+;;}}}
+;;{{{ setup: require
+
+(eval-when-compile
+ (autoload 'ignore-errors "cl-macs" nil 'macro))
+
+;;}}}
+;;{{{ setup: variables
+
+(defvar ti::menu-:load-hook nil
+ "*Hook that is run when package has been loaded.")
+
+(defvar ti::menu-:prefix-arg nil
+ "Prefix arg when menu is called.")
+
+;; This is just an example, not a user variable.
+;; This is how you use the package
+;; NOTE: put the help into the documentation string. Like
+;; in variable ti::menu-:menu-mode.
+
+(defconst ti::menu-:menu-sample
+ '("?)help, 1)test1, 2)test2, m)ode, u)ndefined , e)val. q)uit"
+ ((?1 . ( (ti::menu-test1 1 2 3))) ;this does not have FLAG
+ (?2 . (t (ti::menu-test2))) ;FLAG used.
+ (?m . ti::menu-:menu-mode)
+ (?u . ti::menu-:menu-not-exist) ;this variable does not exist :-)
+ (?e . (t (progn
+ (message "menu item evaled. Pfx: '%s' "
+ (prin1-to-string ti::menu-:prefix-arg))
+ (sleep-for 1))))))
+ "*This is documentation string of variable `ti::menu-:menu-sample'.
+The menu help is put here.
+
+Reserved menu keys (characters)
+
+ `q' and `Q' are reserved for quitting the menu prompt.
+ `?' anf `h' are reserved for help.
+
+Menu structure is as follows
+
+ FLAG is optional. If non-nil, menu should be shown after
+ function has completed. If FLAG is missing, the menu is not displayed
+ after the function call. (that is: call function and exit menu)
+
+ The DISPLAYED-MENU-STRING is evaled, so it can contain any lisp expression
+ yielding a string.
+
+ Below you see 3 different ways to define one menu element.
+
+ (defconst my-meny
+ '(
+ DISPLAYED-MENU-STRING
+ ((CHARACTER-KEY . ANOTHER-MENU-VARIABLE-SYMBOL)
+ (CHARACTER-KEY . ([FLAG] (FUNCTION-NAME PARAMETER PARAMETER...)))
+ (CHARACTER-KEY . ([FLAG] (FORM-TO-EVAL)))
+ ..))
+ \" MENU HELP RESIDES IN THE DOCUMENTATION STRING\")")
+
+;; This is just an example how you could utilize the prefix arguments.
+;;
+;;(defconst ti::menu-:menu-mail
+;; '((if current-prefix-arg
+;; "View mailbox read-only: E)macs M)ailbox P)erl R)ead/write"
+;; "View mailbox: E)macs M)ailbox P)erl R)ead-only")
+;; ((?e . ( (vm-visit-folder "~/mail/emacs" current-prefix-arg)))
+;; (?m . ( (call-interactively 'vm)))
+;; (?p . ( (vm-visit-folder "~/mail/perl" current-prefix-arg)))
+;; (?r . (t(setq current-prefix-arg (if current-prefix-arg nil '(4)))))
+;; ))
+;; "Select a mailbox to visit")
+
+;; This is just an example, not a user variable.
+
+(defconst ti::menu-:menu-mode
+ '("Press ?/ cC)++ l)isp tT)ext f)undamental p)icture F0ill O)font"
+ ((?c . ( (c-mode)))
+ (?C . ( (cc-mode)))
+ (?l . ( (lisp-mode)))
+ (?t . ( (text-mode)))
+ (?T . ( (indented-text-mode)))
+ (?f . ( (fundamental-mode)))
+ (?p . ( (picture-mode)))
+ (?F . (t (auto-fill-mode)))
+ (?O . (t (font-lock-mode)))
+ (?/ . ti::menu-:menu-sample))) ;back to ROOT menu
+ "*Menu help.
+Major modes:
+
+ c = turn on `c-mode'
+ C = turn on C++ mode
+ l = turn on lisp mode
+ t = turn on text mode
+ T = turn on indented text mode
+ f = turn on fundamental mode
+ p = turn on picture mode
+
+Minor modes:
+
+ F = turn on auto fill mode
+ O = turn on f(o)nt lock mode
+
+Special keys
+ / = Return to root menu")
+
+(defvar ti::menu-:menu 'ti::menu-:menu-sample
+ "*Variable holding the default root menu.")
+
+;;}}}
+
+;;; ########################################################### &Funcs ###
+
+;;{{{ code: test funcs
+
+(defun ti::menu-test1 (&optional arg1 arg2 arg3)
+ "Sample Menu test function with ARG1 ARG2 ARG3."
+ (message (format "function 1 called with args: %s %s %s" arg1 arg2 arg3)))
+
+(defun ti::menu-test2 ()
+ "Sample Menu test function."
+ (message (format "function 2 called"))
+ (sleep-for 1))
+
+;;}}}
+;;{{{ menu item add, delete
+
+;;; ------------------------------------------------------------- &add ---
+;;;
+;;;###autoload
+(defun ti::menu-add (menu-symbol ch cell &optional delete)
+ "Add to menu MENU-SYMBOL elt (CH . CELL). Optionally DELETE.
+
+Example:
+
+ (ti::menu-add 'ti::menu-:menu-sample ?2 nil 'delete)
+ (ti::menu-add 'ti::menu-:menu-sample ?t '( (my-test 1 2 3)))
+
+Return:
+
+ nil no add done due to existing CELL
+ no remove due to non-existing CELL"
+ (let* ((menu (symbol-value menu-symbol))
+ (doc (nth 0 menu))
+ (list (nth 1 menu))
+ elt
+ ret)
+ (setq elt (assq ch list))
+ (cond
+ (delete
+ (when elt
+ (setq ret elt)
+ (setq list (delete elt list))
+ (set menu-symbol (list doc list))))
+ ((and (null delete)
+ (not elt)) ;not already exist?
+ (setq ret (cons ch cell))
+ (push ret list)
+ (set menu-symbol (list doc list))))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun ti::menu-set-doc-string (menu-symbol doc-string)
+ "Use MENU-SYMBOL and set its DOC-STRING.
+
+Example:
+
+ (ti::menu-set-doc-string 'ti::menu-:menu-sample \"?=help, 1=test1, t=myTest\")"
+ (let* ((menu (symbol-value menu-symbol)))
+ ;; It's better to check that the arg is right; setcar won't
+ ;; do that
+ (if (not (stringp doc-string))
+ (error "timu: need string."))
+ (setcar menu doc-string)
+ (set menu-symbol menu)))
+
+;;}}}
+
+;;{{{ code: menu
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::menu-read-char-exclusive (msg)
+ "Aa `read-char-exclusive', but for Emacs and XEmacs. Display MSG."
+ (if (fboundp 'read-char-exclusive)
+ (cond
+ ((featurep 'xemacs)
+ (message msg)
+ (read-char-exclusive))
+ (t
+ (read-char-exclusive msg)))
+ (read-char msg)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::menu-help-output (variable-symbol)
+ "Write doctring, ie Menu help, to the *Help* buffer"
+ (with-output-to-temp-buffer "*Help*"
+ (princ
+ (documentation-property
+ variable-symbol
+ 'variable-documentation))))
+
+;;; ----------------------------------------------------------------------
+;;; - This is only simple help. You can't resize the window etc...
+;;;
+(defun ti::menu-help (menu-sym)
+ "Show menu help of MENU-SYM.
+MENU-SYM can variable symbol, whose documentaion is displayed or
+a function symbol.
+
+The help commands are:
+ n or space = next
+ p or del = previous
+ q = end help"
+ (let* ((msg "Help: space or n = next, backspace or p = prev, q = quit")
+ (oframe (selected-frame))
+ (buffer "*help*")
+ (docs (or (documentation-property
+ menu-sym 'variable-documentation)
+ (and (fboundp menu-sym)
+ (documentation menu-sym))))
+ step
+ ch)
+ (cond
+ ((stringp docs)
+ (unwind-protect ;make sure the help buffer is deleted
+ (save-excursion
+ (save-window-excursion
+ ;; We have to save the source window config above
+ ;; Be sure this frame is non-dedicated.
+ (if (window-dedicated-p (selected-window))
+ (raise-frame
+ (select-frame
+ (car (delq
+ (window-frame
+ (get-buffer-window (current-buffer)))
+ (frame-list))))))
+ ;; now we may be in another frame; save it's configuration
+ ;; too
+ (save-window-excursion
+ (with-output-to-temp-buffer buffer (princ docs))
+ (select-window (get-buffer-window buffer))
+ ;; This is simplest way to resize help window
+ (balance-windows)
+ (setq step (1- (window-height)))
+ ;; Now scroll the help
+ (while (not
+ (member
+ (setq ch (char-to-string
+ (ti::menu-read-char-exclusive msg)))
+ '("q" "\e")))
+ (cond
+ ;; 127 = backspace in windowed
+ ;;
+ ((member ch '("p" "P" "\177" "\b"))
+ (ignore-errors (scroll-down step)))
+
+ ((member ch '("n" "N" " "))
+ (ignore-errors (scroll-up step))))))))
+ (if (and (not (null oframe))
+ (framep oframe))
+ (if (framep (setq oframe (raise-frame oframe)))
+ (select-frame oframe)))
+ (kill-buffer buffer)))
+ (t
+ (message "Sorry, no help defined.")
+ (sleep-for 1)
+ (message "")))
+ (discard-input)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun ti::menu-menu (menu-symbol &optional pfx-arg)
+ "The menu navigation engine.
+
+Input:
+
+ MENU-SYMBOL variable symbol containing menu items
+ PFX-ARG the prefix arg user ppossibly passed to menu
+
+References:
+
+ `ti::menu-:menu-sample' Show how the menu is constructed.
+ `ti::menu-:prefix-arg' Copy of current prefix arg"
+ (let* ((var menu-symbol)
+ (m (eval var)) ;menu content
+ (loop t)
+ (current-prefix-arg pfx-arg) ;set for menu functions
+ prompt flag
+ alist
+ ch
+ elt
+ eval-form)
+ (setq ti::menu-:prefix-arg pfx-arg)
+ (while loop
+ (setq prompt (eval (nth 0 m))
+ prompt (and prompt
+ (replace-regexp-in-string "\r" "" prompt))
+ alist (nth 1 m))
+ (when (or (not (stringp prompt))
+ (not (string-match "[^ \t\r\n]" prompt)))
+ (error "Menu structure error; no prompt: %s" m))
+ ;; moving the mouse and reading with read-char would break. Use above.
+ (setq ch (char-to-string (ti::menu-read-char-exclusive prompt)))
+ (setq eval-form nil) ;clear this always
+ ;; .................................................. what ch ? ...
+ (cond
+ ((member ch '("q" "Q" "\e")) ;quit
+ (setq loop nil))
+ ((string= ch "?") ;handle help
+ (ti::menu-help var))
+ ((string= ch "h") ;handle help
+ (ti::menu-help-output var)
+ (setq loop nil))
+ ((setq elt (assq (string-to-char ch) alist))
+ (setq elt (cdr elt))
+ ;; ................................. new menu or call function ...
+ (cond
+ ((symbolp elt)
+ (if (not (boundp elt))
+ (error (format "Menu variable does not exist: %s" elt))
+ ;; replace with another menu
+ (setq var elt
+ m (symbol-value elt))))
+ ;; ..................................................... list ...
+ ((and (not (null elt))
+ (listp elt))
+ (cond ;See if there is flag.
+ ((and (eq 2 (length elt))
+ (equal 'quote (car elt)))
+ ;; A menu entry is not right
+ ;;
+ ;; '(?x . 'my-symbol)
+ ;; --> (quote my-symbol)
+ (error
+ "Menu error, not a symbol. Use cons or list: %s" elt))
+ ((eq 2 (length elt))
+ (setq flag t)
+ (setq elt (nth 1 elt)))
+ (t
+ (setq flag nil)
+ (setq elt (nth 0 elt))))
+ (cond
+ ((fboundp (car elt)) ;is first element a function ?
+ (setq eval-form elt)
+ (setq loop flag))
+ (t
+ (error "Menu structure error %s %s"
+ (assq (string-to-char ch) alist)
+ elt))))))
+ (t
+ ;; ch not found from list, keep looping
+ (sit-for 0.3))) ;flash the echo area
+ (message "") ;clear echo area
+ (when eval-form
+ (eval eval-form)))))
+
+;;; ----------------------------------------------------------------------
+;;; - This is user function
+;;;
+(defun ti::menu-menu-default (&optional arg)
+ "Call echo area menu with prefix ARG.
+Please read the documentation of variable `ti::menu-:menu-sample' to see
+the structure of menu.
+
+Menu pointed by `ti::menu-:menu' is used and PREFIX-ARG is passed to menu engine
+'ti::menu-:menu'.
+
+References:
+ `ti::menu-:menu-sample'"
+ (interactive "P")
+ (ti::menu-menu ti::menu-:menu arg))
+
+;;}}}
+
+(provide 'tinylibmenu)
+(run-hooks 'ti::menu-:load-hook)
+
+;;; tinylibmenu.el ends here
--- /dev/null
+;;; tinylibo.el --- Library for handling (o)verlays
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 1995-2007 Jari Aalto
+;; Keywords: extensions
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program, call M-x tinylibo-version.
+;; Look at the code with folding.el
+
+;; COPYRIGHT NOTICE
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;;; Intallation:
+
+;; ........................................................ &t-install ...
+;; Put this file on your Emacs-Lisp load path, add following into your
+;; ~/.emacs startup file. Yes, you require 'm' lib which publishes
+;; this modules interface.
+;;
+;; (require 'tinylibm)
+
+;;}}}
+;;{{{ Documentation
+
+;; ..................................................... &t-commentary ...
+
+;;; Commentary:
+
+;; Preface 1995
+;;
+;; The functions were developed to ease the highlighting,
+;; at the time when these function were new in Emacs. The overlays
+;; really seemed like "inside" stuff when tried for the first time
+;; to make text colored.
+;;
+;; o This is LIBRARY module, it does nothing on its own.
+;; o Offers functions for overlay handling
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+;;{{{ setup: -- require
+
+;;; ......................................................... &require ...
+
+(require 'tinylibm)
+
+(ti::package-use-dynamic-compilation)
+
+(eval-and-compile
+ (ti::overlay-require-macro
+ (message "\n\
+tinylibo: ** XEmacs needs overlay.el package; emulation may not work.")
+
+ ;; Idea in setnu.el, note that XEmacs 19.15+ includes an overlay.el
+
+ (unless (fboundp 'overlayp)
+ (defalias 'overlayp 'extent-live-p))
+
+ (unless (fboundp 'make-overlay)
+ (defalias 'make-overlay 'make-extent))
+
+ (unless (fboundp 'delete-overlay)
+ (defalias 'delete-overlay 'delete-extent))
+
+ (unless (fboundp 'overlay-get)
+ (defalias 'overlay-get 'extent-property))
+
+ (unless (fboundp 'overlay-put)
+ (defalias 'overlay-put 'set-extent-property))
+
+ (unless (fboundp 'move-overlay)
+ (defalias 'move-overlay 'set-extent-endpoints))
+
+ (unless (fboundp 'overlay-end)
+ (defalias 'overlay-end 'extent-end-position))
+
+ (unless (fboundp 'overlay-start)
+ (defalias 'overlay-start 'extent-start-position))
+
+ (unless (fboundp 'overlay-buffer)
+ (defalias 'overlay-buffer 'extent-start-position))
+
+ (unless (fboundp 'overlay-buffer)
+ (defalias 'overlay-buffer 'extent-start-position))
+
+ (unless (fboundp 'next-overlay-change)
+ (defalias 'next-overlay-change 'next-extent-change))
+
+ (unless (fboundp 'overlay-properties)
+ (defalias 'overlay-properties 'extent-properties))
+
+ (unless (fboundp 'overlay-length)
+ (defalias 'overlay-length 'extent-length))
+
+ (unless (fboundp 'overlays-at)
+ (defun overlays-at (point)
+ "tinylibo.el -- return overlay at POINT."
+ (ti::funcall 'extent-list (current-buffer) point)))))
+
+;;}}}
+;;{{{ setup: -- vars
+
+;;; ....................................................... &v-version ...
+
+(defconst tinylibo-version
+ (substring "$Revision: 2.39 $" 11 15)
+ "Latest version number.")
+
+(defconst tinylibo-version-id
+ "$Id: tinylibo.el,v 2.39 2007/05/01 17:20:45 jaalto Exp $"
+ "Latest modification time and version number.")
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylibo-version (&optional arg)
+ "Show version information. ARG will instruct to print message to echo area."
+ (interactive "P")
+ (ti::package-version-info "tinylibo.el" arg))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylibo-feedback ()
+ "Submit suggestions, error corrections, impressions, anything..."
+ (interactive)
+ (ti::package-submit-feedback "tinylibo.el"))
+
+;;}}}
+
+;;; ########################################################### &funcs ###
+
+;;{{{ macros
+
+;;; .......................................................... ¯os ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::overlay-make (level)
+ "Make overlay according to match in buffer at LEVEL.
+The match is NOT checked. Returns new overlay."
+ (make-overlay
+ (match-beginning level)
+ (match-end level)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::overlay-makec (level)
+ "Make overlay according to match in buffer at LEVEL.
+The match is checked. Returns new overlay or nil."
+ (if (match-end level)
+ (make-overlay
+ (match-beginning level)
+ (match-end level))))
+
+;;}}}
+;;{{{ funcs
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::overlay-make-match (level plist)
+ "Make overlay over the matched text portion. The match level is checked.
+
+Input:
+ LEVEL match level
+ PLIST property list '(PRO-NAME PROP-VAL)
+
+Return:
+ ov overlay or nil"
+ (let* ((ov (ti::overlay-makec level))
+ prop
+ propv)
+ (when ov
+ (while plist
+ (setq prop (nth 0 plist) propv (nth 1 plist))
+ (setq plist (cdr (cdr plist))) ;go 2 fwd
+ (overlay-put ov prop propv)))
+ ov))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::overlay-buffer-substring (ov &optional no-properties)
+ "Read `buffer-substring' underneath overlay OV.
+
+Input:
+
+ OV overlay, can also be nil.
+ NO-PROPERTIES flag, if non-nil remove all properties
+
+Return:
+
+ string
+ nil"
+ (when ov
+ (if no-properties
+ (buffer-substring-no-properties (overlay-start ov) (overlay-end ov))
+ (buffer-substring (overlay-start ov) (overlay-end ov)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::overlay-mouse-on-p (ov)
+ "Check if overlay OV has `mouse-face' on.
+If `mouse-face' contains 'default, it's treated to mean same as nil.
+
+Return:
+ nil or property value of `mouse-face'"
+ (let* (prop
+ propl)
+ (when ov
+ (setq propl (overlay-properties ov)
+ prop (when (memq 'mouse-face propl)
+ (overlay-get ov 'mouse-face)))
+ (unless (or (null prop)
+ (eq prop 'default))
+ ;; it had some property
+ prop))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::overlay-get-mouse ()
+ "Check if the point has 'mouse-face overlay.
+
+Return:
+
+ nil no overlay at the point found
+ t no mouse face
+ ov overlay"
+ (let* (ovl ;overlay list
+ ov)
+ (when (setq ovl (overlays-at (point)))
+ (setq ov (ti::overlay-get-prop ovl (list 'mouse-face)))
+ (if (null ov)
+ (setq ov t))) ;no mouse
+ ov))
+
+;; ----------------------------------------------------------------------
+;; 'prop' means parameter form
+;; - There should only one unique...
+;;
+(defun ti::overlay-get-prop (ovl prop-list)
+ "Read OVL and return first overlay where is property list PROP-LIST.
+
+Input:
+
+ OVL overlay list
+ PROP-LIST list of properties (PROP PROP ..)"
+ (let ((len (length prop-list))
+ ov
+ ovx
+ propl
+ i)
+ (unless (and ovl prop-list)
+ (error "Invalid parameters"))
+
+ (while (and ovl ;until list end
+ (null ov)) ;until found
+ (setq ovx (car ovl)
+ propl (overlay-properties ovx)
+ i 0)
+
+ (dolist (elt prop-list) ;check all properties
+ (when (memq elt propl)
+ (incf i))) ;hit counter
+
+ (if (eq i len)
+ (setq ov ovx)) ;found all matches
+ (setq ovl (cdr ovl)))
+ ov))
+
+;; ----------------------------------------------------------------------
+;; 'prop-val' means parameter form
+;; - This is more heavier function
+;;
+(defun ti::overlay-get-prop-val (ovl prop-list)
+ "Read OVL and find overlay(s) which contain PROP-LIST '(PROP VAL PROP VAL..)
+
+Input:
+
+ OVL overlay list
+ PROP-LIST list of properties (PROP VAL PROP VAL ..)"
+ (let (len
+ ov
+ ovx
+ ptr
+ propl
+ prop
+ propv)
+ (when ovl
+ (setq len (length prop-list))
+
+ (if (or (not (and ovl prop-list))
+ (not (= 0 (% len 2)))) ;must go paired
+ (error "Invalid parameters" ovl prop-list)
+
+ (setq len (/ (length prop-list) 2))
+
+ ;; ..................................................... check ...
+
+ (while (and (setq ovx (pop ovl)) ;until list end
+ (null ov)) ;until found
+
+ (setq ptr prop-list
+ propl (overlay-properties ovx))
+
+ (while ptr
+ (setq prop (car ptr) ptr (cdr ptr)
+ propv (car ptr) ptr (cdr ptr))
+
+;;; (ti::d!! '!! prop propv
+;;; 'memq (memq prop propl)
+;;; 'get (overlay-get ovx prop) propv propl "\n")
+
+ (if (and (memq prop propl)
+ (equal (overlay-get ovx prop) propv))
+ (push ovx ov)))
+
+ (setq ovl (cdr ovl)))) ;; while-if
+
+;;; (ti::d!! "~out" (prin1-to-string ov))
+ ov)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::overlay-re-search
+ (re level list &optional max back reuse reuse-t no-prop-l)
+ "Search for RE at LEVEL by creating overlay and its property LIST.
+Assigning LIST (PROP PROP_VAL) to the overlay. The search is repeated
+until no more hits or up till MAX point is reached.
+
+Input:
+
+ RE regexp
+ LEVEL subexpression level in regexp
+ LIST list of (PROP PROP_VAL)
+ MAX if non-nil, searches up till MAX point.
+ BACK search backward
+ REUSE (PROP PROP PROP ..) or (PROP_SYM PROP_VAL ..)
+
+ When re match is found it looks overlays underneath the
+ point, and the first overlay that satisfies list, will
+ be reused, instead of creating new one. Note that _first_
+ overlay matched is used, if none is found, new is created
+
+ REUSE-T
+
+ Specifies the list _type_ that was given in REUSE.
+ nil = first type , non-nil = second type.
+
+ NO-PROP-L
+
+ Ig given, then possible overlay starting at the same point must
+ not have properties PROP-L (PROL VAL PROP VAL ..). If there is
+ susch matching overlay, then do not create overlay.
+
+Return:
+
+ nil nothing created or used.
+ '(used-list created-list) two lists, list of used and created overlays."
+ (let* ((func (if back 're-search-backward 're-search-forward))
+ (max (if max
+ max ;it's given
+ (if back
+ (point-min)
+ (point-max))))
+ ret-reused
+ ret-created
+ ov
+ ovl
+ prop
+ propv
+ ptr
+ ;; match pointers
+ mb)
+ (unless (and list
+ (listp list)
+ (zerop (% (length list ) 2)))
+ (error "Parameter LIST invalid" re level list))
+
+ (save-excursion
+ (while (funcall func re max t)
+ (setq mb (match-beginning level))
+
+;;; (ti::d! level (match-string level) mb)
+
+ (when mb ;match on this level found
+
+ ;; ....................................... find or create ov ...
+
+ (setq ovl (overlays-at mb)) ;try finding all overlays
+
+ (cond
+ ((and ovl
+ (ti::overlay-get-prop-val ovl no-prop-l))
+ ;; Do nothing, overlap happened
+ nil)
+
+ ((or (null reuse)
+ (null ovl))
+ (setq ov (ti::overlay-make level))
+ (push ov ret-created ))
+
+ (t
+;;; (ti::d! "r" reuse ovl) (setq OVL ovl RE reuse)
+ (if reuse-t ;what type the list is ?
+ (if ovl
+ (setq ov (car-safe (ti::overlay-get-prop-val ovl reuse))))
+ (if ovl
+ (setq ov (ti::overlay-get-prop ovl reuse))))
+
+;;; (ti::d! "after" ov)
+
+ (if ov
+ (push ov ret-reused)
+ (setq ov (ti::overlay-make level)) ;none satisfies us
+ (push ov ret-created)))) ;; cond
+
+ ;; .................................... add properties to ov ...
+ ;; Now we should have overlay in a way or other
+
+ (when ov
+ (setq ptr list)
+;;; (ti::d! list)
+ (while ptr
+ (setq prop (nth 0 ptr) propv (nth 1 ptr))
+ (setq ptr (cdr (cdr ptr))) ;go 2 fwd
+;;; (ti::d! "put" prop propv ov)
+ (overlay-put ov prop propv))))))
+
+ (when (or ret-reused ret-created)
+ (list ret-reused ret-created))))
+
+;;; ----------------------------------------------------------------------
+;;; Try following example:
+;;;
+;;; (setq OV (make-overlay (point) (point)))
+;;; (overlay-put OV 'face 'highlight)
+;;; (ti::overlay-re-search-move OV "ti::o")
+;;;
+;;;
+(defun ti::overlay-re-search-move (ov re &optional level back max)
+ "Maove OV to Search forward for match RE at LEVEL.
+Default level is 0, full match. if BACK is given, search is done
+backward. MAX is last position to search.
+
+If overlay OV is currently in some other buffer, it will be transferred
+to the current buffer.
+
+Input:
+
+ OV overlay
+ RE regexp
+ LEVEL subexpression level in regexp
+ BACK flag, is non-nil, go backward
+ MAX max point of search
+
+Return:
+
+ nil if not moved.
+ nbr overlay end position [matched portion end]"
+ (let* ((max (or max
+ (if back (point-min) (point-max))))
+ (level (or level 0))) ;default is full string
+ (unless ov
+ (error "invalid overlay, nil"))
+
+ (when (and (if back
+ (re-search-backward re max t)
+ (re-search-forward re max t))
+ (match-end level))
+ (move-overlay ov
+ (match-beginning level)
+ (match-end level)
+ (current-buffer))
+ (match-end level))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::overlay-get-within-area (propl &optional propl-t beg end)
+ "Return all overlays which match property list PROPL.
+If PROPL is t then returns all overlays. Default is to search from
+current point forward.
+
+Input:
+ PROPL property list, see next
+ PROPL-T if nil the propl is of type (PROP PROP .. )
+ if non-nil (PROP VAL PROP VAL ..)
+ BEG region beginning
+ END region end"
+ (let* ((p (or beg (point)))
+ (max (or end (point-max)))
+ (all (eq t propl))
+ ovl
+ ovx
+ list)
+ (save-excursion
+ (while (< p max)
+ (goto-char p)
+ (setq ovl (overlays-at p))
+ (when ovl
+ (if all
+ (setq list (append ovl list))
+ (if propl-t
+ (setq ovx (car-safe (ti::overlay-get-prop-val ovl propl)))
+ (setq ovx (ti::overlay-get-prop ovl propl)))
+ (if ovx
+ (push ovx list))))
+ (setq p (next-overlay-change p))))
+ list))
+
+;;; ----------------------------------------------------------------------
+;;; If you're in trouble, call this function interactively
+;;; and it wipes out all overlays.
+;;;
+(defun ti::overlay-remove-region (&optional beg end propl propl-t)
+ "Remove all matched overlays within area.
+Default is from point forward. Ignores buffer read-only status.
+
+Input:
+
+ BEG region beginning
+ END region end
+ PROPL (PROP PROP ..) or
+ (PROP VAL PROP VAL ..)
+ If this value is t, removes all overlays
+
+ PROPL-T Specifies the list type given. nil = first list type."
+ (interactive "r")
+ (let* (buffer-read-only
+ (p (or beg (point)))
+ (max (or end (point-max)))
+ (propl (if propl
+ propl
+ t)) ;set to t is not given
+ (ovl (ti::overlay-get-within-area propl propl-t p max))
+ ovx)
+ (dolist (overlay ovl)
+ (delete-overlay overlay))))
+
+;;}}}
+
+(provide 'tinylibo)
+
+;;; tinylibo.el ends here
--- /dev/null
+;;; tinylibt.el --- Library for handling text properties.
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 1995-2007 Jari Aalto
+;; Keywords: extensions
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program, call M-x tinylibt-version.
+;; Look at the code with folding.el
+
+;; COPYRIGHT NOTICE
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even tqhe 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 program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;; ....................................................... &t-install ...
+;; Put this file on your Emacs-Lisp load path, add following into
+;; ~/.emacs startup file.
+;;
+;; (require 'tinylibt)
+;;
+;; No autoload is suggested, because almost every function would have
+;; to be in autoload state. It's easier to use require. Here are
+;; suggested keybings for interactive use.
+;;
+;; (global-unset-key "\C-z")
+;; (global-set-key "\C-ztm" 'ti::text-mark-region) ;; e.g. permanent 'mark'
+;; (global-set-key "\C-ztu" 'ti::text-unmark-region) ;; remove 'mark'
+;; (global-set-key "\C-ztc" 'ti::text-clear-buffer-properties)
+;; (global-set-key "\C-ztb" 'ti::text-buffer)
+;; (global-set-key "\C-ztU" 'ti::text-undo)
+;;
+;; If you have any questions or feedback, use this function
+;;
+;; M-x ti::text-submit-bug-report
+
+;;}}}
+;;{{{ Documentation
+
+;; ..................................................... &t-commentary ...
+
+;;; Commentary:
+
+;; Overview of features
+;;
+;; o This package is primary aimed for programmers, but
+;; interactive users will also find handy functions.
+;; o Show matched text with color in the buffer.
+;; o This is *NOTHING* like `font-lock' or `lazy-lock'
+;; which are demand driven packages intended for certain major modes.
+;; Use this package to "manually" mark interesting things in
+;; any buffer.
+;; o Examples: highlighting on/off tabs, Verifying PGP
+;; fingerprints against trusted key server list
+;; o UNDO: adjustable stack size. Stack is cleared if
+;; stack limit reached (stack 'wraps')
+;;
+;; User functions
+;;
+;; Mostly this package is designed for programmers, who add
+;; some highlight commands in hooks. For quick text highlighting,
+;; you can use these interactive functions:
+;;
+;; ti::text-looking-at
+;; ti::text-buffer ;; Highlight in whole buffer area
+;; ti::text-re-search-forward
+;; ti::text-re-search-backward
+;; ti::text-undo
+;;
+;; ti::text-clear-buffer-properties
+;; ti::text-clear-region-properties
+;;
+;; ti::text-mark-region
+;; ti::text-unmark-region
+;;
+;; ti::text-mouse-mark-region
+;; ti::text-mouse-unmark-region
+;;
+;; Setting different face (programming)
+;;
+;; If you want permanetly change the face, when marking text
+;; use commands
+;;
+;; ti::text-search-face-set ;to set
+;; ti::text-search-face-reset ;to get default color back
+;;
+;; If you want temporarily use some face, supply direct FACE parameter
+;; when you call search functions, like:
+;;
+;; ti::text-re-search-forward (re &optional level face)
+;;
+;; Note
+;;
+;; This is for simple text highlighting only. Like finding certain items
+;; or marking something quickly and temporarily (great for text files)
+;;
+;; You can mix font-lock/hilit19 and TIMA package, but remember that
+;; these packages have different goals. Use TIMA only for finding
+;; things in buffer, or marking certain articles in gnus...
+;;
+;; Be carefull: if you use `ti::text-clear-buffer-properties', you will
+;; wipe out all text properties.
+;;
+;; Example: highlighting tabs
+;;
+;; (global-set-key "\C-ct" 'my-tabs-highligh-in-buffer)
+;;
+;; (defun my-tabs-highligh-in-buffer (&optional arg)
+;; "Toggless hilit/dehiliting tabs in buffer.
+;; If ARG is integer, force highlighting. If ARG is C-u, then
+;; force dehighlighting."
+;; (interactive "P")
+;; (let (prop)
+;; (save-excursion
+;; (ti::pmin)
+;; (when (re-search-forward "\t" nil t)
+;; ;; is the tab marked?
+;; (setq prop (get-text-property (1- (point)) 'face))
+;; (cond
+;; ((or (integerp arg) ;; Do highlighting
+;; (or (eq prop nil)
+;; (eq prop 'default)))
+;; (beginning-of-line)
+;; (ti::text-re-search-forward "\t+"))
+;; (t
+;; (beginning-of-line)
+;; ;; Remove
+;; (ti::text-re-search-forward "\t+" 0 'default )))))))
+;;
+;; Example: finding PGP key matches
+;;
+;; (defun my-pgp-fp-certify ()
+;; "To certify keys, E.g. get list of remailers
+;; from http://www.uit.no/
+;; - Display in window1 the UIT.NO result file
+;; - Put received key fingerprints in other window (pgp -ka
+;; will tell you)
+;;
+;; Call this function in the Received keys buffer, and it'll
+;; highlight keys that match Fingerprint in uit.no window."
+;; (interactive)
+;; (let* ((blist (ti::window-list 'buffers))
+;; (buffer (car (delq (current-buffer) blist)))
+;; A
+;; elt
+;; ok)
+;; (ti::pmin)
+;; (while (re-search-forward
+;; "Key fingerprint.*= +\\(.*\\)" nil t)
+;; (setq elt (match-string 1) ok nil)
+;; (setq A elt)
+;; (save-excursion
+;; (set-buffer buffer)
+;; (ti::pmin)
+;; (setq ok (ti::text-re-search-forward elt)))
+;; (when ok
+;; (beginning-of-line)
+;; (ti::text-looking-at ".*"))
+;; (end-of-line))))
+;;
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+;;{{{ setup: require
+
+;;; ......................................................... &require ...
+
+(require 'tinylibm)
+(eval-when-compile (ti::package-use-dynamic-compilation))
+
+(ti::package-defgroup-tiny TinylibText ti::text-: extensions
+ "Mark matched text in buffer with face.
+ Overview of features
+
+ o This package is primary aimed for elisp programmers, but
+ interactive users will also find handy functions.
+ o Shows matched text with color in the buffer.
+ o This is *NOTHING* like font-lock, lazy-lock or hilit19,
+ which are demand driven packages intended for certain major modes.
+ Use this package to manually mark interesting things in
+ any buffer.
+ o Examples: highlighting on/off tabs, Verifying PGP
+ fingerprints against trusted list like http://www.uit.no/
+ o UNDO: adjustable stack size. Stack is cleared if
+ stack limit reached (stack 'wraps')
+ ")
+
+;;}}}
+;;{{{ setup: variables
+
+;;; ......................................................... &v-hooks ...
+
+(defcustom ti::text-:load-hook nil
+ "*Hook run when file has been loaded."
+ :type 'hook
+ :group 'TinylibText)
+
+(defcustom ti::text-:stack-size 1000
+ "*How big undo history."
+ :type 'number
+ :group 'TinylibText)
+
+;;; ....................................................... &v-private ...
+
+(defvar ti::text-:stack-count nil
+ "Incremented after every search. Do not touch.")
+
+(defvar ti::text-:stack-push-flag nil
+ "Non-nil means ('undo-func) do not record match data to stack.
+If this variable has value 'undo-func then the next calls to
+`ti::text-re-search' won't record data to stack.")
+
+(defvar ti::text-:stack nil
+ "Private. Contain last search data.
+This is actually property list stack so that undo can be done.
+
+Format:
+
+ '(start-point
+ last-func
+ last-re
+ las-beg-point
+ last-level
+ last-mode)")
+
+;;; ........................................................ &v-public ...
+;;; user configurable
+
+(defcustom ti::text-:face-tab-search-default 'highlight
+ "*Default face used when marking searched text."
+ :type '(symbol :tag "Face symbol")
+ :group 'TinylibText)
+
+;;; For now, only search face is used, but maybe in the future the others..
+;;;
+(defcustom ti::text-:face-table
+ (list
+ (cons 'search 'highlight)
+ (cons 'warn (if (ti::emacs-p) 'region 'bold)) ;XE doesn't have 'region face
+ (cons 'head 'bold))
+ "*Faces used for marking text."
+ :type '(repeat
+ (list
+ (symbol :tag "symbolic face name"
+ (symbol :tag "Face name"))))
+ :group 'TinylibText)
+
+;;}}}
+;;{{{ version
+
+(eval-and-compile
+ (ti::macrof-version-bug-report
+ "tinylibt.el"
+ "tinulibt"
+ ti::text-:version-id
+ "$Id: tinylibt.el,v 2.46 2007/05/06 23:15:20 jaalto Exp $"
+ '(ti::text-:version-id
+ ti::text-:load-hook
+ ti::text-:stack-size
+ ti::text-:stack-count
+ ti::text-:stack-push-flag
+ ti::text-:stack
+ ti::text-:face-search-default
+ ti::text-:face-table)))
+
+;;}}}
+;;{{{ code: misc funcs
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro ti::text-search-face-reset ()
+ "Reset used face to the default value.
+If you use many colours to highlight text. Remember to call this
+when you're finished."
+ (list
+ 'setcdr (list 'assq ''search 'ti::text-:face-table)
+ 'ti::text-:face-search-default))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro ti::text-search-face-set (face)
+ "Change search colour to FACE."
+ (list 'setcdr (list 'assq ''search 'ti::text-:face-table) face))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro ti::text-face (face)
+ "Return real face when logical FACE is given."
+ ;; This way the global variable does not float around the file
+ (list 'cdr (list 'assoc face 'ti::text-:face-table)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::text-stack-clear ()
+ "Clear undo stack."
+ (put 'ti::text-:stack 'definition-stack nil)
+ (setq ti::text-:stack-count 0
+ ti::text-:stack nil))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::text-stack-length ()
+ "Return undo stack length."
+ (length (get 'ti::text-:stack 'definition-stack)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::text-stack-full-p ()
+ "Check if stack is full."
+ (eq (ti::text-stack-length) (1+ ti::text-:stack-size)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst ti::text-stack-p ()
+ "Check if there is data in undo stack. nil means that stack is empty."
+ (or (get 'ti::text-:stack 'definition-stack)
+ ;; Make sure this is also zero because there is no data
+ (progn (setq ti::text-:stack-count 0) nil)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::text-save-data (re level func mode beg)
+ "Save search values RE LEVEL FUNC MODE BEG for undo.
+If the stack is full, then Clear the stack before pushing to it."
+ (or (integerp ti::text-:stack-count)
+ (setq ti::text-:stack-count (ti::text-stack-length) ))
+ (when (and (stringp re)
+ (not (eq ti::text-:stack-push-flag 'undo-func)))
+
+ ;; The last entry in the stack is always nil, that's why
+ ;; 1+.
+ ;;
+ ;; inital: nil
+ ;; 1st: '(mil) pushed last data; size 1
+ ;; 2nd '((..) nil) pushed next, size 2
+ ;;
+ ;; As you can see there actually is only one real data;
+ ;; the 1st push reads the current calues of ti::text-:stack
+ ;; which is nil; because it was the last element that was poped
+ (when (>= ti::text-:stack-count
+ (1+ ti::text-:stack-size))
+ (ti::text-stack-clear)
+ (setq ti::text-:stack-count 0))
+ (ti::push-definition 'ti::text-:stack)
+ (setq ti::text-:stack
+ (list
+ func
+ re
+ beg
+ level
+ mode))
+ (incf ti::text-:stack-count)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::text-undo ()
+ "Undo last highlighting.
+`ti::text-:stack-push-flag' is set to 'undo-func while this function runs."
+ (interactive)
+ (let* ((ti::text-:stack-push-flag 'undo-func)
+ (prev ti::text-:stack)
+ func
+ beg
+ re
+ level
+ mode)
+ ;; - Hm The stack values are empty now, try to pop last saved values
+ ;; from stack.
+ ;; - Actually there should be something in the variable is the stack is
+ ;; not empty and it is an erro condition is variable IS empty AND
+ ;; there is values in the stack! ... We'll we don't nag about that
+ ;; here. I just thought you should know about it.
+ (unless prev
+ (decf ti::text-:stack-count)
+ (ti::pop-definition 'ti::text-:stack)
+ (setq prev ti::text-:stack)) ;Maybe this time there is something
+ (if (not (and (ti::listp prev)
+ (nth 0 prev)))
+ (progn
+ (ti::text-stack-clear)
+ (error "tinylibt: No more undo information in stack."))
+ (setq func (nth 0 prev)
+ re (nth 1 prev)
+ beg (nth 2 prev)
+ level (nth 3 prev)
+ mode (nth 4 prev))
+ (decf ti::text-:stack-count)
+ (save-excursion
+ ;; - What if user has narrowed the buffer
+ ;; - Or he has deleted text
+ (or (ignore-errors (goto-char beg))
+ (error "\
+There is no such search point in the buffer any more? %s" beg))
+ (cond
+ ((eq func 'looking-at)
+ (ti::text-looking-at re level 'default))
+ (t
+ (ti::text-re-search
+ re
+ (if (eq func 're-search-backward)
+ 'back nil)
+ level
+ nil
+ 'default
+ mode))))
+ ;; UNDO done; now get next undo information
+ (ti::pop-definition 'ti::text-:stack))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::text-clear-buffer-properties (&optional propl)
+ "Remove all properties from buffer that match property list PROPL.
+
+Input:
+ See function `ti::text-clear-region-properties'"
+ (interactive)
+ (ti::text-clear-region-properties (point-min) (point-max) propl)
+ (when (interactive-p)
+ (redraw-display)
+ (message "Properties cleared")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::text-clear-region-properties (beg end &optional propl)
+ "Remove properties from BEG END. Affects read only buffers too.
+
+Input:
+
+ PROPL (PROP VAL PROP VAL ..) Property list to match.
+ If nil, then remove all properties."
+ (interactive "r")
+ (let* (buffer-read-only ;allow writing
+ point
+ prop
+ val
+ list
+ read-list
+ elt
+ rprop ;read property name
+ rval
+ delete) ;flag
+ (with-buffer-modified
+ (if (null propl)
+ (set-text-properties beg end nil)
+ (ti::keep-lower-order beg end)
+ (setq prop (nth 0 propl) val (nth 1 propl))
+ (while (and (> (point-max) beg)
+ ;; The beg is advanced in loop
+ ;;
+ (<= beg end)
+ (setq point (text-property-any beg end prop val)))
+ (setq read-list (text-properties-at point)
+ list propl
+ delete t)
+ (while list
+ (setq rprop (nth 0 list)
+ rval (nth 1 list)
+ list (cdr (cdr list))) ;go 2 forward
+ ;; The memq return the rest of list
+ ;;
+ ;; '(owner me face highlight do-it nil)
+ ;; (memq 'face) --> '(face highlight do-it nil)
+ ;;
+ ;; So the (nth 1) gives the value 'highlight which we
+ ;; test.
+ (if (or (null (setq elt (memq rprop read-list)))
+ (not (eq (nth 1 elt) rval)))
+ ;; This doesn'tmatch, stop and cancel delete
+ (setq list nil delete nil)))
+ ;; Character by character, this is bit slow...
+ (when delete
+ (set-text-properties point (1+ point) nil))
+ ;; Search again
+ (setq beg (1+ point)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::text-get-mouse-property ()
+ "Check if the point has 'mouse-face text property.
+notice that if value read from point is nil,
+that means same as no `mouse-face' property exists.
+
+Return:
+
+ nil no property at point found
+ prop `mouse-face' property value"
+ (let* ((prop (text-properties-at (point))))
+ (if (setq prop (memq 'mouse-face prop))
+ (cdr prop)))) ;return value, may be nil
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::text-match-level (&optional level face-or-propl beg end)
+ "Add to match LEVEL a FACE-OR-PROPL in region BEG END.
+If no match in that level, do nothing. Property `rear-nonsticky' is
+added to the end of match unless FACE-OR-PROPL contains it.
+
+Input:
+
+ LEVEL Defaults to 0
+ FACE-OR-PROPL Defaults to '(face highlight)
+ If symbol, must be face symbol.
+ Can also be property list '(PROP VAL PROP VAL ..))
+
+ BEG END If given, then these are the are matched."
+ (let ((add-flag t))
+ (setq beg (or beg (match-beginning (or level 0)))
+ end (or end (match-end (or level 0))))
+ (when (and (and beg end)
+ (not (eq beg end))) ;Nothing to do
+ (cond
+ ((null face-or-propl)
+ (add-text-properties beg end '(face highlight)))
+ ((symbolp face-or-propl)
+ (add-text-properties beg end (list 'face face-or-propl)))
+ (t
+ (setq add-flag (null (memq 'rear-nonsticky face-or-propl)))
+ (add-text-properties beg end face-or-propl)))
+ (when add-flag
+ (if (eq end 1) (setq end 2)) ;(1- 1) = 0, invalid charpos
+ (add-text-properties (1- end) end '(rear-nonsticky t))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun ti::text-re-search
+ (re &optional direction level maxp face mode save-undo)
+ "Highlight found text with search face.
+
+Note:
+
+ The beginning of match and end of match will have
+ property 'rear-nonsticky t, so that adding characters before of after
+ text, won't inherit the face.
+
+Input:
+
+ RE str regexp
+ DIRECTION bool non-nil means backward
+ LEVEL nbr which subexpression in re to highlight, default is 0
+ MAXP nbr last search point [default until bob/eob]
+
+ FACE sym face symbol
+ if symbol is 'null then set face to value nil
+ or if this is list; then it must be properly list
+ of format '(PROP PROP-VAL PROP PROP-VAL ..)
+
+ MODE nbr signify that function should highlight all matches
+ that occur within LEVEL..NBR
+ if you have lot's of xx(match)yy|zz(match)tt|
+ the subexpression are counted from left to to
+ right: 1,2 ...
+ SAVE-UNDO flag non-nil means that the highlight information is
+ recorded for undo. This flag in on if function is
+ called interactively. NOTE: the undo information is
+ saved only if something was matched.
+
+Return:
+
+ nil No match
+ nbr start of match at LEVEL."
+ (let* ((func (if direction
+ 're-search-backward
+ 're-search-forward))
+ (start-point (point))
+ buffer-read-only
+ max-level
+ count
+ bp ep ;beg/end points
+ ret
+ prop
+ val
+ list)
+ (with-buffer-modified
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. set defaults . .
+ (or level
+ (setq level 0))
+ (or maxp
+ (setq maxp
+ (if direction
+ (point-min)
+ (point-max))))
+ (cond
+ ((equal 'null face)
+ (setq face nil))
+ ((null face)
+ (setq face (ti::text-face 'search))))
+ ;; Otherwise face is non-nil
+ (setq max-level (1+ (or mode level)))
+ ;; Make sure the property list has paired values if supplied
+ (if (and (ti::listp face)
+ (not (eq 0 (% (length face) 2))))
+ (error "face properties are not paired: prop val"))
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. do matching . .
+ (while (funcall func re maxp t)
+ (setq count level)
+ (while (< count max-level)
+ (setq bp (match-beginning count)
+ ep (match-end count))
+ (if (and bp (null ret)) ;do only once
+ (setq ret bp))
+ (when (and bp (not (eq bp ep))) ;empty string
+ (cond
+ ((or (symbolp face)
+ (null face))
+ (put-text-property bp ep 'face face))
+ ((listp face)
+ (setq list face)
+ (while list
+ ;; Read two values at time
+ ;;
+ (setq prop (car list) list (cdr list)
+ val (car list) list (cdr list))
+ (put-text-property bp ep prop val))))
+ ;; #todo: something is wrong here, investigate..
+ ;;
+ ;; If a character's `rear-nonsticky'
+ ;; property is `t', then none of its properties are rear-sticky.
+ ;;
+ ;; Hmm, doesn't affect 19.28; is there bug in this emacs?
+ ;; The highlight is still extended If one adds chars after
+ ;; the matched text.
+ ;;
+ ;; The stickiness must be activated ONE before the character.
+ (let (beg)
+ (if (eq bp (1- ep))
+ (setq beg (1- bp))
+ (setq beg (1- ep)))
+ (if (zerop beg)
+ (setq beg 1))
+ (add-text-properties beg ep '(rear-nonsticky t))))
+ (setq count (1+ count))))
+ ;; Saving the search values for possible undo.
+ (if (and save-undo ret)
+ (ti::text-save-data re level func mode start-point))
+ ;; Return success status
+ ret)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::text-property-search-and-modify
+ (match-plist set-plist &optional beg end)
+ "Search all characters forward, whose text properties match MATCH-PLIST.
+Set properties to SET-PLIST. The point moves along the search.
+
+Input:
+
+ MATCH-PLIST property list '(prop val prop val ..)
+ SET-PLIST property list '(prop val prop val ..)
+ BEG start point of search; defaults to `point-min'
+ END end point of search; defaults to `point-max'"
+ (let* ((sprop (car match-plist)) ;serach property
+ (sval (car (cdr match-plist)))
+ point
+ plist mlist
+ elt
+ ok)
+ (if (null match-plist)
+ (error "Invalid match-plist"))
+ (or beg (setq beg (point-min)))
+ (or end (setq end (point-max)))
+ (ti::keep-lower-order beg end)
+ (goto-char beg)
+ (setq point (1- (point)))
+ (while (and (not (eobp))
+ (<= (point) end)
+ (setq point (text-property-any (1+ point) end sprop sval)))
+ (goto-char point)
+ (setq plist (text-properties-at (point))
+ mlist match-plist
+ ok t)
+ (while (and ok mlist)
+ ;; Select 1str PROP fro match-list and see if it is in read PLIST
+ ;; Continue until all MLIST properties are found from read PLIST
+ (setq elt (memq (car mlist) plist)
+ ;; first non-match terminates loop immediately
+ ok (and elt (eq (nth 1 elt) (nth 1 mlist)))
+ mlist (cdr (cdr mlist))))
+ (if ok
+ (set-text-properties (point) (1+ (point)) set-plist)))))
+
+;;}}}
+;;{{{ code: interactive
+
+;;; ----------------------------------------------------------------------
+;;; Mon, 12 Feb 1996, Tom Fontaine <fontaine@esd.ray.com>
+;;; Sent this piece of code. Thanks Tom!
+;;;
+(defun ti::text-read-regexp ()
+ "Read regexp using `regexp-history'."
+ (let*
+ ((default (car regexp-history))
+ (input
+ (read-from-minibuffer
+ (if default
+ (format "Highlight matching regexp (default `%s'): " default)
+ "Highlight matching regexp: ")
+ nil nil nil
+ 'regexp-history)))
+ (if (> (length input) 0) ;the return value
+ input
+ (setcar regexp-history default))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun ti::text-looking-at (re &optional level face-or-plist )
+ "Highlight found RE at LEVEL with FACE-OR-PLIST.
+The LEVEL is subexpression to highlight. PLIST means property list."
+ (interactive "slook at: ")
+ (let (buffer-read-only) ;allow writing
+ (with-buffer-modified
+ (setq level (or level 0)
+ face-or-plist (or face-or-plist (ti::text-face 'search)))
+
+ (when (and (looking-at re)
+ (match-end level))
+ (ti::text-save-data re level 'looking-at nil (point))
+ (ti::text-match-level level face-or-plist)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun ti::text-buffer (re &optional level face mode save-undo)
+ "Highlight RE and sub LEVEL in whole buffer, starting from `point-min'.
+Preserve point.
+
+See `ti::text-re-search' for descriptions of FACE MODE and SAVE-UNDO."
+ (interactive (list (ti::text-read-regexp) current-prefix-arg))
+ (save-excursion
+ (if (interactive-p)
+ (setq save-undo t))
+ (goto-char (point-min))
+ (ti::text-re-search re nil level nil face mode save-undo)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun ti::text-re-search-forward (re &optional level face mode save-undo)
+ "Search RE and highlight forward until `point-max'.
+Optional prefix arg tells which subexpression LEVEL to match that
+function should highlight. point is preserved during call.
+
+See `ti::text-re-search' for descriptions of FACE MODE SAVE-UNDO."
+ (interactive (list (ti::text-read-regexp) current-prefix-arg))
+ (save-excursion
+ (if (interactive-p)
+ (setq save-undo t))
+ (ti::text-re-search re nil level nil face mode save-undo)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun ti::text-re-search-backward (re &optional level face mode save-undo)
+ "Search RE and highlight backward until `point-min'.
+Optional prefix arg tells which subexpression LEVEL to match that
+function should highlight. point is preserved during call.
+
+See `ti::text-re-search' for descriptions of FACE MODE SAVE-UNDO."
+ (interactive (list (ti::text-read-regexp) current-prefix-arg))
+ (save-excursion
+ (if (interactive-p)
+ (setq save-undo t))
+ (ti::text-re-search re 'back level nil face mode save-undo)))
+
+;;; ----------------------------------------------------------------------
+;;; - These are handy when you want to "mark" ceratin texts for quick ref.
+;;;
+;;;###autoload
+(defun ti::text-mouse-mark-region (beg end event)
+ "Highlight region BEG END. EVENT is mouse event."
+ (interactive "r\ne")
+ (ti::text-mark-region beg end))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun ti::text-mouse-unmark-region (beg end event)
+ "Remove highlight from region BEG END. EVENT is mouse event."
+ (interactive "r\ne")
+ (ti::text-mark-region beg end 'remove))
+
+;;; - This is for keyboard users
+;;;
+;;;###autoload
+(defun ti::text-unmark-region (beg end)
+ "Remove highlight from region BEG END."
+ (interactive "r")
+ (ti::text-mark-region beg end 'remove))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun ti::text-mark-region (beg end &optional remove face)
+ "Highlight BEG END. With optional prefix arg REMOVE all matching FACE."
+ (interactive "r\nP")
+ (let* (buffer-read-only ;set this to nil
+ (face (if remove
+ 'default
+ (or face (ti::text-face 'search)))))
+ (with-buffer-modified
+ (put-text-property beg end 'face face))))
+
+;;}}}
+
+(provide 'tinylibt)
+(run-hooks 'ti::text-:load-hook)
+
+;;; tinylibt.el ends here
--- /dev/null
+;;; tinylibxe.el --- Compatibility library for both Emacs and XEmacs
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 1997-2007 Jari Aalto
+;; Keywords: extensions
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program, call M-x tilibxe-version.
+;; Look at the code with folding.el
+
+;; COPYRIGHT NOTICE
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;; ........................................................ &t-install ...
+;; Put this file on your Emacs-Lisp load path, add following into your
+;; package that you're currently developing. This ensures compatibility
+;; for some extent to XEmacs and Emacs.
+;;
+;; (require 'tinylibxe)
+
+;;}}}
+;;{{{ Documentation
+
+;; ..................................................... &t-commentary ...
+
+;;; Commentary:
+
+;; Preface 1996
+;;
+;; o This is library, package itself does nothing.
+;; o Compatibility for both Emacsen, XEmacs and Emacs
+;; o Compatibility for older Emacsen. Code written using later Emacs
+;; versions can be run under lower Emacs version. (e.g.
+;; `require' includes extra parameters in later Emacs versions.
+;;
+;; There are incompatibilities between XEmacs and Emacs which
+;; prevent writing portable code. The bigger problematic things
+;; have been collected here. The trivial ones have been implemented
+;; in lower level libraries like in backward compatibility
+;; library *tinylibb.el*.
+;;
+;; Overlay.el in XEmacs 19.15+
+;;
+;; Good news; Latest XEmacs includes package that emulates
+;; Emacs overlay functions. Load it under XEmacs, if you run code
+;; written using Emacs.
+;;
+;; What you should know -- keep this in mind
+;;
+;; This library's intention is to make it possible to use some package
+;; that is written only for Emacs. Normally it is not possible to use
+;; package under another Emacs, because there may be function calls
+;; that depend on Emacs flavor.
+;;
+;; When this file is loaded, it emulates unknown functions as much as
+;; it can. However, it may not be possible to reproduce exactly the
+;; same behavior that was not the primary target for the package. The
+;; emulation may at worst case be only so, that you are able to load
+;; the package without errors, but the functionality of the package
+;; doesn't correspond to the original's.
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+;;{{{ setup: require
+
+(require 'tinylibm)
+
+;;}}}
+;;{{{ setup: -- version
+
+(defconst tinylibxe-version
+ "$Revision: 2.49 $"
+ "Latest version number.")
+
+(defconst tinylibxe-version-id
+ "$Id: tinylibxe.el,v 2.49 2007/05/07 10:50:08 jaalto Exp $"
+ "Latest modification time and version number.")
+
+(defun tinylibxe-version (&optional arg)
+ "version information."
+ (interactive "P")
+ (ti::package-version-info "tinylibxe.el" arg))
+
+(defun tinylibxe-submit-bug-report ()
+ "Submit bug report."
+ (interactive)
+ (ti::package-submit-bug-report
+ "tinylibxe.el"
+ tinylibxe-version-id
+ '(tinylibxe-version-id)))
+
+;;}}}
+;;{{{ events, window, frames, misc
+
+(cond
+ ((ti::emacs-p)
+ (defalias 'event-window 'posn-window)
+ (defalias 'event-point 'posn-point)
+ (defalias 'event-timestamp 'posn-timestamp)
+ (defalias 'window-pixel-edges 'window-edges))
+ (t
+ (defalias 'posn-window 'event-window)
+ (defalias 'posn-window 'event-window)
+ (defalias 'posn-point 'event-point)
+ (defalias 'posn-timestamp 'event-timestamp)
+;;; (defalias 'posn-col-row ')
+ (defalias 'window-edges 'window-pixel-edges)))
+
+;;; From wid-edit.el
+;;;
+(ti::fboundp-check-autoload 'button-release-event-p "tinylibxe"
+ ;; XEmacs function missing from Emacs.
+ (defun button-release-event-p (event)
+ "Non-nil if EVENT is a mouse-button-release event object."
+ (and (eventp event)
+ (memq (ti::funcall 'event-basic-type event)
+ '(mouse-1 mouse-2 mouse-3))
+ (or (memq 'click (event-modifiers event))
+ (memq 'drag (event-modifiers event))))))
+
+(ti::fboundp-check-autoload 'event-start "tinylibxe"
+ (defun event-start (event)
+ "tinylibxe.el"
+ ;; In Emacs (WINDOW BUFFER-POSITION (X . Y) TIMESTAMP)
+ (list
+ (ti::funcall 'event-window event)
+ (ti::funcall 'event-point event)
+ (ti::funcall 'posn-x-y event)
+ (ti::funcall 'event-timestamp event))))
+
+(ti::fboundp-check-autoload 'event-x "tinylibxe"
+ (defun event-x (event)
+ "tinylibxe.el"
+ (let* ((data (ti::funcall 'event-start event)))
+ (car data))))
+
+(ti::fboundp-check-autoload 'event-y "tinylibxe"
+ (defun event-y (event)
+ "tinylibxe.el"
+ (let* ((data (ti::funcall 'event-start event)))
+ (cdr data))))
+
+(ti::fboundp-check-autoload 'posn-x-y "tinylibxe"
+ (defun posn-x-y (event)
+ "tinylibxe.el"
+ (cons (ti::funcall 'event-x event) (ti::funcall 'event-y event))))
+
+(when (and (not (fboundp 'frame-parameters)) ;obsolete in 19.14
+ (boundp 'frame-properties))
+ (defun frame-parameters (&optional frame)
+ "Return FRAME parameters."
+ ;; Emacs ((arg1 . val) (arg2 . val) ..)
+ ;; XEmacs (arg val arg2 val)
+ (ti::list-to-cons (ti::funcall 'frame-properties))))
+
+;;}}}
+;;{{{ faces
+
+;;; XEmacs /Emacs don't have compatible faces
+
+(and (not (fboundp 'x-display-color-p))
+ (fboundp 'device-class)
+ (defalias 'x-display-color-p 'device-class))
+
+(unless (ti::compat-face-p 'region)
+ (make-face 'region)
+ (set-face-foreground 'region "white")
+ (set-face-background 'region "black"))
+
+(ti::fboundp-check-autoload 'set-background-color "tinylibxe"
+ (defun set-background-color (colour)
+ "Tinylibxe. Emacs emulation"
+ (ti::funcall 'set-face-background 'default colour)))
+
+(ti::fboundp-check-autoload 'set-foreground-color "tinylibxe"
+ (defun set-foreground-color (colour)
+ "Tinylibxe. Emacs emulation"
+ (ti::funcall 'set-face-foreground 'default colour)))
+
+(ti::fboundp-check-autoload 'set-cursor-color "tinylibxe"
+ (defun set-cursor-color (colour)
+ "Tinylibxe. Emacs emulation"
+ (ti::funcall 'set-face-foreground 'text-cursor colour)))
+
+(ti::fboundp-check-autoload 'transient-mark-mode "tinylibxe"
+ (defun transient-mark-mode (&optional mode)
+ "Tinylibxe. Emacs emulation"
+ (interactive)
+ (set 'zmacs-regions (ti::bool-toggle mode))))
+
+;;}}}
+;;{{{ dired
+
+(cond
+ ((ti::emacs-p)
+ (defalias 'dired-unmark-subdir-or-file 'dired-unmark)
+ (defalias 'dired-mark-subdir-or-file 'dired-mark)
+ (defalias 'dired-mark-get-files 'dired-get-marked-files)
+ (defalias 'dired-mark-map 'dired-map-over-marks))
+ (t
+ (defalias 'dired-unmark 'dired-unmark-subdir-or-file)
+ (defalias 'dired-mark 'dired-mark-subdir-or-file)
+ (defalias 'dired-get-marked-files 'dired-mark-get-files)
+ (defalias 'dired-map-over-marks 'dired-mark-map)))
+
+;;}}}
+;;{{{ glyphs
+
+;;; Thanks to Kyle Jone, kyle@wonderworks.com, in setnu.el
+
+(when (and nil (ti::emacs-p)) ;; disabled now
+ (defalias 'extent-live-p 'overlayp)
+ (defalias 'extentp 'overlayp)
+ (defalias 'make-extent 'make-overlay)
+ (defalias 'delete-extent 'delete-overlay)
+ (defalias 'extent-property 'overlay-get)
+ (defalias 'set-extent-property 'overlay-put)
+ (defalias 'set-extent-endpoints 'move-overlay)
+ (defalias 'extent-end-position 'overlay-end)
+ (defalias 'extent-start-position 'overlay-start)
+ (defalias 'extent-start-position 'overlay-buffer)
+ (defalias 'extent-start-position 'overlay-buffer)
+ (defalias 'next-extent-change 'next-overlay-change)
+ (defalias 'extent-properties 'overlay-properties)
+
+ (defun extent-list (buffer point)
+ "tinylibxe.el -- arg3 not supported."
+ (save-excursion
+ (if buffer
+ (set-buffer buffer))
+ (ti::funcall 'overlays-at point)))
+
+ (defun extent-length (e)
+ "tinylibxe.el -- return overlay length."
+ (- (ti::funcall 'overlay-end e) (ti::funcall 'overlay-start e))))
+
+(defvar ti:xe-begin-glyph-property (if (fboundp 'extent-property)
+ 'begin-glyph
+ 'before-string)
+ "Property name to use to set teh begin glyph of an extent.")
+
+(ti::fboundp-check-autoload 'set-overlay-begin-glyph "tinylibxe"
+ (defun set-overlay-begin-glyph (e g)
+ "tinylibxe -- Set glyph G in overlay E."
+ (ti::funcall 'overlay-put e ti:xe-begin-glyph-property g)))
+
+(ti::fboundp-check-autoload 'make-glyph "tinylibxe"
+ (defalias 'make-glyph 'identity))
+
+(cond
+ ((ti::emacs-p)
+ (unless (fboundp 'set-glyph-face)
+ (defun set-glyph-face (g face)
+ "tinylibxe -- Set glyph G to FACE"
+ (put-text-property 0 (length g) 'face face g))))
+
+ (t
+ ;;(defalias 'set-glyph-face 'ignore)
+ nil))
+
+;;}}}
+;;{{{ misc
+
+(when (and nil ;Idea only...
+ (not (fboundp 'easy-menu-add-item))
+ (fboundp 'add-menu-button))
+ (defun easy-menu-add-item ()
+ (cond
+ ((fboundp 'easy-menu-add-item) ;XEmacs 21.x
+ (easy-menu-add-item 'rest-of-the-args))
+ ((fboundp 'add-menu-button) ;XEmacs
+ ;; (add-menu-button
+ ;; '("Tools")
+ ;; ["List Ediff Sessions" ediff-show-registry t] "OO-Browser...")
+ nil)
+ (t
+ (define-key
+ ;; support for pre FSF 20.3
+ 'nothing-yet
+ 'nothing-yet)))))
+
+;;; From wid-edit.el by Per Abrahamsen <abraham@dina.kvl.dk>
+(when (and (not (fboundp 'error-message-string))
+ (fboundp 'display-error))
+ ;; Emacs function missing in XEmacs.
+ (defun error-message-string (obj)
+ "Convert an error value to an error message."
+ (let ((buffer (get-buffer-create " *error-message*")))
+ (with-current-buffer buffer
+ (erase-buffer)
+ ;; Only exist in new emacs release
+ (ti::funcall 'display-error obj buffer)
+ (buffer-string)))))
+
+;; XEmacs doesn't have 'timer package; but 'itimer
+(ti::fboundp-check-autoload 'run-at-time "tinylibxe"
+ (defun run-at-time (time repeat function &rest args)
+ "tinylibxe -- XEmacs and Emacs Compatibility."
+ (require 'itimer)
+ ;; start-itimer: (name function value &optional restart)
+ ;; start-itimer: (NAME FUNCTION VALUE &optional RESTART IS-IDLE WITH-ARGS
+ ;; &rest FUNCTION-ARGUMENTS)
+ ;; We can't use following Emacs arguments: ARGS
+ ;; (run-at-time TIME REPEAT FUNCTION &rest ARGS)
+ (ti::funcall
+ 'start-itimer
+ (cond ;ARG1 NAME
+ ((symbolp function)
+ (symbol-name function))
+ (t
+ "itimer-with-no-name"))
+ function ;ARG2 FUNCTION
+ (if (integerp repeat) ;ARG3 VALUE
+ repeat 10)
+ (if (integerp repeat) ;ARG4 &optional RESTART
+ repeat 10))))
+
+(ti::fboundp-check-autoload 'cancel-timer "tinylibxe"
+ (defun cancel-timer (timer)
+ "tinylibxe -- XEmacs & Emacs Compatibility."
+ (ti::funcall 'delete-itimer timer)))
+
+;;}}}
+;;{{{ advice: code from XEmacs --> Emacs
+
+(when (ti::xemacs-p)
+ (require 'advice)
+
+ ;; This is same as 'beep'
+ ;; Emacs, subr.el:(defalias 'beep 'ding) ;preserve lingual purity
+ ;;
+ (defadvice ding (around tinylibxe (&optional arg &rest args) act)
+ "tinylibxe -- Define Xemacs compatible ding comamnd. Ignores arg 2."
+ ad-do-it)
+
+ (defadvice make-sparse-keymap (before tinylibxe (&optional no-op) act)
+ "tinylibxe -- This advice does nothing except adding an optional argument
+to keep the byte compiler happy when compiling Emacs specific code
+with XEmacs."))
+
+;;}}}
+
+(provide 'tinylibxe)
+
+;;; tinylibxe.el ends here
--- /dev/null
+;;; tinyliby.el --- Library of functions related to Emacs s(y)stem
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 1995-2007 Jari Aalto
+;; Keywords: extensions
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program, call M-x tiliby-version.
+;; Look at the code with folding.el
+
+;; COPYRIGHT NOTICE
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;; ........................................................ &t-install ...
+;; You put this file on your Emacs-Lisp load path, add following into your
+;; .emacs startup file
+;;
+;; (require 'tinyliby)
+;;
+;; But, normally that is not required. All these functions are autoloaded
+;; from the main library, so simple
+;;
+;; (require 'tinylibm)
+;;
+;; will also cover these functions.
+
+;;}}}
+;;{{{ Documentation
+
+;; ..................................................... &t-commentary ...
+
+;;; Commentary:
+
+;; Briefly
+;;
+;; o This is lisp code library. Package itself does nothing.
+;; o Collection of Emacs s(y)stem related functions.
+;;
+;; Examples
+;;
+;; If you're MH, VM user, don't get upset on this example. If you use
+;; RMAIL, but one day you accidentally start VM ... your whole
+;; mail system may be broken. To prevent accidents, you could
+;; wipe all traces of VM and MH with function below. THe function takes a
+;; while to execute.
+;;
+;; (defun my-vm-mh-kill ()
+;; "Removes VM, MH permanently"
+;; (require 'tinyliby)
+;; (let (list)
+;; (setq list (ti::system-get-symbols "^vm-\\|^vm$"))
+;; (ti::system-unload-symbols list)
+;; (setq list (ti::system-get-symbols "^mh-\\|^mh$"))
+;; (ti::system-unload-symbols list)
+;; (setq list (ti::system-get-symbols "hook"))
+;; (ti::system-remove-from-hooks list "^vm\\|mh")))
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+;;{{{ setup: require
+
+(require 'tinylibm)
+
+(eval-and-compile
+ (autoload 'adelete "assoc"))
+
+(eval-when-compile
+ (require 'advice)
+ (ti::package-use-dynamic-compilation))
+
+;;}}}
+
+;;{{{ setup: -- variables
+
+(defvar ti::system-:describe-symbols-history nil
+ "History of used regular expressions.")
+
+(defvar ti::system-:tmp-buffer "*ti::system-tmp*"
+ "*Temporary buffer name.")
+
+(defvar ti::system-:desc-buffer "*desc*"
+ "*Describe buffer.")
+
+;;}}}
+;;{{{ setup: -- version
+
+(defconst tinyliby-version
+ (substring "$Revision: 2.48 $"11 15)
+ "Latest version number.")
+
+(defconst tinyliby-version-id
+ "$Id: tinyliby.el,v 2.48 2007/05/01 17:20:46 jaalto Exp $"
+ "Latest modification time and version number.")
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyliby-version (&optional arg)
+ "Show version information. ARG will instruct to print message to echo area."
+ (interactive "P")
+ (ti::package-version-info "tinyliby.el" arg))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyliby-submit-feedback ()
+ "Submit suggestions, error corrections, impressions, anything..."
+ (interactive)
+ (ti::package-submit-feedback "tinyliby.el"))
+
+;;}}}
+;;{{{ features, load list
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::system-package-where-is-source (package)
+ "Try to locate PACKAGE as string. the one used in `load` command.
+nil parameter is also accepted."
+ (cond
+ ((null package)) ;Skip right away
+ ((string-match "^\\([a-z]:\\)?[\\/]" package)
+ package)
+ ((string-match "\\.el$\\|\\.elc$" package)
+ (locate-library package))
+ (t
+ (locate-library (ti::string-verify-ends package ".el$" ".el")))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::system-load-cleanup (ELT)
+ "Remove ELT from `after-load-alist' by replacing entry with nil."
+ (let* (forms)
+ (dolist (elt after-load-alist)
+ (setq forms (cdr elt))
+ (dolist (frm forms)
+ ;; change form to nil
+ (if (equal frm ELT)
+ (setcar forms nil))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::system-load-history-emacs-lisp-files ()
+ "Return lisp of known Emacs lisp files in `load-history'."
+ (let* (list)
+ (dolist (entry load-history) ;point to functions
+ (push (car entry) list))
+ list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::system-load-history-where-exactly (sym load-history-elt)
+ "After `ti::system-load-history-where' return the elt whre entry is, check `require'.
+
+Return:
+
+ provide-symbol This function returns the provide name which
+ defined the symbol.
+
+Example of LOAD-HISTORY-ELT:
+
+'(\"some-package.el\"
+ (require . custom)
+ gnus-undo-limit gnus-undo-mode gnus-undo-mode-hook ...
+ |
+ Suppose we search this SYM
+ (provide . gnus-undo) << This package provided the symbols
+ ...)"
+ (let* ( ;; require
+ provide
+ item
+ current
+ ret)
+ (dolist (elt load-history-elt)
+ (cond
+ ((ti::listp elt)
+ (setq item (car elt))
+ (cond
+ ((eq item 'provide)
+ (setq provide (cdr elt))
+ ;; if RET has been; indicating that SYM was found,
+ ;; terminate on next provide that should be just after the sym list
+ ;;
+ ;; (require ...)
+ ;; ...sym sym SYM sym sym
+ ;; (provide 'package)
+ (when ret
+ (setq ret provide)
+ (return)))))
+ ((symbolp elt)
+ (setq current elt)))
+ (when (eq sym current)
+ (setq ret provide)))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::system-load-history-where-1 (sym)
+ "Look `load-history' to find SYM. The SYM may be function or variable name.
+
+Return:
+
+ list feature's load history entry where variable were found.
+ nil no information in `load-history' about this variable."
+ (dolist (entry load-history) ;point to functions
+ ;; (FILE (REQUIRE) (REQ) SYM SYM SYM ...)
+ (when (memq sym entry)
+ (return entry))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::system-doc-where-is-source (sym)
+ "Check documentation string of SYM to determine location of definition."
+ (let* ( ;; Defined in `textmodes/fill'.
+ (sfile (and (fboundp 'symbol-file)
+ (ti::funcall 'symbol-file sym)))
+ (file (and (stringp sfile)
+ ;; Use Two a-z's because win32 has D:/ at front
+ (if (string-match "^[a-z][a-z].*/\\(.*\\)" sfile)
+ (match-string 1)
+ sfile))))
+
+ (or (and file
+ (or (and (ti::file-name-path-p file)
+ file)
+ (locate-library file)))
+
+ (let ((doc (documentation-property
+ sym 'variable-documentation)))
+ (when (string-match
+ (concat
+ ;; Emacs: run-at-time is an interactive Lisp function in `timer'.
+ "^.*Lisp[ \t]+function[ \t]+in[ \t'`]+\\([^ \n\r\f\t'`\"]+\\)"
+ ;; XEmacs: -- loaded from "e:\usr\local\bin\emacs...
+ "\\|--[ \t]+loaded from[ \t\"]+\\([^ \n\r\f\t'`\"]+\\)")
+ (or doc "")))))))
+
+;;; ----------------------------------------------------------------------
+;;; Emacs doc string say: Defined in `frame'.
+;;;
+(defun ti::system-load-history-where-is-source (sym)
+ "Check documentation or `load-history' to find SYM.
+The SYM may be function or variable name.
+
+Note:
+
+ From Emacs point of view, a variable is defined at the point
+ where `defconst' or similar `defcustom' or `defvar' is used.
+
+Return:
+
+ string Absolute filename where the symbol was defined."
+ (let* (elt
+ provide
+ file)
+ (when (setq elt (ti::system-load-history-where-1 sym))
+ (setq file (car elt) ;default
+ provide (ti::system-load-history-where-exactly sym elt))
+ (or (and provide
+ (ti::system-package-where-is-source (symbol-name provide)))
+ (and (not (ti::file-name-path-p file))
+ (ti::system-package-where-is-source file))
+ file))))
+
+;;; ----------------------------------------------------------------------
+;;; - Does little garbage collect...but what the heck!
+;;; - lh = load-history
+;;;
+(defun ti::system-load-history-get (sym)
+ "Return variables and functions defined by feature SYM.
+The symbols are tested to be [f]boundp, so the list consists of
+those elements only that actually exist in emacs.
+
+Return:
+
+ ((variable-list ..) (func-list ..))"
+ (let* ((name (symbol-name sym))
+ (list (cdr (assoc name load-history)))
+ vl
+ fl
+ el
+ ptr)
+
+ (if (null list) nil
+ ;; Search the variables' and funtions' start position in list
+ (while (and list
+ (listp (car list)))
+ (setq list (cdr list)))
+ (setq ptr list)
+ (while ptr
+ (setq el (car ptr))
+ (if (listp el)
+ nil
+ (if (boundp el)
+ (setq vl (append vl (list el))))
+ (if (fboundp el)
+ (setq fl (append fl (list el)))))
+ (setq ptr (cdr ptr))))
+ (if (or vl fl)
+ (list vl fl)
+ nil)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::system-enable-disabled-options (&optional verb)
+ "Map all variable symbols and enable options.
+by default, Emacs comes with few presetting disabled. You
+can enable those features (if you knwo what are disabled) wtih
+code like:
+
+ (put 'downcase-region 'disabled nil)
+
+However, this function is more general and it can find
+all user variables i.e. options, that might be disabled.
+
+INPUT:
+
+ verb Print verbose messages."
+ (interactive)
+ (mapatoms
+ (function
+ (lambda (sym)
+ (let (arg)
+ (when (and (boundp 'sym)
+ (setq arg (memq 'disabled (symbol-plist sym)))
+ ;; ARG = '(disabled t ..)
+ (nth 1 arg))
+ (when verb
+ (message "Tinyliby: Enabling variable `%s'" (symbol-name sym)))
+ (put sym 'disabled nil)))))))
+
+;;; ----------------------------------------------------------------------
+;;; - Be sure what your're doing if using this...
+;;;
+(defun ti::system-feature-kill (sym)
+ "Kill feature SYM and its `load-history' information permanently."
+ (let* ((name (symbol-name sym)))
+ ;; Load history , dependencies remove
+ (if (assoc name load-history)
+ (setq load-history (adelete 'load-history name)))
+
+ ;; Kill the symbol from feature list
+ (if (featurep sym)
+ (setq features (delete sym features)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::system-unload-symbols (list)
+ "Unload all variables and functions in LIST of symbols."
+ (mapcar
+ (function
+ (lambda (x)
+ (cond
+ ((fboundp x)
+ (fmakunbound x))
+ ((boundp x)
+ (makunbound x)))))
+ list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::system-unload (mode list)
+ "According to MODE, unload all variables/features/functions in LIST.
+
+MODE can be
+'var list of variables
+'func list of functions
+'feature list of features , caution !! Be sure to get
+ feature's variable and function list before you use this,
+ since it'll delete all information that `unload-feature' needs.
+ The `unload-feature' is not always good cmd, because it checks
+ dependencies and may not allow you to delete a feature.
+
+References:
+
+ `ti::system-get-symbols'."
+ (let* (test-func
+ kill-func)
+ (cond
+ ((eq 'var mode)
+ (setq test-func 'boundp
+ kill-func 'makunbound))
+ ((eq 'func mode)
+ (setq test-func 'fboundp
+ kill-func 'fmakunbound))
+ ((eq 'feature mode)
+ ;; - Emacs don't let us remove a feature if it contains some
+ ;; require statement. Be sure to get the information
+ ;; about the variables and func first before killing feature,
+ ;; since we destroy load-history information also!!
+ ;;
+ (setq test-func 'featurep
+ kill-func 'unload-feature))
+ (t
+ (error "unknown mode" mode)))
+ (dolist (var list)
+ ;; Test if exist
+ (when (funcall test-func var)
+ (cond
+ ((eq kill-func 'unload-feature)
+ ;; Feature kill is special
+ (ti::system-feature-kill var))
+ ((eq kill-func 'fmakunbound)
+ ;; This is shooting with rocks, by calling advice,
+ ;; but it's safest this way.
+ (ad-unadvise var)
+ (funcall kill-func var))
+ (t
+ (funcall kill-func var)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::system-unload-feature (sym &optional verb)
+ "Unload feature SYM, by cleaning `load-history' for all SYM symbols. VERB.
+This is far more extensive wipeout than `unload-feature': All variables,
+functions and ´load-history' is cleaned.
+
+Return:
+ t If feature existed _and_ removed.
+ nil If feature does not exist."
+ (interactive
+ (list
+ (intern-soft
+ (completing-read
+ "Complete feature to unload: "
+ (ti::list-to-assoc-menu (mapcar 'prin1-to-string features))
+ nil 'must-match))))
+
+ (let* (list)
+ (ti::verb)
+
+ (when sym
+ (when (setq list (ti::system-load-history-get sym)) ;get (\var func\) list
+ (ti::system-unload 'feature (list sym)) ;feature + load-history clean
+ (ti::system-unload 'var (nth 0 list) )
+ (ti::system-unload 'func (nth 1 list) ))
+ (ti::system-feature-kill sym))
+
+ (if verb
+ (message "Feature now completely unloaded."))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::system-unload-feature-list (list)
+ "Remove feature LIST, their variables and functions.
+Input is list of features. Does not check any dependencies between features."
+ (dolist (feature list)
+ (ti::system-unload-feature feature)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'ti::system-symbol-dolist-macro 'lisp-indent-function 1)
+(defmacro ti::system-symbol-dolist-macro (symlist &rest body)
+ "Map throught SYMLIST and execute BODY for each hook function.
+You can refer to variables `hook' and `function' in BODY."
+ (`
+ (let* (hook-functions)
+ (dolist (hook (, symlist))
+ (when (boundp hook)
+ (setq hook-functions (symbol-value hook))
+
+ (if (and (not (ti::bool-p hook-functions))
+ (symbolp hook-functions))
+ ;; single function in hook
+ (setq hook-functions (list hook-functions)))
+
+ (when (listp hook-functions)
+ (dolist (function hook-functions)
+ (when (and (not (eq function 'lambda)) ;skip lambda notation
+ (symbolp function))
+ (,@ body)))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::system-remove-from-hooks (symlist re)
+ "Look hook SYMLIST and remove all symbols matching RE.
+
+If hook element is in form of 'lambda' instead of callable function symbol,
+this element is ignored. This function cannot remove lambda functions
+from hook, because match is done against `symbol-name'."
+ (mapcar
+ (function
+ (lambda (hook) ;one hook at the time
+ (if (null (boundp hook)) ;is list element variable ?
+ nil ;cannot handle it
+ (cond
+
+ ;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ add-hook form ^^^
+
+ ((listp (eval hook)) ;is hook in '(...) form ?
+;;; (ti::d! "list" hook)
+ (mapcar ;step functions in list
+ (lambda (el)
+ (if (and (not (eq el 'lambda)) ;skip lambda notation
+ (symbolp el)
+ (string-match re (symbol-name el)))
+ (remove-hook hook el)))
+ (eval hook)))
+
+ ;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ setq form ^^^
+
+ ((and (symbolp (eval hook)))
+ (if (string-match re (symbol-name hook))
+ (set hook nil)))))))
+ symlist))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::system-match-in-hooks (regexp &optional buffer)
+ "Search SYMLIST for every hook functions that match REGEXP.
+Write results i temporary buffer or BUFFER."
+ (interactive
+ (list
+ (read-string "Regesp: ")))
+
+ (or buffer
+ (setq buffer (ti::temp-buffer ti::system-:desc-buffer 'clear)))
+
+ (with-current-buffer buffer
+ (ti::system-symbol-dolist-macro
+ (ti::system-get-symbols "-hook$\\|-functions$")
+ (when (string-match regexp (symbol-name function))
+ (insert (format "%-34s %s\n" (symbol-name hook)
+ (symbol-name function))))))
+
+ (if (interactive-p)
+ (pop-to-buffer buffer))
+
+ buffer)
+
+;;}}}
+;;{{{ internal Symbols
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::system-get-symbols (re &optional test-form)
+ "Return list of symbols that match RE.
+
+The function 'mapatom' will return ALL symbols, no matter if they don't
+even exist any more [fboundp, boundp].
+
+You can supply your own TEST-FORM to cause it drop away certain atoms.
+the current atom is stored in variable 'sym'.
+
+Eg. test-form = '(or (fboundp sym) (boundp sym))"
+ (let* (list)
+ (mapatoms
+ (function
+ (lambda (sym)
+ (if (and (string-match re (symbol-name sym))
+ (or (null test-form)
+ (eval test-form)))
+ (push sym list)))))
+ list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::system-autoload-function-list ()
+ "Return list of autoload function."
+ (let* (list)
+ (mapatoms
+ (function
+ (lambda (sym)
+ (when (ti::autoload-p sym)
+ (pushnew sym list :test 'equal)))))
+ list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::system-autoload-function-file-list (function-list)
+ "Return unique filenames of autoload functions."
+ (let* (list
+ str)
+ (dolist (func function-list)
+ (when (setq str (inline (ti::function-autoload-file func)))
+ (pushnew (match-string 1 str) list :test 'string-equal)))
+ list))
+
+;;; ----------------------------------------------------------------------
+;;; - There is another possibility, step through `load-history', but
+;;; since it's not in all emacs and it's buggy (at least in 19.28)
+;;; we don't use it here...
+;;;
+(defun ti::system-get-file-documentation (file &optional verb)
+ "Gather all documentation from symbols in FILE.
+You have to load the file into emacs first (eval it), because this
+function reads the documentation properties from memory.
+
+Input:
+
+ FILE absolute file name
+ VERB if non-nil, verbose messages are printed and
+ the buffer is displayed when function finishes.
+
+Return:
+
+ buffer pointer where documentation is stored."
+ (interactive
+ (let* (file
+ feature)
+ (setq file
+ (call-interactively
+ (function
+ (lambda (f)
+ (interactive "FDocs from lisp package file: ") f))))
+ ;; We must find the FILE.el name
+ (or (setq feature (ti::string-match ".*/\\(.*\\)\\.el$" 1 file))
+ (error "Can't read .el filename. %s " file))
+ ;; there must be 'FILE feature
+ (or (and (intern-soft feature)
+ (setq feature (intern-soft feature)))
+ (y-or-n-p (format "\
+No '%s feature found, are you absolutely sure you have loaded the file? "
+ feature))
+ (error "Abort."))
+ (list file)))
+ (let* ((tmp-buffer (ti::temp-buffer ti::system-:tmp-buffer 'clear))
+ (file-buffer (ti::find-file-literally file))
+ (all-re (concat "^[(]\\([ \t]*"
+ "defsubst\\|defvar\\|defconst"
+ "\\|defmacro\\|defun"
+ "\\|defadvice\\|deffoo\\|defvoo"
+ "\\)[ \t]*\\([^ \t\n\f()]+\\)"))
+ (func-re (concat "defsubst\\|defmacro\\|defun"
+ "\\|defadvice\\|deffoo\\|defvoo"))
+ (verb (or verb (interactive-p)))
+ (count 0)
+ ok-flag
+ doc
+ type
+ sym-name
+ sym
+ paren)
+ (unwind-protect
+ (with-current-buffer file-buffer
+ (ti::pmin)
+ (while (re-search-forward all-re nil t)
+
+ (setq type (match-string 1)
+ sym-name (match-string 2)
+
+ ;; (defvar list) --> (boundp 'list) = nil !! suprise
+ ;;
+ paren (and (member type '("defvar" "defconst"))
+ (looking-at "[ \t]*)"))
+ sym (intern-soft sym-name)
+ doc nil)
+ (incf count)
+ ;; print messages for every 10th only, it's too fast to
+ ;; show every symbol...
+ (if (and verb
+ (= 0 (% count 10)))
+ (message (concat (int-to-string count) ": " sym-name)))
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... .. func ...
+ (cond
+ ((and (string-match "defadvice" type)
+ (or (null sym)
+ (not (fboundp sym))))
+ (setq doc
+ (format
+ "tinyad: %s does nto exist yet. Can't read documentation."
+ sym-name)))
+ ((string-match func-re type)
+ (if (or (null sym)
+ (not (fboundp sym)))
+ (error (concat "Tinyliby: function not bound " sym-name))
+
+ (setq doc
+ (format
+ "%-40s%s\n%s\n\n"
+ sym-name
+ "Function: "
+ (or (documentation sym)
+ "not documented")))))
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... .. var ..
+ ((not paren)
+ (if (or (null sym)
+ (not (boundp sym)))
+ (error (concat "Tinyliby: variable not bound " sym-name))
+ (setq sym (intern-soft sym-name))
+ (setq doc
+ (format "%-40s%s\n%s\n\n"
+ sym-name
+ (if (user-variable-p sym)
+ "Option: " "Variable: ")
+ (or (documentation-property
+ sym 'variable-documentation)
+ "not documented"))))))
+
+ (if doc
+ (ti::append-to-buffer tmp-buffer doc)))
+ (setq ok-flag t)) ;all completed
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... . cleanup . .
+ ;; - Recover from Ctrl-g, remove the loaded file.
+ ;;
+ (kill-buffer file-buffer))
+ (if (and verb ok-flag)
+ (pop-to-buffer tmp-buffer)) ;show contents
+ (if verb
+ (message "")) ;clear the echo area
+ tmp-buffer))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::system-describe-symbols-i-args (&optional arg)
+ "Ask interactive arguments for `ti::system-describe-symbols'. ARG is prefix arg."
+ (let* (prompt
+ char
+ ans)
+ ;; When user calls us without arguments, offer menu to pick
+ ;; search item
+ (unless arg
+ (setq char (ti::read-char-safe "\
+ v)ars o)options non-(O)options i)nteractive funcs f)uncs all RET)all"))
+ (cond
+ ((char= char ?v) (setq arg '(4)))
+ ((char= char ?o) (setq arg '(16)))
+ ((char= char ?O) (setq arg '64))
+ ((char= char ?i) (setq arg 0))
+ ((char= char ?f) (setq arg 9))))
+ (setq prompt
+ (cond
+ ((equal arg '(4))
+ "Describe <vars all> matching: ")
+ ((equal arg '(16))
+ "Describe <var options> matching: ")
+ ((equal arg '(64))
+ "Describe <var non-options> matching: ")
+ ((equal arg 0)
+ "Describe <funcs interactive> matching: ")
+ ((equal arg 9)
+ "Describe <funcs non-interactive> matching: ")
+ ((integerp arg)
+ "Describe <funcs all> matching: ")
+ (t
+ "Describe <all> symbols matching: ")))
+ (list
+ (read-from-minibuffer ;ARG 1
+ prompt nil
+ nil nil
+ 'ti::system-:describe-symbols-history)
+ arg ;ARG 2
+ ;; Now handle exclude regexp ;ARG 3
+ (if (ti::nil-p (setq ans (read-from-minibuffer "exclude: ")))
+ nil
+ ans)
+ (if (not (ti::listp arg)) ;ARG
+ (y-or-n-p "Try to find key binding info too (takes longer)? "))
+ nil))) ;ARG 5
+
+;;; ----------------------------------------------------------------------
+;; - This originates from the elisp manual pages somewhere,
+;; but I have made major additions and modifications to it.
+;; - Actually this is massive add-on to the original one e.g. it can look
+;; behind aliased functions (fset, defalias) and has nice
+;; interactive interface.
+;;
+;; - I suggest that you add this to your .emacs, since
+;; this function is utterly useful for locating anything.
+;;* (autoload 'describe-symbols "tinyliby" t t)
+;;* (if (not (fboundp 'describe-symbols))
+;;* (defalias 'describe-symbols 'ti::system-describe-symbols))
+;;
+;;
+(defun ti::system-describe-symbols
+ (pattern &optional mode exclude-re bind-info out-buffer)
+ "Describe the Emacs Lisp symbols matching PATTERN.
+All symbols that have PATTERN in their name are described.
+
+MODE can be
+
+ nil return everything
+
+ list 4 return variables prefix arg \\[universal-argument]
+ list 16 return only options, prefix arg \\[universal-argument] \\[universal-argument]
+ list 64 return only non-options, prefix arg \\[universal-argument] \\[universal-argument] \\[universal-argument]
+
+ nbr return only functions
+ nbr 0 return only interactive functions
+ nbr 9 return only non-interactive functions
+
+EXCLUDE-RE
+
+ Excludes matches.
+
+BIND-INFO
+
+ If non-nil, then try to find binding info too. Note: if this flag
+ is on, the time function executes decreases dramatically.
+
+OUT-BUFFER
+
+ Where to print the info.
+
+References:
+
+ `ti::system-:desc-buffer'"
+ ;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ interactive ^^^
+ (interactive (ti::system-describe-symbols-i-args current-prefix-arg))
+
+ ;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ interactive end ^^^
+ (let* ((buffer (or out-buffer ti::system-:desc-buffer))
+ subrp-test
+ MF MFI MFF ;mode func
+ MV MVO MVV ;mode var
+ sym-list
+ ALIAS
+ FUNC
+ (DEF "")
+ tmp
+ ;; Build up the function cell into variable 'describe-func'
+ (describe-func
+ (function
+ (lambda (s) ;; <-- symbol IN
+ ;; ............................................. function ...
+ ;; Print description of symbol.
+ (cond
+ ((and MF (fboundp s))
+ ;; (ti::d! 'function mode s MF MFI MFF)
+ (setq ALIAS (ti::defalias-p s))
+ (setq FUNC (or ALIAS s))
+ (cond ;; what is the main class ?
+ ((and MFI (commandp FUNC)) ;; means interactive
+ (setq DEF "Command: "))
+ ((and MFF)
+ (setq DEF "Function: ")))
+ (if ALIAS
+ (setq DEF (concat DEF "Alias: " (symbol-name ALIAS))))
+ (if (ti::autoload-p FUNC)
+ (setq DEF (concat DEF " Autoload: ")))
+ (princ
+ (format
+ "%-40s %s\n%s%s%s%s\n\n"
+ s
+ DEF
+ (or (and (setq tmp (ti::function-args-p FUNC))
+ (progn
+;;; (ti::d! FUNC "ARGS" tmp (symbol-function FUNC))
+
+ ;; in xe, this doesn't print functions arguments,
+ ;; but the pacakge load information
+ ;; '(from "ange-ftp.elc")', but that's good to
+ ;; know too.
+ ;;
+ (concat tmp "\n")))
+ (and (ti::lambda-p FUNC)
+ (concat
+ (ti::string-left (prin1-to-string
+ (symbol-function FUNC)) 75)
+ "..\n"))
+ "<Can't read func arglist>")
+ ;; .................................... function info ...
+ (when (or MF MFI MFF)
+ (concat
+ (cond
+ ((setq subrp-test (subrp (symbol-function s)))
+ "<Built-in-Lisp-primitive>\n")
+ ((ti::byte-compile-defun-compiled-p s)
+ "<Byte-compiled> ")
+ ((ti::defmacro-p s)
+ "<Macro> ")
+ (t
+ ""))
+
+ (if subrp-test
+ ""
+ (concat
+ "<Package: "
+ (or (car-safe (ti::system-load-history-where-is-source s))
+ "unknown")
+ ">"))))
+ (if (and
+ bind-info
+ (and (or MF MFI MFF)
+ (setq tmp (ti::keymap-function-bind-info s))))
+ (concat "\t" tmp "\n")
+ "\n")
+ (or (condition-case ()
+ (documentation FUNC)
+ (error "<Function does not exist; not defined>"))
+ "not documented")))) ;; cond-function
+ ;; ............................................. variable ...
+ ((and MV (boundp s))
+ ;; (ti::d! 'variable mode s MV MVO MVV)
+ (cond
+ ((and MVO (user-variable-p s)) ;; option var
+ (princ
+ (format "%-40s %-9s%s\n%s\n\n"
+ s
+ "Option: "
+ (prin1-to-string (eval s))
+ (or (documentation-property
+ s 'variable-documentation)
+ "not documented"))))
+ ((and MVV )
+ (princ
+ (format "%-40s %-9s%s\n%s\n\n"
+ s
+ "Variable: "
+ (prin1-to-string (eval s))
+ (or (documentation-property
+ s 'variable-documentation)
+ "not documented")))))))))))
+
+ ;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ let end ^^^
+ (cond
+ ((and (not (null mode))
+ (listp mode))
+ (setq MV t MVO t MVV t)
+ (cond
+ ((equal mode '(16))
+ (setq MVV nil ))
+ ((equal mode '(64))
+ (setq MVO nil ))))
+ ((integerp mode)
+ (setq MF t MFI t MFF t)
+ (cond
+ ((= 0 mode)
+ (setq MFF nil))
+ ((= 9 mode)
+ (setq MFI nil))))
+ (t
+ (setq MV t MVO t MVV t MF t MFI t MFF t)))
+ ;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ options end ^^^
+ ;; Build a list of symbols that match pattern.
+ (mapatoms (function
+ (lambda (sym)
+ (if (and (string-match pattern (symbol-name sym))
+ (or (null exclude-re)
+ (and (stringp exclude-re)
+ (not
+ (string-match exclude-re
+ (symbol-name sym))))))
+ (setq sym-list (cons sym sym-list))))))
+
+ ;; Display the data.
+ (if (null sym-list)
+ (message "Describe symbols: No matches for given criterias.")
+ (with-output-to-temp-buffer buffer
+ (mapcar describe-func (sort sym-list 'string<))
+ (print-help-return-message)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun ti::system-describe-symbol-summary (re &optional verb)
+ "Make elisp script out of variables and functions that match RE. VERB.
+Supposes that point is on buffer that is produced by
+`ti::system-describe-symbols'
+
+Return:
+
+ buffer where is ready output"
+ (interactive "sRe: ")
+ (let* ((out-buffer (ti::temp-buffer ti::system-:tmp-buffer 'clear))
+ (verb (or verb (interactive-p)))
+ list
+ words
+ var
+ vlist
+ flist)
+ (setq list
+ (ti::buffer-grep-lines
+ (concat (or re "")
+ ".*\\(command\\|variable\\|option\\|function\\):")))
+ (save-excursion
+ (set-buffer out-buffer)
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... ... ... ...
+
+ (dolist (line list)
+ (setq words (split-string line)
+ var (nth 0 words))
+ (cond
+ ((string-match "Variable\\|option" line)
+ (push var vlist))
+ ((string-match "Command\\|Function" line)
+ (push var flist))
+ (t
+ ;; problem with line ?
+ (insert (concat "#" line "\n")))))
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... ... ... ...
+ (lisp-mode)
+ (insert "(defconst vlist\n '(\n")
+ (setq vlist (nreverse vlist))
+ (dolist (elt vlist)
+ (insert (concat elt "\n")))
+ (insert ")\n \"Variables\")\n\n")
+ (insert "(defconst flist\n '(\n")
+ (setq flist (nreverse flist))
+ (dolist (elt flist)
+ (insert (concat elt "\n")))
+ (insert ")\n \"Functions\")\n\n")
+ (indent-region (point-min) (point-max) nil))
+ (if verb
+ (pop-to-buffer out-buffer))
+ out-buffer))
+
+;;}}}
+
+(provide 'tinyliby)
+
+;;; tinyliby.el ends here
--- /dev/null
+;;; tinylisp.el --- Emacs lisp programming help grab-bag
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 1997-2007 Jari Aalto
+;; Keywords: tools
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program use M-x tinylisp-version
+;; Look at the code with folding.el
+
+;; COPYRIGHT NOTICE
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;;; Install:
+
+;; ....................................................... &t-install ...
+;; Put this file on your Emacs-Lisp load path, add following into your
+;; ~/.emacs startup file.
+;;
+;; ;; Select some unused, non-shifted, fast prefix key.
+;; ;; My kbd accesses $ without shiff and it is seldom used
+;; ;; in lisp. Other alternatives: "!", "_" ":"
+;;
+;; (setq tinylisp-:mode-prefix-key "$")
+;; (setq tinylisp-:load-hook 'tinylisp-install)
+;; (require 'tinylisp)
+;;
+;; (setq tinylisp-:load-hook nil)
+;; Or prefer following autoload: your Emacs loads this package only
+;; when you need it.
+;;
+;; (autoload 'tinylisp-mode "tinylisp" "" t)
+;; (autoload 'turn-on-tinylisp-mode "tinylisp" "" t)
+;; (add-hook 'emacs-lisp-mode-hook 'turn-on-tinylisp-mode)
+;; (add-hook 'lisp-interaction-mode-hook 'turn-on-tinylisp-mode)
+;;
+;; (setq tinylisp-:load-hook 'tinylisp-install)
+;; (global-set-key "\C-ce" 'tinylisp-mode) ; mode on/off
+;; (global-set-key "\C-cmE" 'eldoc-mode) ; In lastest Emacs
+;;
+;; If you don't want to use the echo-menu, but regular keymap calls
+;; instead, put following into your ~/.emacs. This must be before any
+;; other TinyLisp settings. You must reload package every time if you
+;; change this setting.
+;;
+;; (setq tinylisp-:menu-use-flag nil)
+;;
+;; To manually install or uninstall mode, call:
+;;
+;; M-x tinylisp-install
+;; M-x tinylisp-uninstall
+;;
+;; If you have any questions, use this function
+;;
+;; M-x tinylisp-submit-bug-report
+
+;;}}}
+;;{{{ Documentation
+
+;; ..................................................... &t-commentary ...
+
+;;; Commentary:
+
+;; Preface, Feb 1997
+;;
+;; Private lisp help functions were scattered around files and
+;; in other private libraries. One day the author decided to write
+;; a minor mode to access all those tools that were written one by one
+;; and he I didn't want to continue stacking up `lisp-mode-hook'
+;; for all the growing features. So, if you're programming in Emacs
+;; Lisp, this minor mode may slightly increase your productivity.
+;;
+;; Overview of features
+;;
+;; Lisp coding help
+;;
+;; o Create list of all variables from the buffer. (or occur menu)
+;; You can use this list to update your bug report function or just
+;; to get an overview of the variables. Check names and the order how
+;; you have used them (The order is important if you use defcustom)
+;; o Create function list (or occur menu)
+;; o Create autoload list
+;; o Evaluate current definition under point (re-parse function,
+;; reset defvar or even defcustom variable)
+;; o Print variable's value under point, set variable's value
+;; under point (backs up the original value which you can restore)
+;; o Call function under point (to test it immediately)
+;; o Indent function/variable around point.
+;; o FINDS LISP CODE ERROR POINT.
+;; o In DEBUGGER *Backtrace* hit 'R' to record the content of the value
+;; to *tinylisp-record* This is great when you want to send bug report
+;; to maintainer and you can attach the state of the variables
+;; with it.
+;;
+;; o Code flow help: jump to variable of function definition even if
+;; it is located in different file. Does not use TAGS; but assumes
+;; that function is `known' to Emacs.
+;; o Two extra echo area modes: Show underlying properties/overlays or
+;; Show characters' syntax information.
+;;
+;; Edebug support
+;;
+;; o Cursor at function name and calling `tinylisp-edebug-instrument'
+;; will instrument remote function. If you used just
+;; plain edebug, then you'd have to manually load the function into
+;; current point and hit `edebug-eval-defun', for each function.
+;; (Note that "i" auto-instrument doesn't always work from
+;; edebug)
+;; o Easily uninstrument functions: at point, in buffer
+;;
+;; Elp support -- Lisp code profiling
+;;
+;; o Access elp commands from echo menu
+;; o Profile your package or buffer's functions easily.
+;; Sit somewhere in function and un/instrument it with one command.
+;; Un/instrument all functions in the buffer with one command.
+;;
+;; Elint support -- Lint your elisp code
+;;
+;; o Code by Peter liljenberg, code location unknown.
+;; o catches misspellings and undefined variables
+;; o function calls with the wrong number of arguments, and
+;; some typos such as (let (a (car b)) ...)
+;;
+;; Checkdoc support -- Check doc strings for style requirements
+;;
+;; o ftp://ftp.ultranet.com/pub/zappo
+;; o Easy interface to checkdoc commands.
+;; o A tool that makes sure your package follows the guidelines
+;; presented in File: elisp, Node: Documentation Tips.
+;;
+;; Find-func.el support
+;;
+;; o Use this package as backup if symbol lookup fails.
+;;
+;; Remarks
+;;
+;; o Please take a look new XEmacs package bench.el (19.15 and 20.2)
+;; for bechmarking.
+;;
+;; Tutorial, how do you check your package
+;;
+;; o $ f Take a look at your function names: are they well named,
+;; so that same categories begin with same words. Below it would be
+;; a mistake to have latter as xxx-ti::erase-buffer, because then
+;; you cant find all common function with `lisp-complete-symbol'
+;; command on xxx-buffer-*. Code is not a spoken language but
+;; meant to be used by programmers (Compare function naming in
+;; XEmacs and Emacs, where XEmacs does the the right thing)
+;;
+;; xxx-buffer-handling
+;; xxx-buffer-clear
+;;
+;; Check also that your macros are defined first before functions.
+;; If possible, maintain this definition order in your file
+;;
+;; defvar, defconst, defcustom (on top of file)
+;; defsubst
+;; defmacro
+;; defun
+;;
+;; o C-u $ v Check variable names as the function names above,
+;; but also see that you have defined right user variables which
+;; should be using `defcustom'. The extra C-u argument will print
+;; this information.
+;; o $ x Check the lisp package layout: first line and footer must
+;; be in proper format and that Author etc. tags are in
+;; their places.
+;; o Check the documentation strings with Checkdoc.
+;; To get overview of errors, do: $ c - and $ c RET
+;; which a) turned off query b) checked whole buffer for errors.
+;; When you have got a clear look, then start correcting mistakes
+;; and do $ c a (semiautomatic correction) $ c BACKSPACE to correct
+;; full buffer.
+;;
+;; Defcustom.el and evaluating an `defcustom' variable
+;;
+;; If you don't know what defcustom is, or if you don't use it, you
+;; can ignore this section. The defcustom variables are evaluated
+;; pretending like they were `defconst', but because this evaluation
+;; is a bit special, pay attention to following paragraph.
+;;
+;; If you got thrown to error during evaluation, pay attention now,
+;; CALL COMMAND $ Z or `M-x' `tinylisp-emergency' IMMEDIATELY. For full
+;; details, see function documentation strings in the source file for
+;; these:
+;;
+;; (defadvice defconst
+;; (defun tinylisp-eval-at-point
+;;
+;; Find lisp code error position
+;;
+;; The most useful functions in this package are the two error
+;; finding functions which try their best to put you on a line that
+;; generates the lisp error. You can use this feature to e.g. check
+;; your ~/.emacs startup files and find the spot where
+;; `eval-current-buffer' fails.
+;;
+;; The best function, `tinylisp-error-find-1', was programmed by Mikael
+;; Djurfeldt <mdj@sanscalc.nada.kth.se> and is included here with his
+;; permission. Thanks Mikael, the function saves lot lisp debugging.
+;;
+;; Following lisp code call chain
+;;
+;; The traditional way to follow lisp code is to use TAGS file (See
+;; 'etags' or 'ctags' shell binary and C-h a "tags") which reads bunch
+;; of *el files and builds up internal representation of all defined
+;; symbols and their locations.
+;;
+;; But using tags is not very flexible if you write the code yourself,
+;; because when you add new function or new variable, the TAGS file is
+;; immediately out of date. Hm. The TAGS is general tool for many
+;; programming languages, but in Emacs lisp, we can take advantage of
+;; the fact that Emacs already knows where the symbols are defined.
+;; The information is stored to `load-history' whenever you run `load'
+;; `require' `load-file' or `load-library'.
+;;
+;; In this package, there are two functions that make use of
+;; `load-history' and if the symbol is not in the history, they try to
+;; find definition from the current buffer. You see, if you do
+;; `eval-current-buffer' the definition information is _not_ stored to
+;; `load-history'. With these commands you can browse some packages
+;; without any extra TAGS file.
+;;
+;; [The only assumption is that you have `loaded' the file !!]
+;;
+;; $ ' tinylisp-jump-to-definition (do not record call chain)
+;; $ + tinylisp-jump-to-definition-chain (record call chain)
+;; $ \177 tinylisp-back-to-definition (probably your backspace key)
+;; This returns to previously saved call-chain point
+;;
+;; The jump command also know following prefix arguments
+;;
+;; M-0 $ ' tinylisp-jump-to-definition (empty call chain)
+;; C-u $ ' tinylisp-jump-to-definition (record call-chain)
+;;
+;; Examining text properties and overlays in buffer
+;;
+;; If you have ever played with text properties or overlays (called
+;; extents in XEmacs), you know how hard it is to examine buffer's
+;; characters and debug where the properties are.
+;;
+;; In this package there is "constant char browsing mode" where every
+;; time you move your cursor, the face info and/or overlay info is
+;; displayed in the echo-area. If you supply `3' `C-u' arguments, the
+;; information is also recored to the separate buffer. This is the
+;; most easiest way to examine some character properties in arbitrary
+;; buffer positions. See C-h f on following function:
+;;
+;; $ p tinylisp-property-show-mode
+;;
+;; Examining charcter syntax
+;;
+;; Major modes define syntax tables for characters and sometimes you
+;; want to see the syntax class of a character under cursor. This mode
+;; behaves in the same manner as text property display, just turn it on
+;; and it will constantly show char info.
+;;
+;; $ y tli-syntax-show-mode
+;;
+;; Snooping interesting variables
+;;
+;; Has is happened to you that you're debugging package and it
+;; installs many hooks and and sets many different variables and then
+;; you suddenly realize that it went all wrong? You may even have
+;; noticed that some ill behaving package keeps preventing file
+;; writing!
+;;
+;; No problem, you can define interesting variable sets to peek their
+;; contents, e.g. checking all file related hooks for problems. And if
+;; you supply C-u prefix arg, your editing is updated to the
+;; variables. With any other non-nil arg, the contents of the
+;; variables are recorded (kinda before install -- after install
+;; snooping) See function:
+;;
+;; $ s tinylisp-snoop-variables
+;;
+;; And additional prefix arguments: You can save variables states,
+;; modify them as you like, and go back to restores values.
+;;
+;; Elp: notes
+;;
+;; [excerpt from Barry's elp.el]
+;; ...Elp can instrument byte-compiled functions just as easily as
+;; interpreted functions, but it cannot instrument macros. However,
+;; when you redefine a function (e.g. with eval-defun), you'll need to
+;; re-instrument it with M-x `elp-instrument-function'. This will also
+;; reset profiling information for that function. Elp can handle
+;; interactive functions (i.e. commands), but of course any time spent
+;; idling for user prompts will show up in the timing results.
+;;
+;; To elp functions right, follow these steps. _*important*_ "(defun"
+;; must be left flushed in order the function to be found. If there is
+;; any leading spaces before the '(' or 'defun', then function won't
+;; be found and will not be (un)instrumented.
+;;
+;; o $ e A Restore (a)ll elp'd functions
+;; o $ - Eval buffer containing functions (or eval single function)
+;; o $ e I Instrument all functions in buffer (or single function)
+;; o $ e h Run the harness test that calls the functions
+;;
+;; Elp: Summary mode's sort capabilities
+;;
+;; When you call `$' ´E' `s' to show the elp result(s), the results
+;; buffer is put into `tinylisp-elp-summary-mode' where you can sort
+;; the columns with simple keystrokes. The sort keys correspond to the
+;; column names.
+;;
+;; f)unction Name c)all Count e)lapsed Time a)verage Time
+;; ============== =========== ============= =============
+;;
+;; Elp: customizations
+;;
+;; You should be aware of this variable in elp; which resets the list
+;; every time you display it. You can toggle it's value from the echo
+;; menu.
+;;
+;; elp-reset-after-results
+;;
+;; Edebug support
+;;
+;; To instrument function for edebug, you'd normally have cursor inside
+;; current function and call `C-u' `M-x' `edebug-eval-defun'. But
+;; suppose you only see function call like this:
+;;
+;; (my-function arg arg arg)
+;;
+;; then you'd have to a) find out where the function is defined
+;; b) load that file c) position cursor over the fuction definition
+;; d) call edebug to instrument it. That's too much of a work. Instead
+;; there are commands that do this for you. See edebug submap `C-e'
+;; for edebug commands
+;;
+;; $ C-e RET Instrument function _named_ at point
+;; $ C-e DEL Uninstrument function _named_ at point
+;; $ C-e SPC Instrument all functions in buffer
+;; $ C-e x Uninstrument all functions in buffer
+;; $ C-e X Uninstrument all functions instrumented by $ C-e RET
+;;
+;; Todo section
+;;
+;; In standard Emacs there seems to be underused package trace.el.
+;; Add direct support for it.
+;;
+;; The regress.el provides support for writing and executing
+;; regression tests for Emacs Lisp code. Could that be supported too?
+;;
+;; Add support to xray.el
+
+;;}}}
+;;{{{ history
+
+;;; Change Log:
+
+;;; Code:
+
+;;{{{ require
+
+;;; ......................................................... &require ...
+
+(require 'tinylibm)
+
+(ti::package-require-view) ;; TinyLisp must be first in the minor-mode-list
+
+(eval-when-compile
+ (require 'advice) ;; For apropos.el
+ ;; XEmacs 21.2 NT had a problem loading the edug.el. After
+ ;; debug.el was loaded first, the edebug.el load succeeded.
+ ;;
+ ;; In older XEmacs 20.4 edebug does not "provide", so this uses
+ ;; plain old `load' method.
+ (or (featurep 'debug)
+ (load "debug"))
+ (or (featurep 'edebug)
+ (load "edebug"))
+ ;; Don't show "obsolete function warning", because we know what
+ ;; we're doing below. Emulation in handled in tinylibb.el
+ (put 'frame-parameters 'byte-compile nil))
+
+(eval-and-compile
+ (ti::package-use-dynamic-compilation)
+ (autoload 'tinypath-cache-match-fullpath "tinypath")
+ (autoload 'remprop "cl-extra")
+ (autoload 'edebug-eval-defun "edebug" "" t)
+ ;; Silence bytecompiler
+ (defvar edebug-all-defs)
+ (defvar folding-mode)
+ (defvar checkdoc-arguments-in-order-flag)
+ (defvar checkdoc-verb-check-experimental-flag)
+ (defvar checkdoc-spellcheck-documentation-flag)
+ (defvar checkdoc-bouncy-flag)
+ (defvar checkdoc-bouncy-flag)
+ (defvar checkdoc-autofix-flag)
+ ;; During bute compiling it's best to see from where the
+ ;; libraries are loaded. You can also check *Messages*
+ (defun tinylisp-locate-library (lib)
+ "Print message if located LIB."
+ (let ((loc (locate-library lib)))
+ (when loc
+ (message "tinyLisp.el: %s" loc)
+ t)))
+
+ (let ((count 0))
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. eldoc ..
+ (when (and nil ;; 2004-10-10 disabled.
+ (not (tinylisp-locate-library "eldoc")))
+ (incf count)
+ (message "\
+ ** tinylisp.el: Hm, no eldoc.el found.
+ Emacs function parameter coding help is not available.
+ This package is included in latest Emacs versions.
+ You have to upgrade your Emacs."))
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. . rsz ..
+ (when (and nil ;; 2004-10-10 disabled.
+ ;; XEmacs package is in different name
+ (null (or (tinylisp-locate-library "rsz-minibuf")
+ (tinylisp-locate-library "rsz-mini"))))
+ (incf count)
+ (message "\
+ ** tinylisp.el: Hm, no rsz-mini.el or rsz-minibuf.el found.
+ This package is included in latest Emacs versions.
+ You have to upgrade your Emacs."))
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. . find-func ..
+ (unless (or
+ ;; in XEmacs-20.3(beta) there is no
+ ;; "find-func.el", instead `find-function' is in "help.el" and so
+ ;; in fact dumped with xemacs.
+ (fboundp 'find-function)
+ ;; In Emacs 20 it is in separate package.
+ (locate-library "find-func"))
+ (incf count)
+ (message "\
+ ** tinylisp.el: Hm, no find-func.el found.
+ Upgrade tot latest Emacs and XEmacs."))
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. elint ..
+ (if (and nil ;; 2004-10-10 disabled.
+ (not (tinylisp-locate-library "elint")))
+ (progn
+ (incf count)
+ (message "\
+ ** tinylisp.el: Hm, no elint.el found. No code check features available.
+ Package is included in latest Emacs."))
+ (autoload 'elint-initialize "elint")
+ (autoload 'elint-current-buffer "elint" "" t)
+ (autoload 'elint-defun "elint" "" t))
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. xray ..
+ (unless (tinylisp-locate-library "xray")
+ (incf count)
+ (message "\
+ ** tinylisp.el: Hm, no xray.el found.
+ No lisp symbol \"explain\" features available.
+ 2001-10 it was at http://www.cpqd.com.br/~vinicius"))
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. checkdoc ..
+ (defvar checkdoc-version)
+ (if (and nil ;; 2004-10-10 disabled.
+ (not (tinylisp-locate-library "checkdoc")))
+ (progn
+ (incf count)
+ (message "\
+ ** tinylisp.el: Hm, no checkdoc.el found.
+ No lisp package syntax checks available.
+ Upgrade your Emacs."))
+ (autoload 'checkdoc-interactive "checkdoc" "" t)
+ (autoload 'checkdoc-eval-current-buffer "checkdoc" nil t)
+ (autoload 'checkdoc-current-buffer "checkdoc" nil t)
+ (autoload 'checkdoc "checkdoc" nil t)
+ (autoload 'checkdoc-continue "checkdoc" nil t)
+ (autoload 'checkdoc-comments "checkdoc" nil t)
+ (autoload 'checkdoc-rogue-spaces "checkdoc" nil t)
+ (autoload 'checkdoc-eval-defun "checkdoc" nil t)
+ (autoload 'checkdoc-defun "checkdoc" nil t)
+ (autoload 'checkdoc-minor-mode "checkdoc" nil t)
+ (autoload 'checkdoc-find-error-mouse "checkdoc" nil t)
+ (autoload 'checkdoc-find-error "checkdoc" nil t))
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. . elp ..
+ (if (and nil ;; 2004-10-10 disabled.
+ (not (tinylisp-locate-library "elp")))
+ (progn
+ (incf count)
+ (message "\
+ ** tinylisp.el: Hm, no elp.el found.
+ Lisp profiling functions are not available.
+ This package is included in latest Emacs and XEmacs."))
+ ;; This pretends the functions exist and avoids byte compiler errors.
+ (defvar elp-all-instrumented-list nil)
+ (defvar elp-function-list nil)
+ (defvar elp-master nil)
+ (defvar elp-results-buffer "*ELP Profiling Results*")
+ (defvar elp-reset-after-results nil)
+ (autoload 'elp-instrument-function "elp" "" t)
+ (autoload 'elp-restore-function "elp" "" t)
+ (autoload 'elp-instrument-list "elp" "" t)
+ (autoload 'elp-instrument-package "elp" "" t)
+ (autoload 'elp-restore-list "elp" "" t)
+ (autoload 'elp-restore-all "elp" "" t)
+ (autoload 'elp-reset-function "elp" "" t)
+ (autoload 'elp-reset-list "elp" "" t)
+ (autoload 'elp-reset-all "elp" "" t)
+ (autoload 'elp-set-master "elp" "" t)
+ (autoload 'elp-unset-master "elp" "" )
+ (autoload 'elp-wrapper "elp" "" )
+ (autoload 'elp-sort-by-call-count "elp" "" )
+ (autoload 'elp-sort-by-total-time "elp" "" )
+ (autoload 'elp-sort-by-average-time "elp" "" )
+ (autoload 'elp-output-result "elp" "" )
+ (autoload 'elp-results "elp" "" t)
+ (autoload 'elp-submit-bug-report "elp" "" t))
+ (unless (zerop count)
+ (message "\
+ ** tinylisp.el: Some files were not found. This is not fatal.
+ The package will adjust accoding to available features.
+ Byte compiled file will be ok."))))
+
+(ti::package-defgroup-tiny TinyLisp tinylisp-: tools
+ "Lisp programming help module.
+ Overview of features.
+
+ Lisp coding help
+
+ o Create list of all variables from the buffer.
+ Uou can use the list in your bug report function or just
+ to get an overview of the variables: names and the order how
+ you have used them (The order is important if you use defcustom)
+ o Create function list (or occur menu)
+ o Create autoload list (or occur menu)
+ o Evaluate current definition under point (reparse function,
+ reset defvar or defcustom variable)
+ o Print variable's value under point, set variable's value
+ under point.
+ o Call function under point (to test it immediately)
+ o Indent function/variable around point.
+ o Two tun on Modes: Show underlying properties/overlays or
+ charcter symbol information.
+ o FIND LISP CODE ERROR POINT.")
+
+;;}}}
+;;{{{ setup: mode definition
+
+(defcustom tinylisp-:menu-use-flag t
+ "*Non-nil means to use echo-area facilities from tinymenu.el."
+ :type 'boolean
+ :group 'TinyLisp)
+
+;; Creating a minor mode
+;;
+;; This macro creates the full minor mode and all needed variables
+;;
+;; Mode name "E" for minor name
+;;
+;; A general lisp helper mode; please see these too:
+;;
+;; (e)lisp-mode
+;; (e)lp.el
+;; (e)ldoc.el
+;; (e)xpand.el
+;;
+;; Prefix variable "$"
+;;
+;; You seldom use end anchor $ in lisp. Use $$ to self insert it
+;; Another characters you could choose: "!", "_"
+;; If possible, select some character that is non-shifted
+;; for maximum accessibility of this minor mode.
+;;
+;; You can change the prefix key by adding this statement before
+;; loading this package:
+;;
+;; (setq tinylisp-:mode-prefix-key "C-cE")
+
+(eval-and-compile
+
+;;;###autoload (autoload 'tinylisp-commentary "tinylisp" "" t)
+;;;###autoload (autoload 'tinylisp-mode "tinylisp" "" t)
+;;;###autoload (autoload 'turn-on-tinylisp-mode "tinylisp" "" t)
+;;;###autoload (autoload 'turn-off-tinylisp-mode "tinylisp" "" t)
+
+ (ti::macrof-minor-mode-wizard
+ "tinylisp-" " E" "$" "E" 'TinyLisp "tinylisp-:" ;1-6
+
+ "This minor mode is used along with the lisp major modes. You can
+evaluate expressions, reread functions, check your lisp packages
+syntax, create autoloads and do many more things.
+
+Defined keys:
+
+\\{tinylisp-:mode-prefix-map}"
+
+ "Emacs Lisp extras" ;7
+
+ nil ;8
+
+ "Emacs Lisp menu." ;9
+
+ (list ;arg 10
+ tinylisp-:mode-easymenu-name
+ ["Eval whole buffer" tinylisp-eval-current-buffer t]
+ ["Eval whole buffer, `load'" tinylisp-eval-current-buffer-from-file t]
+ ["Eval whole buffer as defconst" tinylisp-eval-current-buffer-defconst t]
+ ["Eval statement at point" tinylisp-eval-at-point t]
+ ["Eval reverse statement at point" tinylisp-eval-reverse t]
+ ["Eval and edit line " tinylisp-eval-edit t]
+ ["Eval and print result" tinylisp-eval-print-last-sexp t]
+ ["Macroexpand macro funcall" tinylisp-macroexpand t]
+ "----"
+ ["Call statement at point" tinylisp-call-at-point t]
+ ["Set value at point" tinylisp-set-value-at-point t]
+ ["Jump to definiton" tinylisp-jump-to-definition t]
+ ["Jump to definiton (call-chain)" tinylisp-jump-to-definition-chain t]
+ ["Back to definiton (call-chain)" tinylisp-back-to-definition t]
+ "----"
+ ["Forward user var or func" tinylisp-forward-user-option t]
+ ["Backward user var or func" tinylisp-backward-user-option t]
+ "----"
+ (list
+ "Modes, find error, debug"
+ ["Mode, property show" tinylisp-property-show-mode t]
+ ["Mode, char syntax show" tinylisp-syntax-show-mode t]
+ ["Find lisp error, method 1" tinylisp-error-find-1 t]
+ ["Find lisp error, method 2" tinylisp-error-find-2 t]
+ ["Add code debug tags" tinylisp-error-debug-add-tags t])
+
+ (list
+ "Lisp Library"
+ ["Show symbol load path" tinylisp-library-find-symbol-load-info t]
+ ["show loaded libraries" tinylisp-library-info-emacs t]
+ ["Load one" tinylisp-library-info-emacs t]
+ ["Load by regexp" tinylisp-library-load-by-regexp t]
+ ["Find file" tinylisp-library-find-file t]
+ ["Display documentation" tinylisp-library-documentation t])
+ (list
+ "Variables and Symbols"
+ ["Occur" tinylisp-occur-verbose t]
+ ["Occur, select next" tinylisp-occur-select-forward t]
+ ["Collect variable list" tinylisp-find-variable-list t]
+ ["Collect variable list, occur" tinylisp-find-variable-list-occur t]
+ ["Collect function list" tinylisp-find-function-list t]
+ ["Collect function list, occur" tinylisp-find-function-list-occur t]
+ "----"
+ ["Info, buffer local variables" tinylisp-find-buffer-local-variables t]
+ "----"
+ ["Construct autoloads from buffer" tinylisp-autoload-generate-buffer t]
+ ["Construct autoloads from file" ti::package-autoload-create-on-file t]
+ ["Describe library's symbols" tinylisp-library-symbol-information t]
+ ["Snoop variables" tinylisp-snoop-variables t]
+ "----"
+ ["Grep adviced functions" tinylisp-ad-match t]
+ ["Grep Hooks" tinylisp-find-match-from-hooks t]
+ ["Grep variables" tinylisp-find-match-from-variables t]
+ ["Grep symbols" ti::system-describe-symbols t])
+
+ (list
+ "Miscellaneous"
+ ["Emergency - defcustom" tinylisp-emergency t]
+ ["Indent function or variable" tinylisp-indent-around-point t]
+ ["Narrow to function" tinylisp-narrow-to-function t]
+ ["Widen" widen t]
+ ["Convert word to defmacro var." tinylisp-defmacro-surround-word t]
+ ["Byte compile current function." tinylisp-byte-compile-sexp t]
+
+ ["Show call tree for file"
+ tinylisp-byte-compile-display-call-tree t]
+
+ ["Face, show font lock faces" tinylisp-face-list-font-lock-faces t]
+ ["Face, show all faces" tinylisp-face-list-known-faces t]
+ ["Process kill" tinylisp-process-kill t]
+ ["Process list" list-processes t])
+ (list
+ "Package layout check"
+ ["Check overall layout syntax" tinylisp-lisp-mnt-verify t]
+
+ ["Check or fix layout tags in buffer"
+ tinylisp-lisp-mnt-tag-check-and-fix-buffer t]
+
+ ["Check or fix layout tags in file"
+ tinylisp-lisp-mnt-tag-check-and-fix-file t]
+
+ ["Check or fix layout tags in directory"
+ tinylisp-lisp-mnt-tag-check-and-fix-dir t])
+
+ "----"
+
+ (list
+ "Documentation check."
+ ["Check forward" tinylisp-checkdoc t]
+ ["Check buffer, take notes" tinylisp-checkdoc-notes t]
+ ["Check comments" checkdoc-comments t]
+ ["Check comments, take notes" tinylisp-checkdoc-comment-notes t]
+ ["Check defun, current point" checkdoc-eval-defun t]
+ ["Checkdoc minor mode" checkdoc-minor-mode t])
+
+ (list
+ "Elint"
+ ["Check buffer" tinylisp-elint-buffer t]
+ ["Check defun" tinylisp-elint-defun t])
+
+ (list
+ "Edebug"
+ ["Instrument function" tinylisp-edebug-instrument t]
+ ["Uninstrument function" tinylisp-edebug-uninstrument t]
+ ["Instrument buffer" tinylisp-edebug-instrument-buffer t]
+ ["Uninstrument buffer" tinylisp-edebug-uninstrument-buffer t]
+ ["Uninstrument everything" tinylisp-edebug-uninstrument-everything t])
+
+ (list
+ "Elp lisp profiling menu"
+ ["Instrument function" tinylisp-elp-instrument-function t]
+ ["Instrument buffer" tinylisp-elp-instrument-buffer t]
+ ["Instrument by regexp" tinylisp-elp-instrument-by-regexp t]
+ ["Uninstrument function" tinylisp-elp-restore-function t]
+ ["Uninstrument buffer" tinylisp-elp-restore-buffer t]
+ ["Uninstrument all" tinylisp-elp-restore-all t]
+ ["Reparse instrumentation" tinylisp-reparse-instrumentation t]
+
+ "----"
+
+ ["List instrumented functions" tinylisp-elp-function-list-partial t]
+ ["List All instrumented functions" tinylisp-elp-function-list t]
+ ["Harness test (eval from point)" tinylisp-elp-harness t]
+ ["Master set" tinylisp-elp-set-master t]
+ ["Master reset" elp-unset-master t]
+ ["Reset timing list" tinylisp-elp-reset-list t]
+ ["Show timing list" tinylisp-elp-results t])
+
+ ["Keyboard menu" tinylisp-menu-main t]
+ ["Mode on for all lisp buffers" turn-on-tinylisp-mode-all-buffers t]
+ ["Mode off for all lisp buffers" turn-on-tinylisp-mode-all-buffers t]
+ ["Package version" tinylisp-version t]
+ ["Package commentary" tinylisp-commentary t]
+ ["Mode help" tinylisp-mode-help t]
+ ["Mode off" tinylisp-mode t]
+
+ "----")
+
+ (progn ;arg 11
+ (cond
+ (tinylisp-:menu-use-flag
+ ;; Using menu to remeber commands is easier if you don't use
+ ;; menu bar at all.
+ (define-key root-map p 'tinylisp-menu-main))
+
+ (t
+ (tinylisp-install-menu)
+
+ (define-key map "\C-m" 'tinylisp-eval-print-last-sexp)
+
+ (define-key map "Z" 'tinylisp-emergency)
+
+ (define-key map "-" 'tinylisp-eval-current-buffer)
+ (define-key map "*" 'tinylisp-eval-current-buffer-from-file)
+ (define-key map "=" 'tinylisp-eval-current-buffer-defconst)
+ (define-key map "." 'tinylisp-eval-at-point)
+ (define-key map "\\" 'tinylisp-eval-reverse)
+
+ (define-key map "m" 'tinylisp-macroexpand) ;; if @ is inaccessible
+
+ (define-key map "cc" 'tinylisp-byte-compile-buffer)
+ (define-key map "cs" 'tinylisp-byte-compile-sexp)
+ (define-key map "ct" 'tinylisp-byte-compile-display-call-tree)
+
+ (define-key map "," 'tinylisp-call-at-point)
+ (define-key map ";" 'tinylisp-set-value-at-point)
+ (define-key map "!" 'tinylisp-error-find-1)
+ (define-key map "#" 'tinylisp-error-find-2)
+ (define-key map "%" 'tinylisp-error-debug-add-tags)
+ (define-key map "'" 'tinylisp-jump-to-definition)
+ (define-key map "+" 'tinylisp-jump-to-definition)
+ (define-key map "'\177" 'tinylisp-back-to-definition)
+ (define-key map "`" 'tinylisp-defmacro-surround-word)
+
+ (define-key map "{" 'tinylisp-backward-user-option)
+ (define-key map "}" 'tinylisp-forward-user-option)
+
+ (define-key map "<" 'tinylisp-indent-around-point)
+
+ (define-key map "a" 'tinylisp-autoload-generate-buffer)
+ (define-key map "A" 'tinylisp-autoload-generate-file)
+
+ (define-key map "ia" 'tinylisp-ad-match)
+ (define-key map "ie" 'tinylisp-library-info-emacs)
+ (define-key map "ih" 'tinylisp-find-match-from-hooks)
+ (define-key map "il" 'tinylisp-library-symbol-information)
+ (define-key map "iL" 'tinylisp-find-buffer-local-variables)
+ (define-key map "is" 'ti::system-describe-symbols)
+ (define-key map "iv" 'tinylisp-find-match-from-variables)
+
+ (define-key map "I" 'tinylisp-eval-edit)
+
+ (define-key map "f" 'tinylisp-find-function-list)
+ (define-key map "F" 'tinylisp-find-function-list-occur)
+
+ (define-key map "lf" 'tinylisp-library-find-file)
+ (define-key map "ll" 'tinylisp-library-load-library)
+ (define-key map "lL" 'tinylisp-library-load-by-regexp)
+ (define-key map "ls" 'tinylisp-library-find-symbol-load-info)
+ (define-key map "ld" 'tinylisp-library-documentation)
+
+ (define-key map "n" 'tinylisp-narrow-to-function)
+
+ (define-key map "o" 'tinylisp-occur-verbose)
+ (define-key map "+" 'tinylisp-occur-select-forward)
+
+ (define-key map "p" 'tinylisp-property-show-mode)
+ (define-key map "S" 'tinylisp-snoop-variables)
+
+ (define-key map "v" 'tinylisp-find-variable-list)
+ (define-key map "V" 'tinylisp-find-variable-list-occur)
+
+ (define-key map "w" 'widen)
+ (define-key map "x" 'tinylisp-checkdoc)
+ (define-key map "y" 'tinylisp-syntax-show-mode)
+
+ (define-key map "Xv" 'tinylisp-lisp-mnt-verify)
+ (define-key map "Xt" 'tinylisp-lisp-mnt-tag-check-and-fix-buffer)
+ (define-key map "Xf" 'tinylisp-lisp-mnt-tag-check-and-fix-file)
+ (define-key map "Xd" 'tinylisp-lisp-mnt-tag-check-and-fix-dir)
+
+ (define-key map "bv" 'tinylisp-b-variables)
+ (define-key map "bf" 'tinylisp-b-funcs)
+ (define-key map "br" 'tinylisp-b-record)
+ (define-key map "bR" 'tinylisp-b-record-empty)
+ (define-key map "bt" 'tinylisp-b-eval)
+
+ (define-key map "ei" 'tinylisp-elp-instrument-function)
+ (define-key map "eI" 'tinylisp-elp-instrument-buffer)
+ (define-key map "eI" 'tinylisp-elp-instrument-by-regexp)
+ (define-key map "eu" 'tinylisp-elp-restore-function)
+ (define-key map "eU" 'tinylisp-elp-restore-buffer)
+ (define-key map "eA" 'tinylisp-elp-restore-all)
+ (define-key map "ee" 'tinylisp-reparse-instrumentation)
+ (define-key map "eh" 'tinylisp-elp-harness)
+
+ (define-key map "ef" 'tinylisp-elp-function-list-partial)
+ (define-key map "eF" 'tinylisp-elp-function-list)
+ (define-key map "er" 'tinylisp-elp-reset-list)
+ (define-key map "es" 'tinylisp-elp-results)
+ (define-key map "em" 'tinylisp-elp-set-master)
+ (define-key map "eM" 'elp-unset-master)
+
+ (define-key map "E\C-m" 'tinylisp-elint-buffer)
+ (define-key map "E " 'tinylisp-elint-defun)
+
+ (define-key map "\C-e\C-m" 'tinylisp-edebug-instrument)
+ (define-key map "\C-e\C-h" 'tinylisp-edebug-uninstrument)
+ (define-key map "\C-e " 'tinylisp-edebug-instrument-buffer)
+ (define-key map "\C-ex" 'tinylisp-edebug-uninstrument-buffer)
+ (define-key map "\C-eX" 'tinylisp-edebug-uninstrument-everything)
+
+ (define-key map "1f" 'tinylisp-face-list-font-lock-faces)
+ (define-key map "1f" 'tinylisp-face-list-known-faces)
+ (define-key map "1p" 'tinylisp-process-kill)
+ (define-key map "1P" 'list-processes))))))
+
+;;; ................................................... &&mode-summary ...
+
+;;;###autoload (autoload 'tinylisp-elp-summary-mode "tinylisp" "" t)
+;;;###autoload (autoload 'turn-on-tinylisp-elp-summary-mode "tinylisp" "" t)
+;;;###autoload (autoload 'turn-off-tinylisp-elp-summary-mode "tinylisp" "" t)
+
+(eval-and-compile
+
+ (ti::macrof-minor-mode-wizard
+ "tinylisp-elp-summary-" " Elp-sum" nil " Elp-sum" 'TinyLisp
+ "tinylisp-:elp-summary-" ;1-6
+
+ "Commands to help sorting elp summary buffer.
+Defined keys:
+
+\\{tinylisp-:elp-summary-prefix-mode-map}"
+
+ "Elp summary sort" ;7
+
+ nil ;8
+
+ "Elp summary sort menu." ;9
+
+ (list ;arg 10
+ tinylisp-:elp-summary-mode-easymenu-name
+ ["Sort by function name" tinylisp-elp-summary-sort-column-1 t]
+ ["Sort by call count" tinylisp-elp-summary-sort-column-2 t]
+ ["Sort by elapsed time" tinylisp-elp-summary-sort-column-3 t]
+ ["Sort by average time" tinylisp-elp-summary-sort-column-4 t])
+ (progn ;arg 11
+ ;; Function Name Call Count Elapsed Time Average Time
+ ;; ============= ========== ============ ============
+ (define-key map "f" 'tinylisp-elp-summary-sort-column-1)
+ (define-key map "c" 'tinylisp-elp-summary-sort-column-2)
+ (define-key map "e" 'tinylisp-elp-summary-sort-column-3)
+ (define-key map "a" 'tinylisp-elp-summary-sort-column-4))))
+
+;;}}}
+;;{{{ setup: hooks
+
+(defcustom tinylisp-:load-hook nil
+ "*Hook that is run when package is loaded.
+A good value could be '(turn-on-tinylisp-mode-all-buffers) to activate
+the minor mode in every Emac slisp buffer."
+ :type 'hook
+ :group 'TinyLisp)
+
+(defcustom tinylisp-:find-func-list-hook 'tinylisp-highlight-default
+ "*Hook run when tinylisp-find-function-list-hook has displayed the list."
+ :type 'hook
+ :group 'TinyLisp)
+
+(defcustom tinylisp-:find-var-list-hook 'tinylisp-highlight-default
+ "*Hook run when `tinylisp-find-function-list' has displayed the list."
+ :type 'hook
+ :group 'TinyLisp)
+
+(defcustom tinylisp-:with-current-buffer-hook '(turn-on-tinylisp-mode)
+ "*Hook run after ´tinylisp-with-current-buffer'."
+ :type 'hook
+ :group 'TinyLisp)
+
+;;}}}
+;;{{{ setup: public, user configurable
+
+(defcustom tinylisp-:register ?\'
+ "*An Emacs register that is used e.g. for saving point or copying text."
+ :type 'character
+ :group 'TinyLisp)
+
+(defcustom tinylisp-:macroexpand-function-list
+ '("cl-prettyexpand" "macroexpand")
+ "*Completion list of function STRINGS to expand macro call.
+You can use commands `cl-prettyexpand', which sometimes does
+good formatting, but does not necessarily expand to what you want to see.
+The default command is `macroexpand'."
+ :type '(repeat string)
+ :group 'TinyLisp)
+
+(defcustom tinylisp-:table-reverse-eval-alist
+ '((add-hook . remove-hook)
+ (remove-hook . add-hook))
+ "*Table of reverse commands. Format '((ORIG-FSYM . REVERSE-FSYM) ..)."
+ :type 'list
+ :group 'TinyLisp)
+
+(defcustom tinylisp-:table-snoop-variables
+ '(("hook-command"
+ (pre-command-hook
+ post-command-hook
+ post-command-idle-hook))
+ ("hook-file"
+ (write-file-hooks
+ find-file-hooks
+ after-save-hook))
+ ("hook-mail"
+ (mail-mode-hook
+ mail-setup-hook
+ mail-citation-hook
+ mail-yank-hooks
+ mail-send-hook))
+ ("hook-message"
+ (message-mode-hook
+ message-setup-hook
+ message-signature-setup-hook
+ message-header-setup-hook
+ message-header-hook
+ message-send-hook
+ message-sent-hook))
+ ("hook-basic"
+ (pre-command-hook
+ post-command-hook
+ post-command-idle-hook
+ write-file-hooks
+ find-file-hooks
+ after-save-hook
+ after-init-hook)))
+ "*List of interesting variables printed from `tinylisp-snoop-variables'.
+Non existing variables can also be listed but they are not checked.
+
+Format:
+
+ '((\"LIST-NAME\" (var var var ..))
+ ...)"
+
+ :type '(repeat
+ (list
+ (string :tag "Completion name")
+ (repeat (symbol :tag "Var"))))
+ :group 'TinyLisp)
+
+;;}}}
+;;{{{ setup: private variables
+
+(defvar tinylisp-:harness-flag nil
+ "Described in function `tinylisp-elp-harness'.
+This variable is set to t when harness is on going and set to
+nil when harness test is over.")
+
+(defvar tinylisp-:call-chain nil
+ "List of buffers and buffer positions. '(mark mark ..)
+Whenever you call `tinylisp-jump-to-definition' the current positions
+is recoded and one more element to the _beginning_ of list is added.
+You can navigate back with `tinylisp-back-to-definition' and the first
+element from the list is removed.")
+
+(defvar tinylisp-:buffer-elp "*tinylisp-elp*"
+ "Temporary elp info buffer.")
+
+(defvar tinylisp-:buffer-autoload "*tinylisp-autoloads*"
+ "Temporary buffer.")
+
+(defvar tinylisp-:buffer-variables "*tinylisp-variables*"
+ "Temporary buffer.")
+
+(defvar tinylisp-:buffer-data "*tinylisp-data*"
+ "Temporary buffer.")
+
+(defvar tinylisp-:buffer-library "*tinylisp-library*"
+ "Temporary buffer.")
+
+(defvar tinylisp-:buffer-record "*tinylisp-record*"
+ "Record variable contents to this buffer.")
+
+(defvar tinylisp-:buffer-tmp "*tinylisp-tmp*"
+ "Temporary buffer.")
+
+(defvar tinylisp-:buffer-macro "*tinylisp-macroexpand*"
+ "Temporary buffer.")
+
+(defvar tinylisp-:buffer-eval " *tinylisp-eval*"
+ "Temporary buffer.")
+
+(defconst tinylisp-:regexp-macro-definition
+ "^\\(defun\\*\\|defcustom\\|defgroup\\|defadvice\\)"
+ "Regexp for commands that define macros, like `defcustom' `defgroup'.")
+
+(defconst tinylisp-:regexp-function
+ (concat
+ "^(\\("
+ ;; cl DEFINES defun* macro
+ "defun\\*?\\|defsubst\\|defmacro"
+ ;; See SEMI poe.el
+ "\\|defun-maybe\\|defmacro-maybe\\|defalias-maybe"
+ ;; see Gnus nntp.el for deffoo
+ "\\|deffoo\\|defadv"
+ "\\)[ \t]+\\([^ \t\n]+\\)")
+ "Regexp to match functions.
+This must have SUBMATCH1 and SUBMATCH2 which represent function
+type and name.")
+
+(defconst tinylisp-:regexp-variable
+ (concat
+ "^(\\("
+ ;; Normal lisp variables
+ "defvar\\|defconst"
+ ;; Custom.el defined variables in 19.35
+ "\\|defgroup\\|defcustom"
+ "\\)[ \t]+\\([^ \t\n]+\\)")
+ "Regexp to match variables.
+This must have SUBMATCH1 and SUBMATCH2 which represent
+variable type and name.")
+
+(defvar tinylisp-:variable-not-charset "^][()'`\", \t\n\r"
+ "When reading variable from buffer, unse this is character set.
+Notice that ^ at the beginning of character set reverses it.")
+
+(defvar tinylisp-:find-error nil
+ "'Find error' function's data.")
+
+(defvar tinylisp-:occur-history nil
+ "History.")
+
+(defvar tinylisp-:elp-regexp-history nil
+ "History.")
+
+(defvar tinylisp-:elp-not-regexp-history nil
+ "History.")
+
+(defvar tinylisp-:elp-master-history nil
+ "History.")
+
+;; Too bad this is hard coded in emacs..
+(defvar tinylisp-:occur-buffer-name "*Occur*"
+ "Emacs Occur buffer.")
+
+(defvar tinylisp-:edebug-instrument-table nil
+ "Edebug instrumentation information.
+
+Format:
+
+ '((function buffer-pointer buffer-file-name)
+ (function buffer-pointer buffer-file-name)
+ ..)")
+
+;;}}}
+;;{{{ setup: private, mode
+
+;;; These must not be made buffer local.
+
+(defvar tinylisp-:property-show-mode nil
+ "Property show mode (flag).")
+
+(defvar tinylisp-:syntax-show-mode nil
+ "Property show mode (flag).")
+
+;;}}}
+;;{{{ setup: menu
+
+(defvar tinylisp-:menu-main) ;; Just a forward declaration
+
+(defun tinylisp-install-menu ()
+ "Install `tinylisp-:menu-main'."
+ ;; this is a function because if user changes prefix key and
+ ;; calls tinylisp-install, we must reflect the change here in
+ ;; self insert command.
+ ;;
+
+ (defconst tinylisp-:menu-main ;bookmark -- &menu
+ (list
+
+ ;; All commands do not fit to echo menu, but here are at least
+ ;; the most used ones.
+
+ '(format
+ "\
+%s -=*.\\rmE)val ,;'+)call wn)ar py)mode o)ccur aA)load vVfF xSdD >beEcilX C-e"
+ (if current-prefix-arg
+ (format "%s" (prin1-to-string current-prefix-arg))
+ "Lisp:"))
+ (list
+ (cons ?? 'tinylisp-:menu-help)
+ (cons ?\C-m (list '(tinylisp-eval-print-last-sexp)))
+ (cons ?- (list '(call-interactively 'tinylisp-eval-current-buffer)))
+ (cons ?* (list '(call-interactively
+ 'tinylisp-eval-current-buffer-from-file)))
+ (cons ?= (list '(call-interactively
+ 'tinylisp-eval-current-buffer-defconst)))
+ (cons ?. (list '(call-interactively 'tinylisp-eval-at-point)))
+ (cons ?, (list '(tinylisp-call-at-point current-prefix-arg)))
+ (cons ?\\ (list '(call-interactively 'tinylisp-eval-reverse)))
+ (cons ?\; (list '(call-interactively 'tinylisp-set-value-at-point)))
+ (cons ?! (list '(call-interactively 'tinylisp-error-find-1)))
+ (cons ?# (list '(call-interactively 'tinylisp-error-find-2)))
+ (cons ?% (list '(call-interactively 'tinylisp-error-debug-add-tags)))
+ (cons ?+ (list '(call-interactively 'tinylisp-jump-to-definition-chain)))
+ (cons ?' (list '(call-interactively 'tinylisp-jump-to-definition)))
+ (cons ?\177 (list '(tinylisp-back-to-definition)))
+ (cons ?{ (list '(call-interactively 'tinylisp-backward-user-option)))
+ (cons ?} (list '(call-interactively 'tinylisp-forward-user-option)))
+ (cons ?[ (list '(call-interactively 'tinylisp-backward-user-option)))
+ (cons ?] (list '(call-interactively 'tinylisp-forward-user-option)))
+ (cons ?< (list '(call-interactively 'tinylisp-indent-around-point)))
+ (cons ?` (list '(call-interactively 'tinylisp-defmacro-surround-word)))
+ (cons ?a (list '(call-interactively 'tinylisp-autoload-generate-buffer)))
+ (cons ?A (list '(call-interactively 'tinylisp-autoload-generate-file)))
+ (cons ?B (list '(call-interactively 'tinylisp-byte-compile-sexp)))
+ (cons ?f (list '(call-interactively 'tinylisp-find-function-list)))
+ (cons ?F (list '(call-interactively 'tinylisp-find-function-list-occur)))
+ (cons ?I (list '(call-interactively 'tinylisp-eval-edit)))
+ ;; Small "h" is reserved for echo-menu help
+ (cons ?n (list '(call-interactively 'tinylisp-narrow-to-function)))
+ (cons ?m (list '(call-interactively 'tinylisp-macroexpand)))
+ (cons ?o (list '(call-interactively 'tinylisp-occur-verbose
+ current-prefix-arg)))
+ (cons ?+ (list '(tinylisp-occur-select-forward current-prefix-arg)))
+ (cons ?p (list '(tinylisp-property-show-mode current-prefix-arg 'verb)))
+ (cons ?S (list '(let* ((i (tinylisp-snoop-variables-i-args)))
+ (tinylisp-snoop-variables
+ (nth 0 i) (nth 1 i)))))
+ (cons ?v (list '(tinylisp-find-variable-list current-prefix-arg)))
+ (cons ?V (list '(call-interactively 'tinylisp-find-variable-list-occur)))
+ (cons ?w (list '(call-interactively 'widen)))
+ (cons ?y (list '(tinylisp-syntax-show-mode current-prefix-arg 'verb)))
+ (cons ?Z (list '(call-interactively 'tinylisp-emergency)))
+ (cons ?\C-c (list '(call-interactively 'tinylisp-commentary)))
+ (cons ?\C-e 'tinylisp-:menu-edebug)
+ (cons ?\C-v (list '(call-interactively 'tinylisp-version)))
+ (cons ?i 'tinylisp-:menu-info)
+ (cons ?e 'tinylisp-:menu-elp)
+ (cons ?E 'tinylisp-:menu-elint)
+ (cons ?H 'tinylisp-:menu-help)
+ (cons ?b 'tinylisp-:menu-buffers)
+ (cons ?c 'tinylisp-:menu-checkdoc)
+ (cons ?C 'tinylisp-:menu-compile)
+ (cons ?l 'tinylisp-:menu-lisp-library)
+ (cons ?1 'tinylisp-:menu-misc-1)
+ (cons ?X 'tinylisp-:menu-lisp-mnt)
+ ;; Self insert command
+ ;; User may have defined multichararcter minor map entry
+ ;; like C-cE, we only do self insert if it is NOT
+ ;; multicharacter.
+ (cons (string-to-char ;get first char
+ (substring tinylisp-:mode-prefix-key 0 1))
+ (list
+ '(let ((key (ti::keymap-single-key-definition-p
+ tinylisp-:mode-prefix-key)))
+ (if (characterp key)
+ (insert tinylisp-:mode-prefix-key)
+ (message "\
+TinyLisp: Can't self-insert. Prefix is not one charcracter.")))))))
+ "Emacs Lisp coding help menu.
+Documentation of variable `tinylisp-:menu-main' which is main menu
+for mode function `tinylisp-mode'. You can access the mode with
+\\[tinylisp-mode]. Prefix key for the minor mode is defined in
+`tinylisp-:mode-prefix-key'.
+
+Menu controls:
+
+ / Return to previous menu (if in sub-menu)
+ h Echo-menu help. Output this screen and quit
+ q Quit.
+ H TinyLisp Help menu.
+
+Eval commands:
+
+ - Eval whole buffer
+
+ * Reload buffer from file with load command. This has the effect that
+ the function and variable definitions are recorded to load
+ history and you can use \\[tinylisp-jump-to-definition] command.
+
+ = Treat all variables as defconst and eval buffer. (With this
+ you can read the defaults if you're in package buffer)
+
+ . Eval current statement. If you have made changes to the function or
+ variable, which can be also defvar, this command evaluates it again
+ so that it gets the new definition. (defvar is treated as defconst)
+
+ \\ Reverse command around point and eval the statement. See
+ variable `tinylisp-:table-reverse-eval-alist'. E.g. if you see
+ `add-hook', the statement is interpreted as `remove-hook'.
+
+ C - m (RET)
+
+ Eval statement _preceeding_ the cursor. This will output the
+ returned values one by one. E.g.
+
+ (cutrrent-buffer)RET
+ --> <buffer>
+
+ r Reload packages to Emacs by regexp. If you have downloaded
+ new packages and your Emacs session is open, this is easy
+ way to refresh packages to your Emacs.
+
+Finding errors and debugging
+
+ m Macroexpand a macro symbol. [See also (comma) to expand functions]
+
+ I Read current line, allow ed(I)ting it, then eval the statement.
+
+ ! Find errors. Go to `point-min' and evaluate buffer portions
+ until error occurs.
+
+ # Find Lisp error with method 2. Try this if previous failed.
+
+ % Insert permanent debug tags. With \\[universal-argument] remove
+ debug tags. If the byte compilation gives a weird error and does not
+ tell the function and keys ! or # claim that all lisp code is valid,
+ you should instrument debug tags and try byte compiling again.
+
+ Z Emergency! If you evaled `defcustom' variable and you were thrown
+ to error buffer, call this command immediately to
+ restore TinyLisp. The defcustom is adviced and this fixes it.
+
+Function and code flow
+
+ ' Jump to a definition of variable or function.
+ With \\[universal-argument], save the call-chain point.
+ With non-nil prefix argument, clear the call chain. Use
+ BACKSPACE or \\177 (C-h) key to go back the saved call chain.
+
+ + Record position to call chain before jump to the definition. This
+ is shortcut to calling key \".\" with the prefix arg.
+
+ DEL Back to previous definition and remove mark from call chain.
+
+ }] Go to next user option; a star mark, or to user
+ function; interactive.
+ {[ Same as above, but backward.
+
+Symbol manipulation
+
+ , Call current word around point. If the word is a variable, print
+ value. If word is a function, call function or show `symbol-function'
+
+ ; Set new value for variable at point. If the read word is not an
+ existing variable, then this only prints warning messages.
+ old value is saved if there is no previous backup.
+
+ \\[universal-argument] Restore backup'd value
+ \\[universal-argument]\\[universal-argument] Force setting backup value to current value.
+
+ ` Surround current word with defmacro statement (, WORD)
+
+ S Snoop variables. See `tinylisp-:table-snoop-variables'
+ Following prefix arguments are recognized:
+ 1 Record snooped values to
+ to buffer `tinylisp-:buffer-record'
+ 0 Save state
+ 9 Restore values from saved state.
+ 8 Kill saved states
+ 5 Set all snooped variables to nil.
+ \\[universal-argument] edit variable
+
+Symbol find or autoload generation
+
+ a Create autoloads by reading current buffer (must have
+ `buffer-file-name'). With prefix argument, ask package
+ name and locate it in `load-path'.
+
+ A Create autoloads from directory's files matching regular epression
+
+ d Describe symbols. This scans whole Emacs obarray to find all
+ matching symbols. --> See also [I]nfo menu for more targetted
+ matching.
+
+ D Describe loaded package. You can rip all the documentation from
+ a file by doing this 1) load file into Emacs 2) eval it and finally
+ 3) call this function and give file path. It collects all variable
+ and function documentation to a single display.
+
+Listing and occur commands:
+
+ o Run occur for full buffer and filter out comments. Prefix arg says
+ _not_ to filter out full comment lines.
+
+ + Go to next occur line in buffer. With \\[universal-argument] backward.
+
+ f Find all functions from the buffer
+ F Find function and create occur menu.
+
+ l Show symbol Load information (file where is was defined)
+ L Library information, examine all packages in Emacs.
+
+ v Find all variables from buffer. Prefix args classifies variables.
+ V Find variables and create occur menu.
+
+Modes and utilities
+
+ p Property show mode. Three \\[universal-argument]'s turn on recording.
+ y syntax mode, Show syntax of charcter under cursor.
+
+ X Check variable and function documentation strings. Do they follow
+ Emacs Lisp code guidelines? File: elisp, Node: Documentation Tip.
+ (Uses package lisp-mnt.el)
+
+Function commands:
+
+ n Narrow to current lisp function.
+
+ w Widen (\\[widen])
+
+ < Indent current function or variable around point.
+
+Byte compilation
+
+ B Byte compile defun around point. With prefix arg DISSASSEBMLE.
+
+ See [C]ompile menu for more options.
+
+Additional menus
+
+ b Buffer menu. Jump to TinyLisp temp buffers.
+ c Checkdoc, docstring syntax checker menu
+ C Byte (C)ompilation menu.
+ e Elp menu. Emacs lisp profiler menu
+ E Elint menu. Emacs Lisp code syntax checker menu
+ H Help menu.
+ i Info menu. Find adviced functions, find from hooks/variables
+ l Library menu. Load, find lisp libraries for editing.
+ 1 Misc menu 1: Display face settings, process kill menu
+
+ C-e Edebug, Emacs Lisp debugger menu"))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defconst tinylisp-:menu-misc-1
+ (list
+ '(format "%sMisc 1: f)onts F)onts all p)rocess-kill P)rocess list"
+ (if current-prefix-arg
+ (format "%s " (prin1-to-string current-prefix-arg))
+ ""))
+ (list
+ (cons ?f (list '(tinylisp-face-list-font-lock-faces)))
+ (cons ?F (list '(tinylisp-face-list-known-faces)))
+ (cons ?p (list '(tinylisp-process-kill)))
+ (cons ?P (list '(list-processes)))
+ (cons ?/ 'tinylisp-:menu-main)))
+ "*Miscellaneous interface: Processes and fonts.
+/ Back to root menu
+q Quit menu
+f List font lock colors available.
+F List ALL known faces.
+p Kill running processes interactively.
+P List running processes.")
+
+;;; ----------------------------------------------------------------------
+;;;
+(defconst tinylisp-:menu-lisp-library
+ (list
+ '(format
+ "%sLibrary: s)sym-where l)load L)oad-re f)ind pP)kg-where d)doc"
+ (if current-prefix-arg
+ (format "%s " (prin1-to-string current-prefix-arg))
+ ""))
+ (list
+ (cons ?f (list '(call-interactively 'tinylisp-library-find-file)))
+ (cons ?l (list '(call-interactively 'tinylisp-library-load-library)))
+ (cons ?L (list '(call-interactively 'tinylisp-library-load-by-regexp)))
+ (cons ?s (list '(tinylisp-library-find-symbol-load-info)))
+ (cons ?p (list '(tinylisp-library-locate
+ (tinylisp-library-read-name)
+ current-prefix-arg)))
+ (cons ?P (list '(progn
+ (tinylisp-library-locate-by-fullpath-intercative))))
+ (cons ?d (list '(call-interactively 'tinylisp-library-documentation)))
+
+ (cons ?/ 'tinylisp-:menu-main)))
+ "*Lisp library interface:
+/ Back to root menu
+q Quit menu
+
+s Try to loate file where symbol was defined. This relies on
+ internal representation of symbols inside Emacs `load-history'.
+
+l Load one Lisp library with completion into Emacs. (evaluate)
+
+L Load again libraries inside Emacs matching regexp. E.g. if you want to
+ reload all of present gnus, supply regexp `gnus'
+
+f `find-file' a library for editing.
+
+p Package search: like `locate-library' but find all occurrances
+ of package. With prefix argument, insert data into buffer.
+
+P Package search: Search packages whose full path name matches
+ regexp. In order to use this feature, package `tinypath.el'
+ must be available. This command calls directly its functions.
+
+d Display Lisp file's documentation.
+ With prefix argument insert documentation to current point.")
+
+;;; ----------------------------------------------------------------------
+;;;
+(defconst tinylisp-:menu-compile
+ (list
+ '(format "%sByte-Compile: c)ompile t)tree for compile"
+ (if current-prefix-arg
+ (format "%s " (prin1-to-string current-prefix-arg))
+ ""))
+ (list
+ (cons ?c '( (tinylisp-byte-compile-buffer)))
+ (cons ?s '( (tinylisp-byte-compile-sexp)))
+ (cons ?t '( (tinylisp-byte-compile-display-call-tree)))
+ (cons ?/ 'tinylisp-:menu-main)))
+ "*Elint interface: Check code syntax.
+/ Back to root menu
+q Quit menu
+RET Lint buffer
+SPC Lint defun")
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro tinylisp-require (sym)
+ "Require package SYM."
+ (` (unless (featurep (, sym))
+ (require (, sym)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defconst tinylisp-:menu-elp
+ '((let (val)
+ (tinylisp-require 'elp)
+ (format
+ "%selp: iIRuUAe)instrument fF)unc rsS%s)time H)arness mM)aster%s"
+ ;; Is there functions instrumented?
+ (if elp-all-instrumented-list
+ (if (eq 0 (setq val (length elp-all-instrumented-list)))
+ ""
+ (format "%d " val))
+ "")
+ (if elp-reset-after-results
+ ":t"
+ "")
+ (if elp-master
+ (concat ":" (symbol-name elp-master))
+ "")))
+ ((?i . ( (call-interactively 'tinylisp-elp-instrument-function)))
+ (?I . ( (call-interactively 'tinylisp-elp-instrument-buffer)))
+ (?R . ( (call-interactively 'tinylisp-elp-instrument-by-regexp)))
+ (?u . ( (call-interactively 'tinylisp-elp-restore-function)))
+ (?U . ( (call-interactively 'tinylisp-elp-restore-buffer)))
+ (?A . ( (call-interactively 'tinylisp-elp-restore-all)))
+ (?H . ( (tinylisp-elp-harness current-prefix-arg 'verb)))
+ (?e . ( (call-interactively 'tinylisp-reparse-instrumentation)))
+ (?m . ( (call-interactively 'elp-set-master)))
+ (?M . ( (call-interactively 'elp-unset-master)))
+ (?f . ( (tinylisp-elp-function-list-partial current-prefix-arg 'verb)))
+ (?F . ( (tinylisp-elp-function-list current-prefix-arg 'verb)))
+ (?r . ( (call-interactively 'tinylisp-elp-reset-list)))
+ (?s . ( (tinylisp-elp-results current-prefix-arg)))
+ (?S . (t (tinylisp-elp-reset-after-results)))
+ (?/ . tinylisp-:menu-main)))
+ "Elp help menu.
+The menu shows some status parameters in the echo area.
+
+ '[COUNT] elp: [:t]list'
+ | |
+ | See 'S' key when this is shown
+ Count of currently instrumented functions
+
+Basic commands:
+
+/ Back to root menu
+q Quit menu
+
+i Instrument current function at point
+u Uninstrument function at point
+
+I Instrument all functions in buffer.
+U Uninstrument all functions in buffer.
+
+R Instrument by regexp mapping all Emacs functions.
+ If given prefix arg, then uninstrument instead.
+
+A Uninstrument all functions in elp list (reastore all)
+
+e r(e)parse instrumentation: forget all instrumented functions,
+ eval buffer to read new function definitions, and instrument those
+ functions.
+
+Misc:
+
+h Harness test. Eval everything 3 times from current point forward
+ and record results. See `tinylisp-elp-harness' for full explanation.
+ Prefix arg determines harness rounds.
+m Set master function. When functions below master are called, the timing
+ infomation is gathered.
+M Unset master function.
+
+Function information:
+
+f List _all_ instrumented functions . Prefix arg to display the functions
+ in separate buffer.
+F Same as above, but list all only specific functions in
+ `elp-function-list'.
+
+Timing information:
+
+s Show timing results. With prefix arg save results to RECORD buffer.
+S rese(:t) flag, Toggle setting of variable `elp-reset-after-results'.
+r Reset timing list.")
+
+(defconst tinylisp-:menu-info
+ '("info: a)d e)macs f)ile-sym o)hooks l)ocal-vars s)ym v)ar A)utoload"
+ ((?A . ( (call-interactively 'tinylisp-find-autoload-functions)))
+ (?a . ( (call-interactively 'tinylisp-ad-match)))
+ (?e . ( (call-interactively 'tinylisp-library-info-emacs)))
+ (?f . ( (call-interactively 'tinylisp-library-symbol-information)))
+ (?o . ( (call-interactively 'tinylisp-find-match-from-hooks)))
+ (?l . ( (call-interactively 'tinylisp-find-buffer-local-variables)))
+ (?v . ( (call-interactively 'tinylisp-find-match-from-variables)))
+ (?s . ( (call-interactively 'ti::system-describe-symbols)))
+ (?/ . tinylisp-:menu-main)))
+ "Display information about lisp symbols in Emacs
+
+/ Back to root menu
+q Quit menu
+
+a List all adviced functions that match advice NAME. E.g. to find all
+ `my' advices.
+
+e Show all libraries and symbols loaded into Emacs known by `load-history'.
+
+f Describe file symbols. Gather all documentation from symbols in FILE.
+ You have to load the file into Emacs first (eval it with \\[load-file]),
+ because this function reads the documentation properties from memory.
+
+h Search a match from contents of all -hook -function -functions symbols
+ E.g. you can locate all hooks that have function matching 'my'.
+
+l Decribe library symbols. This is like `f', but you do not need to give
+ the full path name, but the file will be located along `load-path'.
+
+L Show buffer local variables.
+
+s Search any symbol (variable or function) from Emacs obrray with REGEXP.
+
+v Search all variables matching variable-REGEXP and whose value match
+ VALUE-REGEXP.")
+
+(defconst tinylisp-:menu-buffers
+ '("go buffer: a)utoload rR)ecord v)vars f)uncs e)val E)lp"
+ ((?a . ( (tinylisp-b-autoload)))
+ (?r . ( (tinylisp-b-record)))
+ (?R . ( (tinylisp-b-record-empty)))
+ (?v . ( (tinylisp-b-variables)))
+ (?f . ( (tinylisp-b-funcs)))
+ (?e . ( (tinylisp-b-eval)))
+ (?E . ( (tinylisp-b-elp)))
+ (?/ . tinylisp-:menu-main)))
+ "Display TinyLisp buffers.
+
+/ Back to root menu.
+q Quit menu
+a Display autoload buffer
+r Display the record buffer where the variable contents
+ are stored when you call \\[universal-argument] `tinylisp-call-at-point'
+R Kill record buffer.
+v variables buffer
+f functions buffer
+e eval buffer")
+
+;;; ----------------------------------------------------------------------
+;;;
+(defconst tinylisp-:menu-elint
+ '("Elint: RET)buffer SPC)defun"
+ (
+ (?\C-m . ( (tinylisp-elint-buffer)))
+ (?\ . ( (tinylisp-elint-defun)))
+ (?/ . tinylisp-:menu-main)))
+ "Elint interface: Check code syntax.
+/ Back to root menu
+q Quit menu
+RET Lint buffer
+SPC Lint defun")
+
+;;; ----------------------------------------------------------------------
+;;;
+(defconst tinylisp-:menu-help
+ '("Help: m)mode c)commentary v)ersion"
+ ((?m . ( (tinylisp-mode-help)))
+ (?c . ( (tinylisp-commentary)))
+ (?v . ( (tinylisp-version)))
+ (?/ . tinylisp-:menu-main)))
+ "Help menu:
+/ Back to root menu
+q Quit menu
+m `tinylisp-mode' Mode description
+v `tinylisp-version'
+c `tinylisp-commentary'")
+
+;;; ----------------------------------------------------------------------
+;;;
+(defconst tinylisp-:menu-lisp-mnt
+ '("Lisp-mnt: RET)verify SPC)fix tags f)file d)directory"
+ ((?\C-m . ( (tinylisp-lisp-mnt-verify)))
+ (?\ . ( (tinylisp-lisp-mnt-tag-check-and-fix-buffer 'error)))
+ (?f . ( (tinylisp-lisp-mnt-tag-check-and-fix-file 'error))) ;;#todo:
+ (?d . ( (tinylisp-lisp-mnt-tag-check-and-fix-dir 'error))) ;;#todo:
+ (?/ . tinylisp-:menu-main)))
+ "Lisp-mnt.el interface: check package layout syntax.
+
+/ Back to root menu
+q Quit menu
+RET Check whole buffer with `lm-verify'
+SPC Check whole buffer tags and automatically fix them
+f Check file
+d Check all files in directory")
+
+;;; ----------------------------------------------------------------------
+;;;
+(defconst tinylisp-:menu-edebug
+ '("Edebug: un/instrument DEL/RET)func x/SPC)buffer l)list e)lint xX)it"
+ ((?\C-m . ( (tinylisp-edebug-instrument)))
+ (?\b . ( (tinylisp-edebug-uninstrument)))
+ (?\177 . ( (tinylisp-edebug-uninstrument)))
+ (?\C-h . ( (tinylisp-edebug-uninstrument)))
+ (?\ . ( (tinylisp-edebug-instrument-buffer)))
+ (?l . ( (tinylisp-edebug-display-instrumented-list)))
+ (?x . ( (tinylisp-edebug-uninstrument-buffer)))
+ (?X . ( (tinylisp-edebug-uninstrument-everything)))
+ (?e . ( (tinylisp-elint-defun)))
+ (?/ . tinylisp-:menu-main)))
+ "Edebug interface.
+
+/ Back to root menu
+q Quit menu
+
+RET Instrument function call (the name) at point. E.g. if you cursor is
+ on top of `my-function' symbol. this is not the same as
+ instrumenting with \\[universal-argument] \\[eval-defun], which
+ instruments _whole_ function at point.
+
+DEL Uninstrument as above. Backspace key works too.
+
+SPC Instrument all functions in this buffer
+
+x Uninstrument all functions in this buffer
+
+X Uninstrument everything known to TinyLisp. This requires that
+ you have have had TinyLisp running before you started
+ instrumenting function with \\[tinylisp-edebug-instrument] or with
+ \\[universal-argument] \\[eval-defun].
+
+e Elint current function (code check).
+
+l List all known instrumented functions.")
+
+;;; ----------------------------------------------------------------------
+;;;
+(defconst tinylisp-:menu-checkdoc
+ '((let (spell
+ val)
+ (tinylisp-require 'checkdoc)
+ (setq spell checkdoc-spellcheck-documentation-flag)
+ (cond
+ ((not (featurep 'checkdoc))
+ (error "No checkdoc available (not loaded)."))
+ ((not (boundp 'checkdoc-verb-check-experimental-flag))
+ (error "You have old checkdoc.el version.")))
+ (format
+ (concat
+ "%s%s%s%s%s checkdoc: "
+ "SPC)point RET)notes DEL)fwd cC)om m)ode Flags: aA~- Bb Ss Tt")
+ (cond
+ ((eq checkdoc-autofix-flag nil) "-")
+ ((eq checkdoc-autofix-flag 'automatic) "Auto")
+ ((eq checkdoc-autofix-flag 'semiautomatic) "Semi")
+ ((eq checkdoc-autofix-flag 'query) "Query")
+ ((null checkdoc-autofix-flag) "")
+ (t "?"))
+ (cond
+ ((null checkdoc-bouncy-flag) "")
+ ((eq checkdoc-bouncy-flag 'never) "")
+ (t "B"))
+ (cond
+ ((null checkdoc-arguments-in-order-flag) "")
+ (t "O"))
+ (if checkdoc-verb-check-experimental-flag "E" "")
+ (cond
+ ((eq spell 'defun) "sD")
+ ((eq spell 'buffer) "sB")
+ ((eq spell 'interactive) "sI")
+ ((eq spell t) "S")
+ ((null spell) "")
+ (t "s?"))
+ (let ((sym 'checkdoc-triple-semi-comment-check-flag))
+ (if (and (boundp sym)
+ (symbol-value sym))
+ "T"
+ ""))))
+ ((?\ . ( (checkdoc-eval-defun)))
+ (?\177 . ( (tinylisp-checkdoc)))
+ (?\b . ( (tinylisp-checkdoc)))
+ (?\C-m . ( (tinylisp-checkdoc-notes current-prefix-arg)))
+ (?\C-j . ( (tinylisp-checkdoc-notes current-prefix-arg)))
+ (?m . ( (call-interactively 'checkdoc-minor-mode)))
+ (?c . ( (checkdoc-comments)))
+ (?C . ( (tinylisp-checkdoc-comment-notes)))
+ (?a . (t (progn (setq checkdoc-autofix-flag 'semiautomatic))))
+ (?A . (t (progn (setq checkdoc-autofix-flag 'automatic))))
+ (?~ . (t (progn (setq checkdoc-autofix-flag 'query))))
+ (?- . (t (progn (setq checkdoc-autofix-flag nil))))
+ (?B . (t (progn (setq checkdoc-bouncy-flag t))))
+ (?b . (t (progn (setq checkdoc-bouncy-flag nil))))
+ (?O . (t (progn (setq checkdoc-arguments-in-order-flag t))))
+ (?o . (t (progn (setq checkdoc-arguments-in-order-flag nil))))
+ (?E . (t (progn (setq checkdoc-verb-check-experimental-flag t))))
+ (?e . (t (progn (setq checkdoc-verb-check-experimental-flag nil))))
+ (?S . (t (progn (setq checkdoc-spellcheck-documentation-flag t))))
+ (?s . (t (progn (setq checkdoc-spellcheck-documentation-flag nil))))
+ (?d . (t (progn (setq checkdoc-spellcheck-documentation-flag
+ 'defun))))
+ (?r . (t (progn (setq checkdoc-spellcheck-documentation-flag
+ 'buffer))))
+ (?T . (t (progn
+ (when (boundp 'checkdoc-triple-semi-comment-check-flag)
+ (setq checkdoc-triple-semi-comment-check-flag t)))))
+ (?t . (t (progn
+ (when (boundp 'checkdoc-triple-semi-comment-check-flag)
+ (setq checkdoc-triple-semi-comment-check-flag
+ nil)))))))
+ "According to checkdoc manual:
+...The Emacs Lisp manual has a nice chapter on how to write
+documentation strings. Many stylistic suggestions are fairly
+deterministic and easy to check for programatically, but also easy
+to forget. The main checkdoc engine will perform the stylistic
+checks needed to make sure these styles are remembered.
+
+The echo area menu shows following status information
+
+ [-|O|E|V|S|T] checkdoc:
+ | | | | | |
+ | | | | | `checkdoc-triple-semi-comment-check-flag'
+ | | | | `checkdoc-spellcheck-documentation-flag'
+ | | | `checkdoc-verb-check-experimental-flag'
+ | | `checkdoc-arguments-in-order-flag'
+ | `checkdoc-bouncy-flag' state
+ `checkdoc-autofix-flag'
+
+Commands:
+
+/ Back to root menu.
+SPC `checkdoc-eval-defun'
+DEL Check code from current point forward.
+RET `tinylisp-checkdoc-notes' Start checking from current point forward.
+ Supply prefix argument, if you want to check whole buffer.
+c `checkdoc-comments'
+C `tinylisp-checkdoc-comment-notes'
+
+Checkdoc mode flags that can be changed:
+
+m Turn on minor mode which checks docstring while you write them
+Aa~- Change `checkdoc-autofix-flag' A)uto a)semi ~)query -)never
+Bb Change `checkdoc-bouncy-flag' B)on b)off
+Oo Change `checkdoc-arguments-in-order-flag' O)n o)ff
+Ee Change `checkdoc-verb-check-experimental-flag' E)on e)off
+Tt Change `checkdoc-triple-semi-comment-check-flag' T)on t)off
+Ssdr Change checkdoc-spellcheck-documentation-flag'
+ s)off S)interactive d)efun r)buffer
+
+======================================================================
+ Excerpts from Checkdoc 0.5
+======================================================================
+
+`checkdoc-autofix-flag'
+
+ Non-nil means attempt auto-fixing of doc-strings.
+ If this value is the symbol 'query, then the user is queried before
+ any change is made. If the value is 'automatic, then all changes are
+ made without asking unless the change is very-complex. If the value
+ is 'semiautomatic, or any other value, then simple fixes are made
+ without asking, and complex changes are made by asking the user first.
+ The value 'never is the same as nil, never ask or change anything.
+ checkdoc-bouncy-flag
+
+`checkdoc-bouncy-flag'
+
+ Non-nil means to 'bounce' to auto-fix locations.
+ Setting this to nil will silently make fixes that require no user
+ interaction. See `checkdoc-autofix-flag' for auto-fixing details.
+
+`checkdoc-force-docstrings-flag'
+
+ Non-nil means that all checkable definitions should have documentation.
+ Style guide dictates that interactive functions MUST have documentation,
+ and that its good but not required practice to make non user visible items
+ have doc-strings.
+
+`checkdoc-arguments-in-order-flag'
+
+ Non-nil means warn if arguments appear out of order.
+ Setting this to nil will mean only checking that all the arguments
+ appear in the proper form in the documentation, not that they are in
+ the same order as they appear in the argument list. No mention is
+ made in the style guide relating to order.
+
+`checkdoc-verb-check-experimental-flag'
+
+ Non-nil means to attempt to check the voice of the doc-string.
+ This check keys off some words which are commonly misused. See the
+ variable `checkdoc-common-verbs-wrong-voice' if you wish to add your
+ own.
+
+`checkdoc-spellcheck-documentation-flag'
+
+ Non-nil means run Ispell on doc-strings based on value.
+ This will be automatically set to nil if Ispell does not exist on your
+ system. Possible values are:
+
+ nil - Don't spell-check during basic style checks.
+ 'defun - Spell-check when style checking a single defun
+ 'buffer - Spell-check only when style checking the whole buffer
+ 'interactive - Spell-check only during `checkdoc-interactive'
+ t - Always spell-check
+
+`checkdoc-triple-semi-comment-check-flag'
+
+ Non-nil means to check for multiple adjacent occurrences of ;;; comments.
+ According to the style of Emacs code in the lisp libraries, a block
+ comment can look like this:
+
+ ;;; Title
+ ;; text
+ ;; text
+
+ But when inside a function, code can be commented out using the ;;;
+ construct for all lines. When this variable is nil, the ;;; construct
+ is ignored regardless of it's location in the code.
+
+Auto-fixing:
+
+ There are four classifications of style errors in terms of how
+ easy they are to fix. They are simple, complex, really complex,
+ and impossible. (Impossible really means that checkdoc does not
+ have a fixing routine yet.) Typically white-space errors are
+ classified as simple, and are auto-fixed by default. Typographic
+ changes are considered complex, and the user is asked if they want
+ the problem fixed before checkdoc makes the change. These changes
+ can be done without asking if `checkdoc-autofix-flag' is properly
+ set. Potentially redundant changes are considered really complex,
+ and the user is always asked before a change is inserted. The
+ variable `checkdoc-autofix-flag' controls how these types of errors
+ are fixed.
+
+Spell checking doc-strings:
+
+ The variable `checkdoc-spellcheck-documentation-flag' can be set
+ to customize how spell checking is to be done. Since spell
+ checking can be quite slow, you can optimize how best you want your
+ checking done. The default is 'defun, which spell checks each time
+ `checkdoc-defun' or `checkdoc-eval-defun' is used. Setting to nil
+ prevents spell checking during normal usage.
+ Setting this variable to nil does not mean you cannot take
+ advantage of the spell checking. You can instead use the
+ interactive functions `checkdoc-Ispell-*' to check the spelling of
+ your documentation.
+ There is a list of lisp-specific words which checkdoc will
+ install into Ispell on the fly, but only if Ispell is not already
+ running. Use `Ispell-kill-Ispell' to make checkdoc restart it with
+ these words enabled.")
+
+;;}}}
+;;{{{ version
+
+;;; ....................................................... &v-version ...
+
+;;;###autoload (autoload 'tinylisp-version "tinylisp" "Display commentary" t)
+(eval-and-compile
+ (ti::macrof-version-bug-report
+ "tinylisp.el"
+ "tinylisp"
+ tinylisp-:version-id
+ "$Id: tinylisp.el,v 2.88 2007/05/01 17:20:46 jaalto Exp $"
+ '(tinylisp-:version-id
+ tinylisp-:debug
+ tinylisp-:load-hook
+ tinylisp-:find-func-list-hook
+ tinylisp-:find-var-list-hook
+ tinylisp-:menu-use-flag
+ tinylisp-:macroexpand-function-list
+ tinylisp-:table-reverse-eval-alist
+ tinylisp-:table-snoop-variables
+ tinylisp-:regexp-macro-definition
+ tinylisp-:regexp-function
+ tinylisp-:regexp-variable)
+ '(tinylisp-:debug-buffer)))
+
+;;}}}
+;;{{{ macros
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinylisp-with-current-buffer 'lisp-indent-function 1)
+(defmacro tinylisp-with-current-buffer (buffer &rest body)
+ "Make BUFFER and run hook `tinylisp-:with-current-buffer-hook'."
+ (`
+ (with-current-buffer (, buffer)
+ (,@ body)
+ (run-hooks 'tinylisp-with-current-buffer-hook))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinylisp-read-word ()
+ "Read word under point."
+ (let ((str (or (ti::remove-properties
+ (ti::buffer-read-word tinylisp-:variable-not-charset))
+ (when (bolp)
+ (ti::buffer-match
+ (concat "^[^ \t\n\r]*\\(["
+ tinylisp-:variable-not-charset
+ "]+\\)+"))
+ 0))))
+ (when str
+ ;; Remove trainling colon
+ (if (string-match "\\(.+\\):$" str)
+ (match-string 1 str)
+ str))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinylisp-safety-belt (function &optional msg arg)
+ "If FUNCTION does not exists, signal error and refer to MSG.
+Call FUNCTION with ARG if it exists."
+ (unless (fboundp function)
+ (error "TinyLisp: %s not exist. %s" (symbol-name function) (or msg "" )))
+ (if arg
+ (ti::funcall function arg)
+ (ti::funcall function)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinylisp-get-symbol (string)
+ "Return symbol from STRING.
+If function does not exist or is string cannot be read, then return nil
+
+ \"(function arg1\" --> 'function
+ \"(defvar xx\" --> 'xx
+ 'xxx-symbol --> 'xxx-symbol"
+ (let* ((re-f (substring tinylisp-:regexp-function
+ 1 (length tinylisp-:regexp-function)))
+
+ (re-v (substring tinylisp-:regexp-variable
+ 1 (length tinylisp-:regexp-variable)))
+ sym)
+ (cond
+ ((and (or (string-match re-f string)
+ (string-match re-v string))
+ (setq sym (intern-soft
+ (match-string 2 string)))))
+ ;; Read first word then
+ ((setq sym (ti::string-match "[^()'\",.; \t\n\]+" 0 string))
+
+ ;; Delete trailing garbage "this-function:" --> "this-function"
+ (if (string-match "\\(.*\\)[^a-zA-Z0-9*]$" sym)
+ (setq sym (match-string 1 sym)))
+
+ (setq sym (intern-soft sym))))
+ sym))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinylisp-push-call-chain (&optional pop data verb)
+ "Push current point to call chain.
+Input:
+
+ POP flag, instead of push, do pop to last saved positions
+ DATA push DATA to chain.
+ VERB print verbose messages.
+
+Optionally POP. VERB prints message."
+ (if (null pop)
+ (push data tinylisp-:call-chain)
+ (if (null tinylisp-:call-chain)
+ (error "tinylisp-:call-chain is empty, nothing to pop.")
+ (let* ((mark (pop tinylisp-:call-chain)))
+ (goto-char mark)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinylisp-symbol-do-macro 'lisp-indent-function 2)
+(defmacro tinylisp-symbol-do-macro (string noerr &rest body)
+ "Execute body if string is interned.
+Input:
+ STRING function or variable name
+ NOERR If nil, then call error. if Non-nil then print message if
+ STRING was not interned.
+ BODY."
+ (`
+ (if (intern-soft (, string))
+ (progn
+ (setq (, string) (intern-soft (, string)))
+ (,@ body))
+ (if (, noerr)
+ (message "TinyLisp: No symbol in obarray: %s" (, string))
+ (error "TinyLisp: No symbol in obarray: %s" (, string))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinylisp-record-macro 'lisp-indent-function 1)
+(defmacro tinylisp-record-macro (flag &rest body)
+ "If FLAG is non-nil execute BODY in record buffer."
+ (`
+ (if (, flag)
+ (tinylisp-with-current-buffer (ti::temp-buffer tinylisp-:buffer-record)
+ (ti::pmax)
+ (,@ body)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinylisp-defun-macro 'lisp-indent-function 0)
+(defmacro tinylisp-defun-macro (&rest body)
+ "(&rest body) Determine sexp bounds and execute BODY.
+Uses `end-of-defun' `forward-sexp' to determine sexp.
+
+Bound variables in macro:
+
+ `beg' `end' sexp bounds.
+ `str' full line read from 'beg' point
+ `buffer' points to the current buffer
+
+You use this macro to bounds of Lisp defun, defvar, defconst
+structures."
+ (`
+ (let* ((buffer (current-buffer))
+ str
+ beg
+ end)
+ (if (null buffer)
+ (setq buffer nil)) ;No-op, byteComp silencer
+ (save-excursion
+ (end-of-defun)
+ (setq end (point))
+ (forward-sexp -1)
+ ;; If no used, ByteComp nags -- silence it so that this macro
+ ;; can be used
+ (setq beg (point))
+ (if (null beg)
+ (setq beg nil))
+ (setq str (ti::read-current-line))
+ (goto-char end)
+ (,@ body)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinylisp-read-function-name-info (&optional string)
+ "Return '(name . sym) After 'defxxxxx'. at point or STRING."
+ (let* ((name (ti::string-match "def[a-zA-Z]+ +\\([^() \t\n\]+\\)" 1
+ (or string (ti::read-current-line))))
+ (sym (and name (intern-soft name))))
+ (if name
+ (cons name sym))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinylisp-defun-sym-macro 'lisp-indent-function 0)
+(defmacro tinylisp-defun-sym-macro (&rest body)
+ "Run BODY when defun sym is found.
+Same as `tinylisp-defun-macro' But define `name' and `sym' for function name."
+ (`
+ (tinylisp-defun-macro
+ (let* ((info (tinylisp-read-function-name-info str))
+ (name (car-safe info))
+ (sym (cdr-safe info)))
+ (if (null info) ;Bytecomp silencer.
+ (setq info nil))
+ (if (null sym) ;Bytecomp silencer.
+ (setq sym nil))
+ (,@ body)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinylisp-defcustom-macro 'lisp-indent-function 0)
+(defmacro tinylisp-defcustom-macro (&rest body)
+ "Activate advice 'tinylisp' for `defconst' _only_ during BODY."
+ (`
+ (unwind-protect
+ (progn
+ (ad-enable-advice 'defconst 'around 'tinylisp)
+ (ad-activate 'defconst)
+ (,@ body))
+ ;; Make sure this is always executed.
+ (tinylisp-emergency))))
+
+;;}}}
+;;{{{ Install
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-menu-main (&optional arg)
+ "Show echo area menu and pass ARG to `ti::menu-menu'."
+ (interactive "P")
+ (unless tinylisp-:menu-main
+ (tinylisp-install-menu))
+ (ti::menu-menu 'tinylisp-:menu-main arg))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun turn-on-tinylisp-mode-all-buffers (&optional off)
+ "Turn function `tinylisp-mode' on in every Lisp buffer. Optionally turn OFF."
+ (interactive "P")
+ (ti::dolist-buffer-list
+ (string-match "lisp\\|debugger-mode" (downcase (symbol-name major-mode)))
+ 'tmp-buffers-too
+ nil
+ (progn
+ (when (eq major-mode 'debugger-mode)
+ (tinylisp-debugger-setup))
+ (if off
+ (unless (null tinylisp-mode)
+ (turn-off-tinylisp-mode))
+ (unless tinylisp-mode
+ (turn-on-tinylisp-mode))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun turn-off-tinylisp-mode-all-buffers ()
+ "Call turn-on-tinylisp-mode-all-buffers' with argument off."
+ (turn-on-tinylisp-mode-all-buffers 'off))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-install-hooks (&optional uninstall)
+ "Install or UNINSTALL hooks that activate TinyLisp minor mode."
+ (let* ()
+ (ti::add-hooks '(emacs-lisp-mode-hook
+ lisp-interaction-mode-hook
+ debugger-mode-hook
+ help-mode-hook
+ gnus-edit-form-mode-hook
+ Info-mode-hook)
+ 'turn-on-tinylisp-mode
+ uninstall)
+ (unless (boundp 'apropos-mode-hook)
+ ;; Standard Emacs does not have this hook
+ (defvar apropos-mode-hook nil
+ "*Hook run when mode is turned on.")
+ (defadvice apropos-mode (after tinylisp act)
+ "Run `apropos-mode-hook'."
+ (run-hooks 'apropos-mode-hook)))
+ (if (boundp 'apropos-mode-hook)
+ (ti::add-hooks 'apropos-mode-hook 'turn-on-tinylisp-mode uninstall))
+ (ti::add-hooks 'tinylisp-:mode-define-keys-hook
+ 'tinylisp-mode-define-keys uninstall)
+ ;; tinylisp-elp-summary-install-mode
+ (ti::add-hooks 'tinylisp-:elp-summary-mode-define-keys-hook
+ 'tinylisp-elp-summary-mode-define-keys
+ uninstall)
+ (cond
+ ((boundp 'debugger-mode-hook)
+ (ti::add-hooks '(tinylisp-debugger-setup turn-on-tinylisp-mode)
+ 'debugger-mode-hook
+ uninstall))
+ (uninstall
+ (ti::advice-control 'debugger-mode "^tinylisp" 'disable))
+ (t
+ ;; 19.x-20.2 doesn't have the debugger hook
+ (defadvice debugger-mode (after tinylisp act)
+ "Run `tinylisp-debugger-setup'."
+ (tinylisp-debugger-setup)
+ (turn-on-tinylisp-mode))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-install (&optional uninstall)
+ "Install package and activate mode in every Emacs lisp buffer.
+To turn on mode on by buffer basis, call `tinylisp-mode'."
+ (interactive "P")
+ (tinylisp-install-hooks uninstall)
+ (turn-on-tinylisp-mode-all-buffers uninstall))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-uninstall ()
+ "Uninstall package."
+ (interactive)
+ (tinylisp-install 'uninsall))
+
+;;}}}
+;;{{{ advice
+
+;;; ----------------------------------------------------------------------
+;;;
+(defadvice byte-compile-file (around tinylisp act)
+ "Change interactive prompt and offer current buffer for compiling(.el)."
+ ;;
+ ;; byte-compile-file (filename &optional load)
+ (interactive
+ (list
+ (read-file-name
+ (if current-prefix-arg
+ "TinyLisp: Byte compile and load file: "
+ "TinyLisp: byte compile file: ")
+
+ (if (and buffer-file-name
+ (string-match "\\.el$" buffer-file-name))
+ buffer-file-name
+ (file-name-directory (or (buffer-file-name)
+ default-directory))))
+ current-prefix-arg))
+ ad-do-it)
+
+;;; ----------------------------------------------------------------------
+;;;
+(defadvice defconst (around tinylisp (sym val &optional doc &rest args) dis)
+ "This advice is only used in TinyLisp and elsewhere inactivated.
+It ignores any extra arguments passed to defconst. In order to
+evaluate following statement
+
+ (defcustom my nil \"docs\" :type 'string :group my)
+
+TinyLisp first converts it to
+
+ (defconst my nil \"docs\" :type 'string :group my)
+
+And turns on this advice to ignore additional :type and :group arguments.
+This all is needed, because defcustom defines the variable as defvar
+and it cannot be re-evaluated/reset without this trick.
+
+After the eval has been done, this advice is turned off.
+If you see this message when calling following, there is bug in TinyLisp.
+
+ (describe-function 'defconst)"
+ (ad-with-originals (defconst)
+ ;; advice prior 19.36 will not work properly with special forms
+ ;; like defconst. Hans explained is as follows to me:
+ ;;
+ ;; | > (ad-with-originals (defconst)
+ ;; | > (defconst sym val doc) ;; Nothing happens?
+ ;;
+ ;; The reason nothing happens here, is that 'sym' does not get evaluated
+ ;; (since 'defconst' is a special form), instead it actually assigns the
+ ;; value to the constant with the name "sym". What you would need to do
+ ;; is use `eval', e.g.,
+ ;;
+ ;; (ad-with-originals (defconst)
+ ;; (eval `(defconst ,sym ,val ,doc)))
+ ;;
+ ;; Hans Chalupsky <hans@ISI.EDU>
+ ;;
+ (eval (` (defconst (, sym) (, val) (, doc))))))
+
+;;}}}
+;;{{{ misc
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-process-kill ()
+ "Kill running processes with y-n-p."
+ (let* ((list (process-list)))
+ (if (null list)
+ (message "TinyLisp: no running processes to kill.")
+ (list-processes)
+ (dolist (proc (process-list))
+ (when (y-or-n-p (format "Kill: %s " (prin1-to-string proc)))
+ (delete-process proc))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-face-list-unique (face-list)
+ "Return unique faces '((var face) ..) from FACE-LIST."
+ (interactive)
+ (let* ((getface 'get-face)
+ face
+ list)
+ (dolist (var face-list)
+ (when (and
+ (not (string-match "^:" (symbol-name var)))
+ (or (and (fboundp 'face-font) ;; XEmacs
+ (ignore-errors (face-font var))
+ (setq face var))
+ (if (or (and (fboundp getface) ;; XEmacs
+ (funcall getface var))
+ ;; Only works in Emacs. Returns nil in XEmacs
+ (facep var))
+ (setq face var)))
+ ;; Filter out duplicates like 'bold
+ (not (member var list)))
+ (push (list var face) list)))
+ list))
+
+;;; ----------------------------------------------------------------------
+;;; (load-library "flyspell")
+;;; (tinylisp-face-print (current-buffer) '(flyspell-incorrect-face))
+;;;
+(defun tinylisp-face-print (buffer face-list)
+ "Insert description to BUFFER for each symbol in FACE-LIST."
+ (let* ((list (tinylisp-face-list-unique face-list))
+ beg
+ var
+ face)
+ (when list
+ (setq buffer (ti::temp-buffer tinylisp-:buffer-tmp 'clear))
+ (with-current-buffer buffer
+ (dolist (elt list)
+ (setq var (car elt)
+ face (nth 1 elt))
+ (insert (format "%-35s" (symbol-name var)))
+ (setq beg (point))
+ (insert "abcdef12345 ")
+ (set-text-properties beg (point) (list 'face face))
+ (if (ti::emacs-p)
+ (insert (format " fg: %-15s bg: %s\n"
+ (face-foreground face)
+ (face-background face)))
+ (insert (format "\n fg: %-15s\n bg: %s\n"
+ (face-foreground face)
+ (face-background face)))))
+ (sort-lines nil (point-min) (point-max)))
+ buffer)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-face-list-font-lock-faces ()
+ "List known font lock faces and colors used."
+ (interactive)
+ (cond
+ ((not (featurep 'font-lock))
+ (message "tinylisp.el: font-lock.el is not loaded. No faces."))
+ (t
+ (let ((symbols
+ (ti::system-get-symbols "^font-lock-.*face$" '(boundp sym))))
+ (when symbols
+ (let ((buffer (ti::temp-buffer tinylisp-:buffer-tmp 'clear)))
+ (tinylisp-face-print buffer symbols)
+ (display-buffer buffer)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-face-list-known-faces ()
+ "List all known 'face' variables."
+ (interactive)
+ (let* ((symbols (ti::system-get-symbols
+ "face"
+ '(or (boundp sym)
+ (and (fboundp 'get-face) ;; XEmacs
+ (get-face sym))
+ ;; Only works in Emacs. Returns nil in XEmacs
+ (facep sym))))
+ (buffer (ti::temp-buffer tinylisp-:buffer-tmp 'clear)))
+ (tinylisp-face-print buffer symbols)
+ (display-buffer buffer)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-highlight-default ()
+ "Highlight functions and variables, see tinylisp-*[func,var}*-hook."
+ (when (ti::colors-supported-p) ;; does it make sense to show colors?
+ (save-excursion (ti::text-re-search-forward "defmacro" 0 'highlight))
+ (save-excursion (ti::text-re-search-forward "defsubst" 0 'bold))
+ (save-excursion (ti::text-re-search-forward "defconst" 0 'highlight))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-show-register-message (&optional msg)
+ "Show what to do with register and show optional MSG."
+ (message
+ (or msg
+ (substitute-command-keys
+ (format
+ (concat
+ "TinyLisp: Jump back to previous positon with "
+ "\\[jump-to-register-compatibility-binding] %s")
+ (char-to-string tinylisp-:register))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-symbol-type (symbol &optional noerr)
+ "Return 'var or 'func according to SYMBOL.
+If NOERR is non-nil, do not call error if symbol type isn't known.
+That usually means that symbol is not yet defined to obarray."
+ (cond
+ ((and (fboundp symbol)
+ (boundp symbol))
+ (if (y-or-n-p (format "select %s: Y = variable, N = Function "
+ (symbol-name symbol)))
+ 'var 'func))
+ ((fboundp symbol)
+ 'func)
+ ((boundp symbol)
+ 'var)
+ (t
+ (unless noerr
+ (error "Don't know symbol type; not a variable or function %s"
+ symbol)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-backward-opening-paren ()
+ "Go backward until parenthesis found."
+ (if (char= ?\( (following-char))
+ (point)
+ (re-search-backward "(" nil t)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-read-symbol-at-point ()
+ "Read function name around point.
+
+o Check if cursor is at the beginning of line whitespace
+ and sees ' +(', then valuate next statement
+o Go backward to opening parenthesis and evaluate command.
+
+Return:
+ (point function-name-string statement)"
+ (let* ((opoint (point))
+ (word (save-excursion (tinylisp-read-word)))
+ point
+ func
+ statement)
+ (save-excursion
+ (cond
+ ((and (stringp word) (intern-soft word))
+ (skip-chars-backward "^ \t"))
+ ((line-end-position) ;;move to opening paren in this line
+ (re-search-backward "(" (line-beginning-position) t))
+ (t
+ ;; if there is whitespace '^ (autoload 'tinylisp-mode...'
+ ;; Then go to first opening paren in the line.
+ ;;
+ ;; - there must be whitespace between bol and opoint
+ ;; - next we must see '(' in the current line (eol)
+ (beginning-of-line)
+ (if (not (and (re-search-forward "^[ \t]*" opoint t)
+ (re-search-forward "(" (line-end-position) t)))
+ ;; restore
+ (goto-char opoint))))
+ (when (and (tinylisp-backward-opening-paren)
+ (setq point (point))
+ (re-search-forward "[^ \t\n(]" nil t))
+
+ (setq func (or word (tinylisp-read-word)))
+ (goto-char point)
+ (ignore-errors ;In comment; this breaks.
+ (forward-sexp 1)
+ (setq statement (buffer-substring point (point))))
+ (if statement
+ (list point func statement))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-find-package-prefix ()
+ "Read function from the beginning of file and first word from the name.
+
+ (defun XXX-do-it-like-this ()
+
+Return:
+ string The XXX
+ nil can't find one."
+ (save-excursion
+ (ti::pmin)
+ (if (re-search-forward "^(defun[ \t]+\\([^ \t]+-\\)" nil t)
+ (match-string 1))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-eval (str1 str2 type &optional arg1 arg2 arg3)
+ "Substitute STR1 with STR2 in string and eval all in temporary buffer..
+
+If TYPE is nil
+ Read string from buffer ARG1, position ARG2 and ARG3.
+
+If TYPE is non-nil
+ ARG1 contains string
+
+References:
+ `tinylisp-:buffer-eval'"
+ (tinylisp-with-current-buffer
+ (ti::temp-buffer tinylisp-:buffer-eval 'clear)
+ (if type
+ (insert arg1)
+ (if (not (get-buffer arg1))
+ (error "arg1 must be (existing) buffer")
+ (insert-buffer-substring arg1 arg2 arg3)))
+ (ti::pmin)
+ (replace-string str1 str2)
+ (tinylisp-eval-fix-defconst)
+ (tinylisp-eval-current-buffer)
+;;; (erase-buffer) ;May be big
+ nil))
+
+;;}}}
+;;{{{ Internally used buffers
+
+;;; --------------------------------------------------------- &buffers ---
+;;;
+(defun tinylisp-b-display (buffer point-min)
+ "Display BUFFER (must be string) if it exists and go to optional POINT-MIN.
+Shrink and print message if not exist."
+ (let* ((win (get-buffer-window buffer))
+ (frame-win (get-buffer-window buffer t))
+ (owin (selected-window)))
+ (if (not (buffer-live-p (get-buffer buffer)))
+ (message "TinyLisp: Buffer does not exist, %s" buffer)
+ ;; Do nothing special if window is already visible
+ (cond
+ (win
+ (when point-min
+ (select-window win) (ti::pmin)
+ (select-window owin)))
+ (frame-win
+ (raise-frame (window-frame frame-win))
+ (select-window frame-win))
+ (t
+ (display-buffer buffer)
+ (with-current-buffer buffer
+ (shrink-window-if-larger-than-buffer)
+ (if point-min (ti::pmin))))))))
+
+;;; ----------------------------------------------------------------------
+;;; (defun tinylisp-b-eval (&optional pmin)
+;;; (interactive) (tinylisp-b-display tinylisp-:buffer-eval pmin))
+;;;
+;;; This is just byteComp forward declaration, kinda.
+
+(defun tinylisp-b-record (&rest args)
+ "Ignore ARGS."
+ nil)
+
+;; Real functions are defined here.
+
+(mapcar
+ (function
+ (lambda (x)
+ (let ((sym (intern (format "tinylisp-b-%s" x)))
+ (var (intern (format "tinylisp-:buffer-%s" x)))
+ def)
+ (setq def
+ (` (defun (, sym) (&optional pmin)
+ (interactive "P")
+ (tinylisp-b-display (, var) pmin))))
+ (eval def))))
+ '("eval" "record" "variables" "funcs" "autoload" ))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-b-record-empty (&optional verb)
+ "Empty buffer `tinylisp-:buffer-record'. VERB."
+ (interactive)
+ (ti::verb)
+ (if (buffer-live-p (get-buffer tinylisp-:buffer-record))
+ (ti::erase-buffer tinylisp-:buffer-record))
+ (if verb
+ (message "TinyLisp: record buffer emptied.")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-b-elp (&optional verb)
+ "Go to Elp summary buffer. VERB."
+ (interactive)
+ (ti::verb)
+ (if (buffer-live-p (get-buffer elp-results-buffer))
+ (display-buffer elp-results-buffer)
+ (if verb
+ (message "TinyLisp: No Elp Profiling results buffer."))))
+
+;;}}}
+;;{{{ advice, elp
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-ad-match-1 (regexp)
+ "Return '((function class name) ..) that are adviced matching NAME REGEXP."
+ (let* (list
+ sym-name)
+ (ad-do-advised-functions (advised-function)
+ (dolist (class '(before after around))
+ (dolist (info (ad-get-advice-info-field advised-function class))
+ (setq sym-name (symbol-name (car info)))
+ (when (string-match regexp sym-name)
+ (push (list advised-function class (car info)) list)))))
+ list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-ad-match (regexp &optional verb)
+ "Loop through adviced functions to find all that match REGEXP. VERB."
+ (interactive "sAd name match Regexp: ")
+ (if (ti::nil-p regexp)
+ (error "Invalid regexp"))
+ (let* ((list (tinylisp-ad-match-1 regexp)))
+ (ti::verb)
+ (tinylisp-with-current-buffer
+ (ti::temp-buffer tinylisp-:buffer-data 'clear)
+ (dolist (elt list)
+ (insert
+ (format
+ "%-35s %-7s %s\n"
+ (symbol-name (nth 0 elt))
+ (symbol-name (nth 1 elt))
+ (symbol-name (nth 2 elt))))))
+ (when verb
+ (pop-to-buffer tinylisp-:buffer-data)
+ (ti::pmin))))
+
+;;}}}
+;;{{{ elp
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-elp-function-list-partial (&optional arg verb)
+ "Call `tinylisp-elp-function-list'. See ARG and VERB parameters there."
+ (interactive "P")
+ (ti::verb)
+ ;; elp-all-instrumented-list. The
+ ;; `elp-function-list' is list of functions to profile
+ (tinylisp-elp-function-list arg elp-function-list verb))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-elp-function-list (arg &optional list verb)
+ "Print list of functions that are currently being profiled.
+If functions can fit in echo area they are printed there unless
+prefix ARG is given.
+
+LIST defaults to `elp-all-instrumented-list`. VERB."
+ (interactive "P")
+ (let* (str)
+ (ti::verb)
+ (setq list (or list
+ elp-all-instrumented-list)
+ str (if list
+ (prin1-to-string list)))
+ (if (null list)
+ (progn
+ (if verb
+ (message "TinyLisp: No functions elp'd"))
+ ;; function return code
+ nil)
+ (if (and (null arg)
+ (< (length str) 80))
+ (message str)
+ (tinylisp-with-current-buffer
+ (ti::temp-buffer tinylisp-:buffer-elp 'clear)
+ (dolist (elt list)
+ (insert (symbol-name elt) "\n"))
+ (sort-lines nil (point-min) (point-max))
+ (pop-to-buffer (current-buffer))
+ (message "TinyLisp: %d functions have been elp'd"
+ (length elp-all-instrumented-list))))
+ t)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-elp-reset-after-results (&optional arg)
+ "Toggle variable `elp-reset-after-results' according to ARG."
+ (interactive "P")
+ (ti::bool-toggle elp-reset-after-results))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-elp-restore-all (&optional verb)
+ "Remove all instrumented functions. VERB."
+ (interactive)
+ (ti::verb)
+ (elp-restore-all)
+ (if verb
+ (message "TinyLisp: ELP, all functions restored.")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-elp-reset-list (&optional verb)
+ "Reset timing list. VERB."
+ (interactive)
+ (ti::verb)
+ (elp-reset-all)
+ (if (get-buffer-window elp-results-buffer)
+ (tinylisp-elp-results)) ;Clear the window
+ (if verb
+ (message "TinyLisp: ELP, Timing list cleared.")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-elp-results (&optional record string verb)
+ "Show results, but do not change window.
+if RECORD is non-nil; then copy t
+iming to record buffer.
+Insert STRING after the record stamp. VERB."
+ (interactive)
+ (let ((obuffer (current-buffer)))
+ (ti::verb)
+ (elp-results)
+ (ti::pmin)
+ (tinylisp-elp-summary-mode 1)
+ (tinylisp-record-macro record
+ (insert "\nELP: " (ti::date-standard-date) " " (buffer-name)
+ (if string string "\n"))
+ (insert-buffer elp-results-buffer)
+ (if verb
+ (message "TinyLisp: Results RECORDED.")))
+ (pop-to-buffer obuffer)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-elp-instrument-buffer-i-args (pfx-arg iact)
+ "Ask args for `tinylisp-elp-instrument-buffer'.
+PFX-ARG is usually `current-prefix-arg' if you know that already.
+IACT signifies interactive spec."
+ (let* (pfx)
+ (setq pfx
+ (read-from-minibuffer
+ (format
+ "%sInstrument using package prefix [empty=examine functions]: "
+ (if pfx-arg "Un)" ""))
+ (or (tinylisp-find-package-prefix)
+ "")))
+ (if (ti::nil-p pfx)
+ (list nil pfx-arg 'find iact)
+ (list pfx pfx-arg nil iact))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-elp-instrument-buffer (prefix &optional remove type verb)
+ "Instrument all functions in the current buffer.
+
+There are two possibilities when you run this in the buffer
+
+o Buffer contains a lisp package. Each function is prefixed
+ with some unique identifier.
+
+o You're in scratch buffer or badly formed package where
+ the names of the functions are not prefixed properly.
+
+Interactive call note:
+
+ The choice how to instrument functions is asked.
+
+Input:
+
+ PREFIX can be nil if type is non-nil.
+ REMOVE uninstrument functions. (Interactive call's prefix arg)
+ TYPE if nil then instrument using PREFIX
+ if non-nil, force finding all function names and
+ instrument them. This uses `defun' keyword seach.
+ VERB verbose mode"
+ (interactive
+ (tinylisp-elp-instrument-buffer-i-args current-prefix-arg 'iact))
+
+ (let* ((str (if remove "un" ""))
+ (count 0)
+ list)
+ (ti::verb)
+ (cond
+ (type
+ (setq list (tinylisp-find-function-list 'no-show 'alternative))
+ (if (null list)
+ (if verb
+ (message "TinyLisp: Can't find functions from buffer"))
+ (let (type)
+ (dolist (func list)
+ (setq type (car func))
+ (setq func (cdr func)) ;("defun" . "t1")
+ ;; elp can only insrument functions
+ (when (string-match "defun\\|defsubst" type)
+ (incf count)
+ (tinylisp-symbol-do-macro func nil
+ (elp-restore-function func) ;do this first
+ (if (null remove)
+ (elp-instrument-function func))))))
+ (if verb
+ (message "TinyLisp: %sinstrumented %d functions" str count))))
+ (t
+ (if remove
+ (elp-restore-all)
+ (elp-instrument-package prefix))
+ (if verb (message
+ "\
+TinyLisp: %sinstrumented package '%s'. Count of functions is unknown."
+ str prefix))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-elp-instrument-function ()
+ "Instrument current function. Search the function name."
+ (interactive)
+ (let* ((func (ti::buffer-defun-function-name)))
+ (if (not func)
+ (message "TinyLisp: Can't find function name.")
+ ;; This evaluates the function prior elp'ing it.
+ (tinylisp-eval-at-point)
+ (tinylisp-symbol-do-macro func nil
+ (elp-restore-function func) ;do this first
+ (elp-instrument-function func))
+ (message (format "TinyLisp: ELP instrumented [%s]" func)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-elp-mapsym (regexp &optional not-regexp real-name)
+ "Return list of function matching REGEXP NOT-REGEXP REAL-NAME.
+See `tinylisp-elp-instrument-by-regexp'."
+ (let* (list
+ name
+ real)
+ (mapatoms
+ (function
+ (lambda (sym)
+ (when (fboundp sym)
+ ;; What's the real function?
+ (setq real (or (ti::defalias-p sym) sym))
+ (when (not (memq (car-safe (symbol-function real))
+ '(autoload macro)))
+ (if real-name
+ (setq sym real)) ;yes this is real function name.
+ (setq name (symbol-name sym))
+ (when (and (string-match regexp name)
+ (not (string-match "ad-Orig-" name))
+ ;; Don't instrument adviced functions
+ (or (not (featurep 'advice))
+ ;; real an sym must hnot have any advice active
+ (cond
+ ((ad-has-any-advice real)
+ (not (ad-is-active real)))
+ ((ad-has-any-advice sym)
+ (not (ad-is-active sym)))
+ (t ;Okay, no advice
+ t)))
+ (or (not (stringp not-regexp))
+ (not (string-match not-regexp name))))
+ (push sym list)))))))
+ list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-elp-instrument-by-regexp
+ (regexp &optional not-regexp real-name uninstrument verb)
+ "Elp all functions that match REGEXP and NOT-REGEXP.
+Note, calling this function is slow, because it will map
+through every single defined atom in Emacs. (there are thousands).
+
+Note:
+
+ Adviced functions starting with `ad-' are not instrumented.
+
+Input:
+
+ REGEXP Regexp to match functon name
+ NOT-REGEXP If REGEXP matches, function must not match this. If nil,
+ then only REGEXP is used.
+ REAL-NAME If non-nil then look function name behind
+ defalias statements. After we get non-alias name the REGEXP
+ is matched.
+ UNINSTRUMENT Flag, if non-nil. Do the opposite: Uninstrument functions.
+ This is the prefix argument.
+ VERB Verbose message."
+ (interactive
+ (list
+ (read-string
+ (if current-prefix-arg
+ "Elp uninstrument Regexp: "
+ "Elp Regexp: ")
+ nil 'tinylisp-:elp-regexp-history)
+ (read-string "Not Regexp: " nil 'tinylisp-:elp-not-regexp-history)
+ (y-or-n-p "Match against real names? (look under alias name) ")
+ current-prefix-arg))
+ (ti::verb)
+
+ (if (ti::nil-p not-regexp) ;It's "" after RET in interactive
+ (setq not-regexp nil))
+
+ (let* ((list (tinylisp-elp-mapsym regexp not-regexp real-name))
+ (msg (if uninstrument "un" "")))
+ (if uninstrument
+ (elp-restore-list list)
+ (elp-instrument-list list))
+ (if verb
+ (message "TinyLisp: %d functions %sinstrumented"
+ (length list) msg))
+ list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-elp-set-master (function)
+ "Set master FUNCTION."
+ (interactive
+ (list
+ (intern
+ (completing-read
+ "Master function: "
+ obarray
+ 'fboundp
+ 'match
+ nil
+ 'tinylisp-:elp-master-history))))
+ (elp-set-master function))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-elp-restore-buffer ()
+ "Read functions from the buffer and cancel elp for them."
+ (interactive)
+ (let* ((args (tinylisp-elp-instrument-buffer-i-args 'pfx 'iact)))
+ (tinylisp-elp-instrument-buffer
+ (nth 0 args)
+ (nth 1 args)
+ (nth 2 args)
+ (nth 3 args))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-elp-restore-function ()
+ "Remove elp code from current function. Search the function name."
+ (interactive)
+ (let* ((func (ti::buffer-defun-function-name)))
+ (if (not func)
+ (message "TinyLisp: ELP, Can't find function name.")
+ (tinylisp-symbol-do-macro func nil
+ (elp-restore-function func))
+ (message (format "TinyLisp: ELP, restored [%s]" func)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-reparse-instrumentation (&optional verb)
+ "Uninstrument all currently instrumented functions.
+Then eval current buffer (to get new function definitions) and last instrument
+all found functions in the buffer.
+
+In short: remove previous instrumentation and do new one. VERB."
+ (interactive)
+ (ti::verb)
+ (tinylisp-elp-restore-all)
+ (tinylisp-eval-current-buffer)
+ (tinylisp-elp-instrument-buffer nil nil 'find verb))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-elp-harness (&optional count verb)
+ "Call elp multiple times to get reliable results.
+Default is call count is 3,but you can supply numeric prefix COUNT. VERB.
+
+ ** You must have instrumented the functions before you call this function
+
+This is bit exotic function and it requires that you have written
+following test setup in the clear Lisp buffer. Let's say we're
+interested if 'let*' is slower that 'let'.
+
+ (defun t-1 () (let* () ))
+ (defun t-2 () (let () ))
+ (defun t-3 () )
+
+ [* point/cursor is before this statement]
+ ;; The trick here is that when you instrument whole
+ ;; buffer and eval all the functions with '$ -' ,
+ ;; the when forms are bypassed
+ ;;
+ ;; When you have Evaled/instrumented buffer, then change
+ ;; it to 'when t' and call the harness function.
+ ;;
+ ;; The variable tinylisp-:harness-flag is set to t when you can this
+ ;; function and set to nil when this function finishes.
+ ;;
+ (when tinylisp-:harness-flag
+ (ti::dotimes count 1 500 ; run 500 times
+ (t-1)
+ (t-2)
+ (t-3)))
+
+This function evals everything from current point forward ARG times.
+If there is word tinylisp-:harness-flag in the buffer, the current point is not
+used but the eval is started from the beginning of that line forward.
+
+After each eval round it records the elp result to `tinylisp-:buffer-record'.
+In the above setup, this means that we repeat the test setup 3 times
+to get 3 elp timing results. Since using elp only once for small functions,
+doesn't give reliable results; we have to repeat the test at least 3 times.
+
+The `tinylisp-:buffer-record' buffer is displayed after the harness run is over."
+ (interactive "P")
+ (let* (case-fold-search
+ beg
+ h-found
+ rounds)
+ (ti::verb)
+ (setq count (or count 3)
+ rounds count)
+ ;; See if there this word in the buffer
+ (save-excursion
+ (ti::pmin)
+ (when (re-search-forward "tinylisp-:harness-flag" nil t)
+ (setq beg (line-beginning-position) h-found t)))
+ (or beg ;we already found it
+ (setq beg (point))) ;nope, use current point
+ (if (null elp-all-instrumented-list)
+ (error "No functions in elp list"))
+ (if (and verb
+ (null
+ (y-or-n-p
+ (format
+ (if h-found
+ "tinylisp-:harness-flag %s times, ok? "
+ "Harness %s times, from current point forward, ok? ")
+ count))))
+ (error "Abort."))
+ (if (and verb
+ (y-or-n-p "Do you want to clear RECORD buffer first? "))
+ (tinylisp-b-record-empty))
+ (unwind-protect ;; make sure tinylisp-:harness-flag is set to nil
+ (progn
+ (setq tinylisp-:harness-flag t)
+ (ti::dotimes iterator 0 count
+ (tinylisp-elp-reset-list) ;wipe timings
+ (if verb (message "TinyLisp: Eval round %d/%d ... "
+ (1+ iterator) rounds))
+ (eval-region beg (point-max))
+ (tinylisp-elp-results
+ 'record (format " -- %d/%d\n" (1+ iterator) rounds)))
+ (if verb
+ (message "TinyLisp: Eval rounds done."))
+ (tinylisp-b-record 'pmin))
+ (setq tinylisp-:harness-flag nil))))
+
+;;}}}
+;;{{{ elp results
+
+;;; ----------------------------------------------------------------------
+;;;
+(mapcar
+ (function
+ (lambda (x)
+ (let ((sym (intern (format "tinylisp-elp-summary-sort-column-%d" x)))
+ def)
+ (setq def
+ (` (defun (, sym) (&optional arg)
+;;; "Sort by field. ARG to reverse sort."
+ (interactive "P")
+ (tinylisp-elp-summary-sort-column (, x) arg))))
+ (eval def))))
+ '(1 2 3 4 5 6 7 8 9))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-elp-summary-sort-column (nbr &optional reverse)
+ "Sort column NBR or REVERSE."
+ ;; Nope...
+ ;; (setq nbr (if reverse (- nbr) nbr))
+ (untabify (point-min) (point-max))
+ (ti::save-with-marker-macro
+ (ti::pmin)
+ (forward-line 2) ;Skip header.
+ (cond
+ ((memq nbr '(2 3 4))
+ (sort-numeric-fields nbr (point) (point-max)))
+ (t
+ (sort-fields nbr (point) (point-max))))))
+
+;;}}}
+;;{{{ code help: debug, find-error
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-error-debug-add-tags (&optional remove verb)
+ "Add simple debug code before every left flushed parenthesis. REMOVE. VERB.
+When you compile a file, sometimes it is very hard to find the error
+position from the output; which gives no further clues:
+
+ While compiling toplevel forms in file xxx.el:
+ !! Wrong type argument ((number-or-marker-p nil))
+ Done
+
+The funny thing might be that this happens only when file is compiled. By
+evaluating each piece of code with `eval-region' the error does not occur.
+To help spotting the place, this function inserts random tags in the buffer
+which are shown during compilation. DO NOT change the inserted tags. After
+you have corrected errors, you can REMOVE the extra debug tags with prefix
+argument.
+
+DebugTag: 21-56 file.el
+ !! Wrong type argument ((number-or-marker-p nil))
+DebugTag: 22-56 file.el
+..."
+ (interactive "*P")
+ (let* ((tag ";;__LISP-DEBUG__")
+ (fmt (concat
+ " (eval-and-compile "
+ "(message \"DebugTag: %d-%d %s\"))"))
+ (re (regexp-quote tag))
+ (i 0)
+ ;; We have to randomize the tag, because suppose
+ ;; - user inserts tags. He runs debug and doesn find the spor
+ ;; - He left flushed more code
+ ;; - He inserts tags again, but because there is already tags,
+ ;; the _new_ tags must be different ==> randomized tags.
+ (rand (rand1 100))
+ (name (buffer-name)))
+ (ti::verb)
+ (save-excursion
+ (ti::pmin)
+ (if remove
+ (while (re-search-forward tag nil t)
+ (if verb (message "TinyLisp: uninstrumenting tag %d" i))
+ (incf i)
+ (beginning-of-line)
+ (kill-line 1))
+ (when (or (null (re-search-forward tag nil t))
+ (y-or-n-p
+ "TinyLisp: Debug tags already instrumented. Proceed? "))
+ (setq re (concat ".*" re))
+ (while (re-search-forward "^(" nil t)
+
+ (ti::save-with-marker-macro
+ (beginning-of-line)
+ (unless (looking-at re)
+ (insert (format fmt i rand name))
+ (insert tag "\n") ))
+ (forward-line 1)
+ (if verb
+ (message "TinyLisp: instrumenting tag %d" i))
+ (incf i)))))
+ (when (and verb (not (zerop i)))
+ (if remove
+ (message "TinyLisp: Debug tags removed.")
+ (message "TinyLisp: %d Debug tags inserted." i)))))
+
+;;; ----------------------------------------------------------------------
+;;; Simple solution
+;;;
+(defun tinylisp-error-find-2 ()
+ "Start from point min and Eval region at time until error occurs."
+ (interactive)
+ (let* ((p -1)
+ (opoint (point))
+ last-p)
+ (ti::pmin)
+ (setq last-p (point))
+ (while (not (eq p (point)))
+ (setq p (point))
+ (eval-region last-p (point))
+ (setq last-p (point))
+ (end-of-defun))
+ ;; The while loop never finishes if there was error
+ (message "TinyLisp: No lisp errors found.")
+ (goto-char opoint)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-error-find-1 ()
+ "Find code error position and put point near the error."
+ (interactive)
+ (let ((lower-bound 1))
+ (setq tinylisp-:find-error nil)
+ (save-excursion
+ (let (half
+ (low 1)
+ (high (tinylisp-error-count-sexps)))
+ (if tinylisp-:find-error ;See tinylisp-error-count-sexps
+ (setq lower-bound (point))
+ (setq high (1+ high))
+ (while (< low high)
+ (if (tinylisp-error-try-parse lower-bound
+ (tinylisp-error-sexp-position
+ (setq half (/ (+ low high) 2))))
+ (progn (setq low (1+ half))
+ (forward-sexp 2)
+ (backward-sexp)
+ (while (not (bolp))
+ (backward-sexp))
+ (setq lower-bound (point)))
+ (setq high half)))
+ (backward-sexp)
+ (setq lower-bound (point)))))
+
+ (if (not tinylisp-:find-error)
+ (message "TinyLisp: No errors found.")
+ (goto-char lower-bound)
+ (message "TinyLisp: %s" tinylisp-:find-error))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-error-try-parse (from to)
+ "Eval regions and try to find error in FROM TO."
+ (condition-case err
+ (progn (eval-region from to) t)
+ (error
+ (progn
+ (setq tinylisp-:find-error err)
+ nil))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-error-count-sexps ()
+ "Eval regions and try to find error."
+ (goto-char (point-max))
+ (condition-case err
+ (let ((n 0))
+ (while (not (bobp))
+ (backward-sexp)
+ (setq n (1+ n)))
+ n)
+ (error (setq tinylisp-:find-error err))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-error-sexp-position (n)
+ "Find sexp N."
+ (goto-char 1)
+ (forward-sexp n)
+ (if (or (not (eobp))
+ (save-excursion
+ (goto-char 1)
+ (forward-sexp (1- n))
+ (skip-chars-forward " \t\n")
+ (not (eobp))))
+ (backward-sexp))
+ (point))
+
+;;}}}
+;;{{{ code help: jump, eval
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-symbol-file-location (symbol)
+ "Search SYMBOL from Emacs obarrays and try to find file location."
+ (when symbol
+ (or (ti::system-load-history-where-is-source symbol)
+ (ti::system-doc-where-is-source symbol)
+ (and (ti::autoload-p symbol)
+ (let ((lib (ti::autoload-file symbol)))
+ (if lib
+ (locate-library lib)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-jump-to-definition (&optional save word verb nodisplay)
+ "Search function or variable definition in the same file or from outside.
+This function relies on the `load-history' and if there is no such
+symbol, this function can't jump to definition. If you have evaled buffer
+or function inside Emacs and not used the load* commands then the
+definition information is not in `load-history'.
+
+Input:
+
+SAVE \\[universal-argument]: then save the point so
+ that you can build call-chain and use
+ \\[tinylisp-back-to-definition] to return this point.
+
+ non-nil: then clear the call chain, save point, and jump to
+ definition. This lets you start building call chain again.
+
+WORD String. Symbol to search.
+
+VERB Flag. Allows displaying verbose messages.
+
+NODISPLAY Flag. If non-nil, don't display the found point.
+
+References:
+
+ `tinylisp-:call-chain'"
+
+ (interactive (list current-prefix-arg
+ (tinylisp-read-word)))
+
+ (let* ((f-re
+ (concat "^(\\(defun\\*?\\|defmacro\\*?\\|defsubst\\|deffoo"
+ "\\|defun-maybe\\|defsubst-maybe"
+ "\\|define-derived-mode"
+ "\\|defalias\\|fset"
+ ;; See grep.el::define-compilation-mode
+ "\\|define-[^ \t\r\n]+-mode"
+ "\\)[ \t']+%s[ \t\r\n]"))
+ (v-re
+ "^(\\(defvar\\|defconst\\|defcustom\\|defvoo\\)[ \t]+%s[ \t\r\n]")
+ (reg tinylisp-:register)
+ (call-chain-data (point-marker))
+ re
+ type
+ point
+ file
+ sym
+ alias
+ buffer)
+ (ti::verb)
+ (if (ti::nil-p word)
+ (error "TinyLisp: searched WORD is nil.")
+ (when (setq sym (intern-soft word))
+ (when (setq alias (ti::defalias-p sym))
+ (message "TinyLisp: Symbol `%s `==> alias to `%s'" sym alias)
+ (setq sym alias))
+ (setq type (tinylisp-symbol-type sym 'noerr)))
+ ;; ..................................... Search from this buffer ...
+ (save-excursion
+ (ti::pmin)
+ (let ((function (if alias
+ (symbol-name alias)
+ word)))
+ (cond
+ ((eq type 'func)
+ (setq re (format f-re function)))
+ ((eq type 'var)
+ (setq re (format v-re function)))
+ (t
+ ;; since the symbol is not defined in Emacs we can't
+ ;; know which one to search, variable or function.
+ ;; Try anything.
+ (setq re (concat
+ ;; This could also be and alias, like
+ ;; used in many Gnus files.
+ (format f-re function)
+ "\\|"
+ (format v-re word)))))
+ (when (re-search-forward re nil t)
+ (setq buffer (current-buffer))
+ (setq point (line-beginning-position)))))
+ ;; If the definition is not in current buffer where user is,
+ ;; Then try to search somewhere else.
+ (when (and sym
+ (null point))
+ (setq file (tinylisp-symbol-file-location sym)))
+ ;; Still no luck? Loosen the REGEXP so that do not require the
+ ;; function to be to the left "^", but allow adding spaces, like in:
+ ;;
+ ;; (eval-and-compile
+ ;; (defun this-here ()
+ ;; ...
+ (unless (or point file)
+ (setq re (concat (format (substring f-re 1) word)
+ "\\|"
+ (format (substring v-re 1) word)))
+ (save-excursion
+ (ti::pmin)
+ (when (re-search-forward re nil t)
+ (setq buffer (current-buffer))
+ (setq point (line-beginning-position)))))
+ (cond
+ ;; ............................................... check intern ...
+ ((when (and (null point)
+ (null (intern-soft word)))
+ (message "TinyLisp: Can't find definition for %s (undef)" word)))
+ ;; .................................................... external ...
+ ((and (null point) ;; See re-search above which set the point
+ (null file)
+ (or alias sym)
+ (ti::subrp-p (or alias sym)))
+ (if (and alias
+ (not (eq alias sym)))
+ (message
+ "TinyLisp: alias `%s' => `%s' points to built-in function."
+ word
+ (symbol-name alias))
+ (message
+ "TinyLisp: `%s' is built-in function." word)))
+ ((and (null point) ;; See re-search above which set the point
+ (null file))
+ ;; Can't find from this file, does load history entry say
+ ;; from which file it was loaded ?
+ (message
+ "TinyLisp: Can't find `load-history' definition for %s" word))
+ ((stringp file)
+ (unless (ti::file-name-path-p file)
+ (error
+ "TinyLisp: Couldn't find absolute path %s %s. Contact maintainer"
+ sym file))
+ (when (string-match "\\(.*\\.el\\)c$" file)
+ (setq file (match-string 1 file))
+ (unless (file-exists-p file)
+ (error "TinyLisp: There is only compiled file at %s" file)))
+
+ (when (or (find-buffer-visiting file) ;Already loaded
+ (null verb)
+ (y-or-n-p (format "TinyLisp: Go to: %s ? " file)))
+ (unless (string-match "\\.el$" file)
+ (setq file (concat file ".el")))
+ (unless (ti::file-name-path-absolute-p file)
+ (let ((path (locate-library file)))
+ (if path
+ (setq file path))))
+ (unless (file-exists-p file)
+ (error "Tinylisp: cannot find file %s" file))
+ (setq buffer (find-file-noselect file))
+ (with-current-buffer buffer
+ (setq point (point))
+ (ti::pmin)
+ (ti::buffer-outline-widen)
+ (if (re-search-forward re nil t)
+ (setq point (point))
+ (goto-char point) ;back to original position
+ (setq point nil) ;Clear flag
+ (message "TinyLisp: Strange... cant't find definition: %s"
+ word)
+ (sit-for 2))
+ (when save
+ (if (and save (not (equal save '(4))))
+ (setq tinylisp-:call-chain nil)
+ (tinylisp-push-call-chain nil call-chain-data verb)
+ (if verb
+ (message
+ "TinyLisp: Call chain %d"
+ (length tinylisp-:call-chain)))))))
+ (when (null file)
+ ;; No load-history so try searching all buffers in Emacs
+ (setq buffer nil)
+ (dolist (buf (buffer-list))
+ (save-excursion
+ (set-buffer buf)
+ (when (re-search-forward re nil t)
+ (setq buffer (current-buffer))
+ (setq point (line-beginning-position))
+ (return))))))
+ ;; ....................................................... other ...
+ (point ;; point is set
+ (when save
+ (if (and save (not (equal save '(4))))
+ (setq tinylisp-:call-chain nil)
+ (tinylisp-push-call-chain nil call-chain-data verb)
+ (if verb
+ (message "TinyLisp: Call chain %d"
+ (length tinylisp-:call-chain)))))
+ (point-to-register reg)
+ (goto-char point)
+ (when (null type)
+ (message "TinyLisp: Warning, this symbol is not in obarray.")
+ (sit-for 1))
+ (tinylisp-show-register-message))))
+ ;; ........................................... display found point ...
+ (when (and buffer
+ (not nodisplay)
+ (not (eq buffer (current-buffer))))
+ (ti::pop-to-buffer-or-window buffer point))
+ buffer))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-back-to-definition ()
+ "Jump back to last call chain point in `tinylisp-:call-chain'."
+ (interactive)
+ (tinylisp-push-call-chain 'pop)
+ (message "TinyLisp: Call chain %d" (length tinylisp-:call-chain)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-jump-to-definition-chain (&optional verb)
+ "Save position to call chain and jump to definition.
+See `tinylisp-jump-to-definition'. VERB."
+ (interactive)
+ (ti::verb)
+ (tinylisp-jump-to-definition '(4) (tinylisp-read-word) verb))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-backward-user-option ()
+ "See `tinylisp-forward-user-option'."
+ (interactive)
+ (tinylisp-forward-user-option 'back (interactive-p)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-forward-user-option (&optional back verb)
+ "Search forward or BACK a user variable or user callable function. VERB."
+ (interactive)
+ (let* ((opoint (point))
+ type
+ sym
+ point
+ beg
+ end)
+ (ti::verb)
+ (while (and (null point)
+ (prog1 (setq beg (if back
+ (tinylisp-forward-def 'back)
+ (tinylisp-forward-def)))
+ (unless beg
+ (message "TinyLisp: No more user options.")
+ ;; If you have 'paren' package on and your cursor is
+ ;; at (defun
+ ;; *
+ ;;
+ ;; then the paren will show "Matches (((...."
+ ;; and you wouldn't ever see this message without sit-for
+ ;;
+ ;; Same goes for eldoc.el
+ (sit-for 1))))
+ (cond
+ ((looking-at tinylisp-:regexp-variable)
+ (setq type (match-string 1)
+ sym (intern-soft (match-string 2))))
+ ((looking-at "^(defun[ \t]+\\([^ \t]+\\)")
+ (setq type "defun"
+ sym (intern-soft (match-string 1)))))
+ ;; ..................................................... examine ...
+ ;; Okay we're somewhere at the beginning of variable of
+ (cond
+ ((looking-at "defcustom") ;Yes, this is user variable
+ (setq point (point)))
+ ((and sym ;Is this sym _defined_ ?
+ (or
+ (and (not (string-match "defun" type))
+ (boundp sym) ;Then check is easy
+ (user-variable-p sym))
+ (and (string-match "defun" type)
+ (fboundp sym)
+ (commandp sym))))
+ (setq point (point)))
+ (t
+ ;; ................................................ not loaded ...
+ ;; package is not loaded into memory, we may be looking at
+ ;; varible or function. Determine var/func region first.
+
+ (setq beg (point))
+ (setq end (save-excursion
+ (beginning-of-line)
+ (forward-sexp 1) (point)))
+ (beginning-of-line)
+ ;; This fails only if variable docs at flushed left, but
+ ;; then you don't follow guidelines...
+ ;;
+ ;; (defvar nil
+ ;; "*docs"
+ ;;
+ (if (if (looking-at "^(defun")
+ (re-search-forward "(interactive[) ]" end t)
+ (re-search-forward "^[ \t]+\"\\*" end t)) ;It's variable
+ (setq point beg))))
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. . continue ..
+ (if beg
+ (goto-char beg))
+ ;; Reset round
+ (setq sym nil
+ type nil
+ beg nil
+ end nil))
+ (unless point
+ (goto-char opoint)
+ (if verb
+ (message "TinyLisp: no more user variables or functions.")))
+ point))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;; You can also do this in program code like this.
+;;;
+;;; (fset 'test
+;;; (byte-compile-sexp
+;;; (lambda () nil)))
+;;;
+(defun tinylisp-byte-compile-sexp (&optional disassemble verb)
+ "Byte compile function around point.
+If you give prefix argument DISASSEMBLE, then the function is also
+disassembled to byte code format. VERB."
+ (interactive "P")
+ (let* ((debug-on-error t)
+ name)
+ (ti::verb)
+ (tinylisp-defun-macro
+ (setq name (ti::string-match "def[a-zA-Z]+ +\\([^() \t\n\]+\\)" 1 str))
+ (cond
+ ((not (stringp name))
+ (if verb
+ (message "TinyLisp:No sexp to compile here...")))
+ ((null (intern-soft name))
+ (if verb
+ (message "TinyLisp:%s is not interned symbol." name)))
+ ((null (fboundp (setq name (intern name))))
+ (if verb
+ (message "TinyLisp:%s is not a function name." name)))
+ (disassemble
+ (disassemble name))
+ (t
+ (byte-compile name)
+ (if verb
+ (message "TinyLisp: byte compiled [%s]" name)))))))
+
+;;; ----------------------------------------------------------------------
+;;; #todo: how do you detect the emacs binary used ?
+;;; #todo: unfinished
+;;;
+(defun tinylisp-byte-compile-buffer ()
+ "Compile current buffer as if Emacs were newer loaded.
+Since your current Emacs has already loaded packages, it's not
+wise to compile using `byte-compile-file'.
+
+Instead we cal anmother copy of Emacs to do the compilation so that
+you would catch any errors with undefined variables and functions."
+ (interactive)
+ (let* ((byte-compile-generate-call-tree nil)
+ (file (buffer-file-name)))
+ (if (null file)
+ (message "TinyLisp: Buffer %s is not visiting file." (buffer-name))
+ (call-interactively 'byte-compile-file))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-byte-compile-display-call-tree ()
+ "See bytecomp.el `display-call-tree'."
+ (interactive)
+ (let* ((byte-compile-generate-call-tree t)
+ (file (buffer-file-name)))
+ (if (null file)
+ (message (concat "TinyLisp: Buffer %s is not visiting file."
+ " Cannot display call tree.")
+ (buffer-name))
+ (call-interactively 'byte-compile-file)
+ (let ((buffer (get-buffer "*Call-Tree*")))
+ (when (buffer-live-p buffer)
+ (with-current-buffer buffer
+ (let (buffer-read-only)
+ (save-excursion
+ (ti::pmax)
+ (insert "
+
+** TinyLisp: [NOTE] 'Noninteractive functions not known to be called' usually
+means that the functions were declared defsubst.\n"))
+ buffer)))))))
+
+;;; ----------------------------------------------------------------------
+;;; #todo:
+(defun tinylisp-byte-compile-parse-needed-packages ()
+ "Byte Compile file and check what packages it needs.
+With this function you can find out what other packages are needed to
+run a file."
+ (interactive)
+ (let* ((buffer (tinylisp-byte-compile-display-call-tree)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-set-value-at-point (&optional arg)
+ "Read word under point and if it's variable, ask new value for it.
+ARG can be
+ \\[universal-argument] 'restore variable's content
+ \\[universal-argument]\\[universal-argument] 'backup variable's value"
+ (interactive "P")
+ (let* ((var (tinylisp-read-word))
+ (cmd (cond
+ ((equal arg '(4)) 'restore)
+ ((equal arg '(16)) 'bup))) ;Back it up
+ val)
+ (if (ti::nil-p var)
+ (message "TinyLisp: Couldn't read variable at point")
+ (tinylisp-symbol-do-macro var 'noerr
+ (if (not (boundp var))
+ (message "TinyLisp: There is no %s variable" (symbol-name var))
+ (unless (or (eq cmd 'bup) (memq 'original (symbol-plist var)))
+ (put var 'original (symbol-value var)))
+ (cond
+ ((eq cmd 'restore)
+ (set var (get var 'original))
+ (message
+ "TinyLisp:%s restored to original value" (symbol-name var)))
+ (t
+ (setq val
+ (read-from-minibuffer
+ (format "Set %s to lisp expression: " (symbol-name var))
+ (prin1-to-string (symbol-value var))))
+
+ (setq val (read val)) ;Convert to lisp
+ (set var val))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-call-at-point (&optional record)
+ "Call object at point.
+If prefix arg RECORD is given, the content of the variable
+is appended to record buffer.
+
+- If read object is not in obarray, do nothing.
+- If it is function; ask what to do
+ Show symol-function, so that you can tell if it is byte compiled.
+ Call it, possibly interactively
+- If it's variable, eval it, possibly yielding the content."
+ (interactive "P")
+ (let* ((str (tinylisp-read-word))
+ sym
+ type)
+ (if (or (ti::nil-p str)
+ (null (setq sym (intern-soft str))))
+ (message "TinyLisp: Can't use word to eval (void?): %s "
+ (or str "<no word read>" ))
+ (if (and (fboundp sym)
+ (boundp sym))
+ (if (y-or-n-p (format
+ "Which %s eval: Y = variable, N = function " str))
+ (setq type 'var)
+ (setq type 'func)))
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. . func type ..
+ (cond
+ ((or (eq type 'func)
+ (and (eq type nil)
+ (fboundp sym)))
+ (cond
+ ((null (y-or-n-p "Y = Next choice, N = see symbol-function "))
+ ;; We can't use `message', because it would go nuts; eg if
+ ;; function would contain "%" which are formatting directives
+ (pop-to-buffer (ti::temp-buffer tinylisp-:buffer-macro 'clear))
+ (insert (pp (symbol-function sym)))
+ (ti::pmin))
+ (t
+ (if (and (commandp sym)
+ (y-or-n-p (format "Call interactively '%s' " str)))
+ (call-interactively sym)
+ (setq str (ti::function-args-p 'tinylisp-find-function-list)))
+ (cond
+ ((or (ti::nil-p str)
+ (y-or-n-p
+ (format "Seems to need args %s; call anyway? " str)))
+ (setq str (funcall sym))
+ (message "TinyLisp: function returned: %s"
+ (prin1-to-string str)))))))
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. . var type ..
+ ((or (eq type 'var)
+ (and (eq type nil)
+ (boundp sym)))
+ (setq str (prin1-to-string (eval sym)))
+ (tinylisp-record-macro record
+ (insert "\n" (symbol-name sym) ":\n" str)
+ (message "TinyLisp: Content of variable recorded.")
+ (sit-for 1))
+ (setq str (ti::remove-properties str))
+ (if (< (length str) 73)
+ (message (format "TinyLisp: %s => %s" (symbol-name sym) str))
+ (tinylisp-with-current-buffer
+ (get-buffer-create tinylisp-:buffer-macro)
+ (let ((win (get-buffer-window (current-buffer)))
+ (str (pp (symbol-value sym))))
+ (display-buffer (current-buffer))
+ (ti::pmax)
+ ;; Record this to *Message* buffer too as what we did
+ ;; if the content fit the screen (size 73)
+ ;; User can copy paste the results from Message bufer
+ ;; if needed later
+ (message (format "%s => %s" (symbol-name sym) str))
+ (ti::save-with-marker-macro
+ (insert "\n" (symbol-name sym) " =>\n" str))
+ (set-window-point (get-buffer-window (current-buffer)) (point))
+ ;; If window was not previously visible, resize the content.
+ ;; If the buffer was visible, let it alone, perhaps
+ ;; user wants to keep the size as it.
+ (unless win
+ (shrink-window-if-larger-than-buffer))))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-eval-at-point ()
+ "Evaluate variable or function around point.
+
+Note:
+
+ The definition must be written like this
+
+ (defvar , (defconst , (defun ..
+
+ And there must be no spaces after the opening parenthesis. The following
+ statement is not recognised
+
+ ( defvar
+
+defcustom note:
+
+ When we evaluate defcustom variable, we don't actually evaluate statement
+ as is, but pretend that the defcustom is read like 'defconst'. this has the
+ effect of setting new value for the variable. If you really want to
+ evaluate variable as it stand there: as defcustom, you have to put cursor
+ manually behind the definition and call \\[eval-last-sexp]. In this case
+ defcustom treats the variable as `defvar' and only defcustom properties are
+ touched.
+
+ DANGER:
+
+ When you evaluate `defcustom` variable with this function, be very careful
+ that you have written it correctly, so that you won't get thrown out to
+ error. If this happens, you're in BIG TROUBLE; repeat ; BE ON YOUR TOES
+ and think carefully your next move.
+
+ An error condition prevented restoring an advice that was enabled for
+ special form 'defconst' during the evaluation of `defcustom' definition.
+ The advice is still in effect and you should immediately disable it
+ before you do anything else.
+
+ Call \\[tinylisp-emergency] NOW! After that things are back to normal.
+ and you can continue as usual."
+ (interactive)
+ (let* ((debug-on-error t)) ;Make sure this is on!
+ (tinylisp-defun-macro
+ ;; We handle defvar as defconst so that new value takes in
+ ;; effect.
+ (cond
+ ((string-match "defcustom" str)
+ (tinylisp-defcustom-macro
+ (tinylisp-eval "defcustom" "defconst" nil buffer beg end)))
+ ((string-match "defvar" str)
+ (tinylisp-eval "defvar" "defconst" nil buffer beg end))
+ (t
+ (eval-last-sexp nil)))
+ (message (concat "TinyLisp: evaled " (or str "<nothing>"))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-eval-fix-defconst ()
+ "Fix defconst that has no argument.
+
+ (defvar var) ;; valid,
+
+When converted
+
+ (defconst var) ;; invalid
+
+The defconst must have initial value: we supply 'nil"
+ (ti::pmin)
+ (while (re-search-forward "^(defconst[ \t]+[^ \t]+\\([ \t]\\)*)" nil t)
+ (backward-char 1)
+ (insert " nil")
+ (end-of-line)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-eval-print-last-sexp ()
+ "Like `eval-print-last-sexp', but print --> at front."
+ (interactive)
+ (let ((standard-output (current-buffer)))
+ (terpri)
+ (eval-last-sexp t))
+ (save-excursion
+ (beginning-of-line)
+ (insert "--> ")
+ (end-of-line)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-eval-current-buffer-defconst ()
+ "Eval buffer as defconst and print message."
+ (interactive)
+ (let* ((obuffer (current-buffer))
+ (name (buffer-name))
+ (beg (point-min)) ;maybe narrowed?
+ (end (point-max)))
+ (tinylisp-with-current-buffer
+ (ti::temp-buffer tinylisp-:buffer-tmp 'clear)
+ (insert-buffer-substring obuffer beg end)
+ (ti::pmin)
+ (while (re-search-forward "^(defvar \\|^(defcustom " nil t)
+ (replace-match "(defconst "))
+ ;; We have to do another sweep
+ (tinylisp-eval-fix-defconst)
+ (tinylisp-defcustom-macro (tinylisp-eval-current-buffer)))
+ (message "TinyLisp: ok, evaled buffer %s as defconst." name)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-eval-current-buffer-from-file ()
+ "Evaluate buffer by doing `load-file' from disk.
+This effectively stored the function and variable definitions
+to `load-history'.
+
+If current buffer has no file, call `tinylisp-eval-current-buffer'."
+ (interactive)
+ (cond
+ ((null buffer-file-name)
+ (tinylisp-eval-current-buffer))
+ (t
+ (if (and (buffer-modified-p)
+ (y-or-n-p "Save before loading? "))
+ (save-buffer))
+ ;; `load' prints message for user
+ (load buffer-file-name))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-eval-current-buffer ()
+ "Eval buffer and print message."
+ (interactive)
+ ;; This silences byte compiler
+ (if (fboundp 'eval-buffer)
+ (ti::funcall 'eval-buffer) ;XEmacs
+ (ti::funcall 'eval-current-buffer))
+ (message "TinyLisp: ok, evaled buffer %s" (buffer-name)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-eval-reverse ()
+ "Search backward for opening parenthesis and Reverse the statement.
+See variable `tinylisp-:table-reverse-eval-alist'"
+ (interactive)
+ (let* ((stat (tinylisp-read-symbol-at-point))
+ (table tinylisp-:table-reverse-eval-alist)
+ func
+ str1
+ str2
+ statement)
+ (if (or (null stat)
+ (ti::nil-p (setq func (nth 1 stat))))
+ (message "TinyLisp: Can't find command around point.")
+
+ (tinylisp-symbol-do-macro func 'noerr
+ (setq str1 (symbol-name func))
+ (if (null (setq func (cdr-safe (assq func table))))
+ (message "TinyLisp: Can't find reverse command for %s" str1)
+ (setq str2 (symbol-name func)
+ statement (nth 2 stat))
+
+ ;; Do some special handling, e.g. add hook may have
+ ;; additional argument 'add , remove it.
+
+ (when (string-match "add-hook +[^ ]+ +[^ ]+\\( +[^ )]+\\))"
+ statement)
+ (setq statement (ti::replace-match 1 "" statement)))
+
+ (tinylisp-eval str1 str2 'string statement)
+ (message "TinyLisp: evaled as %s" str2))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-eval-edit ()
+ "Read current line and allow editing the statement before evaling it."
+ (interactive)
+ (let* ((line (ti::string-remove-whitespace (ti::read-current-line)))
+ ret)
+ (setq ret (eval (read (read-from-minibuffer "tinylisp-Eval: " line))))
+ (message "TinyLisp: returned: %s" (prin1-to-string ret))))
+
+;;}}}
+;;{{{ code help: functions and variables
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-find-function-list-occur ()
+ "Run occur to find functions from whole buffer."
+ (interactive)
+ (ti::occur-macro tinylisp-:regexp-function nil
+ (ti::text-re-search-forward "(defmacro")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-find-function-list (&optional no-show mode)
+ "Find functions from buffer (macros too).
+
+Output line format:
+
+ [DEF][!?] FUNCTION-NAME INTERACTIVE-SPEC
+
+ The DEF can defmacro, defun and defsubst.
+
+ [!] If you see exclamation mark then it means that you have mixed
+ defsubst and interactive function, which is very dangerous situation,
+ because when function is in-lined the (interactive-p) tests from functions
+ are in-lined too. Check that you really want to do in-lining for
+ interactive functions.
+
+ [?]Question mark means that the function does not exist in obarray
+ and the possible interactive property is unknown.
+
+Input:
+
+ NO-SHOW if non-nil, then the result buffer is not shown.
+ MODE if 'alternative then if there are no left flushed functions then
+ try finding indented ones.
+
+return:
+
+ '((type-string . name) ...)"
+ (interactive)
+ (let* ((re tinylisp-:regexp-function)
+ (buffer tinylisp-:buffer-data)
+ (loop t)
+ list
+ type
+ var
+ str
+ func)
+ (while loop
+ (setq loop nil)
+ (save-excursion
+ (ti::pmin)
+ (while (re-search-forward re nil t)
+ (setq type (match-string 1)
+ var (match-string 2))
+ (if (and type var)
+ (ti::nconc list (cons type var))))
+ (if (and (null list)
+ (eq mode 'alternative))
+ (setq loop t ;try again
+ ;; remove anchor
+ re (substring re 1)))))
+ (if (and list (null no-show))
+ (tinylisp-with-current-buffer (ti::temp-buffer buffer 'clear)
+ (dolist (var list)
+ (setq str nil) ;Clear this
+ ;; Is it symbol? Yes; okay is there really such function?
+ ;; Okay, read the interactive arguments the, OTW
+ ;; it was not a function.
+ (if (setq func (intern-soft (cdr var)))
+ (if (fboundp func)
+ (setq str (commandp func))
+ (setq func nil)))
+ (insert (format "%-12s%s%s %-40s %s\n"
+ (car var)
+ ;; Interactive and defsubst? this is dangerous!
+ ;;
+ (if (and str
+ (string= "defsubst" (car var)))
+ " !" "")
+ (if (null func) " ?" "")
+
+ (cdr var)
+ (or str ""))))
+ (pop-to-buffer (current-buffer))
+ (ti::pmin)
+ (run-hooks 'tinylisp-:find-func-list-hook)))
+ list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-find-variable-list-occur ()
+ "Run occur to find variables from whole buffer."
+ (interactive)
+ (ti::occur-macro tinylisp-:regexp-variable nil
+ (ti::text-re-search-forward "(defconst")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-find-variable-list (&optional show-type)
+ "Get all defvars and defconst from current buffer.
+you can e.g. call this function to get all variables and update them
+to your M - x xxx-submit-bug-report function's variable list.
+
+the appearing list will wave defvar's first, then defconst.
+
+input:
+ SHOW-TYPE if non-nil, then show `user-variable-p' and
+ `defcustom' information too."
+ (interactive "p")
+ (let* ((re tinylisp-:regexp-variable)
+ (buffer tinylisp-:buffer-variables)
+ str
+ sym
+ type var
+ vl ;def(v)ar (l)ist
+ cl ;def(c)onst (l)ist
+ list)
+ (save-excursion
+ (ti::pmin)
+ (while (re-search-forward re nil t)
+ (setq type (match-string 1)
+ var (match-string 2))
+ (if (string-match "defvar\\|defcustom" type)
+ (push (cons type var) vl)
+ (push (cons type var) cl))))
+ (if (not (or vl cl))
+ (message "TinyLisp: Can't' find any variables.")
+ (with-current-buffer (ti::temp-buffer buffer 'clear)
+ (display-buffer (current-buffer))
+ ;; Preserve order with reverse
+ (setq vl (nreverse vl)
+ cl (nreverse cl))
+ (setq list (list vl cl))
+ (dolist (elt list) ;loop both lists
+ (dolist (var elt)
+ (setq type (car var)
+ sym (cdr var)
+ str ";; #symbol not found")
+ (tinylisp-symbol-do-macro sym 'noerr
+ (setq str "")
+ (if (user-variable-p sym)
+ (setq str "user variable"))
+ (if (string= type "defcustom")
+ (setq str (concat str " defcustom")))
+ (if (not (ti::nil-p str)) ;Add comment prefix if not empty
+ (setq str (concat ";; " str))))
+ (if (null show-type)
+ (insert (cdr var) "\n")
+ (insert (format "%-40s%s\n" (cdr var) str))))
+ (insert "\n")
+ (ti::pmin)
+ (run-hooks 'tinylisp-:find-var-list-hook))))
+ buffer))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-narrow-to-function ()
+ "Narrow to current function around point."
+ (interactive)
+ (let* ((re tinylisp-:regexp-function)
+ beg
+ end)
+ (save-excursion
+ (beginning-of-line)
+ (if (not (looking-at re))
+ (re-search-backward tinylisp-:regexp-function))
+ ;; find first empty line
+ (re-search-backward "^[ \t]*$" nil t)
+ (setq beg (point))
+ (forward-sexp 1)
+ (setq end (point)))
+ (narrow-to-region beg end)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-library-symbol-information (file &optional verb)
+ "Display symbol information from FILE (full path name). VERB.
+FILE must be loaded into Emacs to gather all the variable
+and function definitions."
+ (interactive
+ (list
+ (locate-library
+ (tinylisp-library-read-name 'el))
+ current-prefix-arg))
+ (let* ((feature-name (intern-soft
+ (file-name-sans-extension
+ (file-name-nondirectory file)))))
+ ;; If the feature is not same as file name, we have no
+ ;; other choice to load the file. If feature-name was
+ ;; set, then the feature is already in Emacs (file was loaded
+ ;; previously)
+ (unless feature-name
+ (load file))
+ (with-current-buffer (ti::system-get-file-documentation file verb)
+ (turn-on-tinylisp-mode))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-library-info-emacs (&optional verb)
+ "Examine load history and print libraries loaded into Emacs.
+The summary for each library is in following format:
+
+ [*]xxx.el NN /usr/local/Emacs/lisp tinylibm tinylib
+ | | | |
+ | | | | What it `required'
+ | | Where it is according to `load-path' order.
+ | How many symbols defined
+ If star, then the load history had full path name for library
+
+If VERB parameter is nil, then the buffer is not shown and no
+messages are displayed.
+
+Return:
+
+ buffer `tinylisp-:buffer-data'"
+ (interactive)
+ (let* ((max (length load-history ))
+ (buffer (ti::temp-buffer tinylisp-:buffer-library 'clear))
+ (i 0)
+ (unknown "--unknown--")
+ dep-list
+ name
+ path)
+ (ti::verb)
+ (tinylisp-with-current-buffer buffer
+ (dolist (pkg load-history)
+ (when (stringp (setq name (car pkg)))
+ (setq path (ti::system-load-history-where-is-source name)))
+ ;; Go to next element, these will have dependency information
+ ;; ("tinycom" (require . tinylibm) byte-compile-dynamic ...
+ ;; |
+ ;; Get these
+ (pop pkg)
+ (while (ti::consp (car pkg))
+ (push (cdr (car pkg)) dep-list)
+ (pop pkg))
+ ;; User has evaled the package 'in place' and not loaded it.
+ (unless (stringp name)
+ (setq name unknown))
+ (insert
+ (format
+ "%-15s %3d %-35s %s %s\n"
+ (concat
+ (if (string-match "^/" (or name ""))
+ "*"
+ "")
+ (file-name-nondirectory name))
+ (length pkg)
+ (if path
+ (file-name-directory path)
+ "<no path>")
+ (mapconcat
+ (function (lambda (x) (symbol-name x)))
+ dep-list
+ " ")
+ ;; - If the package name is unknow, print some symbol
+ ;; names that it defined so that user can use grep later
+ ;; to find out what packagage it was
+ ;;
+ (if (not (string= name unknown))
+ ""
+ (format "%s ..." (ti::string-left (prin1-to-string pkg) 80)))))
+ (if verb
+ (message "TinyLisp: lib info %d/%d %s" i max name))
+ (incf i)
+ (setq dep-list nil
+ pkg nil)))
+ (tinylisp-with-current-buffer buffer
+ (ti::pmin)
+ (sort-lines nil (point-min) (point-max)))
+ (when verb
+ (pop-to-buffer buffer)
+ (ti::pmin)
+ (message "Done."))
+ buffer))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-read-something ()
+ "Position point to over some words near point."
+ (save-excursion
+ (if (looking-at "[ \t\n]") ;only spaces ahead?
+ (ti::read-current-line)
+ ;; go backward until space(word) or function call
+ (unless (char= (following-char) ?\( )
+ (re-search-backward "[( \t\n]" nil t)
+ (skip-chars-forward " \t\n")))
+ (buffer-substring (point) (line-end-position))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-library-read-name (&optional el)
+ "Read lisp library name with possible completion. If EL, return with .el"
+ (let* ((cache (fboundp 'tinypath-emacs-lisp-file-list))
+ (list (cond
+ (cache
+ ;; tinyPath caches all files for fast loading
+ ;; Use it if available
+ (ti::funcall 'tinypath-emacs-lisp-file-list 'from-cache))
+ (t
+ (ti::list-to-assoc-menu
+ (ti::system-load-history-emacs-lisp-files)))))
+ (word (ti::string-match "[a-z0-9]+[a-z0-9-.]+" 0
+ (or (tinylisp-read-word) "" )))
+ file)
+ (when (setq file
+ (completing-read
+ (format "%sLisp Library: "
+ (if cache
+ "(tinypath cache)"
+ "(load-history)"))
+ list
+ nil
+ nil
+ word))
+ (when el
+ (when (string-match "^\\(.*\\)\\.elc$" file)
+ (setq file (concat (match-string 1 file))))
+ (unless (string-match "\\.el" file)
+ (setq file (concat file ".el")))))
+ file))
+
+;;; ----------------------------------------------------------------------
+;;; The name is not a mistake although it may sound repetitive. All
+;;; function in TinyLisp have prefix "tinylisp-library" if they deal with
+;;; load-path libraries.
+;;;
+;;; The second part is `locate-library' which is standard Emacs function.
+;;; If you do a C-h a `locate-library' you will correctly find both
+;;; of these implementations.
+;;;
+(defun tinylisp-library-locate-library-1 (file &optional extensions)
+ "Like `locate-library' but find all possible occurrances of FILE.
+This also finds compressed files. Path portion and file extensions
+in FILE are ignored.
+
+Extensiosn are by default '(\".el\" \".elc\")."
+ (let* ((compressions '("" ".gz" ".Z" ".z" ".bz2" ".zip"))
+ try
+ ret)
+ (setq file (file-name-sans-extension
+ (file-name-nondirectory file)))
+ (or extensions
+ (setq extensions '(".el" ".elc")))
+ (dolist (path load-path)
+ (setq path (expand-file-name path))
+ (dolist (end extensions)
+ (dolist (z compressions)
+ (setq try (format "%s%s%s%s"
+ (file-name-as-directory path) file end z))
+ (if (file-exists-p try)
+ (pushnew try ret :test 'string=)) )))
+ ;; Preserve search order (due to push)
+ (nreverse ret)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-library-locate-by-fullpath-intercative ()
+ "Call `tinylisp-library-locate-by-fullpath' interactive with a check."
+ (interactive)
+ (cond
+ ((not (featurep 'tinylisp))
+ (message "Tinylisp: [ERROR] Fullpath locate requires tinypath.el."))
+ (t
+ (call-interactively
+ 'tinylisp-library-locate-by-fullpath))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-library-locate-by-fullpath (regexp)
+ "Find all packages whose full path name match REGEXP.
+This function requires that feature 'tinypath is present.
+List is outputted to message buffer."
+ (interactive "sMatch package fullpath by regexp: ")
+ (message "Tinylisp: Locate by FULLPATH regexp '%s' -- begin"
+ regexp)
+ (dolist (path (tinypath-cache-match-fullpath regexp 'names))
+ (message path))
+ (message "Tinylisp: Locate by FULLPATH regexp '%s' -- end"
+ regexp)
+ (display-buffer (ti::buffer-pointer-of-messages)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-library-locate (file &optional insert)
+ "Like `locate-library' but find all possible occurrances of FILE.
+Optionally. INSERT found filenames to point."
+ (interactive (list (tinylisp-library-read-name) current-prefix-arg))
+ (let ((list (tinylisp-library-locate-library-1 file)))
+ (if (null list)
+ (message "TinyLisp: no library found %s" file)
+ (message "TinyLisp: %s" (ti::list-to-string list))
+ (if insert
+ (insert (ti::list-to-string list "\n"))))
+ list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-library-documentation (file &optional insert)
+ "Print the documentation of lisp FILE and possibly INSERT it to point.
+This relies on the fact that documentation is at the beginning of file.
+
+Return:
+
+ buffer Content of Commentary: section"
+ (interactive
+ (list (tinylisp-library-read-name 'el) current-prefix-arg))
+ (let* ((list (tinylisp-library-locate-library-1 file '(".el") ))
+ str
+ file
+ buffer)
+ (when list
+ (when (interactive-p)
+ (setq file (car list))
+ (if (> (length list) 1)
+ (setq file
+ (completing-read "TinyLisp: [Choose] "
+ (ti::list-to-assoc-menu list)
+ nil
+ 'match)))
+ ;; Same what finder-commentary uses.
+ ;; One problem: lm-commentary has a bug, which causes killing
+ ;; the file from emacs after it's done. But we don't want that
+ ;; if use is viewing or loaded it to emacs before us.
+ ;;
+ ;; Work around that bug.
+ (let ((buffer (find-buffer-visiting file)))
+ (setq str
+ (if (null buffer)
+ (lm-commentary file)
+ (with-temp-buffer
+ (insert-buffer buffer)
+ (lm-commentary)))))
+ (if (not (stringp str))
+ (message "TinyLisp: No commentary in %s" file)
+ (with-temp-buffer
+ (insert str)
+ (ti::pmin) (ti::buffer-replace-regexp "^;+" 0 "")
+ (ti::pmin) (ti::buffer-replace-regexp "\r" 0 "")
+ (setq str (buffer-string)))
+ (cond
+ (insert
+ (insert str)
+ (setq buffer (current-buffer)))
+ (t
+ (setq buffer (ti::temp-buffer tinylisp-:buffer-library 'clear))
+ (with-current-buffer tinylisp-:buffer-library
+ (insert str)
+ (ti::pmin) ;;#todo: how to display it at start?
+ (display-buffer (current-buffer))))))))
+ buffer))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-library-find-file (file)
+ "`find-file' a lisp library FILE along `load-path'.
+In interactive call, the FILE is completed using `load-path' libraries."
+ (interactive (list (tinylisp-library-read-name 'el)))
+ (let* ((path (locate-library file)))
+ (if (not path)
+ (message "TinyLisp: file %s not along `load-path'" file)
+ (find-file path))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-library-load-library (file)
+ "Like `load-library' but offer completion of lisp files."
+ (interactive (list (tinylisp-library-read-name)))
+ (let* ((file (locate-library file)))
+ (if (not file)
+ (message "TinyLisp: file %s not along `load-path'" file)
+ (load-library file))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-load-history-grep (regexp)
+ "Grep load history with REGEXP."
+ (ti::list-find
+ (mapcar 'car load-history)
+ regexp
+ (function
+ (lambda (arg elt)
+ (string-match arg (or elt ""))))
+ 'all-matches))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-library-load-by-regexp (regexp &optional no-elc verb)
+ "Reload all packages (that are inside Emacs) matching REGEXP.
+NO-ELC says to load non-compiled packages. VERB."
+ (interactive
+ (list
+ (read-from-minibuffer "Reload packages matching regexp: ")
+ (y-or-n-p "Load uncompiled versions ")))
+
+ (let* ((count 0)
+ list
+ done)
+ (ti::verb)
+ (when (and verb
+ (string-match "el$" regexp))
+ (message "Tinylisp: Reload, regexp should not need to match .el$"))
+ (setq list (tinylisp-load-history-grep regexp))
+ (dolist (elt list)
+ (setq elt (expand-file-name elt))
+ ;; Remove extension and use .el always,
+ ;; Note, that the elt may not have extension at all
+ ;; when we do del-re
+ (cond
+ (no-elc
+ (setq elt (replace-regexp-in-string "\\.elc?$" "" elt))
+ (setq elt (concat elt ".el")))
+ (t
+ ;; Remove whole extension
+ (setq elt (replace-regexp-in-string "\\.elc?$" "" elt))))
+ (unless (member elt done)
+ ;; In XEmacs; the packages are stored as absolute path names.
+ ;; In Emacs, just "package.el".
+ ;; Try loading absolute, if it does not work; try without.
+ (push elt done)
+ (cond
+ ((or (and (ti::file-name-path-p elt)
+ (load elt 'noerr))
+ (progn
+ (setq elt (file-name-nondirectory elt))
+ (load elt 'noerr)))
+ (incf count))
+ (t
+ (message "TinyLisp: Reload failed %s" elt)))))
+ (when verb
+ (message "TinyLisp: %s packages reloaded" count))
+ list))
+
+;;; ----------------------------------------------------------------------
+;;; See XEmacs ilisp.el :: describe-symbol-find-file
+;;;
+;;; (defun describe-symbol-find-file (symbol)
+;;; (loop for (file . load-data) in load-history
+;;; do (when (memq symbol load-data)
+;;; (return file))))
+;;;
+(defun tinylisp-library-find-symbol-load-info ()
+ "Try to look up load history to determine from where functions was defined.
+read current line from point forward.
+
+displayed message format:
+
+ [m]{AD} symbol-xxx: package.el (~/elisp/mime/)
+ [m]{AD} symbol-xxx: ~/elisp/xxx.el
+
+Description:
+
+ The first line says that the load history entry contains only
+ \"package.e\" and according to `load-path' information the package was
+ found from directory ~/elisp/mime/.
+
+ The second line: `load-history' contained full path for the package
+
+Note:
+
+ Additional characters at the beginning: `m' function is macro.
+
+ The additional 'AD' String appears on the line of the function has
+ any advice code attached to it. To check the advice documentation
+ string, call \\[describe-function].
+
+ BUT, this flag only tells if there is advice code, it does not tell
+ whether the acvice is active or not (If you don't see advice mentioned
+ after \\[describe-function], then the aadvice is instrumented, but
+ latent, and not working currently)."
+ (interactive)
+ (let* ((str (tinylisp-read-something))
+ (sym (tinylisp-get-symbol str))
+ (alias (or (ti::defalias-p sym) sym))
+ (autoload (ti::autoload-p sym))
+ (ad-info "")
+ package
+ path
+ msg)
+ (if (null sym)
+ (message "TinyLisp: \
+Can't find _defined_ variable or function on the line (eval buffer first).")
+ (if (memq 'ad-advice-info (symbol-plist sym))
+ (setq ad-info "AD "))
+ (cond
+ ((null (fboundp alias))
+ (setq msg "not a function"))
+ ((ti::subrp-p alias)
+ (setq msg "<Built-in function>"))
+ (autoload
+ (let* ( ;; (autoload "dired-aux" "Copy all..")
+ (file (ti::string-match
+ " \"\\([^\"]+\\)" 1
+ (prin1-to-string (symbol-function autoload))))
+ (name (symbol-name autoload))
+ (path (locate-library file)))
+ (setq msg
+ (format "[autoload] %s %s (%s)"
+ (if (not (eq autoload sym))
+ (concat "defalias->" name)
+ "")
+ (if path
+ (file-name-nondirectory path)
+ file)
+ (if path
+ (file-name-directory path)
+ "<no path found>")))))
+ ;; ............................................... load-history ...
+ ((setq package (car-safe
+ (ti::system-load-history-where-is-source alias)))
+ (if (setq path (ti::system-load-history-where-is-source package))
+ (setq msg
+ (format "%s (%s)"
+ (file-name-nondirectory path)
+ (file-name-directory path)))
+ (setq msg "<no path found>")))
+ ;; ...................................................... other ...
+ (t
+ ;; See if we have find-func available and call it
+ (if (not (and (fboundp 'find-function)
+ (ignore-errors (ti::funcall 'find-function alias))))
+ (setq msg "no `load-history' entry; maybe evaled locally?"))))
+ ;; ..................................................... message ...
+ (message "%s%s%s: %s"
+ (if (ti::defmacro-p sym) "(macro)" "")
+ ad-info
+ (if (and alias
+ (not (eq alias sym)))
+ (format "[%s alias --> %s]"
+ (symbol-name sym)
+ (symbol-name alias))
+ (symbol-name sym))
+ msg))))
+
+;;}}}
+;;{{{ code help: misc
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-autoload-generate-library (library)
+ "Read all defuns and construct autoloads from LIBRARY on `load-path'."
+ (interactive
+ (list (tinylisp-library-read-name)))
+ (let* ((path (if (file-name-absolute-p library)
+ library
+ (or (locate-library library)
+ (error "TinyLisp: Can't locate library %s" library)))))
+ ;; The name MUST end to .el, because that is the source of autoloads
+ (cond
+ ((string-match "\\.elc$" path)
+ (setq path (replace-match ".el" nil t path)))
+ ((not (string-match "\\.el$" path))
+ (setq path (concat path ".el"))))
+
+ (ti::package-autoload-create-on-file
+ path (get-buffer-create tinylisp-:buffer-autoload))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-autoload-generate-buffer (&optional arg)
+ "Read all defuns and construct autoloads from buffer's file on disk.
+The autoloads cannot be generated from anonymous buffer, because the
+syntax is:
+
+ (autoload 'function \"file\" ..)
+ |
+ This is mandatory
+
+ ARG Ask lisp library name and locate it in `load-path' and generate
+ autoloads."
+ (interactive "P")
+ (cond
+ (arg
+ (tinylisp-autoload-generate-library
+ (tinylisp-library-read-name)))
+ ((buffer-file-name)
+ (ti::package-autoload-create-on-file
+ (buffer-file-name) (get-buffer-create tinylisp-:buffer-autoload)))
+ (t
+ (message "TinyLisp: Autoloads can only be generated from file."))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-autoload-generate-file
+ (file &optional regexp no-desc buffer verb)
+ "Generate autoload from FILE matching REGEXP.
+Input:
+
+ FILE file or directory.
+ REGEXP if FILE was directory, include fiels matching REGEXP.
+ NO-DESC If non-nil, do not include function desctiotion comments.
+ Interactively supply \\[universal-argument].
+ BUFFER Buffer where to gateher autoload; default
+ `tinylisp-:buffer-autoload'
+ VERB Flag, Pop to autoload buffer."
+ (interactive "DAutoload directory: \nsFiles Matching regexp: \nP")
+ (let* ((files (if (file-directory-p file)
+ (ti::directory-files file regexp 'abs
+ '(and (not (file-directory-p arg))
+ (string-match "\\.el$" arg)))
+ (list file)))) ;single filename
+ (or buffer
+ (setq buffer (get-buffer-create tinylisp-:buffer-autoload)))
+ (ti::verb)
+ (dolist (file files)
+ (ti::package-autoload-create-on-file
+ file
+ buffer
+ (null verb)
+ no-desc))
+ buffer))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-forward-def (&optional back verb)
+ "Go to next `def' forrward or `BACK'. VERB."
+ (interactive "P")
+ (let* ((opoint (point))
+ ret)
+ (ti::verb)
+ ;; Before doing slow loop, try this. This may fail; because
+ ;; the 'defun macro' doesn't land always to right spot. Try negative
+ ;; indent inside fuction
+ ;;
+ ;; (defun ...
+ ;; (negative-indent
+ ;; ...other function code
+ ;; *point here
+ ;;
+ ;; And the defu macro would go to `negative' indent position and not
+ ;; to the `defun'. That's why regexp text.
+ (cond
+ (back
+ (beginning-of-defun)
+ (cond
+ ((looking-at "^(def")
+ (setq ret (point)))
+ ((re-search-backward "^(def" nil t)
+ (setq ret (match-beginning 0)))))
+ (t
+ (end-of-defun)
+ (if (re-search-forward "^(def" nil t)
+ (setq ret (match-beginning 0)))))
+ (if ret
+ (goto-char ret)
+ (goto-char opoint)
+ (if verb "No more `def' matches"))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-indent-around-point (&optional verb )
+ "Indent current statement around the point. typically a function.
+VERB."
+ (interactive)
+ (let* (msg
+ beg
+ end)
+ (ti::verb)
+ (and (save-excursion
+ (and (setq beg (tinylisp-forward-def 'back))
+ (setq msg (ti::string-left (ti::read-current-line) 60)))
+ beg)
+ (save-excursion
+ (goto-char beg) (end-of-defun)
+ (setq end (point))))
+
+ (if (not (and beg end))
+ (if verb (message "TinyLisp: can't find anything to indent here."))
+ ;; Reset the prefix or disaster occur
+ (let (fill-prefix) (indent-region beg end nil))
+ (if verb (message "TinyLisp: [indented] %s" msg)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-defmacro-surround-word ()
+ "Surround current word with (, ) defmacro statement."
+ (interactive)
+ (unless (ti::char-in-list-case (preceding-char) '(?\ ?\t ?\n))
+ (backward-word 1))
+ (insert "(, ")
+ (forward-word 1)
+ (insert ")"))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-macroexpand (&optional expand-function)
+ "Expand macro call with EXPAND-FUNCTION which is string.
+If point is sitting inside call to macro, expand it.
+in the following example the cursor is at point [*].
+
+ (macro-function-call arg1 * arg2 arg3)
+
+references:
+ `tinylisp-:buffer-macro'
+ `tinylisp-:macroexpand-function-list'"
+
+ (interactive
+ (list
+ (intern-soft
+ (completing-read
+ "Expand with function: "
+ (ti::list-to-assoc-menu tinylisp-:macroexpand-function-list)
+ nil
+ nil
+ (car tinylisp-:macroexpand-function-list)))))
+ (let* ((mac-re tinylisp-:regexp-macro-definition)
+ (opoint (point))
+ point
+ symbol
+ sym
+ to-buffer)
+ (when (not (and (symbolp expand-function)
+ (fboundp expand-function)))
+ (error "Not a function %s" expand-function))
+ (tinylisp-defun-macro
+ (if (setq symbol (ti::string-match "[^() \t\n\]+" 0 str))
+ (setq sym (intern-soft symbol)))
+ (cond
+ ((and (stringp symbol)
+ ;; These are macros
+ (not (string-match mac-re symbol))
+ ;; Others are supposed to be function definitions
+ (string-match "^def" symbol)
+ (not (ti::defmacro-p sym)))
+ (message
+ "TinyLisp: grabbed %s, but it is not a macro's call statement"
+ symbol))
+ ((and (stringp symbol)
+ sym
+ (ti::defmacro-p sym))
+ (setq to-buffer (ti::temp-buffer tinylisp-:buffer-macro 'clear))
+ (append-to-buffer to-buffer beg end)
+ (goto-char opoint) ;restore position
+ (pop-to-buffer to-buffer)
+ (ti::pmin)
+ (emacs-lisp-mode)
+ (insert "(" (symbol-name expand-function) " '\n" )
+ (ti::pmax) (insert ")")
+ (setq point (point))
+ (eval-last-sexp 'output)
+ (delete-region (point-min) point)
+ (ti::pmin))
+ ((and (stringp symbol)
+ (fboundp sym))
+ (message "TinyLisp: macroexpand, sexp was function: %s" symbol))
+ (t
+ (message "TinyLisp: macroexpand, skipped: %s"
+ (or str "<can't read>")))))))
+
+;;}}}
+;;{{{ properties display
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-post-command-config (&optional restore)
+ "Disable modes that echo something to the echo-ares.
+User can't see string echoed otherwise. Optionally RESTORE."
+ (let* ((list '(
+ ("lisp" . eldoc-mode)
+ ("." . paren-message-offscreen)))
+ sym
+ re)
+ (dolist (elt list)
+ (setq re (car elt) sym (cdr elt))
+ (when (and (boundp sym)
+ (string-match re (symbol-name major-mode)))
+ (put 'tinylisp-mode sym (symbol-value sym))
+ (set sym (if restore t nil))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-post-command-run-p ()
+ "Check if running post command is allowed."
+ (and (not (eq (selected-window) (minibuffer-window)))
+ (not (minibuffer-window-active-p (minibuffer-window)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-syntax-post-command ()
+ "Show syntax information for current point."
+ (when (tinylisp-post-command-run-p)
+ (message "[TinyLisp syntax info] %s: %s"
+ (char-to-string (following-char))
+ (ti::string-syntax-info (following-char)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-syntax-show-mode (&optional arg verb)
+ "Constantly show character syntax info, ARG behaves like mode arg. VERB."
+ (interactive "p")
+ (ti::verb)
+ (cond
+ (tinylisp-:property-show-mode
+ (error "Turn off property show mode first."))
+ (t
+ (ti::bool-toggle tinylisp-:syntax-show-mode arg)
+ (cond
+ (tinylisp-:syntax-show-mode
+ (make-local-hook 'post-command-hook)
+ (add-hook 'post-command-hook 'tinylisp-syntax-post-command)
+ (tinylisp-post-command-config))
+ (t
+ (remove-hook 'post-command-hook 'tinylisp-syntax-post-command)
+ (tinylisp-post-command-config 'restore)))))
+ (if verb
+ (message
+ "TinyLisp: syntax show mode is %s"
+ (if tinylisp-:syntax-show-mode
+ "on"
+ "off"))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-property-info (&optional arg)
+ "See `tinylisp-property-show' and ARG. Return string 'face-info ov-info'."
+ (let ((count 0)
+ (face-str "")
+ (ov-str "")
+ prefix-ok
+ ovl)
+ (if (member arg '(1 (16) (64)))
+ (setq face-str
+ (format
+ "%s"
+ (prin1-to-string (text-properties-at (point))))))
+ (when (member arg '((4) (16) (64)))
+ (setq ovl (ti::compat-overlays-at (point)))
+ ;; When there is only one verlay at point, the message should say
+ ;; "ov" and reserve "ov1" "ov2" for multiple overlays.
+ (if (> (length ovl) 1)
+ (setq prefix-ok t))
+ (dolist (elt ovl)
+ (incf count)
+ (setq ov-str
+ (format
+ "%sov%s%s "
+ ov-str
+ (if prefix-ok
+ (int-to-string count)
+ "")
+ (prin1-to-string (ti::compat-overlay-properties elt))))))
+ (concat face-str " " ov-str)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-property-post-command ()
+ "Display property info according to `tinylisp-:property-show-mode'.
+This is post command."
+ (when (tinylisp-post-command-run-p)
+ (let* ((record (equal '(64) tinylisp-:property-show-mode))
+ (ch (char-to-string (following-char)))
+ str)
+ (setq str
+ (format
+ "%s:%s"
+ (point)
+ (tinylisp-property-info tinylisp-:property-show-mode)))
+ (tinylisp-record-macro record (insert ch str "\n"))
+ (message "TinyLisp: %s%s" (if record "r" "") str))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-property-show-mode (arg &optional verb)
+ "Toggle permanent text property info mode with ARG. VERB.
+Utilises local `post-command-hook'.
+
+The echo-area will show following message; definition first, then example.
+It says that there is one face and two overlays in current position 12.
+The little 'r' appeared at the beginning if the record mode is selected.
+
+ [r]POINT:FACE-PROPERTIES[ovN:OVERLAY-PROPERTIES]
+ 12:(face highlight)ov1(face region)ov2(owner my)
+
+Input ARG:
+ nil toggle between 0 and '(16)
+ 0 off
+ 1 show face properties
+ '(4) C -u show overlay properties.
+ '(16) C -u C -u show both text properties and overlays.
+ '(64) C -u C -u C -u show both text properties and overlays AND
+ record info in buffer `tinylisp-:buffer-record'.
+VERB verbose flag"
+ (interactive "P")
+ (ti::verb)
+ (if tinylisp-:syntax-show-mode
+ (error "Please turn off Syntax show mode first.")
+ (cond
+ ((null arg)
+ (if (null tinylisp-:property-show-mode)
+ (setq tinylisp-:property-show-mode '(16))
+ (setq tinylisp-:property-show-mode nil)))
+ ((member arg '((4) (16) (64)))
+ (setq tinylisp-:property-show-mode arg)))
+ (cond
+ (tinylisp-:property-show-mode
+ (tinylisp-post-command-config)
+ (when verb
+ (message
+ "TinyLisp: Property show mode is on %s"
+ (if (equal arg '(64)) "(RECORDING)" "")))
+ (make-local-hook 'post-command-hook)
+ (add-hook 'post-command-hook 'tinylisp-property-post-command))
+ (t
+ (tinylisp-post-command-config 'restore)
+ (remove-hook 'post-command-hook 'tinylisp-property-post-command)
+ (if verb (message "TinyLisp: Property show mode is off"))))))
+
+;;}}}
+;;{{{ Snooping
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-snoop-variables-i-args ()
+ "Ask arguments to `tinylisp-snoop-variables'."
+ (list
+ current-prefix-arg
+ (nth
+ 1
+ (assoc
+ (completing-read
+ "Name of variable snoop list: "
+ (ti::list-to-assoc-menu
+ (mapcar 'car tinylisp-:table-snoop-variables))
+ nil
+ 'match-it)
+ tinylisp-:table-snoop-variables))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-find-buffer-local-variables (&optional buffer)
+ "Print buffer local variables to BUFFER."
+ (interactive)
+ (flet ((my-sort2
+ (list)
+ (sort list
+ (function
+ (lambda (a b)
+ (string< (symbol-name (car a))
+ (symbol-name (car b)))))))
+ (my-sort1
+ (list)
+ (sort list
+ (function
+ (lambda (a b)
+ (string< (symbol-name a)
+ (symbol-name b)))))))
+ (let* (var
+ val)
+ (or buffer
+ (setq buffer (current-buffer)))
+ (pop-to-buffer (get-buffer-create tinylisp-:buffer-variables))
+ (ti::pmax)
+ (insert "\nbuffer-local-variables: " (buffer-name buffer) "\n\n" )
+ (dolist (elt (my-sort2 (buffer-local-variables buffer)))
+ (setq var (car elt))
+ (when (and (symbolp var) ;skip markers etc.
+ (not (memq var '(buffer-undo-list
+ font-lock-syntax-table))))
+ (insert (format "%-30s => %s\n"
+ (symbol-name var)
+ (pp (cdr elt))))))
+ (insert "\nframe-parameters: " (buffer-name buffer) "\n\n" )
+ (dolist (elt (my-sort2 (frame-parameters)))
+ (insert (format "%-30s => %s\n"
+ (symbol-name (car elt))
+ (pp (cdr elt)))))
+ (insert "\ncoding variables: " (buffer-name buffer) "\n\n" )
+ (dolist (elt (my-sort1
+ (ti::system-get-symbols "coding" '(boundp sym))))
+ (unless (memq elt '(coding-system-alist
+ coding-category-list
+ coding-system-list
+ set-coding-system-map))
+ (setq val (symbol-value elt))
+ (insert (format "%-30s => %s%s\n"
+ (if (ti::listp val) ;; Start separate line
+ "\n"
+ "")
+ (symbol-name elt)
+ (pp val))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-find-autoload-functions (&optional buffer)
+ "Display all autoload functions."
+ (interactive)
+ (let* ((list (ti::system-autoload-function-list))
+ doc)
+ (if (null list)
+ (message "TinyLisp: No autoload functions found in Emacs.")
+ (or buffer
+ (setq buffer
+ (get-buffer-create tinylisp-:buffer-autoload)))
+ (pop-to-buffer buffer)
+ (erase-buffer)
+ (insert "\n[TinyLisp] Autoload functions currently in Emacs:\n\n")
+ (dolist (func list)
+ (setq doc (documentation func))
+ (cond
+ ((eq doc nil)
+ (setq doc "<no documentation>"))
+ ((ti::nil-p doc)
+ (setq doc "<empty documentation string>")))
+ (insert (format "%s: %s\n%s\n\n"
+ (symbol-name func)
+ (or (ti::function-autoload-file func)
+ "<autoload file unknown>")
+ doc))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-find-match-from-hooks (regexp)
+ "Search all functions that match REGEXP in -hooks -function[s] symbols."
+ (interactive "sSearch match from hooks: ")
+ (tinylisp-with-current-buffer
+ (get-buffer-create tinylisp-:buffer-data)
+ (ti::pmax))
+ (pop-to-buffer (ti::system-match-in-hooks regexp tinylisp-:buffer-data))
+ (sort-lines nil (point-min) (point-max)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-find-match-from-variables (var-regexp val-regexp)
+ "Search variables for VAR-REGEXP and values matching VAL-REGEXP."
+ (interactive "sMatch variable name: \nsMatch content in variable: ")
+ (pop-to-buffer tinylisp-:buffer-data)
+ (ti::pmax)
+ (insert "\n")
+ (mapatoms
+ (function
+ (lambda (sym &optional val)
+ (when (and (boundp sym)
+ (string-match var-regexp (symbol-name sym))
+ (string-match val-regexp
+ (setq val (prin1-to-string
+ (symbol-value sym)))))
+ (insert (format "[%s] %s\n\n" (symbol-name sym) val)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-snoop-variables (&optional arg list)
+ "Display contents of hooks. See `tinylisp-:table-snoop-variables'.
+
+ARG can be
+ 1 With prefix arg, variables values are recorded to
+ to buffer `tinylisp-:buffer-record' and
+
+ 0 Save variables values.
+ 9 Restore variables values from the saved copies.
+ 8 Kill saved variable state
+ 5 Set all variables to nil in list
+
+ C -u allows editing the variables.
+
+LIST list of variables.
+
+Flags when viewing, editing echo-area:
+
++w Is shown when you're actually modifying the contents.
+! is shown if the variable's state has been saved and is non-nil."
+ (interactive (tinylisp-snoop-variables-i-args))
+ (let* ((write (equal arg '(4)))
+ (read (eq arg nil))
+ (record (eq arg 1))
+ (save (eq arg 0))
+ (restore (eq arg 9))
+ (kill (eq arg 8))
+ (reset (eq arg 5))
+ (msg (format
+ "(%s) %s"
+ (length list)
+ (mapconcat 'symbol-name list " ")))
+ (prop 'tinylisp-original)
+ str
+ val
+ ok)
+ (dolist (elt list)
+ (setq ok (boundp elt))
+ (cond
+ ((or read write record)
+ (if ok
+ (setq val (prin1-to-string (symbol-value elt)))
+ (setq val "<variable does not exist>"))
+ (tinylisp-record-macro record
+ (insert (format "%s %s\n" (symbol-name elt) val)))
+ ;; Using rsz-mini we can show whole content.
+ (setq str (read-from-minibuffer
+ (format "%s%s%s: "
+ (if write "+w " "")
+ (if (get elt prop)
+ "! "
+ "")
+ (symbol-name elt))
+ val))
+ (if write ;replace content?
+ (set elt (read str))))
+ (save
+ (put elt prop (symbol-value elt)))
+ (kill
+ (remprop elt prop))
+ (restore
+ (set elt (get elt prop)))
+ (reset
+ (set elt nil))
+ (t
+ (message "TinyLisp: Unknown arg %s" (prin1-to-string arg)))))
+ (cond
+ (save (message "TinyLisp: Saved %s" msg))
+ (save (message "TinyLisp: Restored %s" msg))
+ (kill (message "TinyLisp: Killed saved value copies %s" msg))
+ (kill (message "TinyLisp: Set to nil %s" msg)))))
+
+;;}}}
+;;{{{ Occur
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-occur-i-args ()
+ "Ask arg1 to `tinylisp-occur'."
+ (read-from-minibuffer
+ "TinyLisp occur: "
+ (nth 1 (tinylisp-read-symbol-at-point))
+ nil
+ nil
+ 'tinylisp-:occur-history))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-occur (regexp &optional arg)
+ "Run occur on REGEXP for whole buffer.
+If ARG is non-nil, do not filter comment lines."
+ (interactive (list (tinylisp-occur-i-args) current-prefix-arg))
+ (let* ((obuffer (current-buffer)))
+ (ti::occur-macro regexp nil
+ (ti::text-re-search-forward regexp)
+ (ti::pmin)
+ (unless arg
+ ;; Remove comments.
+ (let (buffer-read-only)
+ (while (re-search-forward "^ *+[0-9]+:\\([ \t]*;.*\\)" nil t)
+ (delete-region (line-beginning-position)
+ (min (1+ (line-end-position))
+ (point-max)))))))
+ ;; Keep cursor in original buffer
+ (pop-to-buffer obuffer)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-occur-verbose (regexp &optional arg)
+ "Call `tinylisp-occur' as user would with ARG."
+ (interactive (list (tinylisp-occur-i-args) current-prefix-arg))
+ (when (and (stringp regexp)
+ (not (string= "" regexp)))
+ (tinylisp-occur regexp arg)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-occur-select-forward (&optional back)
+ "Select next line from the occur buffer. You must first run `tinylisp-occur'.
+Optionally goes BACK."
+ (interactive "P")
+ (let* ((buffer (get-buffer tinylisp-:occur-buffer-name))
+ line
+ file
+ str
+ go-buffer)
+ (if (null buffer)
+ (message "TinyLisp: No occur buffer exist.")
+ (tinylisp-with-current-buffer buffer
+ ;; This is ugly, but I don't know other way to move
+ ;; point permanently in the buffer. The select-window
+ ;; is the crucial command to make the point move.
+ (save-window-excursion
+ (pop-to-buffer (current-buffer))
+ (select-window (selected-window))
+ (if back
+ (forward-line -1)
+ (forward-line 1)))
+ (setq str (ti::read-current-line))
+ (if (null (setq line (ti::buffer-match "^\\([0-9]+\\):" 1)))
+ (message "TinyLisp: Can't find line number from occur buffer.")
+ (setq line (string-to-int line))
+ ;; first line in occur buffer has
+ ;; "Lines matching "tipgpd" in buffer xxx.el"
+ (if (null (setq file
+ (ti::re-search-check "^Lines matching.* \\(.*\\).$"
+ 1 nil 'matched)))
+ (message
+ "TinyLisp: Can't find file name from occur buffer."))))
+ (if (and file
+ (null (setq go-buffer (get-buffer file))))
+ (message "TinyLisp: buffer not exist %s" file)
+ (pop-to-buffer go-buffer)
+ (goto-line line)
+ (message str)))))
+
+;;}}}
+;;{{{ debugger: std Emacs
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-debugger-setup ()
+ "Define new commands to *Backtrace*."
+ (defvar debugger-mode-map nil) ;no-op ByteComp silencer
+ (define-key debugger-mode-map "R" 'tinylisp-debugger-record-value))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-debugger-record-value (exp)
+ "Read EXP and record it's value to `tinylisp-:buffer-record' buffer."
+ (interactive
+ (list (read-from-minibuffer
+ "Eval: "
+ (ti::remove-properties (ti::buffer-read-word "^( \t\n'"))
+ read-expression-map t
+ 'read-expression-history)))
+ (let* ((buffer (ti::temp-buffer tinylisp-:buffer-record))
+ (standard-output buffer))
+ (defvar debugger-old-buffer nil) ;No-op ByteComp silencer.
+ (save-excursion
+ (if (null (buffer-name debugger-old-buffer))
+ ;; old buffer deleted
+ (setq debugger-old-buffer (current-buffer)))
+ (princ (format "Debugger (%s): " exp))
+ (princ (eval-expression exp))
+ (terpri))
+ (tinylisp-with-current-buffer buffer
+ (save-excursion
+ (backward-line 1)
+ (message (ti::read-current-line))))))
+
+;;}}}
+;;{{{ Additional support functions
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-emergency (&optional verb)
+ "Restore any dangerously advised functions.
+See `tinylisp-eval-at-point'. VERB."
+ (interactive)
+ (ti::verb)
+ (ad-disable-advice 'defconst 'around 'tinylisp)
+ (ad-activate 'defconst)
+ (if verb
+ (message
+ "TinyLisp: Function states restored; you can continue as usual.")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-elint-init ()
+ "Prepare buffer for Elint."
+ (unless (get 'tinylisp-mode 'elint)
+ (tinylisp-safety-belt 'elint-initialize "See elint.el")
+ (put 'tinylisp-mode 'elint 'initialized)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-elint-buffer ()
+ "Elint the buffer."
+ (interactive)
+ (tinylisp-elint-init)
+ (tinylisp-safety-belt 'elint-current-buffer "See elint.el"))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-elint-defun ()
+ "Elint the buffer."
+ (interactive)
+ (tinylisp-elint-init)
+ (tinylisp-safety-belt 'elint-defun "See elint.el"))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defadvice edebug-eval-defun (after tinylisp-record-instrumented-function act)
+ "Record the function info to `tinylisp-:edebug-instrument-table'.
+See function `tinylisp-edebug-uninstrument-everything' for more information."
+ (tinylisp-defun-sym-macro
+ (when sym
+ (cond
+ ((ad-get-arg 0)
+ (message "TinyLisp: instrumented and cached %s (Edebug advice)" name)
+ (pushnew
+ (list
+ sym
+ (current-buffer)
+ (buffer-file-name))
+ tinylisp-:edebug-instrument-table
+ :test 'equal))
+ (t
+ (tinylisp-edebug-table-remove-entry sym)))))
+ ;; activate again
+ (ti::advice-control 'eval-defun "^tinylisp"))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defadvice eval-last-sexp (after tinylisp-remove-instrumented-function act)
+ "Remove possibly edebug instrumented function info.
+See `tinylisp-edebug-table-remove-entry'"
+ (save-excursion
+ (ignore-errors (forward-sexp -1))
+ (let ((info (tinylisp-read-function-name-info)))
+ (when (cdr-safe info)
+ (tinylisp-edebug-table-remove-entry (cdr-safe info))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-edebug-table-remove-entry (function)
+ "Remove FUNCTION from `tinylisp-:edebug-instrument-table'."
+ (interactive)
+ (let* ((elt (assq function tinylisp-:edebug-instrument-table)))
+ (setq tinylisp-:edebug-instrument-table
+ (delete elt tinylisp-:edebug-instrument-table))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-edebug-uninstrument-buffer ()
+ "This is same as `eval-buffer', which cancels all edebug information."
+ (tinylisp-eval-current-buffer))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-edebug-instrument-buffer ()
+ "Read whole buffer and instrument every found left flushed `defun'."
+ (interactive)
+ (let* (edebug-all-defs)
+ (save-excursion
+ (ti::pmin)
+ (while (re-search-forward "^(defun " nil t)
+ ;; thi makes Edebug instrument the function
+ (message "TinyLisp: instrumenting %s" (ti::read-current-line))
+ (eval-defun 'instrument)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-edebug-display-instrumented-list ()
+ "List all instrumented function from cache `tinylisp-:edebug-instrument-table'.
+Show results in `tinylisp-:buffer-record'. The display shows
+
+ FUNCTION-NAME BUFFER-OF-EVAL LIVE-BUFFER FILE-NAME-FOR-BUFFER"
+ (interactive)
+ (let* ((buffer (ti::temp-buffer tinylisp-:buffer-record))
+ function
+ name
+ live-buffer
+ live-name
+ file)
+ (display-buffer buffer)
+ (tinylisp-with-current-buffer buffer
+ (ti::pmax)
+ (dolist (elt tinylisp-:edebug-instrument-table)
+ (setq function (nth 0 elt)
+ name (symbol-name function)
+ buffer (nth 1 elt)
+ live-buffer (if (buffer-live-p buffer) (get-buffer buffer))
+ live-name (if live-buffer (buffer-name live-buffer))
+;;; key (or live-buffer file)
+ file (nth 2 elt))
+ (insert (format "\n%-20s %-15s %-15s %s"
+ name buffer live-name file))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-edebug-uninstrument-everything ()
+ "Uninstrument every function instrumented via `tinylisp-edebug-instrument'.
+When you Edebug you functions, you instrument function here, function
+there in different packages and soon you'll find that you don't
+remember any more what you have instrumented. You want to get rid of
+all Edebug instrumentation when you think you no longer need them.
+
+This function looks up `tinylisp-:edebug-instrument-table' and with raw
+force reloads every package again thus wiping out Edebug instrumentation."
+ (interactive)
+ (let* (file-list
+ buffer-list
+ function
+ name
+ buffer
+ live-buffer
+ live-name
+ file
+ key
+ tmp)
+ (dolist (elt tinylisp-:edebug-instrument-table)
+ (setq function (nth 0 elt)
+ name (symbol-name function)
+ buffer (nth 1 elt)
+ live-buffer (if (buffer-live-p buffer) (get-buffer buffer))
+ live-name (if live-buffer (buffer-name live-buffer))
+ file (nth 2 elt)
+ key (or live-buffer file))
+ (cond
+ ((or (and (stringp key) (member key file-list))
+ (and (bufferp key) (memq key buffer-list)))
+ (message "TinyLisp: (edebug) %s %s already wiped"
+ name
+ (or file
+ live-name
+ "")))
+ (live-buffer
+ (with-current-buffer live-buffer
+ (tinylisp-eval-current-buffer))
+ (message "TinyLisp: (edebug) wiped %s by re-evaluating buffer %s"
+ name live-name)
+ (push buffer buffer-list))
+ ((stringp file)
+ (load-file file)
+ (message "TinyLisp: (edebug) wiped %s by loading file %s" name file)
+ (ti::kill-buffer-safe tmp)
+ (push file file-list))))
+ (setq tinylisp-:edebug-instrument-table nil)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-edebug-uninstrument (&optional verb)
+ "Uninstrument function whose _name_ is at current point. VERB.
+See `tinylisp-edebug-instrument'."
+ (interactive)
+ (tinylisp-edebug-instrument 'restore (ti::verb)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-edebug-instrument (&optional uninstrument verb)
+ "Instrument or UNINSTRUMENT function _name_ at current point. VERB.
+
+If there is a functon call at cursor position, instrument that function.
+This is not same as edebug instrumenting \\[universal-argument]
+\\[eval-defun] in `emacs-lisp-mode'. The function name at current point is
+located and file is loaded to make edebug to instrument that function.
+
+If there is no function call at point, behave like standard
+`edebug-eval-defun' accessed via \\[edebug-eval-defun].
+
+Example
+
+ ;; If point is over the word 'my-function2', that function is
+ ;; instrumented
+
+ (defun my-function ()
+ (interactive)
+ (let ((buffer (buffer-name))
+ (case-fold-search t))
+ ;; -!-
+ (my-function2 buffer)
+ ....
+
+References:
+
+ `tinylisp-:edebug-instrument-table'"
+ (interactive "P")
+ (ti::verb)
+ (save-excursion
+ (save-window-excursion
+ (cond
+ ((ignore-errors
+ (tinylisp-jump-to-definition
+ nil
+ (tinylisp-read-word)
+ (not 'verb)
+ (not 'nodisplay))
+ (if uninstrument
+ (eval-defun nil)
+ (edebug-eval-defun 'instrument))
+ t))
+ (t
+ ;; No function at point.
+ (edebug-eval-defun 'debug))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-checkdoc ()
+ "Interactively check document from current point forward.
+See `checkdoc-interactive'."
+ (interactive)
+ (tinylisp-safety-belt 'checkdoc-interactive "See checkdoc.el" (point)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-checkdoc-notes (&optional start)
+ "Take notes from current point forward or START from beginning of buffer."
+ (interactive "P")
+ (tinylisp-require 'checkdoc)
+ (let* ((buffer (symbol-value 'checkdoc-diagnostic-buffer))
+ (checkdoc-arguments-in-order-flag t)
+ (checkdoc-verb-check-experimental-flag t)
+ (checkdoc-bouncy-flag t) ;; No auto fixing
+ checkdoc-spellcheck-documentation-flag ;; Don't call spell
+ checkdoc-autofix-flag)
+ (save-excursion
+ (if start
+ (ti::pmin))
+ (with-current-buffer (get-buffer-create buffer)
+ (ti::pmax)
+ (insert (format "\n\nCheckdoc: %s *** Style check %s"
+ (symbol-value 'checkdoc-version)
+ (ti::date-standard-date 'minutes))))
+ (tinylisp-safety-belt
+ 'checkdoc-continue
+ "See checkdoc.el"
+ 'take-notes))
+ (unless (get-buffer-window buffer)
+ (display-buffer buffer))
+ (with-current-buffer buffer
+ (if (fboundp 'turn-on-tinyurl-mode-1)
+ (turn-on-tinyurl-mode-1)))
+ (when nil ;;#todo: doesn't work
+ (let ((win (get-buffer-window buffer))
+ point)
+ (with-current-buffer buffer
+ ;; Go to start of the message
+ (ti::pmax)
+ (when (re-search-backward "^[\r\n]" nil t)
+ (setq point (point))
+ (set-window-point win point)))))
+ (message "TinyLisp: Checkdoc Take notes done.")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-checkdoc-comment-notes ()
+ "See `checkdoc'."
+ (interactive)
+ (tinylisp-safety-belt 'checkdoc-comments "See checkdoc.el" t))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-lisp-mnt-verify ()
+ "Check package layout.
+The latest Emacs distribution has improved lisp-mnt.el which has
+function `lm-verify', which you should run in your package. It helps
+ensuring that you have all the proper keywords in place. Here is rough
+valid layout format:
+
+ ;; XXX.el -- proper first line
+
+ ;; Author
+ ;; Maintainer
+ ;; Created:
+ ;; Keywords:
+
+ ;;; Commentary:
+ ;;; Change Log:
+ ;;; Code:
+
+ ;;; XXX.el ends here
+
+See unix what(1) and GNU RCS indent(1) why you should adopt a style where
+you use @(#) and $Keywords$."
+ (interactive)
+ (require 'lisp-mnt)
+ (if (not (string= (symbol-value 'lm-history-header)
+ "Change Log\\|History"))
+ (message "\
+TinyLisp: your lisp-mnt.el is too old to have improved checking. Get newer.")
+ (call-interactively 'lm-verify)))
+
+;;}}}
+;;{{{ lisp-mnt.el
+
+;;#todo: Sent patch to FSF to include these in lisp-mnt.el
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-lisp-mnt-tag-check-and-fix (tag &optional on-error)
+ "Correct misplaced lisp-mnt.el tag. Stop ON-ERROR.
+Return:
+ 'missing
+ 'fixed
+ nil Means ok."
+ (ti::pmin)
+ (let* ((regexp (concat "^;+[ \t]*" tag ":[ \t]*$"))
+ (reference (format ";;; %s:" tag))
+ status
+ case-fold-search)
+ (if (not (re-search-forward regexp nil t))
+ (setq status 'missing)
+ (unless (string= (match-string 0) reference)
+ (replace-match reference)
+ (setq status 'fixed))
+ (forward-line -1)
+ (if (looking-at "^[ \t]*$")
+ (forward-line 1)
+ (forward-line 1)
+ (insert "\n")
+ (setq status 'fixed))
+ (forward-line 1)
+ (unless (looking-at "^[ \t]*$")
+ (insert "\n")
+ (setq status 'fixed)))
+ (when (and on-error
+ (eq status 'missing))
+ (pop-to-buffer (current-buffer))
+ (error "Lisp-mnt: missing tags `;;; %s:'" tag))
+ status))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-lisp-mnt-tag-check-and-fix-buffer (&optional on-error)
+ "Check all Lisp commentary tags and fix as needed. Stop ON-ERROR.
+Return: '((missing-tags) (fixed-tags))."
+ (interactive "P")
+ (let* (missing
+ fixed
+ stat)
+ (if (and (featurep 'folding)
+ folding-mode)
+ (folding-open-buffer))
+ (dolist (tag '("Commentary" "Change Log" "Code"))
+ (setq stat (tinylisp-lisp-mnt-tag-check-and-fix tag on-error))
+ (cond
+ ((eq stat 'missing)
+ (push tag missing))
+ ((eq stat 'fixed)
+ (push tag fixed))))
+ (if (or missing fixed)
+ (list missing fixed))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-lisp-mnt-tag-check-and-fix-file (file &optional on-error)
+ "Check all Lisp commentary tags on FILE and fix as needed. Stop ON-ERROR.
+Return: '((missing-tags) (fixed-tags))."
+ (interactive "fLisp file: \nP")
+ (let* ((buffer (find-buffer-visiting (expand-file-name file)))
+ find-file-hooks)
+ (unless buffer
+ (setq buffer (find-file-noselect file)))
+ (with-current-buffer buffer
+ (tinylisp-lisp-mnt-tag-check-and-fix-buffer on-error))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylisp-lisp-mnt-tag-check-and-fix-dir (dir &optional on-error)
+ "Check all Lisp commentary tags and fix as needed. Stop ON-ERROR.
+Return.
+ '((file ((missing-tags) (fixed-tags))) ..)."
+ (interactive "DDir: \nP")
+ (let* (stat
+ list)
+ (dolist (file (directory-files dir 'abs "\\.el$"))
+ (setq stat (tinylisp-lisp-mnt-tag-check-and-fix-file file on-error))
+ (if stat
+ (push (list file stat) list)))
+ list))
+
+;; (tinylisp-lisp-mnt-tag-check-and-fix-dir "~/elisp/tiny/lisp" 'err)
+
+;;}}}
+
+(provide 'tinylisp)
+
+;; These must be set, otherwise the mode setup will not activate
+;; correctly when user calls M-x tinylisp-mode.
+
+(add-hook 'tinylisp-:mode-define-keys-hook
+ 'tinylisp-mode-define-keys)
+(add-hook 'tinylisp-:elp-summary-mode-define-keys-hook
+ 'tinylisp-elp-summary-mode-define-keys)
+
+(tinylisp-install-menu)
+(run-hooks 'tinylisp-:load-hook)
+
+;;; tinylisp.el ends here
--- /dev/null
+;;; tinyload.el --- Load set of packages when Emacs is idle (lazy load)
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 1997-2007 Jari Aalto
+;; Keywords: extensions
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program, call M-x tinyload-version.
+;; Look at the code with folding.el
+
+;; COPYRIGHT NOTICE
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;; ....................................................... &t-install ...
+;; Put this file on your Emacs-Lisp load path, add following into your
+;; ~/.emacs startup file. Move all your `require' commands into
+;; the load list.
+;;
+;; (setq tinyload-:load-list '("package" "package" ...))
+;; (require 'tinyload)
+;;
+;; TinyLoad can't be autoloaded, because it installs an idle-timer
+;; function.
+;;
+;; See examples at the end of file how do I utilize this package in full.
+;; If you have any questions, use 'submit' function. In case of error
+;; or misbehavior, turn on the debug and send the debug results
+;; From the *Messages* buffer and describe what was happening
+;;
+;; M-x tinyload-debug-toggle
+;; M-x tinyload-submit-bug-report
+
+;;}}}
+
+;;{{{ Documentation
+
+;; ..................................................... &t-commentary ...
+
+;;; Commentary:
+
+;; Preface, Jul 1997
+;;
+;; While it is possible to arrange Emacs `rc' (start-up) files to use
+;; all possible and imaginable autoloads, there are still packages
+;; that can't be autoloaded due to their setup nature or other
+;; behavior: `require' commands are necessary in `.emacs' in order
+;; to use those modules. This means that for every `require' command,
+;; the Emacs startup slows remarkably. Experienced Emacs users have
+;; very complex boot configurations, so waiting minutes for Emacs
+;; startup screen to appear is quite frustrating.
+;;
+;; The described situation gave birth to this package. Now the emacs
+;; is ready to use within few seconds.
+;;
+;; What this package does, is, that it caches the load requests and
+;; executes them when it thinks there is free time. Instead of setting
+;; up all at once on startup, the emacs configuration is built piece
+;; by piece, until the whole 100% configuration is there.
+;;
+;; The benefit is that Emacs starts instantly, and when it is
+;; idle, the remaining packages, that you wanted to be
+;; available in your daily Emacs session, are loaded.
+;;
+;; Overview of features
+;;
+;; o Delayed (Lazy) loading of packages (at some later time); after
+;; 15 seconds of idle time, remaining files are loaded one by one.
+;; o You no longer have to use `require' in your .emacs, instead,
+;; you define `tinyload-:load-list' where you put the requests.
+;; o Your .emacs starts faster when the extra `require' and
+;; `load' commands be moved to load list.
+;;
+;; If you're a first time Emacs user or if you consider lisp
+;; difficult, have a look at simpler setup than what is described
+;; below from C-h v `tinyload-:load-file'. The idea is that you
+;; tell the configuration file which lists packages that you
+;; want to load in format:
+;;
+;; PACKAGE CONFIG-WORD
+;;
+;; The CONFIG-WORD should be self explanatory: it instructs in which
+;; OS and in which Emacs flavor the package is loaded. Here isa
+;; sample: reportmail is only loaded under win32 and XEmacs.
+;;
+;; paren
+;; autorevert win32
+;; gnus.el
+;; reportmail win32-xemacs
+;;
+;; Another easy interface is to use functions:
+;;
+;; `tinyload-load-list-add-function'
+;; `tinyload-load-list-add-package'
+;; `tinyload-load-list-delete-function'
+;; `tinyload-load-list-delete-package'
+;;
+;; First user notice
+;;
+;; When you use this package for the first time, you may feel
+;; uncomfortable with the amount of messages you see displayed on
+;; the echo area. And if you're in echo-area prompt (e.g. after `C-x'
+;; `C-f') those messages may disturb the echo area prompt.
+;;
+;; Just don't panic. Move your cursor key to the left (C-a)
+;; or start typing and the load will be interrupted. As long as
+;; there is activity in your Emacs the load will not happen.
+;;
+;; The messages that are displayed in the echo area are important,
+;; because they get stored in *Messages* buffers and you can take a
+;; look if anything strange happened. Like if some package couldn't be
+;; loaded at all. Pay attention to *fatal* messages.
+;;
+;; Messages in *Message* buffer
+;;
+;; There are different types of messages
+;;
+;; TinyLoad: fdb ok (10% 1/10) [1]
+;; TinyLoad: elp 'noerr! (20% 2/10) [2]
+;; TinyLoad: [ERROR] loading ~/elisp/rc/emacs-rc-init.el [3]
+;;
+;; o [1] Package was loaded and the display shows some remaining
+;; statistics.
+;; o [2] There was 'noerr parameter defined and the
+;; recent load of the package failed: perhaps it didn't exist along
+;; `load-path' or there was other problem in the package itself.
+;; o [3] When file was loaded, some error happened. You
+;; should study this file by hand and spot the problem manually.
+;; Be sure that the syntax of the file is correct.
+;;
+;; In addition to these basic messages, there are some internal
+;; messages that do not concern regular user, only the maintainer.
+;; When TinyLoad wakes up, you might see following message
+;;
+;; Tinyload: timer expired; invoking load process..[busy;stop;N]
+;; | | |
+;; user activity status | |
+;; Continue status |
+;; Busy count; and deadlock indicator
+;;
+;; Which simply means that Emacs called the loader function and
+;; because *Continue* *status* was nil, user did nothing at the time
+;; of invocation. If the message [busy;stop;N] then user was doing
+;; something that weren't allowed to be interrupted. Usually this
+;; happens when cursor is in echo area e.g. after `C-x' `C-f'.
+;; If the cursor never leaves the echo area or if the busy situation
+;; continues for a certain period of time, the program automatically
+;; clears the busy signal and continues loading. You should not see
+;; infinite [busy;stop.N] messages. If you really see 10 such messages,
+;; then contact the author: there must be an unresolved deadlock and
+;; a bug in the program.
+;;
+;; When the `tinyload-:load-list' has been handled, the loader process
+;; terminates itself. The following message tells that the process has
+;; ceased to exist. If you want to start reading the list again,
+;; call `M-x' `tinyload-install'.
+;;
+;; TinyLoad: Loader process terminated.
+;;
+;; Tutorial
+;;
+;; Let's supposes your emacs startup consists of following `rc' files
+;; The name `rc' comes from Unix resource files, like
+;; $HOME/.bashrc, $HOME/.cshrc ...
+;;
+;; emacs-rc-main.el -- the main load controller
+;; emacs-rc-path.el -- settings `auto-mode-alist' etc.
+;; emacs-rc-bup.el -- Backup settings
+;; emacs-rc-set.el -- Emacs variable settings
+;;
+;; emacs-rc-keys.el -- Keyboard customizations
+;; emacs-rc-font.el -- Fonts and Font lock; face settings
+;; emacs-rc-hooks.el -- All add-hook commands and mode settings.
+;; emacs-rc-ding.el -- Gnus customizations (symlink to ~/.gnus)
+;; emacs-rc-pkg-std.el -- Loading std Emacs packages and their setup
+;; emacs-rc-pkg-misc.el -- Non-std distrib, additional packages
+;; emacs-rc-tips.el -- Tips (code samples) from the Usenet
+;; emacs-rc-mail.el -- mail agent, Rmail, VM, message.el etc. setup
+;;
+;; Now suppose your .emacs loads all these files like this
+;;
+;; ;; $HOME/.emacs -- Emacs startup controller
+;;
+;; (require 'cl) ;; Tell location of startup files
+;; (pushnew "~/elisp/rc" load-path :test 'string=)
+;;
+;; (require 'emacs-rc-path)
+;; (require 'emacs-rc-bup)
+;; (require 'emacs-rc-set)
+;; (load "emacs-rc-keys.el")
+;; (require 'emacs-rc-font)
+;; (load "emacs-rc-hooks")
+;; (load "emacs-rc-ding")
+;; (load "emacs-rc-pkg-std")
+;; (load "emacs-rc-pkg-misc")
+;; (load "emacs-rc-tips")
+;; (add-hook 'mail-mode-hook '(lambda () (require 'emacs-rc-mail)))
+;;
+;; ;; End of file $HOME/.emacs
+;;
+;; The reason why there may be both `load' and `require' commands
+;; may be that you frequently make updates and changes to some of your
+;; start-up files. Like if you frequently update Setting for Gnus,
+;; and you want to reload your settings, the (load "emacs-rc-ding")
+;; is executed again. If you used `require' the new settings would not
+;; have been loaded. (See explanation of `load' and `require' from the
+;; Emacs info manual). So, to re-cap, if you would call:
+;;
+;; M-x load-file ~/.emacs
+;;
+;; Only the `load' commands' files would be loaded again. All the
+;; `require' files would have been skipped, because the `rc' resource
+;; features had already been defined.
+;;
+;; Now, loading all these files, either with `require' or `load',
+;; takes too much time when you start Emacs. After some rearrangements
+;; you can put the delayed loading into use:
+;;
+;; ;; $HOME/.emacs -- Emacs startup controller
+;;
+;; (require 'cl) ;; Tell location of startup files
+;; (pushnew "~/elisp/rc" load-path :test 'string=)
+;;
+;; ;; Have these minimum features immediately available
+;;
+;; (require 'emacs-rc-path)
+;; (require 'emacs-rc-bup)
+;; (require 'emacs-rc-set)
+;; (load "emacs-rc-keys.el")
+;;
+;; ;; Load this setup only when mail composing is started
+;;
+;; (add-hook 'mail-mode-hook '(lambda () (require 'emacs-rc-mail)))
+;;
+;; ;; ........................................... lazy loading ....
+;; ;; We can afford to load these later
+;;
+;; (setq tinyload-:load-list
+;; '(("emacs-rc-font")
+;; ("emacs-rc-hooks")
+;; ("emacs-rc-ding")
+;; ("emacs-rc-pkg-std")
+;; ("emacs-rc-pkg-misc")
+;; ("emacs-rc-tips")
+;; ("emacs-rc-mail")))
+;;
+;; (require 'tinyload)
+;; ;; End of file $HOME/.emacs
+;;
+;; When Emacs load this startup, only the most important files are
+;; loaded saving the start time considerably. After `tinyload' finds
+;; that your Emacs is idle it starts loading all the rest of the
+;; packages you defined in the `tinyload-:load-list'. For more complex
+;; setup, refer to end of tinyload.el source file, where you can
+;; find a complete example setup.
+;;
+;; NOTE: Please pay attention to one detail above. The `emacs-rc-mail'
+;; will be loaded from load list _and_ it will be loaded when
+;; you call M-x `mail'. Do you believe there is redundancy? The
+;; idea is that you may call M-x `mail' way before the TinyLoad
+;; reaches that file in its load list and the hook guarantees that
+;; you get the setup at mail invoke time.
+;;
+;; But it may be the other way round: TinyLoad has already loaded
+;; the mail setup for you and thus invoking M-x `mail' is fast,
+;; because there is nothing to load any more.
+;;
+;; Similar things you should do to GNUS, VM, RMAIL and others that
+;; you call and whose setup you want to have immediately available
+;;
+;; Delayed loading, require and autoload
+;;
+;; Above you saw how to load your Emacs `rc' files. But the delayed
+;; loading is not only suitable for those. It also helps you to load
+;; files, that can't be autoloaded.
+;;
+;; If you can arrange loading a packages with `autoload' command,
+;; do that. Never put `require' or direct `load' command into your
+;; Emacs `rc' file, because load commands eat start time.
+;;
+;; Packages usually explain in the *installation* section two ways
+;; how to load them: here is an example from tinytab.el
+;;
+;; (require 'tinytab)
+;;
+;; or use this; your .emacs is read quicker
+;;
+;; (autoload 'tinytab-mode "tinytab" "" t)
+;; (autoload 'tinytab-return-key-toggle "tinytab" "" t)
+;;
+;; The first way forces loading the whole file (takes time); and
+;; the latter only tells that the package's functions
+;; `tinytab-return-key-toggle' and `tinytab-mode' exists. If you
+;; happen to call those functions, _only_ then the package gets
+;; loaded. The big difference here is that when you put the
+;; latter in your Emacs rc file, Emacs reads `autoload' statements much
+;; faster than the `require' command.
+;;
+;; It is not always possible arrange to load package with autoloads,
+;; because the package may behave so that in order to get the features
+;; installed, package must do the setup by itself: you can't do it
+;; yourself. Here are few packages that can't be autoloaded:
+;;
+;; crypt++ -- crypt(1) support.
+;; tinymy -- collection of utilities
+;; fa-extras -- Filling extras
+;;
+;; When you would normally include a `require' command for these
+;; into your Emacs `rc' file, you can now move the packages to load
+;; list and keep only autoloads in the `rc' files.
+;;
+;; ;; Old rc file
+;;
+;; (autoload ....
+;; (autoload ....
+;; (require 'fa-extras)
+;; (autoload ....
+;;
+;; ;; New rc file
+;;
+;; (autoload ....
+;; (autoload ....
+;; (autoload ....
+;;
+;; And the missing `require' entry has been moved to
+;; `tinyload-:load-list'.
+;;
+;; Use separate rc file for load definitions
+;;
+;; It may be good idea to make a separate `rc' file that only has
+;; the load list definition and a call to tinyload.el, like this:
+;;
+;; ;; emacs-rc-tinyload.el -- load definitions for tinyload.el
+;; ;;
+;; ;; If you compile this file, `defconst' shuts up Byte Compiler
+;;
+;; (defconst tinyload-:load-list
+;; '(...
+;; ...))
+;; (require 'tinyload)
+;; (provide 'emacs-rc-tinyload)
+;; ;; End of file
+;;
+;; And then you add following call to your *$HOME/.emacs*, to the end
+;; of the file, although the place really doesn't matter.
+;;
+;; (require 'emacs-rc-tinyload)
+;;
+;; Used timer process
+;;
+;; A normal timer process is used to load the packages from the load
+;; list. The timer awakens at regular intervals and loads one package at
+;; a time: more packages are not loaded if there was input pending at
+;; the time of previous load. The load messages are recorded to
+;; *Messages* buffer. In old Emacs releases this buffer does not
+;; exist; but it will be created for you.
+;;
+;; About implementation
+;;
+;; When `tinyload-:load-list' is set, the value of the variable is
+;; saved under property `original'. When the idle timer runs, the list
+;; is read from the beginning and each package at a time is loaded.
+;; The last unloaded package position is saved under property 'pos.
+;;
+;; The situation looks like this:
+;;
+;; tinyload-:load-list 'original --> (list) original contents
+;; tinyload-:load-list 'pos --> (nth nbr) next package to load.
+;;
+;; If your do something in your emacs while the list is being looped,
+;; or when the loader function is about to be called, that interrupts
+;; the work. Next time the timer functions run runs, happens:
+;;
+;; o It checks if the current list matches `original'. Yes, means that
+;; the list hasn't been modified. No, means that it should examine
+;; the list all aver again, starting from the beginning.
+;; o If the list was original, it picks the `pos' point and
+;; loads all the remaining packages, one at a time until it
+;; sees activity.
+;; o If there is nothing to load, the `pos' points to the end
+;; of list. Function returns immediately and does nothing.
+;; At this point the loader process terminates itself by
+;; clearing the idle timer list.
+;;
+;; Force loading
+;;
+;; There is also property `fatal-list' which contains entries that
+;; couldn't be loaded. The list is updated while the loading takes
+;; place. If you examine the failed files and make corrections;
+;; you can try to reload the whole load list again if you call
+;;
+;; C-u M-x tinyload-loader-process
+;;
+;; Special features
+;;
+;; In case you want to load all packages and leave nothing in
+;; autoload state, add this code to your Emacs startup file. When the
+;; loader process exits, it will check all Emacs functions for autoload
+;; definitions and load those packages as well.
+;;
+;; (add-hook 'tinyload-:process-uninstall-hook
+;; 'tinyload-autoload-function-load)
+;;
+;; Restart and cancel
+;;
+;; If you want to restart the evaluation of load list, call `M-x'
+;; `tinyload-install', which will install the package again by removing
+;; old processes and resetting counters. To stop the loader process
+;; permanently, call `tinyload-cancel'.
+;;
+;; Bugs
+;;
+;; Every effort has been made to check that Emacs has no activity
+;; before the package is loaded at the background. A series of
+;; `sit-for' `input-pending-p' and more obscure mini-buffer
+;; checks have been run before the load kicks in. If a package
+;; still gets loaded while you are doing something, please send
+;; a suggestion how that event could be detected so that the load
+;; wouldn't interrupt you again. Unfortunately, there is no single
+;; solution to notice all user activity in a reliable way.
+;;
+;; Despite of the efforts, an unlucky moment may cause loading the
+;; package, when it would not have been appropriate. Please hang on
+;; and wait for the load to finish, you're will regain control soon.
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+;;{{{ require
+
+;;; ......................................................... &require ...
+
+(require 'tinylibm)
+
+;; #todo: Does Xemacs reportmail.el define this function too?
+;; #todo: 2000-11 Emacs 2?.7 seems to include reportmail.el
+
+(eval-and-compile
+ (autoload 'display-time "time"))
+
+(eval-when-compile (ti::package-use-dynamic-compilation))
+
+(ti::package-defgroup-tiny TinyLoad tinyload-: extensions
+ "Overview of features
+ o Delayed loading of packages (in some later time)
+ o You no longer have to use `require' in your .emacs, instead,
+ you can put the package to `tinyload-:load-list' and have it loaded
+ when Emacs is idle.
+ o Your .emacs starts faster when the `require' commands are out.")
+
+;;}}}
+
+;;{{{ Hooks
+
+;;; ......................................................... &v-hooks ...
+
+(defcustom tinyload-:load-hook nil
+ "*Hook that is run when package is loaded."
+ :type 'hook
+ :group 'TinyLoad)
+
+(defcustom tinyload-:process-install-hook nil
+ "*Hook run when `tinyload-install' is called."
+ :type 'hook
+ :group 'TinyLoad)
+
+(defcustom tinyload-:process-uninstall-hook nil
+ "*Hook run when `tinyload-cancel' is called."
+ :type 'hook
+ :group 'TinyLoad)
+
+;;}}}
+;;{{{ variables: public
+
+;;; ........................................................ &v-public ...
+;;; User configurable
+
+(defcustom tinyload-:idle-time 20
+ "*When Emacs is this many seconds idle, start load process.
+Warning: Do not set this value below 4 seconds, because the previous
+call must complete before the timer process is called again. Some
+big packages may take a while to load."
+ :type 'integer
+ :group 'TinyLoad)
+
+(defcustom tinyload-:init-time 2
+ "*Time in seconds to wait before activating loader for the first time.
+This is the initial time it takes before the loader process starts for the
+first time. The default is 2 seconds."
+ :type 'integer
+ :group 'TinyLoad)
+
+(defcustom tinyload-:wait-next-load 0.5
+ "*Time in seconds in load process to see if there is user activity.
+This is the time loader process waits before it tries to load next package;
+a time gap where any activity cancels the process from continuing
+if user types something in Emacs.
+Suggested value range: 0.2 - 1.5 seconds."
+ :type 'integer
+ :group 'TinyLoad)
+
+(defcustom tinyload-:load-file nil
+ "*File to liast packages to load.
+If you set this variable, you can't use `tinyload-:load-list', because
+`tinyload-:load-list' is initalized from this file's content.
+
+This variable is menat for simpler load control than what
+could be done in lisp level with `tinyload-:load-list'.
+
+The format of the FILE is simple:
+
+- Comments in file start with semicolon (;)
+- Added file to load in one line, next to next line and so on
+- Add check configuration-word right after the filename.
+ This must be a SINGLE word.
+
+An example:
+
+ ;; tinyload configuration file start
+
+ paren
+ autorevert win32
+ gnus.el
+ reportmail win32-xemacs
+
+ ;; tinyload configuration file end
+
+The above file's configuration words above are \"win32\" and
+\"win32-xemacs\", where e.g. package autorevert will only be loaded under
+win32. Similarly reportmail package is only loaded if current OS is win32
+and Emacs flavor is XEmacs.
+
+The recognized configuration tokens, that must form a single word, are:
+
+ win32 emacs xemacs"
+ :type 'file
+ :group 'TinyLoad)
+
+(defcustom tinyload-:load-list nil
+ "*List of packages to load when emacs has been idle.
+The idle time in seconds to load packages is defined in `tinyload-:idle-time'.
+
+References:
+
+ You can also manipulate this list with following functions:
+ `tinyload-load-list-add-function'
+ `tinyload-load-list-add-package'
+ `tinyload-load-list-delete-function'
+ `tinyload-load-list-delete-package'
+
+Format:
+
+ '((PACKAGE-OF-FILE [FEATURE-SYM] [NOERR] [NOMSG] [FORM-BEFORE] [FORM-AFTER])
+ ...)
+
+ PACKAGE-OR-FILE can be any valid `load' command filename parameter:
+
+ \"package\"
+ \"package.el\"
+ \"package.elc\"
+ \"~/elisp/package.el\"
+
+ You must provide FEATURE-SYM if the package provides different feature than
+ the package name; e.g. entry (\"~/rc/emacs-rc-my\" 'rc-my) says; that you
+ want to do (load \"~/rc/emacs-rc-my\") only if (featurep 'rc-my) returns false.
+
+ [NOERR] is optional and parameter for `load' command
+ [NOMSG] is optional and parameter for `load' command
+
+ [FORM-BEFORE] is evaluated before load command.
+ [FORM-AFTER] is evaluated after load command.
+
+Note:
+
+ Nil entries in this table are skipped. This allows you to construct
+ dynamic load list entry like this:
+
+ (setq tinyload-:load-list
+ (list
+ (if (and (ti::emacs-p)
+ (= 28 emacs-minor-version))
+ (list \"~/rc/emacs-rc-19.28\" 'rc-28))))
+
+ The `tinyload-:load-list' would be '(nil) in non-19.28 Emacs
+
+Example:
+
+ (setq tinyload-:load-list
+ '(\"ffap.el\"
+ \"tinylibmail.el\"))"
+ :type '(repeat sexp)
+ :group 'TinyLoad)
+
+;;}}}
+;;{{{ variables: private
+
+;;; ....................................................... &v-private ...
+;;; Private variables
+
+(defvar tinyload-:timer-elt nil
+ "The timer process if used in current Emacs.")
+
+(defvar tinyload-:process-busy-p nil
+ "When load process is loading something this flag is non-nil.
+This prevents invoking multiple load processes.")
+
+;;}}}
+;;{{{ version
+
+;;; ....................................................... &v-version ...
+
+(eval-and-compile
+ (ti::macrof-version-bug-report
+ "tinyload.el"
+ "tinyload"
+ tinyload-:version-id
+ "$Id: tinyload.el,v 2.66 2007/05/06 23:06:11 jaalto Exp $"
+ '(tinyload-:version-id
+ tinyload-:debug
+ tinyload-:load-hook
+ tinyload-:load-list
+ tinyload-:load-file
+ tinyload-:process-install-hook
+ tinyload-:process-uninstall-hook
+ tinyload-:timer-elt
+ tinyload-:process-busy-p
+ tinyload-:idle-time
+ tinyload-:init-time
+ tinyload-:wait-next-load)
+ '(tinyload-:debug-buffer)))
+
+;;;### (autoload 'tinyload-debug-toggle "tinyload" t t)
+
+(eval-and-compile (ti::macrof-debug-standard "tinyload" "-:"))
+
+;;}}}
+;;{{{ installation
+
+;;; --------------------------------------------------------- &install ---
+;;;
+;;;###autoload
+(defun tinyload-install (&optional remove)
+ "Install package or REMOVE.
+This function removes any previous TinyLoad timer process and resets
+the list pointer to 0."
+ (interactive "P")
+ (tinyload-config-file-load-default)
+ ;; Kill old process(es)
+ (ti::compat-timer-cancel-function 'tinyload-loader-process)
+ (setq tinyload-:timer-elt nil)
+ (cond
+ ((or remove
+ (null tinyload-:load-list))
+ (let* ((str (concat
+ "TinyLoad: Loader process terminated."
+ (if (null tinyload-:load-list)
+ " `tinyload-:load-list' is empty."
+ ""))))
+ (tinyload-message str))
+ (tinyload-debug "Tinyload: Install, stopped. HOOK"
+ tinyload-:process-uninstall-hook)
+ (run-hooks 'tinyload-:process-uninstall-hook))
+ (t
+ (put 'tinyload-:load-list 'pos 0)
+ (put 'tinyload-:load-list 'fatal-list nil)
+ ;; Put startup info into *Messages*" buffer
+ (tinyload-message
+ (format
+ (concat "TinyLoad: Started with %d items in load list."
+ " Init %d and interval %d seconds.")
+ (length tinyload-:load-list)
+ tinyload-:init-time
+ tinyload-:idle-time))
+ (tinyload-debug "Tinyload: Install, started. HOOK"
+ tinyload-:process-install-hook)
+ (display-time)
+ (setq tinyload-:timer-elt
+ (run-at-time
+ (format "%d sec" tinyload-:init-time)
+ tinyload-:idle-time
+ 'tinyload-loader-process))
+ (tinyload-debug "tinyload-install: `run-at-time' timer elt"
+ tinyload-:timer-elt)
+ (run-hooks 'tinyload-:process-install-hook)))
+ (setq tinyload-:process-busy-p nil)
+ tinyload-:timer-elt)
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyload-cancel ()
+ "Kill the loaded process and stop loading.
+To start loader process, call \\[tinyload-install]."
+ (interactive)
+ (tinyload-install 'remove))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyload-start ()
+ "Start loader process. This function is synonym to ´tinyload-install'"
+ (interactive)
+ (tinyload-install))
+
+;;}}}
+;;{{{ support functions
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyload-autoload-function-load (&optional verb)
+ "Load all autoloaded functions. VERB."
+ (interactive)
+ (ti::verb)
+ (let* ((fid "tinyload-autoload-function-load:")
+ (funcs (ti::system-autoload-function-list))
+ (load (when funcs
+ (ti::system-autoload-function-file-list funcs)))
+ (count 0)
+ str)
+ (unless fid ;; No-op. XEmacs byte compiler silencer
+ (setq fid nil))
+ (tinyload-debug
+ (format "Tinyload: [debug] %s FUNCTIONS %s FILES %s"
+ fid
+ (prin1-to-string funcs)
+ (prin1-to-string load)))
+ (dolist (file load)
+ (condition-case err
+ (load file)
+ (error
+ (setq str (format
+ "Tinyload: autoload function load fail %s %s "
+ file (prin1-to-string err)))
+ (message str)
+ (tinyload-debug str)))
+ (incf count)
+ (when verb
+ (message "Tinyload: autoloading clean %d/%d %s"
+ count (length load) file)))
+ load))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyload-feature-p (pkg &optional feature)
+ "Check if feature has been loaded.
+See PKG and FEATURE from `tinyload-:load-list'"
+ ;; User didn't give us separate feature name, construct
+ ;; one from package name ~/elisp/test.el --> "test"
+ (let* ((fid "tinyload-feature-p")
+ status)
+ (unless fid ;; No-op. XEmacs byte compiler silencer
+ (setq fid nil))
+ (tinyload-debug
+ (format "TinyLoad: [debug] %s (a) PACKAGE [%s] FEATURE [%s]"
+ fid (prin1-to-string pkg) (prin1-to-string feature)))
+ ;; Make feature name out of the package name if
+ ;; it was not given gnus.el -> 'gnus
+ (when (and (null feature)
+ (stringp pkg))
+ (setq feature (file-name-nondirectory pkg))
+ (if (and (string-match "^\\(.+\\)\\.el" feature)
+ (match-end 1))
+ (setq feature (match-string 1 feature))))
+ (setq status
+ (cond
+ ((and (not (null feature))
+ (symbolp feature)
+ (featurep feature))
+ 'symbol)
+ ((and (stringp feature)
+ (intern-soft feature)
+ (featurep (intern-soft feature)))
+ 'intern)
+ (t nil)))
+ (tinyload-debug
+ (format "TinyLoad: [debug] %s (b) PACKAGE [%s] FEATURE [%s] stat %s"
+ fid
+ (prin1-to-string pkg)
+ (prin1-to-string feature)
+ (prin1-to-string status)))
+ status))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyload-message (msg)
+ "Display MSG and put it to *Messages* Buffer."
+ (if (string-match "%" msg)
+ (setq msg (subst-char-with-string msg ?% "%%")))
+ (tinyload-debug msg)
+ (message msg)
+ ;; Old releases don't have this buffer; generate one.
+ (when (and (ti::emacs-p)
+ (string-match "19.2[0-9]" emacs-version))
+ (with-current-buffer (get-buffer-create "*Messages*")
+ (ti::pmax) (insert msg "\n"))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyload-status ()
+ "Print status. How many packages are left in load list."
+ (interactive)
+ (if (null tinyload-:timer-elt)
+ (message "TinyLoad process is not alive any more.")
+ (message "Position %s/%s in load list."
+ (get 'tinyload-:load-list 'pos)
+ (length tinyload-:load-list))))
+
+;;}}}
+;;{{{ Load list manipulation support functions
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyload-load-list-search-elt (search position)
+ "SEARCH item in `tinyload-:load-list' by checking POSITION.
+
+package feature noerr nomsg before after
+0 1 2 3 4 5
+
+The SEARCH item is checked with `equal' function."
+ (let (picked)
+ (dolist (elt tinyload-:load-list)
+ ;; package feature noerr nomsg before after
+ (setq picked (nth position elt))
+ (when (equal picked search)
+ (return elt)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyload-load-list-search-function (function)
+ "Search FUNCTION in `tinyload-:load-list'."
+ (tinyload-load-list-search-elt function 4))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyload-load-list-search-package (package)
+ "Search PACKAGE in `tinyload-:load-list'."
+ (tinyload-load-list-search-elt package 0))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyload-load-list-add-function (function)
+ "Add FUNCTION to `tinyload-:load-list'.
+This function places a null entry to the laod list, so that only the
+load-before form is exected: it runs the FUNCTION."
+ (let ((elt (list "run-function-only" nil 'noerr 'nomsg function nil))
+ (entry (tinyload-load-list-search-function function)))
+ (unless entry
+ (push elt tinyload-:load-list))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyload-load-list-add-package (package &optional feature)
+ "Add PACKAGE FEATURE with 'noerr 'nomsg attributes to `tinyload-:load-list'."
+ (let ((elt (list package feature 'noerr 'nomsg))
+ (entry (tinyload-load-list-search-package package)))
+ (unless entry
+ (push elt tinyload-:load-list))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyload-load-list-delete-elt (elt)
+ "Remove ELT from `tinyload-:load-list'."
+ (setq tinyload-:load-list (delete elt tinyload-:load-list)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyload-load-list-delete-function (function)
+ "Remove FUNCTION from `tinyload-:load-list'."
+ (let ((entry (tinyload-load-list-search-function function)))
+ (when entry
+ (tinyload-load-list-delete-elt entry))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyload-load-list-delete-package (package)
+ "Remove PACKAGE from `tinyload-:load-list'."
+ (let ((entry (tinyload-load-list-search-package package)))
+ (when entry
+ (tinyload-load-list-delete-elt entry))))
+
+;;}}}
+;;{{{ Config file interface
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyload-config-file-emacs-type-ok-p (string)
+ "Test STRING for xemacs, emacs and win32."
+ (if (null string)
+ t
+ (let* ((emacs-ok 'not-tested)
+ (os-ok 'not-tested))
+ (when (string-match "win32" string)
+ (setq os-ok (ti::win32-p)))
+ (when (string-match "emacs" string)
+ (setq emacs-ok
+ (or (and (string-match "xemacs" string)
+ (ti::xemacs-p))
+ (and (not (string-match "xemacs" string))
+ (string-match "emacs" string)
+ (ti::emacs-p)))))
+ (and emacs-ok
+ os-ok))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyload-config-file-parse ()
+ "Parse entries ein configuration file and ignore comments.
+File format is:
+
+ ;; Comment
+ ;; Another comment
+ file win32-xemacs
+ file.el emacs
+ file.elc
+
+ ;; End of file
+
+In the above example, FILE means command \(load \"file\" 'noerr). You can
+add additional .el or .elc extension to force loading uncompiled or
+compiled version of the file.
+
+The additional PARAMETER-WORD follows directly after the filename. It must
+be only one word and you can separate different tests with dash(-). Valid
+test names recognized are
+
+ win32
+ emacs
+ xemacs
+
+For example if line reads:
+
+ file win32-xemacs
+
+This means that package \"file\" if loaded only if current Emacs
+flavor is XEmacs and the operating system is win32
+
+Any empty lines, spaces and comment started with semicolon (;)
+are ignored.
+
+Return:
+
+ Similar list than what is described for variable
+ `tinyload-:load-list'"
+ (let* ((fid "tinyload-config-file-parse")
+ list
+ test
+ file)
+ (unless fid ;; No-op. XEmacs byte compiler silencer
+ (setq fid nil))
+ (ti::pmin)
+ (while (re-search-forward
+ "^[ \t]*\\([^ ;\t\r\n]+\\)[ \t]*\\([^ ;\t\r\n]+\\)" nil t)
+ (when (setq file (match-string 1))
+ (setq test (match-string 2))
+ (when (tinyload-config-file-emacs-type-ok-p test)
+ (push (list file) list))))
+ ;; Preserve read order
+ (setq list (nreverse list))
+ (tinyload-debug fid "RET" list)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyload-config-file-load-1 (file)
+ "Load configuration file and return list in format `tinyload-:load-list'."
+ (interactive "fTinyLoad configuration file: ")
+ (with-temp-buffer
+ (insert-file-contents file)
+ (tinyload-config-file-parse)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyload-config-file-load-default ()
+ "Load `tinyload-:load-file' and return list in format `tinyload-:load-list'."
+ (let* ((file tinyload-:load-file))
+ (tinyload-debug "tinyload-config-file-load-default"
+ "tinyload-:load-file"
+ file)
+ (cond
+ ((not (stringp file))
+ nil)
+ ((not (file-exists-p tinyload-:load-file))
+ (message "Tinyload: tinyload-:load-file does not exist %s"
+ tinyload-:load-file))
+ (t
+ (setq tinyload-:load-list
+ (tinyload-config-file-load-1 file))))))
+
+;;}}}
+;;{{{ main
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyload-minibuffer-active-p ()
+ "check if minibuffer is active."
+ (if (fboundp 'active-minibuffer-window)
+ (ti::funcall 'active-minibuffer-window)
+ (eq (selected-window) (minibuffer-window))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyload-no-action ()
+ "Check that Emacs is still."
+ (and
+ ;; (ti::no-action-in-progress-p 'timer) isn't working right
+ (sit-for 0.2)
+ (not cursor-in-echo-area)
+ (not (tinyload-minibuffer-active-p))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyload-process-continue (&optional force)
+ "Check if process is clear to continue and Emacs is not busy.
+Return status '(continue no-action no-input)."
+ (let* ((fid "tinyload-process-continue")
+ no-action
+ no-input
+ continue)
+ (unless fid ;; No-op. XEmacs byte compiler silencer
+ (setq fid nil))
+ (setq no-action (tinyload-no-action)
+ no-input (null (input-pending-p))
+ continue (or force
+ (and no-input
+ no-action)))
+ (tinyload-debug
+ (format
+ "TinyLoad: [debug] %s no-action: %s no-input: %s continue: %s busy: %s"
+ fid
+ (prin1-to-string no-action)
+ (prin1-to-string no-input)
+ (prin1-to-string continue)
+ (if tinyload-:process-busy-p
+ "yes"
+ "no")))
+
+ (list continue no-action no-input)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyload-eval (form type)
+ "Eval FORM. TYPE is string AFTER or BEFORE."
+ (condition-case err
+ (if form
+ (eval form))
+ (error
+ (let* ((str
+ (format "Tinyload: [ERROR] EVAL %s generated an error %s %s"
+ type
+ (prin1-to-string err)
+ (prin1-to-string form))))
+ (message str)
+ (tinyload-debug str)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyload-load (pkg noerr nomsg)
+ "Load PKG with NOERR NOMSG. Return load status."
+ (let* (stat)
+ (cond
+ (noerr
+ (condition-case data
+ (setq stat (load pkg noerr nomsg))
+ (error
+ (message "TinyLoad: [%s] %s"
+ pkg
+ (prin1-to-string data))))
+ (tinyload-debug "TinyLoad: 'noerr load %s: %s" pkg stat))
+ (t
+ (setq stat (ignore-errors (load pkg noerr nomsg)))))
+ stat))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyload-load-failure (pkg elt)
+ "Record PKG ELT failure to `tinyload-:load-list'. Return failed-list."
+ ;; Record failed entries.
+ (let* ((failed-list (get 'tinyload-:load-list 'failed-list)))
+ (add-to-list 'failed-list elt)
+ (put 'tinyload-:load-list 'failed-list failed-list)
+ (let ((str
+ (format "TinyLoad: [ERROR] while loading %s" pkg)))
+ (ding)
+ (tinyload-debug str)
+ (tinyload-message str))
+ ;; This will tell the path and put the message
+ ;; in *Message* buffers. It will also tell if
+ ;; it was .elc or .el that had troubles.
+ ;; >> FOR DEBUG PURPOSES
+ (ignore-errors (locate-library pkg))
+ failed-list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyload-initialize ()
+ "Initialise `tinyload-:load-list'.
+Return:
+
+ '(load-list pointer)."
+ (let ((orig (get 'tinyload-:load-list 'original)))
+ ;; first invocation
+ (put 'tinyload-:process-busy-p 'count 0)
+ ;; No original values available, so set defaults
+ (unless orig
+ (put 'tinyload-:load-list 'original tinyload-:load-list))
+ (unless (integerp (get 'tinyload-:load-list 'pos))
+ (put 'tinyload-:load-list 'pos 0))
+ ;; user has recently changed "list", do update.
+ (unless (equal orig tinyload-:load-list)
+ (put 'tinyload-:load-list 'original tinyload-:load-list)
+ (put 'tinyload-:load-list 'pos 0))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyload-terminate-process ()
+ "Remove process."
+ ;; No more loading; do self kill so that this process is
+ ;; not unnecessarily held in timer list.
+ ;;
+ ;; 19.34 bug: Process can't remove itself. Ack. Fixed in
+ ;; new Emacs releases.
+ (tinyload-message "TinyLoad: Bye, No more packages to load.")
+ (setq tinyload-:process-busy-p nil)
+ (tinyload-install 'remove))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyload-busy-count ()
+ "Return `tinyload-:process-busy-p' busy count."
+ (get 'tinyload-:process-busy-p 'count))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyload-busy-count-incf ()
+ "Increase `tinyload-:process-busy-p' busy count."
+ ;; - If counter keeps incrementing all the time,
+ ;; then the main loop never cleared the flag
+ ;; - Keep on eye on the counter and prevent deadlock by resetting
+ ;; the busy signal.
+ (let ((busy-count (get 'tinyload-:process-busy-p 'count)))
+ (cond
+ ;; Not yet defined, set initial value
+ ((not (integerp busy-count))
+ (setq busy-count 0))
+ (t
+ (incf busy-count)))
+ (put 'tinyload-:process-busy-p 'count busy-count)
+ (put 'tinyload-:process-busy-p 'count2 busy-count)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyload-continue-check (&optional force)
+ "Check if process can continue with FORCE.
+Return CONTINUE if there is no activity."
+ (multiple-value-bind (continue no-act no-input)
+ (tinyload-process-continue force)
+ (tinyload-message
+ (format
+ "TinyLoad: timer triggered; invoking load process... [%s;%s;%s;%d]"
+ (if no-act "not-busy" "busy")
+ (if (null continue) "stop" "cont")
+ (if no-input "" "input")
+ (or (tinyload-busy-count) 0)))
+ (tinyload-debug
+ (format "tinyload-continue-check: %s" (prin1-to-string continue)))
+ continue))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyload-failed-list-update (elt)
+ "Update `tinyload-:load-list' property 'failed-list with ELT."
+ (let* ((fid "tinyload-failed-list-update")
+ (failed-list (get 'tinyload-:load-list 'failed-list)))
+ (unless fid ;; No-op. XEmacs byte compiler silencer
+ (setq fid nil))
+ ;; Remove entry from failed list
+ (setq failed-list (delete elt failed-list))
+ (put 'tinyload-:load-list 'failed-list failed-list)
+ (tinyload-debug
+ (format "TinyLoad: [Debug] %s failed-list: " fid) failed-list)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyload-library-info (pkg noerr)
+ "Record PKG NOERR library info under debug."
+ (when tinyload-:debug
+ (message "TinyLoad: [debug] locating library %s %s"
+ pkg (prin1-to-string noerr))
+ (let ((tmp (locate-library pkg)))
+ (tinyload-debug (format "TinyLoad: [debug] locate %s %s"
+ pkg (or tmp ""))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyload-load-ignore-message (pkg pos len)
+ "Print PKG POS LEN status. Already in Emacs."
+ (let* ((str (format "\
+TinyLoad: %-15s %s (%2d%% %2d/%2d) <ignored, feature already in emacs>"
+ pkg
+ "ok"
+ (/ (* 100 pos) len)
+ (1+ pos) (1+ len))))
+ (tinyload-message str)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyload-load-ok-message (pkg pos len stat)
+ "Print PKG POS LEN status. Loaded."
+ (let* ((str (format "TinyLoad: %-15s %s (%2d%% %2d/%2d)"
+ pkg
+ (if stat
+ "ok"
+ "'noerr!")
+ (/ (* 100 (1+ pos)) len)
+ (1+ pos) len)))
+ (tinyload-message str)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyload-busy-count-controller ()
+ "Handle busy checking and deadlocks.
+Return:
+ deadlock if non-nil, deadlock was detected."
+ (let* ((busy-count (tinyload-busy-count-incf))
+ deadlock)
+ (incf busy-count)
+ (when (> busy-count 5)
+ (tinyload-debug "Tinyload: busy count too high, clearing DEADLOCK")
+ (tinyload-message "TinyLoad: Deadlock detected, clearing...")
+ (setq tinyload-:process-busy-p nil
+ busy-count 0
+ ;; If there is infnite prompt open, we never would get
+ ;; past it, because the input-pending-p tests later would
+ ;; stop preceeding to load commands. FORCE going one load
+ ;; this time. The next busy, will again wait for deadlock,
+ ;; (if prompt is still open), but eventually the packages
+ ;; will get loaded.
+ ;;
+ ;; Extended period of prompt open is an indication that
+ ;; use is not present.
+ ;;
+ ;; #todo: to be asolutely sure, utilize top level `count2'
+ ;; which would keep track of deadlocks and never-loads.
+ ;; ==> if too hight, only then FORCE load.
+ ;;
+ deadlock t))
+ (put 'tinyload-:process-busy-p 'count busy-count)
+ deadlock))
+
+;;; ----------------------------------------------------------------------
+;;; (tinyload-loader-process 'force)
+;;;
+;;;###autoload
+(defun tinyload-loader-process (&optional force)
+ "Load packages defined in `tinyload-:load-list'.
+If called interactively, FORCE loading all packages in the list."
+ (interactive (list 'force))
+ (let* (continue
+ list
+ pos
+ len
+ stat)
+ (tinyload-debug "TinyLoad: [debug] main()"
+ "INPUT PENDING STATUS"
+ (input-pending-p)
+ "TIMER ELT"
+ tinyload-:timer-elt)
+ ;; ................................................... zombie test ...
+ ;; tinyload-:timer-elt
+ ;;
+ ;; - Emacs 19.34 has a bug. If the load list has been finished and _this_
+ ;; function tries to remove itseld with (tinyload-install 'remove);
+ ;; the timer element is not removed. Suprise.
+ ;; - However If I manually execute C-u M-x tinyload-install; then
+ ;; the process is killed all right.
+ ;; - So when the (tinyload-install 'remove) is called below; it sets
+ ;; the timer elt to nil; _but_ emacs still keeps calling this
+ ;; function. We're are now a zombie; we did try to kill
+ ;; ourself; but Emacs didn't let that to happen.
+ ;; - While we're a zombie, we don't display any messages or
+ ;; do anything. Calling this zombie function is no-op and won't
+ ;; take process time much.
+ ;;
+ ;; There may be previous function still loading; don't
+ ;; interrupt it; but terminate this invocation.
+ (when tinyload-:timer-elt
+ (setq continue (tinyload-continue-check force))
+ (if (tinyload-busy-count-controller)
+ (setq force t
+ continue t)))
+ (tinyload-debug "TinyLoad: [debug] main() continue status: "
+ continue
+ (if tinyload-:process-busy-p
+ "process busy" "process not busy"))
+ (when (or force
+ (and continue
+ (null tinyload-:process-busy-p)))
+ (unwind-protect
+ (catch 'exit
+ (tinyload-initialize)
+ ;; ........................................... load list ...
+ (setq pos (get 'tinyload-:load-list 'pos)
+ len (length tinyload-:load-list)
+ list (nthcdr pos tinyload-:load-list))
+ (tinyload-debug
+ (format "TinyLoad: [Debug] list pointer: pos %d len %d" pos len))
+ (unless list
+ (tinyload-terminate-process)
+ (throw 'exit t))
+ (tinyload-debug "TinyLoad: [Debug] list" list)
+ (dolist (elt list)
+ (setq tinyload-:process-busy-p 'busy)
+ ;; simple STRING is package name only
+ (when elt
+ (setq elt (ti::list-make elt)))
+ (multiple-value-bind (pkg feature noerr nomsg
+ form-before form-after)
+ elt
+ ;; Remove entry from failed list
+ (tinyload-failed-list-update elt)
+ (tinyload-debug
+ (format (concat "TinyLoad: [Debug] LIST ELT "
+ "pkg: %s feature: %s elt: %s ")
+ pkg
+ feature
+ (prin1-to-string elt)))
+ ;; ........................................... load it ...
+ (when (and elt pkg)
+ ;; Try to sit for some time before preceeding, otherwise
+ ;; if we can't sit still that long, user is
+ ;; doing something..
+ (tinyload-debug "TinyLoad: >>> 1 -- input pending?")
+ (let* ((wait (or tinyload-:wait-next-load 0.3)))
+ (unless (and (sit-for wait)
+ (not (input-pending-p)))
+ (tinyload-debug
+ (format "´THROW ´sit-for' didn't return t (activity) %d"
+ wait))
+ (throw 'exit t)))
+ (tinyload-debug "TinyLoad: >>> 2 -- feature present?")
+ (setq stat (tinyload-feature-p pkg feature))
+ (incf pos)
+ (put 'tinyload-:load-list 'pos pos)
+ (tinyload-debug
+ (format "TinyLoad: >>> 3, pkg %s feature `%s' status: %s"
+ (prin1-to-string pkg)
+ (prin1-to-string feature)
+ (prin1-to-string stat)))
+ (tinyload-debug
+ (format "TinyLoad: [Debug] pkg forms before:%s after:%s"
+ (prin1-to-string form-before)
+ (prin1-to-string form-after)))
+ (cond
+ ;; ................................. feature in Emacs ...
+ (stat
+ (tinyload-load-ignore-message pkg pos len))
+ ;; ..................................... not in emacs ...
+ (t
+ (tinyload-eval form-before "BEFORE")
+ (tinyload-library-info pkg noerr)
+ (unless (tinyload-process-continue)
+ (tinyload-debug
+ (format "THROW 2 input-p didn't return t (activity)"))
+ (throw 'exit t))
+ (setq stat (tinyload-load pkg noerr nomsg))
+ (cond
+ (stat
+ (tinyload-eval form-after "AFTER")
+ (tinyload-load-ok-message pkg pos len stat))
+ (t
+ (tinyload-load-failure pkg elt)
+ (setq stat 'fatal))))))
+ (when (or (input-pending-p)
+ (eq stat 'fatal))
+ (throw 'exit t)))))
+ ;; .................................................... unwind ...
+ (setq tinyload-:process-busy-p nil)))))
+
+;;}}}
+;;{{{ example
+
+;;; ......................................................... &example ...
+;;; - Here is example at the time of writing tinyload v1.14
+;;; - Hope you get some ideas from this.
+
+;;; --++-- --++-- --++-- --++-- --++-- --++-- --++-- --++-- -- example --
+(when nil ;; Start of example - Emacs does not read code below
+
+ ;; ~/elisp/rc/emacs-rc-tinyload.el -- Delayed loading of files
+ ;;
+ ;; Docid
+ ;;
+ ;; This is a personal Emacs (rc) resource files and it
+ ;; is loaded from .emacs in the following manner
+ ;;
+ ;; (require 'emacs-rc-tinyload)
+ ;;
+ ;; This file may be under some other name in the current directory
+ ;; where you found it, but do not mind that.. Just rename this file to
+ ;; whatever is shown in the first line.
+ ;;
+ ;; Description
+ ;;
+ ;; This file configures all packages and files that can be loaded
+ ;; later when Emacs sits idle for tinyload.el. See for full description
+ ;; of the usage from there.
+ ;;
+ ;; `emacs-rc-xxx' are all Emacs resource files of various kind.
+ ;;
+ ;; `ti::compat-window-system' is Emacs independent window system check
+ ;; function found from tinylib.el
+
+;;; ............................................................ &load ...
+
+ (let* ((w (ti::compat-window-system)) ;XEmacs and Emacs detection
+ (x (eq w 'x)) ;x windowed
+ (win32 (eq w 'win32))) ;Windows
+ (setq tinyload-:load-list
+ (list
+ ;; Those with 'noerr flag are not essential packages
+ ;;
+ ;; In X Windowed emacs, Load non-compiled rc file in XEmacs, because
+ ;; the compiled faces are not compatible with XEmacs.
+ (when w
+ (list (if (ti::emacs-p) "emacs-rc-font" "emacs-rc-font.el")
+ 'rc-font nil nil nil
+ ;; The file defines function `my-face-change'
+ ;; that is called after load.
+ ;; It configures faces for this emacs.
+ '(progn
+ (cond
+ (nt (my-face-change 'pc))
+ (t (my-face-change 'def))))))
+ (list "emacs-rc-macros")
+ (list "emacs-rc-setting")
+ (list "emacs-rc-tiny")
+ (list "emacs-rc-standard-packages")
+ (list "emacs-rc-hooks")
+ (unless win32 ;; I don't use mail here
+ ;; Package contain faces: load non-compiled version for XEmacs
+ (list (if (ti::emacs-p)
+ "emacs-rc-mail"
+ "emacs-rc-mail.el")))
+ ;; Tiny Tools distribution
+ (list "tinyef" nil 'noerr)
+ (list "tinytab" nil 'noerr)
+ (list "tinylisp" nil)
+ (list "tinymy" nil)
+ (list "tinysword" nil 'noerr)
+ (list "tinydiff" nil 'noerr)
+ (list "tinyreplace" nil 'noerr)
+ (list "tinytfo" nil 'noerr)
+ (list "tinydired" nil 'noerr)
+ (list "tinycache" nil 'noerr)
+ (list "tinyigrep" nil 'noerr)
+ (list "tinylibmenu" nil)
+ (list "tinymatch" nil)
+ (list "tinylibid" nil 'noerr)
+ (list "tinydesk" nil 'noerr)
+ (if (ti::emacs-p)
+ (list "mldrag" nil 'noerr nil
+ '(progn (setq mldrag-load-hook 'mldrag-default-keys))))
+ ;; Run extra fa-setup aftert package.
+ (list "fa-extras" nil 'noerr nil nil '(progn (my-fa-setup)))
+ ;; Personal lisp function library. Run compression
+ ;; After loading this package.
+ (list "mylib.el"
+ 'mylib
+ nil
+ nil
+ nil
+ '(progn
+ (when (fboundp 'my-compress-household)
+ (my-compress-household)))))))
+
+ (defun my-fa-setup ()
+ "Filladapt setup."
+ (when (boundp 'filladapt-token-table)
+ (defvar filladapt-token-table nil)
+ (defconst filladapt-mode-line-string " Fa")
+ (let* ((tok "[*]+")
+ (elt (assoc tok filladapt-token-table)))
+ ;; Clear the old definition
+ (cond
+ ((setq filladapt-token-table (delq elt filladapt-token-table))
+ (setq filladapt-token-table
+ (cons (cons tok 'citation->)
+ filladapt-token-table))))
+ (setq tok ">+")
+ ;; (setq tok adaptive-fill-regexp)
+ (cond
+ ((setq elt (assoc tok filladapt-token-table))
+ (setq filladapt-token-table (delq elt filladapt-token-table))
+ (setq filladapt-token-table
+ (list (cons adaptive-fill-regexp 'citation->))))))))
+
+ ;; (provide 'emacs-rc-tinyload)
+
+ ;; ;; End of file emacs-rc-tinyload.el
+
+ ) ;; ++Example-End++
+;;; --++-- --++-- --++-- --++-- --++-- --++-- --++-- --++-- -- example --
+
+;;}}}
+;;{{{ final setup
+
+(tinyload-install)
+(provide 'tinyload)
+(run-hooks 'tinyload-:load-hook)
+
+;;}}}
+
+;;; tinyload.el ends here
--- /dev/null
+;;; tinylock.el --- Simple emacs locking utility
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 1995-2007 Jari Aalto
+;; Keywords: extensions
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program, call -x tinylock-version.
+;; Look at the code with folding.el
+
+;; COPYRIGHT NOTICE
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;; ....................................................... &t-install ...
+;; Put this file on your Emacs-Lisp load path, add one of these into your
+;; ~/.emacs startup file
+;;
+;; Normal load
+;;
+;; (require 'tinylock)
+;;
+;; Autoload, your emacs starts up faster, prefered, but doesn't
+;; activate the auto locking feature.
+;;
+;; (autoload 'tinylock-lock "tinylock" "Lock emacs" t)
+;;
+;; ESC-l, suggested keybinding, replaces downcase-word binding
+;; because you can accomplish the same with C-x C-l,
+;; downcase-region.
+;;
+;; (global-set-key "\M-l" 'tinylock-lock) ;; Suggested keybinding.
+;;
+;;
+;; If you have any questions, use this function
+;;
+;; M-x tinylock-submit-feedback
+;;
+;; See also Example section at the end of file.
+
+;;}}}
+;;{{{ Documentation
+
+;; ..................................................... &t-commentary ...
+
+;;; Commentary:
+
+;; Overview of features
+;;
+;; o Locks emacs completely until right key is entered.
+;; o Auto-locks emacs after NN minutes idle time
+;; o False login attemps are stored in history log.
+;; o Blanks display or displays message buffer when locked.
+;; o Hooks: before and after lock is activated and removed
+;;
+;; About locking procedure
+;;
+;; Don't get shocked now... When the lock gets in effect there must be
+;; no running processes inside emacs that would generate error and
+;; make emacs vulnerable to break in. That's why all the running
+;; processes are killed before the lock takes in effect. If you have
+;; some valuable processes that are constantly running, you must make
+;; a separate "process control" function that would restart any such
+;; processes. Use the appropriate hook to activate those processes
+;; again after the emacs is unlocked. Use hooks
+;;
+;; tinylock-:before-lock-hook ;; Save processes here
+;; tinylock-:after-lock-hook ;; restore processes here
+;;
+;; and following function which tells you what processes are running.
+;;
+;; M-x list-processes
+;;
+;; All extra frames are also deleted. At least for now, because I
+;; don't know a reasonable way to save the frame configurations
+;; right now. Please send me piece of code or pointer to package
+;; that can save and restore frames and the windows back to previous
+;; state if you know good solution.
+;;
+;; About auto locking feature, Emacs prior 19.34
+;;
+;; When you load this package the `tinylock-:load-hook' runs
+;; `tinylock-install-lock-timer' command that setup up a timer process that
+;; wakes up periodically. If the emacs has not changed compared to
+;; last saved emacs state, then the auto locking takes in effect
+;; immediately.
+;;
+;; In old Emacs the activity is determined in simple way
+;;
+;; o if buffer list order has changed user is doing something.
+;; o if `switch-buffer' was used, user is doing something
+;; o if any buffer's size has changed, user is doing something.
+;;
+;; This checking may not be enough: if user just scroll some
+;; text in buffer for NN minutes, then from `tinylock-process' 's point of
+;; view there has not been any activity and the user may suddenly
+;; notice that emacs locks up. Doing nothing but viewing one buffer
+;; all the time is fortunately rare.
+;;
+;; About auto locking feature in new Emacs
+;;
+;; New Emacs releases have command `run-with-idle-timer' which we use
+;; if it is available. When there has been no activity for NN minutes,
+;; your Emacs locks up.
+;;
+;; The advice code and the other tricks we needed to detect idle
+;; activity in lower emacs versions aren't installed in these Emacs
+;; versions, so you don't have to worry about sudden lock.
+;;
+;; Auto lock password
+;;
+;; Do not put password in your ~/.emacs, but answer to the question
+;; which is asked when this file is loaded. If you want to change it
+;; during your emacs session, call function
+;;
+;; M-x tinylock-auto-lock-set-password
+;;
+;; Changing the auto lock interval
+;;
+;; The auto lock interval depends on the wake up time of timer
+;; process. The default time is 20 minutes when you load this
+;; file. You can change the time by calling
+;;
+;; M-x tinylock-auto-lock-set-interval
+;;
+;; Or by putting this code in your ~/.emacs
+;;
+;; ;; First define the hook, so that we can append to it
+;; (setq tinylock-:load-hook
+;; '(tinylock-timer-control tinylock-auto-lock-set-password)
+;;
+;; ;; add function to the end
+;; (add-hook 'tinylock-:load-hook 'my-tinylock-auto-lock-set-interval 'append)
+;;
+;;
+;; (defun my-tinylock-auto-lock-set-interval ()
+;; "Change interval to 10 minutes."
+;; (tinylock-auto-lock-set-interval 10))
+;; ;; end of example
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+;;{{{ setup: require
+
+(require 'tinylibm)
+
+(eval-and-compile
+ ;; If this is not 19.34+, then we need advice code, otherwise it is
+ ;; skipped.
+ (unless (fboundp 'run-with-idle-timer)
+ (require 'advice))
+ (ti::package-package-require-timer))
+
+(eval-when-compile (ti::package-use-dynamic-compilation))
+
+(ti::package-defgroup-tiny TinyLock tinylock-: extensions
+ "Simple emacs locking utility.
+ Overview of features
+
+ o Locks emacs completely until right key is entered.
+ o Auto-locks emacs after XXX idle time
+ o False attemps are stored in history log.
+ o Blanks or displays buffer message when locked.
+ o Hooks: before and after lock is entered/removed")
+
+;;}}}
+;;{{{ setup: variables
+
+(defcustom tinylock-:load-hook nil
+ "*Hook run after file is loaded."
+ :type 'hook
+ :group 'TinyLock)
+
+(defcustom tinylock-:before-lock-hook nil
+ "*Hook that is run when the locking process initiates.
+This is your chance to save frame configurations or processes before
+they are killed."
+ :type 'hook
+ :group 'TinyLock)
+
+(defcustom tinylock-:after-lock-hook nil
+ "*Hook that is run after lock is removed."
+ :type 'hook
+ :group 'TinyLock)
+
+;;; ....................................................... &v-private ...
+
+(defconst tinylock-:history nil
+ "\(DATE PASSWD\) A storage where attempts of entering locked Emacs is put.
+Cleared every time lock takes effect.")
+
+(defvar tinylock-:auto-lock-data nil
+ "Data to tell about the idle state, updated by timer process.
+Contains:
+'(current-time ;; time stamp of user activity
+ (BUFFER-LIST)
+ (SIZE SIZE SIZE ..)) ;; every buffers size.")
+
+(defvar tinylock-:auto-lock-password nil
+ "Password in auto lock situation.
+Password is asked when you load this file. You shouldn't define
+this in you ~/.emacs")
+
+(defvar tinylock-:auto-lock-interval nil
+ "The timer interval in minutes. Use \\[tinylock-auto-lock-set-interval].")
+
+(defvar tinylock-:idle-timer-process nil
+ "19.34+ timer process.")
+
+;;; ........................................................ &v-config ...
+
+(defcustom tinylock-:login-error-sleep 2
+ "*Time in seconds that is waited until new login to is possible."
+ :type '(integer :tag "Seconds")
+ :group 'TinyLock)
+
+(defcustom tinylock-:buffer-login-history "*tinylock-hist*"
+ "*Buffer to output the history data."
+ :type 'string
+ :group 'TinyLock)
+
+(defcustom tinylock-:buffer-blank "*blank*"
+ "*Buffer name used when screen is blanked."
+ :type 'string
+ :group 'TinyLock)
+
+(defcustom tinylock-:blank-when-locked-flag t
+ "*Non-nil means show `tinylock-:buffer-blank' buffer."
+ :type 'string
+ :group 'TinyLock)
+
+;;}}}
+;;{{{ setup: version
+
+;;; ....................................................... &v-version ...
+
+;;;###autoload (autoload 'tinylock-version "tinylock" "Display commentary." t)
+(eval-and-compile
+ (ti::macrof-version-bug-report
+ "tinylock.el"
+ "tinylock"
+ tinylock-:version-id
+ "$Id: tinylock.el,v 2.42 2007/05/06 23:15:20 jaalto Exp $"
+ '(tinylock-:version-id
+ tinylock-:before-lock-hook
+ tinylock-:after-lock-hook
+ tinylock-:load-hook
+ tinylock-:auto-lock-data
+ tinylock-:auto-lock-password
+ tinylock-:auto-lock-interval
+ tinylock-:idle-timer-process
+ tinylock-:login-error-sleep
+ tinylock-:buffer-login-history
+ tinylock-:buffer-blank
+ tinylock-:blank-when-locked-flag)))
+
+;;}}}
+;;{{{ code: macros, advices
+
+(defmacro tinylock-time-dd (time)
+ "Return Day from TIME."
+ (list 'string-to-int (list 'substring time 8 10)))
+
+(defmacro tinylock-time-hh (time)
+ "Return hour from TIME."
+ (list 'string-to-int (list 'substring time -13 -11)))
+
+(eval-and-compile
+ (unless (fboundp 'run-with-idle-timer) ;we need this if not 19.34+
+ (require 'advice)
+ ;; What else easy means we have to tell that user is working with
+ ;; the emacs ?
+ ;;
+ ;; The advice shouldn't disturb normal emacs behavior and the functions
+ ;; calls are _inlined_, ie. function is expanded to point
+ ;; when byte compiled, so that the advice works as fast as possible
+ ;; and doesn't take time from the original function.
+ ;;
+ ;; (ti::advice-control '(switch-to-buffer other-window) "^til$" 'dis)
+ ;;
+ (defadvice switch-to-buffer (before til act) ;C-x C-b
+ "Tell to Emacs auto lock that there is user activity."
+ (if (interactive-p)
+ (inline (tinylock-user-activity))))
+
+ (defadvice execute-extended-command (before til act) ;; M-x called
+ "Tell to Emacs auto lock that there is user activity."
+ (if (interactive-p) (inline (tinylock-user-activity))))
+
+ (defadvice other-window (before til act) ;C-x o
+ "Tell to Emacs auto lock that there is user activity."
+ (if (interactive-p)
+ (inline (tinylock-user-activity))))))
+
+;;}}}
+;;{{{ code: misc funcs
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylock-auto-lock-set-interval (minutes)
+ "Set new MINUTES interval by stopping and restarting timer process."
+ (interactive "Nminutes: ")
+ (tinylock-install-lock-timer nil minutes)
+ nil)
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylock-auto-lock-set-password ()
+ "Set auto lock password."
+ (interactive)
+ (let* (pass)
+ (if (ti::nil-p (setq pass (ti::query-read-input-as-password
+ "TinyLock, give autolock password: ")))
+ (error "Password is empty.")
+ (setq tinylock-:auto-lock-password pass))
+ nil))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylock-process-on ()
+ "Start auto lock process."
+ (tinylock-install-lock-timer nil tinylock-:auto-lock-interval))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylock-install-lock-timer (&optional uninstall interval)
+ "Install process that locks Emacs when there is no activity.
+
+Input:
+
+ UNINSTALL `tinylock-process'
+ INTERVAL in minutes, by default 20."
+ (interactive "P")
+ ;; .......................................................... kill ...
+ (ti::compat-timer-cancel-function 'tinylock-process)
+ (setq tinylock-:idle-timer-process nil)
+ ;; .................................................... set values ...
+ (setq tinylock-:auto-lock-interval
+ (or interval
+ tinylock-:auto-lock-interval
+ 20)) ;Default 20 minutes
+ ;; ................................................... maybe start ...
+ (unless uninstall
+ (cond
+ ((fboundp 'run-with-idle-timer) ;19.34+
+ (setq
+ tinylock-:idle-timer-process
+ (ti::funcall
+ 'run-with-idle-timer
+ (* tinylock-:auto-lock-interval 60)
+ 'repeat
+ 'tinylock-lock-now)))
+ (t
+ (tinylock-process-data-set)
+ (run-at-time
+ "1 sec"
+ (* tinylock-:auto-lock-interval 60)
+ 'tinylock-process))))
+ (if (interactive-p)
+ (message "Autolock process %s"
+ (if uninstall
+ "deleted"
+ "started"))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylock-user-activity ()
+ "Tell to timer process that the has bee user activity."
+ (or
+ (ignore-errors (setcar tinylock-:auto-lock-data (current-time)))
+ ;; Hmm, data is corrupted... reset it.
+ (tinylock-process-data-set)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylock-process-data-set ()
+ "Update timer process data."
+ (setq tinylock-:auto-lock-data
+ (list
+ (current-time)
+ (buffer-list)
+ (mapcar
+ (function
+ (lambda (x)
+ (with-current-buffer x
+ (buffer-size))))
+ (buffer-list))))
+ nil)
+
+;;; ----------------------------------------------------------------------
+;;; Just testing... (tinylock-process-data-set) (tinylock-process-data-unchanged-p)
+;;;
+(defun tinylock-process-data-unchanged-p ()
+ "Return t if timer data has not changed = No activity in."
+ (let* ((data tinylock-:auto-lock-data)
+ (time (nth 0 data))
+ (buffer-list (nth 1 data))
+ (size-list (nth 2 data))
+ (list (buffer-list))
+ (i 0)
+ unchanged)
+ (if (null tinylock-:auto-lock-data)
+ (tinylock-process-data-set)
+ ;; o if buffer list order is the same, the user may not have
+ ;; done any new work...
+ ;; o Next we check if buffer sizes have changed, if not, then
+ ;; user hasn't done any work in emacs.
+ (condition-case nil
+ (and (> (ti::date-time-difference (current-time) time)
+ (- (* tinylock-:auto-lock-interval 60) 5)) ;5 sec timeframe
+ (equal list buffer-list)
+ (progn
+ (setq unchanged t)
+ (dolist (elt list)
+ (with-current-buffer elt
+ (if (not (eq (buffer-size)
+ (nth i size-list)))
+ ;; Found changed buffer, stop there and
+ ;; reset lock status, and quit the loop by
+ ;; killing the list
+ ;;
+ (setq list nil unchanged nil))
+ (incf i)))))
+ ;; Data is corrupted somehow, fix it.
+ (error
+ (tinylock-process-data-set)))
+ unchanged)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylock-process ()
+ "Lock up Emacs if it there has not been any user activity."
+ (when (tinylock-process-data-unchanged-p)
+ ;; When Emacs locks up, this function process will die too.
+ (tinylock-lock-now))
+ (tinylock-process-data-set))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylock-add-history (passwd)
+ "Add login attempt to `tinylock-:history'.PASSWD is the attempted login password."
+ (let* ((d (current-time-string)))
+ (setq tinylock-:history
+ (append tinylock-:history
+ (list (list d passwd))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylock-kill-process-control (&optional kill)
+ "Return all processes in string format, or KILL all processes (not timer)."
+ (let* ((list (process-list))
+ ret)
+ (if list
+ (mapcar
+ (function
+ (lambda (x)
+ (cond
+ ((null kill)
+ (setq ret (concat (or ret "") (prin1-to-string x))))
+ (t
+ ;; let's not kill the timer
+ (if (not (string-match "display-time\\|timer"
+ (prin1-to-string x)))
+ (delete-process x))))))
+ list))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinylock-history ()
+ "Displays login history. Optionally to given buffer BUFFER."
+ (interactive)
+ (let* ((i 0))
+ (switch-to-buffer-other-window
+ (get-buffer-create tinylock-:buffer-login-history))
+ (erase-buffer)
+ (dolist (elt tinylock-:history)
+ (insert (format "%2d: %-27s %s\n" i (nth 0 elt) (or (nth 1 elt) "<nil>") ))
+ (setq i (1+ i)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylock-blank-control (&optional unblank)
+ "Blank display or UNBLANK."
+ (let* ((blank (get-buffer-create tinylock-:buffer-blank)))
+ (cond
+ (unblank
+ (ti::kill-buffer-safe blank))
+ (t
+ (ti::select-frame-non-dedicated)
+ (dolist (frame (delq (selected-frame) (frame-list)))
+ (delete-frame frame))
+ (switch-to-buffer blank t)
+ (delete-other-windows) ;delete all other windows
+ ;; This is necessary in 19.28 for some unknown reason
+ ;; otw, the sreen is not shown
+ (sit-for 1)))))
+
+;;}}}
+;;{{{ code: main
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylock-lock-now ()
+ "Lock up Emac."
+ (tinylock-lock tinylock-:auto-lock-password "Autolocking.. emacs " 'doit ))
+
+;;; ------------------------------------------------------------ &main ---
+;;;
+;;;###autoload
+(defun tinylock-lock (psw &optional msg lock-now)
+ "Lock Emacs with PSW password and MSG.
+Message is displayed if LOCK-NOW is nil.
+If LOCK-NOW is non-nil emacs is immediately locked with PSW."
+ (interactive
+ (list
+ (progn
+ (message "Now enter lock string...") (sit-for 1)
+ (ti::query-read-input-invisible))))
+ (let* ((cursor-in-echo-area nil)
+ ;; It's good programming style NOT to use globals directly
+ ;; inside code This way maintainer sees at glance what it uses.
+ (key-msg "This emacs is locked, enter key:")
+ (entry-err "Unauthorized access.")
+ (wait tinylock-:login-error-sleep)
+ (loop t)
+ (msg (or msg "Lock Emacs ? "))
+ ans)
+ (catch 'done
+ (if (ti::nil-p psw)
+ (error "Password is empty."))
+ (if (and (null lock-now)
+ (null (y-or-n-p msg)))
+ (throw 'done t))
+ (save-window-excursion
+ (run-hooks 'tinylock-:before-lock-hook))
+ ;; It's better to save work, you may forgot the password :-/
+ (save-some-buffers 'noAsk)
+ (ti::compat-timer-list-control 'save)
+ (tinylock-install-lock-timer 'kill) ;our process
+ (tinylock-kill-process-control 'kill) ;get rid of them
+ (ti::compat-timer-list-control 'kill) ;Stop all timers
+ (tinylock-blank-control)
+ ;; we need to restore windows config when we return
+ (save-window-excursion
+ (save-excursion
+ ;; Now we make interrupting impossible, C-g won't work now on...
+ (setq inhibit-quit t)
+ (setq tinylock-:history nil) ;clear the log buffer
+ (message "TinyLock: Emacs LOCKED %s " (ti::date-standard-date))
+ (sleep-for 1)
+ (message "")
+ (while loop
+ (when (input-pending-p) ;wait for kbd event
+ (discard-input)
+ (message key-msg)
+ (sleep-for 1)
+ (message "")
+ (discard-input)
+ (setq ans (ti::query-read-input-invisible))
+ (cond
+ ((string-equal ans psw)
+ (setq loop nil)) ; right password, let user in
+ (t
+ (tinylock-add-history ans) ; record to log
+ (message entry-err)
+ (sit-for wait)))))))
+ (tinylock-blank-control 'unblank)
+ (message "TinyLock: Emacs unlocked %s" (ti::date-standard-date))
+ (setq quit-flag nil inhibit-quit nil) ; restore flags
+ (ti::compat-timer-list-control 'restore)
+ (tinylock-process-on)
+ (run-hooks 'tinylock-:after-lock-hook)
+ nil)))
+
+;;}}}
+;;{{{ Default: hook functions.
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylock-before-lock-function ()
+ "Saves emacs state, so that you can recover from accidental crash."
+ (when (fboundp 'tid-save-state)
+ (message "TinyLock: wait, using TinyDesk to save emacs state...")
+ (ti::funcall 'tid-save-state "~/emacs.lock-state.saved")
+ (message "TinyLock: wait, using TinyDesk to save emacs state...done.")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylock-after-lock-function ()
+ "Restores Emacs state after lock"
+ (display-time) ;re-enable process
+ (when (fboundp 'timi-report-install-maybe)
+ (ti::funcall 'timi-report-install-maybe)))
+
+(add-hook 'tinylock-:load-hook 'tinylock-process-on)
+
+;; Ask lock password at startup
+
+(if tinylock-:auto-lock-password
+ (remove-hook 'tinylock-:load-hook 'tinylock-auto-lock-set-password)
+ (add-hook 'tinylock-:load-hook 'tinylock-auto-lock-set-password))
+
+(add-hook 'tinylock-:before-lock-hook 'tinylock-before-lock-function)
+(add-hook 'tinylock-:after-lock-hook 'tinylock-after-lock-function)
+
+;;}}}
+
+(provide 'tinylock)
+(run-hooks 'tinylock-:load-hook)
+
+;;; tinylock.el ends here
--- /dev/null
+;;; tinylpr.el --- Easy Emacs lpr command handling, pop-up, completions
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 1996-2007 Jari Aalto
+;; Keywords: extensions
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program, call M-x tinylpr-version.
+;; Look at the code with folding.el
+
+;; COPYRIGHT NOTICE
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;;; Install:
+
+;; ....................................................... &t-install ...
+;; Put this file on your Emacs-Lisp load path, add following into your
+;; ~/.emacs startup file
+;;
+;; (require 'tinylpr)
+;;
+;; Suggested key binding. The commands are available via echo-menu, but
+;; you can bind each command individually too. The echo menu:
+;;
+;; (ti::use-prefix-key "\C-z") ;; Free C-z for us.
+;; (global-set-key "\C-zp" (ti::definteractive (ti::menu-menu 'tinylpr-:menu)))
+;;
+;; Notice, that loading this file changes your `lpr-command' immediately
+;; to "sh". This is essential and if you want to use this package,
+;; leave it there or choose some compatible shell that accepts "-c"
+;; switch.
+;;
+;; CHANGE THE VARIABLES !
+;;
+;; You must copy the user variables and put your own definitions
+;; there. The ones that ship with this module are only examples
+;;
+;; If you have any questions, use this function
+;;
+;; M-x tinylpr-submit-feedback
+
+;;}}}
+;;{{{ Documentation
+
+;; ..................................................... &t-commentary ...
+
+;;; Commentary:
+
+;; Overview of features
+;;
+;; o Managing printers or print styles easily
+;; o Queue information
+;; o Has ready X-popup example to select print styles etc.
+;; o Echo menu provided to select printing advice:
+;;
+;; TinyLpr: 01c2 r)egion b)uffer l)ine numbers d)printer
+;; Q)ueue s)tyle >P
+;;
+;; o Ps print support in another `P' echo-menu:
+;;
+;; TinyLpr: 01c2(ps) rR)egion bB)uffer sS)Spool d)espool
+;;
+;; Introduction
+;;
+;; Unix environment offers numerous utilizes to format printing
+;; the user wants, not to mention the numerous printers that can be set.
+;; you may find these command in your system:
+;;
+;; mmpage multi-page 1-8, like sunOS enscript
+;; lp
+;; lpr
+;; a2ps
+;; squeeze.awk my own empty line squeezer. Ever run CPP on C/C++ ?
+;; groff I make some nroff files...
+;; banner big letters
+;; lpstat
+;; col -bx remove ctrl codes from man pages
+;; pps pretty printer for PostScript -- jau@tut.fi
+;; pr format files
+;; fold fold long lines for finite width output device
+;; adjust for filling, centering, ..justifying
+;;
+;; If you want to print the file in some other format, i.e. combining
+;; some of the commands above, you have change `lpr-switches'
+;; every time. This is tedious. Instead this package offers a pop up menu
+;; where you can select lpstatus, select print command, cancel print
+;; job etc...
+;;
+;; Example
+;;
+;; (defun my-x-menu (event)
+;; "Pop up an X window of user defined commands. "
+;; (interactive "e")
+;; (let* ((pstat
+;; (replace-regexp-in-string ;remove directory name
+;; ".*/"
+;; ""
+;; (or (my-print-status) "")))
+;; item)
+;; (setq
+;; item
+;; (x-popup-menu
+;; event
+;; (list
+;; "Command Menu"
+;; (list
+;; "Printer: "
+;; ;; This first one is header, not selection
+;; (cons (concat ":: " pstat) 'ignore)
+;; ;; these are selections
+;; '("* Print region" . print-region)
+;; '("* Print buffer" . print-buffer)
+;; '("Destination" . tinylpr-select-printer)
+;; '("Print style" . tinylpr-print-style-select)
+;; '("Queue status" . tinylpr-queue)))))
+;; (cond
+;; (item ;direct command
+;; (call-interactively item)))))
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+;;{{{ setup: require
+
+(require 'tinylibm)
+(require 'lpr)
+
+(eval-and-compile
+
+ (autoload 'ps-print-buffer "ps-print" nil t)
+ (autoload 'ps-print-buffer-with-faces "ps-print" nil t)
+ (autoload 'ps-print-region "ps-print" nil t)
+ (autoload 'ps-print-region-with-faces "ps-print" nil t)
+ (autoload 'ps-spool-buffer "ps-print" nil t)
+ (autoload 'ps-spool-buffer-with-faces "ps-print" nil t)
+ (autoload 'ps-spool-region "ps-print" nil t)
+ (autoload 'ps-spool-region-with-faces "ps-print" nil t)
+
+ (defvar ps-lpr-switches) ;to quiet ByteCompiler
+ (defvar lpr-switches)
+ (defvar lpr-command))
+
+(eval-when-compile (ti::package-use-dynamic-compilation))
+
+(ti::package-defgroup-tiny TinyLpr tinylpr-: extensions
+ "Easy Emacs lpr command handling, popup, completions
+ o Managing printers or print styles easily
+ o Queue information
+ o Has ready X-popup example to select print styles etc.")
+
+;;}}}
+;;{{{ setup: variables
+
+;;; ......................................................... &v-hooks ...
+
+(defcustom tinylpr-:load-hook nil
+ "Hook run when file is loaded."
+ :type 'hook
+ :group 'TinyLpr)
+
+;;; .......................................................... &v-vars ...
+;;; *** important ***
+;;;
+;;; These are just examples. Copy the variables into your ~/.emacs
+;;; and make changes to reflect your system.
+;;;
+;;;
+
+(defcustom tinylpr-:set-ps-lpr-switches t
+ "If non-nil, set also ps-lpr-switches from ps-print.el when
+changing printer."
+ :type 'boolean
+ :group 'TinyLpr)
+
+(defcustom tinylpr-:queue-cmd
+ (or (executable-find "lpstat")
+ (let ((function (if (ti::win32-p)
+ 'message
+ 'error)))
+ (funcall function
+ "TinyLpr: can't use default [lpstat] for tinylpr-:queue-cmd")))
+ "*Shell Command to return queue status"
+ :type '(string :tag "Shell Command")
+ :group 'TinyLpr)
+
+(eval-and-compile
+ (defcustom tinylpr-:printer-list
+ (delq nil
+ (list
+ (getenv "PRINTER")
+ (if (ti::win32-p) "lpt1:")
+ (if (ti::win32-p) "prn:")))
+ "*List of available printers, like '(\"PRINTER1\" \"PRINTER2\")."
+ :type '(repeat (string :tag "printer"))
+ :group 'TinyLpr)
+
+ (defcustom tinylpr-:print-style-list
+ (let* ((mp (executable-find "mpage")) ;HP-UX multipage
+ (lp (executable-find "lp"))
+ (lpr (executable-find "lpr"))
+ (nl (executable-find "nl"))
+ (ens (executable-find "enscript"))
+ (gs (executable-find "gs"))
+ (gs32 (executable-find "gs386"))) ;; Ghostscript in Win32
+ (delq
+ nil ;Remove empty entries
+ (list
+ (if lp
+ (list
+ ;; Select the first string so, that it's easy to complete.
+ "lp, straight lp" (concat lp " -d#")))
+ (if lpr
+ (list
+ "lpr straight" (concat lpr " -d#")))
+ (if (and nl lp)
+ (list
+ "nl, numbered lp" "nl | lp -d#"))
+ (if mp
+ (list
+ "2 mpage" (concat mp " -A -2 -P#")))
+ (if mp
+ (list
+ "4 mpage" (concat mp " -A -4 -P#")))
+ (if mp
+ (list
+ "8 mpage" (concat mp " -A -8 -P#")))
+ (if mp
+ (list
+ "2l mpage landscape" (concat mp " -A -l -2 -P#")))
+ (if ens
+ (list
+ "enscript" (concat ens " -d#")))
+ (if ens
+ (list
+ "et enscript TOC" (concat ens " --toc -d#")))
+ (if ens
+ (list
+ "2l enscript landscape" (concat ens " -r -2 -d#")))
+ (if gs
+ (list
+ "ghostscript a4"
+ (concat gs "-q -dNOPAUSE -sDEVICE=SomeDevice"
+ "-r600 -sPAPERSIZE=a4 "
+ "-sOutputFile=#"
+ "-Ic:/gs -"))))))
+ "*Available print styles.
+The # char tells where to install printer in command.
+
+Format:
+
+ '((COMPLETION-STRING PRINTER-COMMAND-STRING) ..)
+
+Example
+
+ '((\"2 pages\" \"mpage -A -2 -P#\"))"
+ :type '(repeat
+ (list (string :tag "Completion name")
+ (string :tag "Shell Command.")))
+
+ :group 'TinyLpr)
+
+ ) ;; eval-and-compile
+
+;;; ....................................................... &v-private ...
+
+(defvar tinylpr-:current-printer (car-safe tinylpr-:printer-list)
+ "Private. Current printer.")
+
+(defvar tinylpr-:current-print-style (car-safe (car-safe tinylpr-:print-style-list))
+ "Private. Current print style.")
+
+(defvar tinylpr-:printer-list-history nil
+ "Private. History list for `tinylpr-:printer-list'.")
+
+(defvar tinylpr-:print-style-history nil
+ "Private. History list for tinylpr-print-style-completions.")
+
+;;; ....................................................... &v-version ...
+
+(eval-and-compile
+ (ti::macrof-version-bug-report
+ "tinylpr.el"
+ "tinylpr"
+ tinylpr-:version-id
+ "$Id: tinylpr.el,v 2.42 2007/05/01 17:20:49 jaalto Exp $"
+ '(tinylpr-:version-id
+ tinylpr-:load-hook
+ tinylpr-:set-ps-lpr-switches
+ tinylpr-:queue-cmd
+ tinylpr-:printer-list
+ tinylpr-:print-style-list
+ tinylpr-:current-printer
+ tinylpr-:current-print-style
+ tinylpr-:printer-list-history
+ tinylpr-:print-style-history)))
+
+(defvar tinylpr-:menu
+ '((format
+ "TinyLpr: %s r)egion b)uffer l)ine numbers d)printer Q)ueue s)tyle >P"
+ tinylpr-:current-printer)
+ ((?d . (t (call-interactively 'tinylpr-select-printer)))
+ (?Q . ( (call-interactively 'tinylpr-queue)))
+ (?s . (t (call-interactively 'tinylpr-print-style-select)))
+ (?r . ( (call-interactively 'print-region)))
+ (?b . ( (call-interactively 'print-buffer)))
+ (?l . ( (call-interactively 'tinylpr-print-with-line-numbers)))
+ (?P . tinylpr-:ps-print-menu)))
+ "*Echo menu to access printer commands. Select `P' for ps-print.el commands.")
+
+(defvar tinylpr-:ps-print-menu
+ '((format "\
+TinyLpr: %s(ps) rR)egion bB)uffer sS)Spool d)espool "
+ tinylpr-:current-printer)
+ ((?r . ( (call-interactively 'ps-print-region)))
+ (?R . ( (call-interactively 'ps-print-region-with-faces)))
+ (?b . ( (call-interactively 'ps-print-buffer)))
+ (?B . ( (call-interactively 'ps-print-buffer-with-faces)))
+ (?s . ( (call-interactively 'ps-spool-buffer)))
+ (?S . ( (call-interactively 'ps-spool-buffer-with-faces)))
+ (?w . ( (call-interactively 'ps-spool-region)))
+ (?W . ( (call-interactively 'ps-spool-region-with-faces)))
+ (?d . ( (call-interactively 'ps-despool)))))
+ "*Echo menu to access ps-print commands.
+
+ r Print region.
+ R Print region with faces.
+ b Print buffer.
+ B rint buffer with faces.
+
+ s Spool buffer.
+ S Spool buffer with faces.
+ w Spool region.
+ W Spool region with faces.
+
+ d Despool (send spooled items)")
+
+;;}}}
+
+;;; ########################################################### &Funcs ###
+
+;;{{{ code: funcs
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylpr-install-lpr-command ()
+ "Set correct shell for `lpr-command'."
+ (interactive)
+ (let* (sh)
+ (unless (string-match "sh\\|bash\\|cmd.exe\\|command.exe"
+ (or lpr-command ""))
+ ;; NT Cygnus users get served too by putting sh,bash test first.
+ (cond
+ ((setq sh (or (executable-find "sh")
+ (executable-find "bash")))
+ (setq lpr-command sh))
+ ((and (ti::win32-p)
+ (setq sh (or (executable-find "cmd")
+ (executable-find "command"))))
+ (setq lpr-command sh))
+ (t
+ (error "\
+TinyLpr: sh, bash or cmd.exe not available. Can't set lpr-command." ))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylpr-set-command (template printer)
+ "Substitutes possible # n TEMPLATE with PRINTER name in."
+ (if (string-match "\\(#\\)" template)
+ (setq template (ti::replace-match 1 printer template)))
+
+ ;; We know the lpr-command is "sh", so just put the "-c" as
+ ;; first option.
+
+ (cond
+ ((string-match "\\(sh\\|bash\\)$" lpr-command)
+ (setq lpr-switches (list "-c" template)))
+ ((string-match "\\(command\\|cmd\\)\\.exe$" lpr-command) ;Win32
+ (setq lpr-switches (list "/c" template)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylpr-print-with-line-numbers ()
+ "Adds line numbers to buffer and prints it. After printing,
+removes line numbers."
+ (interactive)
+ (let* (buffer-read-only
+ fmt
+ len)
+ (with-buffer-modified
+ (save-excursion
+ (ti::pmax)
+ ;; Set dynamic format according to biggest line number
+ (setq len (ti::digit-length (ti::current-line-number))
+ fmt (concat "%0" len "d: %s"))
+ (unwind-protect
+ (progn
+ (ti::buffer-insert-line-numbers (point-min) (point-max) 1 1 fmt)
+ (print-buffer))
+ (ti::buffer-remove-line-numbers
+ (point-min)
+ (point-max)
+ "^[0-9]+: " 0))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylpr-print-style-completions ()
+ "Build up the completion array."
+ (let* ((list tinylpr-:print-style-list)
+ (i 0)
+ completions)
+ (mapcar
+ (function
+ (lambda (x)
+ (setq i (1+ i))
+ (setq completions (cons (cons (car x) i) completions))))
+ list)
+ completions))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylpr-setting-status ()
+ "Return current settings."
+ (interactive)
+ (let* ((stat (nth 1 lpr-switches)))
+ (if (interactive-p)
+ (message stat))
+ stat))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylpr-queue ()
+ "Return queue status."
+ (interactive)
+ (let* ((cmd tinylpr-:queue-cmd)
+ (buffer (ti::temp-buffer "*tmp*" 'clear)))
+ (display-buffer buffer)
+ (shell-command cmd buffer)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylpr-select-printer (printer)
+ "Select PRINTER printer."
+ (interactive
+ (list
+ (completing-read
+ (concat "Printer [" tinylpr-:current-printer "]: ")
+ (ti::list-to-assoc-menu tinylpr-:printer-list)
+ nil t
+ nil
+ 'tinylpr-:printer-list-history)))
+ (when (not (ti::nil-p printer))
+ (setq tinylpr-:current-printer printer)
+ (if tinylpr-:set-ps-lpr-switches
+ (setq ps-lpr-switches (list (concat "-P" printer))))
+ (tinylpr-print-style-select tinylpr-:current-print-style)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinylpr-print-style-select (arg)
+ "Select print output style with ARG."
+ (interactive
+ (list
+ (completing-read
+ (format "Print style [%s: %s ]: "
+ (or tinylpr-:current-print-style "<style unknown>")
+ (tinylpr-setting-status))
+ (tinylpr-print-style-completions)
+ nil
+ t)))
+
+ (let* ((printer (or tinylpr-:current-printer ""))
+ elt
+ args)
+ ;; Try to find the style in assoc array
+ (if (not (and arg (setq elt (assoc arg tinylpr-:print-style-list))))
+ (message "No such style")
+ ;; replace # with printer name
+ (setq tinylpr-:current-print-style arg)
+ (setq args (nth 1 elt))
+ (tinylpr-set-command args printer)
+ (message "Print <%s> on %s" arg (tinylpr-setting-status)))))
+
+;;}}}
+;;{{{ code: install
+
+;;; .................................................... &auto-install ...
+
+;; Install package, reset lpr variables
+
+(tinylpr-install-lpr-command)
+
+(let* ((template (nth 1 (car tinylpr-:print-style-list))))
+ (if (and template tinylpr-:current-printer)
+ (tinylpr-set-command template tinylpr-:current-printer)
+ (message "\
+TinyLpr: ** Auto setup failure, please define tinylpr-:print-style-list and
+TinyLpr: ** tinylpr-:current-printer")))
+
+;;}}}
+
+(provide 'tinylpr)
+(run-hooks 'tinylpr-:load-hook)
+
+;;; tinylpr.el ends here
--- /dev/null
+;;; tinymacro.el --- Fast way to assign newly created macro to a key
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 1995-2007 Jari Aalto
+;; Keywords: extensions
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program, call M-x tinymacro-version.
+;; Look at the code with folding.el
+
+;; COPYRIGHT NOTICE
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;;; Intall:
+
+;; ........................................................ &t-install ...
+;; Put this file on your Emacs-Lisp load path, add following into your
+;; ~/.emacs startup file. Rip code with tinylib.el/ti::package-rip-magic
+;;
+;; ;; To use default keybinding "C-x(" and "C-x)", add this:
+;; (add-hook 'tinymacro-:load-hook 'tinymacro-install-default-keybindings)
+;; (require 'tinymacro)
+;;
+;; or use autoload and your $HOME/.emacs starts faster
+;;
+;; (global-set-key "\C-x)" 'tinymacro-end-kbd-macro-and-assign)
+;; (autoload 'tinymacro-end-kbd-macro-and-assign "tinymacro" "" t)
+;;
+;; If you have any questions, feedback, use this function
+;;
+;; M-x tinymacro-submit-bug-report
+
+;;}}}
+;;{{{ Documentation
+
+;; ..................................................... &t-commentary ...
+
+;;; Commentary:
+
+;; Preface, 1995
+;;
+;; This started as a very little project when
+;; <mosh@ramanujan.cs.albany.edu> (Mohsin-Ahmed) 1995-03-17 in
+;; gnu.emacs.help post asked for easy way to assign newly created
+;; macro to some key. In reponse the author sent a simple function to do
+;; it, but he informaed that one macro, which was recycled every time,
+;; was too little. Author started modifying code more, and that was
+;; the birth of this package.
+;;
+;; Description
+;;
+;; o Two keystrokes to make a macro: one to record, one to
+;; assign it to key.
+;; o To see the macro assignments to keys, just call `tinymacro-macro-info'
+;; o Default macro count is 10, increase with `tinymacro-:stack-max'
+
+;;}}}
+
+;;; Change log:
+
+;;; Code:
+
+;;{{{ setup: require
+
+(require 'tinylibm)
+
+(eval-when-compile (ti::package-use-dynamic-compilation))
+
+(ti::package-defgroup-tiny TinyMacro tinymacro-: extensions
+ "Fast way to assign newly created macro to key
+ Overview of features.
+
+ o Two keystrokes to make a macro: one to record, one to
+ assign it to key.
+ o To see the macro assignments to keys, just call tinymacro-macro-info")
+
+;;}}}
+;;{{{ setup: hooks, private
+
+(defcustom tinymacro-:macro-assigned-hook nil
+ "*If new macro were asiigned, this hook will be run. The function
+SYMBOL that was used is in variable tinymacro-:last-macro-func"
+ :type 'hook
+ :group 'TinyMacro)
+
+(defcustom tinymacro-:load-hook nil
+ "*Hook run when file has been loaded."
+ :type 'hook
+ :group 'TinyMacro)
+
+;;}}}
+;;{{{ setup: public, user configurable
+
+(defcustom tinymacro-:macro-function-name-prefix "tinymacro--macro"
+ "*The function name prefix to use, when assigning name to last kbd macro"
+ :type 'string
+ :group 'TinyMacro)
+
+(defcustom tinymacro-:ask-when-stack-wrap-flag nil
+ "*Non-nil means ask user if used function stack wraps."
+ :type 'boolean
+ :group 'TinyMacro)
+
+(defcustom tinymacro-:stack-max 10
+ "*Maximum stack depth of unique macronames.
+ The name run from 0..max, and wraps to 0 after max."
+ :type 'integer
+ :group 'TinyMacro)
+
+(defcustom tinymacro-:tmp-buffer "*temp*"
+ "*Temporary buffer. Eg. displaying the macro bindings to keys."
+ :type 'string
+ :group 'TinyMacro)
+
+;;}}}
+;;{{{ setup: private variables
+
+(defvar tinymacro-:stack-ptr 0
+ "Keep record of available stack space.")
+
+(defvar tinymacro-:last-macro-func nil
+ "Hold last function SYMBOL that were used in assignment.")
+
+(defvar tinymacro-:last-macro-key nil
+ "Hold last key STRING or VECTOR that were used in assignment.")
+
+(defvar tinymacro-:function-list nil
+ "List of original KEY -- FUNCTION pairs, whic are currently occupied
+by macros")
+
+;;}}}
+;;{{{ setup: version
+
+;;;###autoload (autoload 'tinymacro-version "tinymacro" "Display commentary." t)
+(eval-and-compile
+ (ti::macrof-version-bug-report
+ "tinymacro.el"
+ "tinymacro"
+ tinymacro-:version-id
+ "$Id: tinymacro.el,v 2.43 2007/05/01 17:20:50 jaalto Exp $"
+ '(tinymacro-:version-id
+ tinymacro-:stack-ptr
+ tinymacro-:last-macro-func
+ tinymacro-:last-macro-key
+ tinymacro-:function-list
+ tinymacro-:macro-assigned-hook
+ tinymacro-:load-hook
+ tinymacro-:macro-function-name-prefix
+ tinymacro-:ask-when-stack-wrap-flag
+ tinymacro-:stack-max
+ tinymacro-:tmp-buffer)))
+
+;;}}}
+;;{{{ code: misc
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymacro-restore ()
+ "Restores all macro bindings, so that keys that occupy macros
+are restored to original functions.
+
+References:
+ tinymacro-:function-list list is cleared too."
+ (interactive)
+ (let* ((list tinymacro-:function-list))
+ (if (null list)
+ (if (interactive-p)
+ (message "TinyMacro: No macros active."))
+ (dolist (elt list)
+ (global-set-key (nth 0 elt) (nth 1 elt)))
+ (setq tinymacro-:function-list nil))))
+
+;;}}}
+;;{{{ code: symbol
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymacro-create-symbol()
+ "Creates macro variable. Returns NEW or EXISTING SYMBOL."
+ (let* ((max tinymacro-:stack-max)
+ (sp tinymacro-:stack-ptr)
+ (q tinymacro-:ask-when-stack-wrap-flag)
+ (name tinymacro-:macro-function-name-prefix)
+ sym2
+ new
+ ret)
+ (if (or (null q)
+ (< sp max)) ; yes, go ahead with new
+ (setq new (format "%s%d"
+ name
+ (if (< sp max) ; 0..max
+ (setq sp (1+ sp))
+ (setq sp 0))))
+ (if (y-or-n-p "Macro stack full, wrap? ")
+ (setq new
+ (if (< sp max) ; 0..max
+ (setq sp (1+ sp))
+ (setq sp 0)))))
+
+ (when new ; Must update stack
+ (setq tinymacro-:stack-ptr sp
+ ret (intern-soft new)) ; return symbol
+ (if ret nil ; Already exist
+ ;; a) make it b)s et to nil c) put into ret val
+ (setq sym2 (intern new))
+ (set sym2 nil)
+ (setq ret sym2)))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymacro-create-name ()
+ "Creates macro name."
+ (let* ((max tinymacro-:stack-max)
+ (sp tinymacro-:stack-ptr)
+ (q tinymacro-:ask-when-stack-wrap-flag)
+ (n tinymacro-:macro-function-name-prefix)
+ new)
+ (if (or q (< sp max)) ; yes, go ahead with new
+ (setq new
+ (concat n (if (< sp max) ; 0..max
+ (setq sp (1+ sp))
+ (setq sp 0))))
+ (if (y-or-n-p "Macro stack full, wrap? ")
+ (setq new (concat n (if (< sp max) ; 0..max
+ (setq sp (1+ sp))
+ (setq sp 0))))))
+ (if new ; Must update stack
+ (setq tinymacro-:stack-ptr sp))
+ new))
+
+;;}}}
+;;{{{ code: main
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymacro-macro-info ()
+ "Show which macros are assigned to which keys."
+ (interactive)
+ (let* ((sp tinymacro-:stack-ptr)
+ (max tinymacro-:stack-max)
+ (buf tinymacro-:tmp-buffer)
+ (base tinymacro-:macro-function-name-prefix)
+ (i 0)
+ (round 0)
+ bp ;buffer pointer
+ name
+ key)
+ (while (< i (1+ max))
+ (setq name (concat base i) i (1+ i) key "")
+ (if (null (intern-soft name)) nil ;not use yet
+ (if (> round 0) nil ;do only once
+ (setq bp (get-buffer-create buf))
+ (set-buffer bp) (erase-buffer)
+ (insert (format "Stack pointer : %d\n" sp )))
+ (if (null (setq key (ti::keymap-function-bind-info (intern name))))
+ (setq key "[??]")) ;should never happen
+ (insert (format "%-10s %s\n" key name))
+ (setq round (1+ round))))
+ (if (and (interactive-p)
+ (eq 0 round))
+ (message "TinyMacro: No macros bound or set."))
+ (switch-to-buffer-other-window bp)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinymacro-end-kbd-macro-and-assign ()
+ "Terminate reading macro and assign it to key."
+ (interactive)
+ (end-kbd-macro)
+ (call-interactively 'tinymacro-assign))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymacro-install-default-keybindings ()
+ "Install keybinding C-x) to record and assign macro to a key."
+ (interactive)
+ (global-set-key "\C-x)" 'tinymacro-end-kbd-macro-and-assign)
+ (message
+ (substitute-command-keys
+ (concat
+ "Tinymacro: command tinymacro-end-kbd-macro-and-assign set to key "
+ "\\[tinymacro-end-kbd-macro-and-assign]"))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinymacro-assign (&optional key verb)
+ "Name last macro and assigns it to user defined KEY.
+Runs tinymacro-:macro-assigned-hook if key macro gets installed.
+The query options should be turned off if you call this within
+function, since it always return nil if the options are on.
+
+Input:
+
+ KEY Should be valid emacs key-bind-sequence/key-vector
+ VERB Boolean, verbose messages
+
+Return:
+
+ t is assigned
+ nil not assigned `keyboard-quit'"
+ (interactive)
+
+ (let* ((f-name "") ;func name
+ do-it
+ macro-name ;our new macro !
+ lookup ;what was found
+
+ ;; --- 1 ---
+ ;; The bullet proof way to find key bind for abort
+ ;; (ti::keymap-function-bind-info 'keyboard-quit global-map)
+
+ ;; --- 2 --
+ ;; - Or we just say where it is... Nobody relocates it anyway
+ ;; - We use this because function2key does not work in XEmacs
+
+ (abort-ch (char-to-string ?\007)))
+ (ti::verb)
+ (if (null key)
+ (setq key
+ (read-key-sequence "Tinymacro: Set last macro to key(s): ")))
+ (if (equal key abort-ch)
+ (progn
+ (if (interactive-p)
+ (message "Tinymacro: Skipping abort key. Not assigned."))
+ nil)
+ ;; Search the key, if it's already assigned
+ (setq lookup
+ (or (and (current-local-map) ;in fundamental-mode this is nil.
+ (lookup-key (current-local-map) key))
+ (lookup-key global-map key) key))
+ ;; ................................................... occupied? ...
+ (when lookup
+ (if (and (symbolp lookup)
+ (fboundp lookup)) ;just plain function
+ (setq f-name (symbol-name lookup))
+ (setq f-name (prin1-to-string lookup))))
+ ;; ............................................. ask permission? ...
+ (when
+ (and verb
+ (not (null lookup)))
+ (setq do-it
+ (y-or-n-p
+ (format
+ "Key already occupied by %s; continue? " f-name))))
+ ;; ................................................ assign macro ...
+ (cond
+ ((and verb (null do-it))
+ (message
+ (substitute-command-keys
+ "Tinymacro: Cancelled. Use \\[tinymacro-assign] to rebind.")))
+ (t
+ (setq macro-name (tinymacro-create-symbol))
+ (name-last-kbd-macro macro-name)
+ ;; save previous
+ (when (and (symbolp lookup)
+ (fboundp lookup)
+ (not (string-match "^tim" f-name))
+ (not (assoc key tinymacro-:function-list)))
+ (push (list key lookup) tinymacro-:function-list))
+ (global-set-key key macro-name)
+ (setq tinymacro-:last-macro-func macro-name ;set >> GLOBALS <<
+ tinymacro-:last-macro-key key)
+ (if verb
+ (message
+ "TinyMacro: Created function: %s" (symbol-name macro-name)))
+ (run-hooks 'tinymacro-:macro-assigned-hook)
+ t)))))
+
+;;}}}
+
+(provide 'tinymacro)
+(run-hooks 'tinymacro-:load-hook)
+
+;;; tinymacro.el ends here
--- /dev/null
+;;; tinymail.el --- Mail add-ons. Report incoming mail, passwd, BBDB complete.
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 1996-2007 Jari Aalto
+;; Keywords: tools
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program run M-x tinymail-version
+;; Look at the code with folding.el
+
+;; COPYRIGHT NOTICE
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;; ....................................................... &t-install ...
+;; Put this file on your Emacs-Lisp load path, add following into your
+;; ~/.emacs startup file:
+;;
+;; (require 'tinymail-install)
+;; (require 'tinymail-install-extras) ;; optional
+;;
+;; Other setting you may wish to add:
+;;
+;; ;; Activate nice citation
+;; (add-hook 'tinymail-:load-hook 'tinymail-install-citation)
+;;
+;; ;; If you want nice TAB to indent for your messages,
+;; ;; add this. You TAB advances 4 spaces in the body of message.
+;; (autoload 'turn-on-tinytab-mode "tinytab" "" t)
+;; (add-hook 'tinymail-:mode-hook 'turn-on-tinytab-mode)
+;;
+;; ;; If you use NIS, use "ypcat passwd"
+;; (setq tinymail-:password-cat-cmd "cat /etc/passwd")
+;;
+;; ;; Protect plain text email addresses in the body
+;; (add-hook 'mail-send-hook 'tinymail-buffer-email-address-scramble)
+;; (add-hook 'message-send-hook 'tinymail-buffer-email-address-scramble)
+;;
+;; If you have any questions, use 'submit' function. In case of error
+;; or misbehavior, turn on the debug and send the debug result and
+;; describe what you did and what went wrong.
+;;
+;; .. do what you did in mail buffer ..
+;; M-x tinymail-debug-toggle Make sure debug is on
+;; C-u M-x tinymail-process-1 Run this if you got error signall
+;; M-x tinymail-submit-bug-report And compose bug report
+;;
+;; To read the documentation, run
+;;
+;; M-x load-library RET tinymail RET
+;; M-x tinymail-version [Add C-u, shows version only]
+
+;;}}}
+;;{{{ Documentation
+
+;; ..................................................... &t-commentary ...
+
+;;; Commentary:
+
+;; Overview of features
+;;
+;; o Generate sendmail PLUS address: login@domain (Mr Foo+info)
+;; Works like real sendmail PLUS addressing:
+;; login+info@domain (Mr Foo)
+;; o Generate anti-ube addresses to prevent UBE/Spam from arriving
+;; to your mailbox.
+;; o Changes Fcc dynamically according to header content.
+;; o Very easy TAB completion: two modes, alias and definition string.
+;; Also completes password file entries if your .mailrc doesn't
+;; contain a match.
+;; o Easy interface for completing any field with TAB. E.g. complete
+;; `Followup-To:', `Gcc', `Newsgroups' and any user defined fields,
+;; like `Class' or `Priority'.
+;; o Fcc/Gcc folder can have compression extension .gz or .Z
+;; o When you reply, tour address is removed from CC to prevent
+;; duplicates.
+;; o `mail-mode], Gnus `message-mode' and VM compatible.
+;; o MIME support: turns on Multi part sending if buffer size is
+;; bigger than 50K.
+;;
+;; BBDB supported
+;;
+;; Search BBDB for partial matches when you complete *To* and *Cc*
+;; fields in header. E.g. if you remember person's address, "site" or
+;; something, hit just TAB and all found BBDB's `net' field completions
+;; are offered.
+;;
+;; Notice that you have to _manually_ add full
+;; user name, phone number, whatever to the Net Field on order to
+;; complete to those items. The default `:' command adds only
+;; this:
+;;
+;; Foo Bar
+;; net: abc@example.com
+;;
+;; An in order to make that useful for completion purposes, you need to
+;; modify the `net' field with `C-o'
+;;
+;; Foo Bar
+;; net: Foo Bar - Head of Skyscraper inc. <abc@example.com>
+;;
+;; Now you can complete to any word found in the `net' line.
+;; If you want case sensitive completions, set this:
+;;
+;; (setq tinymail-:complete-bbdb-case-fold-search nil)
+;;
+;; Installation note
+;;
+;; This package installs itself to `mail-setup-hook' and you should
+;; know why if you try to get the package running for some other
+;; mail agent than Emacs mail, RMAIL, Gnus and VM where this package
+;; has been tested.
+;;
+;; The `mail-setup-hook' is called *after* the basic headers, like
+;; `To' and `Subject', which are already in the buffer. Function
+;; `tinymail-mail' needs to read the contents of `To' in order to
+;; determine how it starts. It puts 1 or 2 spaces at the beginning of
+;; `To' field at the initial start, so that the packages `Cc' control
+;; is started correctly. When you use simple mail, `C-x' `m', the auto
+;; Cc feature addds 1 space (on) and when you hit reply, the auto Cc
+;; feature adds 2 spaces (off).
+;; So, if your mail agent doesn't call `mail-setup-hook', find similar
+;; hook that runs after the headers are in the buffer and install
+;; to that hook `tinymail-mail'.
+;;
+;; Completion: Guess Completion feature
+;;
+;; There are two basic completion modes: 'alias and 'string, which is
+;; selected via `tinymail-:complete-mode'. They refer to your
+;; ~/.mailrc definitions: When you hit the completions key (TAB in
+;; headers) the current word is picked at point and searched from
+;; either of these two definition lists.
+;;
+;; alias test "Mister Foo, Skyscraper Doing co. <foo@company.com>"
+;; | |
+;; alias mode string match mode
+;;
+;; The caces 1-4 below present words that you can type into the `To' field
+;; before you hit the completion key, TAB.
+;;
+;; 1 To: company
+;; 2 To: Foo
+;; 3 To: sky
+;; 4 To: mister
+;;
+;; It doesn't matter what you type initially; it can be anything you
+;; remember from the person's definition string. TheTAB calls function
+;; `tinymail-complete-guess' and any of those lines, 1-4, will be
+;; replaced with
+;;
+;; To: Mister Foo, Skyscraper Doing co. <foo@doing.com>
+;;
+;; If there are more than one match, a completion list is displayed.
+;;
+;; Completion and BBDB integration
+;;
+;; The completion is integrated to BBDB, but you have to have
+;; BBDB present with appropriate (require 'bbdb). The fields
+;; in NET and NAME are searched by default, but you can make the
+;; completion feature to try ANY-FIELD if you change the value
+;; of `tinymail-:complete-bbdb-fuzzy-method'. See variable documentation
+;; for complete description.
+;;
+;; Accepting the found match from .mailrc
+;;
+;; TinyMail supports running several completion functions so that
+;; the right match is inserted into the buffer. In order to
+;; discard the found match from .mailrc file, you can set a trigger
+;; to `tinymail-:confirm-mailrc-regexp'. Suppose, you want to confirm
+;; completion whenever you are sending mail to your colleagues that
+;; work in "disney.com". You'd set:
+;;
+;; (setq tinymail-:confirm-mailrc-regexp "disney.com")
+;;
+;; And if the match was picked from mailrc, you have a chance to
+;; reject the string and move on with other completion functions.
+;;
+;; To: world
+;;
+;; When you hit tab here, a string "info@disneyword.com" was found from
+;; the mailrc, but may not be what you want to insert. Because
+;; you had set `tinymail-:confirm-mailrc-regexp', you get confirmation:
+;;
+;; TinyMail: Use? info@disneyword.com
+;;
+;; Where you can answer "n". The completion is canceled and all
+;; other completion function have a chance to find more
+;; suitable choice. (See Shared Shared Tab key explanation later)
+;;
+;; Completion: Password table
+;;
+;; In addition to .mailrc completion, there is support for completing
+;; entries found from *passwd* file. If the guess complete above fails
+;; the password file is examined if the mode is turned on. See
+;; variable
+;;
+;; tinymail-:password-mode
+;;
+;; Which is set to t by default. When you complete password entries
+;; for the first time, building all necessary variables will take some
+;; time. After the password file completions have been parsed, the
+;; content is written to cache file
+;;
+;; tinymail-:password-file
+;;
+;; Next time you need password completions, if this file exists,
+;; it will be read instead of heavy /etc/passwd file parsing. If you
+;; want to force reading the /etc/passwd again, just delete
+;; `tinymail-:password-file' and it will be recreated next time
+;; password completion is used.
+;;
+;; Completion: Custom completion of any header
+;;
+;; You can complete any field by setting variable
+;; `tinymail-:table-header-complete' For example to complete "Class" header,
+;; you would set the variable like this. See variable documentation
+;; for more information.
+;;
+;; (require 'assoc)
+;; (aput
+;; 'tinymail-:table-header-complete
+;; "Class" ;; Add new header for use with TAB
+;; (list
+;; '("confidential" ;; completion list
+;; "private"
+;; "for internal use only"
+;; "personal private"
+;; "personal another")))
+;; ;; end example
+;;
+;; CC field tracking
+;;
+;; You can delete any elements from `Cc' field if you set variable
+;; `tinymail-:cc-kill-regexp'. This feature can be used to delete
+;; e.g. your email addresses from the list of `Cc' recipients to
+;; to avoid getting duplicate copies of the mail when you reply.
+;;
+;; At any time you can add two spaces in front of `Cc' field to
+;; disable this "kill" feature. This is desirable if you WANT to
+;; add a CC to your other email addresses. An example:
+;;
+;; (setq tinymail-:cc-kill-regexp \"me@here.at\")
+;;
+;; To: some@example.com
+;; CC: me@here.at << will be removed
+;; CC: me@here.at << NOT removed, because field has two spaces.
+;;
+;; RMAIL Fcc field tracking
+;;
+;; By default the `Fcc' is not added in your mail message, thus this
+;; package's automatic Fcc tracking isn't activated. Add following entry
+;; into your $HOME/.emacs to record your outgoing mail messages
+;;
+;; (setq mail-archive-file-name "~/.RMAIL.out")
+;;
+;; When Emacs sees that you have set this, it adds the Fcc field to
+;; your mail message. Alternatively you can press keys
+;;
+;; C-c C-f C-f ;; mail-fcc
+;;
+;; in *mail* buffer and it asks you to insert the Fcc field. Only
+;; now, when the `Fcc' is in the message, the automatic Fcc handling
+;; starts snooping around your headers and changing it if it finds a
+;; match from variable
+;;
+;; tinymail-:table-fcc
+;;
+;; If you want to disable Fcc changing (and edit it by hand),
+;; put two spaces at front of the Fcc. like this:
+;;
+;; FCC: ~/.RMAIL.secondary
+;; ^^
+;;
+;; Fcc and saving outgoing copy in compressed format
+;;
+;; If you have an count that has quota limits, you want to save space
+;; as much as possible. You can save your outgoing mail copy in
+;; compressed format if you prepend the filename with ".gz" or
+;; ".Z". TinyMail will automatically load jka-compr if it sees any of
+;; those extensions. The fcc folder definition looks like this.
+;;
+;; (defconst tinymail-:table-fcc
+;; (list
+;; (list "elisp-archive" " ~/.mail.elisp-post.gz")
+;; (list "bug-gnu" " ~/.mail.bug.gz")
+;; (list "." " ~/.mail.out.gz"))) ;; general
+;;
+;; You _have_ to add (require 'jka-compr) is you want to use compresses
+;; RMAIL file.
+;;
+;; ;; first one is defined in paths.el
+;; (setq rmail-file-name "~/RMAIL.gz")
+;; (setq mail-archive-file-name "~/.RMAIL.out.gz")
+;;
+;; Gnus Gcc archiving
+;;
+;; `Gcc' feature is similar to Fcc, but the Gcc is special to Gnus.
+;; All instruction you read above for Fcc are same for
+;; Gcc tracking feature. The table you have to configure is
+;;
+;; tinymail-:table-gcc
+;;
+;; Before you start defining Gnus folders, you must create them from
+;; Gnus *Group* buffer with command `G' `m'. E.g. you may have
+;; created following Gnus folders for newsgroup posting
+;;
+;; nnfolder+archive:post-pgp
+;; nnfolder+archive:post-emacs
+;; nnfolder+archive:post-gen
+;;
+;; The code below sets the `Gcc' folder only once when you start
+;; composing message, probably a followup and there is a `Newsgroups'
+;; header in the buffer. But if you hit `R' or `r' to reply directly to
+;; person (or use message-mode for mailing), there is `To' header in
+;; the buffer. Only now this package changes the Gcc field according to `To'
+;; field contents. The code below is for Newsgroup posting.
+;;
+;; (setq gnus-message-archive-group 'my-gnus-archive)
+;;
+;; (defun my-gnus-archive (group)
+;; "Archive outgoing mail to right group: Create the group by G m"
+;; (interactive)
+;; (let* ()
+;; (or (stringp group) ;No accidents...
+;; (setq group ""))
+;; (cond
+;; ((string-match "pgp\\|anon\\|privacy" group)
+;; "nnfolder+archive:post-pgp")
+;; ((string-match "emacs\\|gnu" group)
+;; "nnfolder+archive:post-emacs")
+;; (t
+;; "nnfolder+archive:post-gen"))))
+;;
+;; Feature: Sending message to mailing list
+;;
+;; In Gnus you may have defined mailing lists like this
+;;
+;; list.linux-announce
+;; list.ding
+;; list.java
+;;
+;; And your personal work and mail groups with
+;;
+;; mail.private
+;; mail.misc
+;;
+;; work.documents
+;; work.fault
+;; work.customer
+;;
+;; Daemon messages to junk.daemon, Spam to junk.spam and so on.
+;; Now suppose you are reading group `list.xxx' and you hit `f'
+;; to send followup to an article. Your composed message looks like this:
+;;
+;; To: answer-to-person <foo@bar.com>
+;; Cc: <someone@list.com>, <list-foo@bar.com>
+;;
+;; The Message goes to two people in the list and gets CC'd to
+;; list. Not what you want. You want simple:
+;;
+;; To: <list-foo@bar.com>
+;;
+;; And this is what this package does for you. All you need to do it to
+;; make sure the current group has Group parameter `to-list'.
+;; defined. You add one with `G' `p] From *Group* and typing
+;;
+;; ((to-list . "The List FOO <list-foo@bar.com>"))
+;;
+;; This feature is controlled by `tinymail-:feature-hook' which contains
+;; function `tinymail-mail-send-to-list'. If you remove the function from
+;; the hook, this feature is disabled
+;;
+;; Feature: Reporting incoming mail in local mail spool
+;;
+;; Function to control mail reporting:
+;;
+;; turn-on-tinymail-report-mail
+;; turn-off-tinymail-report-mail
+;;
+;; When you load this package the Report Mail feature is activated.
+;; If you're running windowed Emacs, the X-drag bar (top of the frame)
+;; is used to display the last incoming mail and count of pending
+;; unread mail. Here the last message was from Mr. foo and the
+;; pending mail count in spool is six.
+;;
+;; "foo@bar.com 6" ;; See variable `tinymail-:report-format-string'
+;;
+;; In non-windowed Emacs this same information is displayed in echo
+;; are instead. If you would like to have it always displayed in
+;; echo area, even in X environment, then set variable
+;; `tinymail-:report-window-system' to nil before loading this package.
+;;
+;; If you would like see more information about the arrived mail, you
+;; can adjust `tinymail-:report-spool-buffer-control' e.g. to keep
+;; permanent record of incoming mail. Value 'keep says that the report
+;; mail buffer is kept when mail is queried, so you can glance it from
+;; time to to for full information about arrived messages.
+;;
+;; If the only feature you want is the mail reporting functionality,
+;; you can activate it and disable all other settings with:
+;;
+;; ;; Don't activate tinymail-mode
+;; (setq tinymail-:enter-mail-hook-list nil)
+;; (require 'tinymail)
+;;
+;; Setting up report mail notify program
+;;
+;; The `tinymail-:report-mail-notify-program' fetches the Berkeley Mailbox
+;; formatted information from mailboxes. The default program used
+;; is `from(1)', but in case you don't have it, a equivalent command
+;; "grep '^From ' $MAIL" is used. See also `frm(1)'
+;; and `nfrm(1)' `newmail(1)' and `mailfrom(1)' if you can
+;; find those in your system.
+;;
+;; If you use Gnus and separate spool files, like you would do with
+;; Procmail, then you need to gather mail arrival information from all
+;; the spool files. Let's suppose you don't want to get notified on
+;; mailing list messages, but only messages saved to your private and
+;; work spool files:
+;;
+;; ~/Mail/spool or `nnmail-procmail-directory'
+;; mail.misc
+;; mail.private
+;; mail.programming
+;; mail.emacs
+;; mail.java
+;; ...
+;;
+;; work.meetings
+;; work.docs
+;; work.customer
+;; ...
+;;
+;; In that case you have to install custom mail notify program. A
+;; simple multiple mailbox grep will work here. Note, we also grep
+;; default $MAIL:
+;;
+;; (setq tinymail-:report-mail-notify-program
+;; (format
+;; "grep '^From ' %s %s %s "
+;; (or (getenv "MAIL") (error "No $MAIL defined"))
+;; (concat (expand-file-name "~/Mail/spool/") "mail.*")
+;; (concat (expand-file-name "~/Mail/spool/") "work.*")))
+;;
+;; Take a look at variable `tinymail-:report-spool-buffer-control'
+;; which has default value 'keep where the
+;; `tinymail-:report-mail-notify-program' results are gathered. You
+;; may find it useful to keep the `tinymail-:report-spool-buffer'
+;; *tinymail-mail-spool* visible in some frame to act like `biff(1)'.
+;; From there you can find more detailed information of incoming
+;; message queue, than the simple message count in echo-area or x-drag
+;; bar.
+;;
+;; _Note_: XEmacs has package `reportmail.el'. In case that package
+;; is loaded, the report mail feature here is not installed.
+;;
+;; Feature: Saving unused mail buffers on Emacs exit
+;;
+;; This file installs one function to `kill-emacs-hook' that loops
+;; through all mail buffers and appends the buffer content to
+;;
+;; tinymail-:dead-mail-file
+;;
+;; If you had some unfinished messages that you didn't yet send, you
+;; can restore the copy from this file when you restart emacs again.
+;; In Gnus `message-mode', you can use following to trash sent mail:
+;;
+;; (setq message-kill-buffer-on-exit t)
+;;
+;; If you don't want to use this feature, add following code to your
+;; $HOME/.emacs
+;;
+;; (add-hook 'tinymail-:load-hook 'my-tinymail-:load-hook)
+;; (defun my-tinymail-:load-hook ()
+;; (remove-hook 'kill-emacs-hook 'tinymail-save-dead-mail))
+;;
+;; _Note_: VM and Gnus can keep the sent mail buffer around. This
+;; package won't install `tinymail-save-dead-mail-maybe' the dead mail
+;; collector under
+;; Gnus and VM.
+;;
+;; Feature: anti-ube email addresses
+;;
+;; Philosophy
+;;
+;; Changing the email address so that is is not pointing to your
+;; natural address is usually referred as "address munging". There are
+;; two schools that take firm position to express their views in this
+;; matter. Those who say that it is "plain wrong to munge address" and
+;; those who say "RFC does not require you to use REAL, returnable,
+;; address". It can be argued that the email address is property of
+;; an individual who can take measures to protect himself from getting
+;; into the email harvester's "2 billion email address on a CD for
+;; $100"
+;;
+;; Here is an opinion whether it is right to munge the
+;; address according to RFC by Marty Fouts
+;; 1997-11-05 in newsgroup gnus.emacs.gnus:
+;;
+;; o The real implementation of news software doesn't care if the from
+;; field is munged or not
+;; o No RFC forces the address of the poster to be a *reachable* addr.
+;; It only requires such addresses to be syntactically correct.
+;; o RFC 1036 _specifically_ states that it is not an Internet
+;; standard.
+;; o News is a *public* forum. Mail is a *private*
+;; communication medium. Posting in a _public_ forum does not
+;; require that you give you access to _private_ address, just as
+;; speaking at a public meeting does not require that I give you give
+;; unlisted phone number.
+;;
+;; Why to munge From address
+;;
+;; o Email address is one's own property. The reasons to munge are
+;; one's own. In perfect world you wouldn't need lock to your
+;; doors, but you do have them in houses. The world has changed
+;; in respect to email too.
+;; o Filter solution is no-road. It's an arms race; some UBE always
+;; sneaks through and it will never stop the actual UBE.
+;; o Not all people have access to filtering tools (some amy
+;; require certain Operating System e.g. Unix Procmail).
+;; o POP users download their post and each UBE byte costs in transfer
+;; time.
+;; o Nothing works as well as *not* giving the real address in the
+;; first place.
+;;
+;; This package can activate the address munging very easily for
+;; selected newsgroups and make those email harverters gathering job
+;; more difficult. Humans that want to contact the person can still
+;; decode the address.
+;;
+;; To activate address munging for newsgroups matching regexp, set
+;; variable `tinymail-:from-anti-ube-regexp'. Your `user-mail-address'
+;; is be hashed and different address is generated for each post.
+;;
+;; me@here.com --> me.ads-hang@here.com, me.hate-ube@here.com ...
+;;
+;; Feature: Sendmail Plus Addressing (introduction)
+;;
+;; [excerpted from http://pm-doc.sourceforge.net/ for background]
+;; Recall from [rfc1036] that the preferred Usenet email address
+;; formats are following
+;;
+;; From: login@example.com
+;; From: login@example.com (First Surname)
+;; From: First Surname <login@example.com>
+;;
+;; A new sendmail supports plus addressing, where the address is
+;; treated like <login@example.com> and the extra "plus-info" is
+;; available eg to procmail or other LDAs. See Eli'd faq for more
+;; information at http://www.faqs.org/faqs/mail/addressing/ A typical
+;; sendmail enabled plus address looks like:
+;;
+;; login+plus-info@domain
+;;
+;; We can simulate plus addressing with pure RFC compliant address.
+;; We exploit RFC comment syntax, where comment is any text inside
+;; parentheses. According to Eli's paper, comments should be
+;; preserved during transit. They may not appear in the exact place
+;; where originally put, but that shouldn't be a problem. So, we
+;; send out message with following `From' or `Reply-To' line:
+;;
+;; first.surname@domain (First Surname+mail.default)
+;;
+;; Now, when someone replies to you, the MUA usually copies that
+;; address as is and you can read in the receiving end the PLUS
+;; information and drop the mail to appropriate folder: `mail.default'.
+;;
+;; [About subscribing to mailing lists with RFC comment-plus addess]
+;;
+;; It's very unfortunate that when you subscribe to lists, the comment
+;; is not preserved when you're added to the list database. Only the
+;; address part is preserved. I even put the comment inside angles to
+;; fool program to pick up everything between angles.
+;;
+;; first.surname(+list.linux)@example.com
+;;
+;; But I had no luck. They have too good RFC parsers, which throw away
+;; and clean comments like this. E.g. procmail based mailing lists, the
+;; famous `Smartlist', use `formail' to derive the return address and
+;; `formail' does not preserve comments. The above gets truncated to
+;;
+;; first.surname@example.com
+;;
+;; You can put anything inside RFC comment and do whatever you want
+;; with these plus addresses. _NOTE_: there are no guarantees that
+;; the RFC comment is preserved every time. Well, the standard RFC822
+;; says is must be passed untouched, but I'd say it is 90% of the
+;; cases where mail is delivered from one server to another, it is
+;; kept.
+;;
+;; Example: if you discuss in usenet groups, you could use address
+;;
+;; first.surname@example.com (First Surname+usenet.default)
+;; first.surname@example.com (First Surname+usenet.games)
+;; first.surname@example.com (First Surname+usenet.emacs)
+;; first.surname@example.com (First Surname+usenet.linux)
+;;
+;; Feature: Sendmail Plus Addressing in this package
+;;
+;; The idea of setting PLUS information is that you "tag" you messages
+;; and when messages are returned to you, you can file the messages to
+;; proper folders. Unix users can set up a procmail receipe to trap
+;; the plus information. Alternatively Emacs Gnus can be configured
+;; to use fancy splitting methods for IMAP, POP and regular
+;; mailbox.
+;;
+;; The sender field generation is disabled in `message-mode-hook' by
+;; function `tinymail-message-disable-sender', so that *From* field
+;; gets a trusted status. If you still want to generate the *Sender*
+;; field, then add this after package has been loaded.
+;;
+;; (remove-hook 'tinymail-message-disable-sender 'message-mode-hook)
+;;
+;; Non-Newsgroup posting
+;;
+;; Use your custom function to decide what address to use and what
+;; plus information to use by setting function to
+;; `tinymail-:from-info-function'. Non-Newsroup posting means, that
+;; you're not inside a Gnus Newsgroup from where you initiate
+;; a "post". A typical invocation to non-Newsroup posting is `C-x' `m'.
+;;
+;; Newsgroup posting
+;;
+;; You might want to set `tinymail-:from-info-function' return
+;; different email address for Usenet newsgroup posts. Set up an free
+;; email account somewhere and use only that for Usenet discussions.
+;; That way you can reserve your normal address to your private email
+;; communication.
+;;
+;; The settings you need to enable the address generation is simple.
+;; Table `tinymail-:from-table-prefix' sets the left part of
+;; the plus address component and `tinymail-:from-table-postfix' can
+;; set the right part after period.
+;;
+;; tinymail-:from-table-prefix + tinymail-:from-table-postfix
+;;
+;; This makes the the *+left.right* information which is added after
+;; your `user-full-name' part. If `tinymail-:from-table-prefix'
+;; returns nothing, the `tinymail-:from-table-postfix' is used as is.
+;; Here is example setup. Pay attention to the "work.misc" which is
+;; the return value for all addresses matching "my-work-site".
+;;
+;; (setq tinymail-:from-table-prefix
+;; '(("emacs\\|perl" . "mail")
+;; ("." . "usenet"))
+;;
+;; (setq tinymail-:from-table-postfix
+;; '(("games" . "games")
+;; ("emacs\\|[a-z]+\\.el\\>\\|(def\\|(setq" . "emacs")
+;; ("perl\\|\\.pl\\>" . "perl")
+;; ("my-work-site\\>" . "work.misc"))
+;;
+;; Gnus support
+;;
+;; If you use Gnus news reader, then you get some bonus. For Gnus
+;; users the default plus information is generated based on the group
+;; you're posting from. In general the plus address generated is
+;; directly the group's name. That's quite convenient. To make this
+;; this effective for mailing lists too, do this:
+;;
+;; o Rename all your mailing lists to start with *list.NAME*
+;; like list.ding, list.linux, list.procmail, list.dance ...
+;; o Edit each mailing lists group parameter with `G' `p'
+;; from *Group* buffer and add mailing list destination address:
+;;
+;; ((to-list . "Mailing List Name <address@example.com>"))
+;;
+;; Now when the `to-list' property is set, The Gnus group is labeled
+;; as "mailing list". If the `to-list' property is not set, the group
+;; is not considered as mailing list.
+;;
+;; Feature: Toggle plugged state
+;;
+;; With dial up connections, it is customary to swap between on-line
+;; and off-line mode. If you use Gnus as your mail reader, TinyMail
+;; can show the plugged status in the `mode-line'. If you see "tm!"
+;; you're plugged (on-line). The key to change the Gnus plugged status
+;; is bound to `C-c' `t' `j' in TinyMail controlled mail buffer.
+;;
+;; Configuration: Highlighting color settings
+;;
+;; The default highlighting is only provided to your convenience. If
+;; you use `font-lock' the internal highlighting is *automatically*
+;; suppressed.
+;;
+;; Configuration: Default citation header
+;;
+;; This feature is mainly designed for Gnus `message-mode'. Use it
+;; like this:
+;;
+;; (setq mail-yank-prefix "| ") ;; less noisy, than "> "
+;; (setq mail-user-agent 'message-user-agent)
+;;
+;; There is function `tinymail-citation-generate' which generates
+;; citation that uses international ISO 8601 date format, user name
+;; and the Gnus mailing group from where the reply started:
+;;
+;; * Tue YYYY-MM-DD John Doe <johnd@example.com> mail.emacs
+;; | ...said something
+;;
+;; To activate this citation reference function with your Mail User
+;; Agent (Gnus, RMAIL ..), call:
+;;
+;; (add-hook 'tinymail-:load-hook 'tinymail-install-citation)
+;;
+;; For supercite, install this function to the handlers and select
+;; it with index 0:
+;;
+;; (require 'sc)
+;; (push (list tinymail-citation-generate) sc-rewrite-header-list)
+;; (setq sc-preferred-header-style 0)
+;;
+;; Code Note: shared TAB key
+;;
+;; When TinyMail is active in the mail buffer, it takes ower the tab
+;; key. The default function `tinymail-complete-guess-in-headers' is
+;; electric, meaning that it behaves like ordinary tab if the point is
+;; not in completing headers. E.g. If the point is in `Cc' or in `To',
+;; then the completion feature is activated. If you have plans to use
+;; the tab key to do some other special things in other headers,
+;; you're free to to do so. All you have to do is to add your own
+;; custom function into
+;;
+;; `tinymail-:complete-key-hook'
+;;
+;; The custom function must return `t' if it did something. See also
+;; `tinymail-:table-header-complete' where it is possible to define
+;; custom headers and the completions easily.
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+;;{{{ setup: require
+
+;;; ......................................................... &require ...
+
+(require 'tinylibm)
+(require 'tinylibmail)
+
+;; We must have these minor modes loaded beforehand. That's
+;; because we can't override that TAB key unless we "became" minor
+;; mode after these packages.
+
+(require 'tinytab nil 'noerr)
+(require 'tinyindent nil 'noerr)
+
+(autoload 'bbdb-hashtable "bbdb" "" nil 'macro)
+(autoload 'bbdb-gethash "bbdb")
+(autoload 'bbdb-record-net "bbdb")
+(autoload 'bbdb-record-name "bbdb")
+(autoload 'bbdb-record-notes "bbdb")
+
+(autoload 'mail-position-on-field "sendmail")
+(autoload 'mml-secure-message-sign-pgpmime "mml")
+(autoload 'mml-secure-message-encrypt-pgpmime "mml")
+
+(eval-and-compile
+
+ (ti::package-use-dynamic-compilation)
+ (ti::package-require-mail-abbrevs)
+
+ ;; forward declarations for byte compiler
+ (defvar message-citation-line-function)
+ (defvar message-reply-headers)
+ (defvar bbdb-file)
+ (defvar tinytab-:tab-insert-hook)
+ (defvar tinytab-mode)
+
+ (unless (locate-library "bbdb")
+ (message "\
+ ** tinymail.el: No bbdb.el along `load-path'. http://bbdb.sourceforge.net/
+ You can still use the package if you do not byte compile it.
+ Package will adapt to missing BBDB features."))
+
+ (autoload 'message-tab "message" "" t)
+ (autoload 'message-narrow-to-headers "message")
+
+ (let ((loc (locate-library "nnheader")))
+ (unless loc
+ (message "\
+ ** tinymail.el: You have too old Gnus, visit http://www.gnus.org/
+ Old Gnus version found at %s" loc)))
+
+ (autoload 'mail-header-from "nnheader" "" nil 'macro)
+ (autoload 'mail-header-date "nnheader" "" nil 'macro))
+
+(eval-when-compile
+ ;; (require 'advice)
+ (ti::package-use-dynamic-compilation))
+
+(ti::package-defgroup-tiny TinyMail tinymail-: mail
+ "Some mail additions: dynamic Fcc, Cc
+ Overview of features
+
+ o Some handy additions to mail sending interface.
+ o Adds automatically Cc field when you type the To: address.
+ o Changes Fcc dynamically according to header content.
+ o Very easy TAB completion: two modes, alias and definition string.
+ or password file entry completion.
+ o if Fcc folder has .gz or .Z name it automatically triggers
+ loading jka-compr.")
+
+;; Without fully qualified domain name, smtpmail.el
+;; can't send messages. Make sure the email is in format user@domain.com
+
+(when (or (not (stringp user-mail-address))
+ (not (string-match ".+@.*\\..+"
+ (or user-mail-address
+ ""))))
+ (message
+ (concat "Tinymail: [ERROR] Please set `user-mail-address' "
+ "to \"user@somewhere.net\". Was %s")
+ (prin1-to-string user-mail-address)))
+
+;;}}}
+;;{{{ setup: hooks
+
+;;; ......................................................... &v-hooks ...
+;;; hooks and functions
+
+(defcustom tinymail-:load-hook nil
+ "*Hook run when package has been loaded."
+ :type 'hook
+ :group 'TinyMail)
+
+;; Add more dynamic change functions to this hook
+
+(defcustom tinymail-:process-hook nil
+ "*Hook run when `tinymail-:awake-time' is up. This hook is always run."
+ :type 'hook
+ :group 'TinyMail)
+
+(defcustom tinymail-:feature-hook '(tinymail-mail-send-to-list)
+ "*Hook run when idle time is up. Optional features to run.
+Eg If you're using Gnus for mailing lists. Please define `to-list'
+Group parameter for each group."
+ :type 'hook
+ :group 'TinyMail)
+
+(defcustom tinymail-:complete-key-hook
+ '(tinymail-complete-everything
+ ;; tinymail-complete-bbdb-fuzzy ;honor BBDB first
+
+ ;; tinymail-complete-bbdb <NO GOOD> because displays
+ ;; BBDB record.
+ tinymail-complete-simple
+ tinymail-complete-guess-in-headers ; then passwd
+
+ ;; tinymail-complete-bbdb <NO GOOD> because displays
+ ;; BBDB record. fuzzy is better
+
+ ;; tinymail-complete-bbdb-fuzzy
+
+ tinymail-complete-headers-nothing-found
+
+ ;; tinymail-complete-guest-packages
+ ;; tinymail-complete-abbrevs
+ ;; tinymail-complete-headers-move-to-next-field
+
+ tinymail-complete-everything)
+ "*Run each function with argument nil until success.
+This function contains default try funcions
+to completes email addresses in the Cc and To headers. It is strongly
+suggested that you don't add new functions to this hook with `add-hook',
+but that that you set the value manually. The order of the tried functions
+is important.
+
+Default value for this hook is as follows. These are preset at startup
+by calling function `tinymail-install-hooks' at package load time.
+
+ '(tinymail-complete-everything
+ tinymail-complete-simple
+ tinymail-complete-headers-nothing-found
+ tinymail-complete-abbrevs
+ ;; put your own completion functions here. Befor call to guest packages
+ tinymail-complete-guest-packages)
+
+Function call arguments:
+
+ info This variable holds the string part at current point
+ '(BEG END STRING)
+
+Function should return:
+
+ nil Did nothing; pass control to next function in hook.
+ non-nil Handled the Tab at point"
+ :type 'hook
+ :group 'TinyMail)
+
+(defcustom tinymail-:complete-body-hook
+ '(tinymail-complete-bbdb-fuzzy-at-point
+ tinymail-complete-guess)
+ "*Run each function with argument nil until completion success.
+This is similar variable like `tinymail-:complete-key-hook' but run in the
+message body. E.g. When user want to add a BBDB net entry to the current point."
+ :type 'hook
+ :group 'TinyMail)
+
+(defcustom tinymail-:send-mail-hook-list
+ '(mail-send-hook ;; VM runs this too
+ message-send-hook
+ mh-before-send-letter-hook)
+ "*List of mail sending hooks."
+ :type '(repeat (symbol :tag "Hook"))
+ :group 'TinyMail)
+
+(defcustom tinymail-:citation-message-id-function 'tinymail-message-id
+ "Return message-id line that is added above the citation header."
+ :type 'function
+ :group 'TinyMail)
+
+;;}}}
+;;{{{ setup: config public
+
+;;; ........................................................ &v-public ...
+;;; User configurable
+
+(defcustom tinymail-:protect-email-addresses t
+ "*If non-nil, then scrable all words that look like an email address.
+E.g. this@example.com is made something like this <AT> example.com.
+
+Note: If you are sending other content with mail, like patches, make sure
+you protect those with base64 encoding to prevent changing the content."
+ :type '(repeat (symbol :tag "Keymap variable"))
+ :group 'TinyMail)
+
+(defcustom tinymail-:table-keymap-list
+ '(mail-mode-map
+ message-mode-map
+ mh-letter-mode-map)
+ "*List of keymaps where to install default bindings."
+ :type '(repeat (symbol :tag "Keymap variable"))
+ :group 'TinyMail)
+
+(defcustom tinymail-:enter-mail-hook-list
+ '( ;; gnus-message-setup-hook
+ message-header-setup-hook
+
+ ;; mail-send-hook
+ mail-setup-hook
+
+ mh-letter-mode-hook ;; MH
+ vm-mail-mode-hook) ;; VM
+ "*List of hooks where to install `tinymail-mail'."
+ :type '(repeat (symbol :tag "Hook"))
+ :group 'TinyMail)
+
+(defcustom tinymail-:dead-mail-file
+ (ti::package-config-file-prefix "tinymail-dead-mail")
+ "*Append all mail buffers to this fAile on Emacs exit."
+ :type 'file
+ :group 'TinyMail)
+
+(defcustom tinymail-:awake-time
+ (if (ti::xemacs-p)
+ 10 ;XEmacs needs lower value
+ 15)
+ "*Sleep time of `post-command-hook' before activation."
+ :type '(integer :tag "Movement Cycles")
+ :group 'TinyMail)
+
+(defcustom tinymail-:confirm-mailrc-regexp "."
+ "*If matches, confirm picked completions from .mailrc file.
+When the completion is found from the .mailrc it is matched against
+this regexp. If `tinymail-:confirm-mailrc-regexp' matches, then
+you're asked if you accept the match. If you discard it the other
+completion functions get a chance to run."
+ :type 'regexp
+ :group 'TinyMail)
+
+(defcustom tinymail-:cc-kill-regexp (and (stringp user-mail-address)
+ (regexp-quote user-mail-address))
+ "*Kill all CC field elements matching regexp.
+The usual value is you possibel Email addresses that you
+wish to remove from CC fields to avoid duplicate copies when
+you already use Means of Fcc, Gcc etc.
+
+At any time you can add two spaces in front of CC field to
+disable this \"kill\" feature. This is desirable if you WANT to
+add a CC to your other email addresses. An example:
+
+ (setq tinymail-:cc-kill-regexp \"me@here.at\")
+
+ To: some@example.com
+ CC: me@here.at << will be removed
+ CC: me@here.at << NOT removed, because field has two spaces."
+ :type 'regexp
+ :group 'TinyMail)
+
+(defcustom tinymail-:password-mode t
+ "*Should we try to complete passwd entries?.
+if normal .mailrc completion fails then non-nil enables completion.
+
+If you're running slow machine and huge amount of users, and
+you can't afford to use `tinymail-:password-file' due to disk quota
+reasons, set this variable to nil and no passwords entries are
+completed. It's faster to defne .mailrc aliases that you need.
+
+This variable can be toggled with \\[tinymail-complete-password-mode]."
+ :type 'boolen
+ :group 'TinyMail)
+
+(defcustom tinymail-:password-file
+ (ti::package-config-file-prefix "tinypath-passwd.el")
+ "*Preparsed password file completions.
+If this file does not exist it will be created when passwd
+completion is needed. You _can_ keep this file in compressed format by
+adding extension .gz to filename.
+
+If this file is nil, then no file is read or written to."
+ :type 'file
+ :group 'TinyMail)
+
+(defcustom tinymail-:password-cat-cmd
+ (cond
+ ((ti::os-check-hpux-p)
+ "ypcat passwd")
+ ((ti::os-check-sunos-p)
+ "cat /etc/passwd")
+ ((string-match "irix" (emacs-version))
+ "ypcat passwd")
+ ((ti::os-check-linux-like-p)
+ "cat /etc/passwd")
+ ((ti::win32-p)
+ nil) ;; No password file here
+ (t
+ (error
+ (substitute-command-keys
+ (concat
+ "TinyMail: No tinymail-:password-cat-cmd. Please share your know-how"
+ " with \\[tinymail-submit-bug-report]")))))
+ "*Shell command that print the contents of standard UNIX passwd file.
+If your systems shell command isn't seen here, contact maintainer
+immedately and report right shell command, so that it is set automatically
+right."
+ :type '(string :tag "Command")
+ :group 'TinyMail)
+
+(defcustom tinymail-:complete-bbdb-fuzzy-method
+ '( ;; Can't funcall macros, so wrap them inside lambda's
+ (lambda (record) (bbdb-record-net record))
+ (lambda (record) (bbdb-record-aka record))
+ (lambda (record) (bbdb-record-name record))
+ (lambda (record) (bbdb-record-raw-notes record)))
+ "*Which fields to check against the completion string.
+The value must be list of functions to return a string or list of strings
+to match when passed and BBDB RECORD.
+
+The value must be callable by `funcall', e.g. macros are not callable."
+ :type '(list sexp)
+ :group 'TinyMail)
+
+(defcustom tinymail-:complete-bbdb-case-fold-search case-fold-search
+ "*Should completing against BBDB record be case sensitive.")
+
+(defcustom tinymail-:complete-mode 'string
+ "*Control how completion is done.
+
+'alias
+
+ Means that we should complete alias names and
+ that the alias expansion is shown in echo-area.
+
+'string
+
+ Means that _string_, which may include any character including white
+ spaces, is searched from the full expansion list of aliases. This way
+ you can remember anything from the person itself and it will be
+ searched. Found expansion is inserted in place of typed
+ string.
+
+ Your ~/.mailrc can have entries like this:
+
+ alias mark \"Mark Eggert -- Project engineer <meg@twenix.com>\"
+ alias mike \"Michael Lowell -- SkyTrax consulting <ml@sky.com>\"
+
+ The right hand strings are searched with picked _string_ and
+ if there is only one match for the string, the expansion (rh element)
+ is inserted into buffer."
+ :type '(choice
+ (const alias)
+ (const expansion))
+ :group 'TinyMail)
+
+(defconst tinymail-:idle-timer-seconds 1
+ "*Seconds after Emacs is idle to check the mail contant in buffer.")
+
+;;; ........................................................ &v-tables ...
+
+(defcustom tinymail-:table-fcc nil
+ "*Replace Fcc content with FCC-FIELD-STRING when headers match REGEXP.
+If there is _two_ spaces in the Fcc field, the Fcc header is not touched.
+Format is '((REGEXP FCC-FIELD-STRING) ..)"
+ :type '(repeat
+ (list
+ (string :tag "To Regexp")
+ (sexp :tag "Fcc field string")))
+ :group 'TinyMail)
+
+(defcustom tinymail-:table-gcc nil
+ "*Replace Gcc content with GCC-FIELD-STRING when headers match REGEXP.
+If there is _two_ spaces in the Gcc field, the Gcc header is not touched.
+Format is '((REGEXP GCC-FIELD-STRING) ..)"
+ :type '(repeat
+ (list
+ (string :tag "To Regexp")
+ (sexp :tag "Gcc field string")))
+ :group 'TinyMail)
+
+;; (all-completions "nnml" gnus-active-hashtb 'gnus-valid-move-group-p)
+
+(defcustom tinymail-:table-header-complete nil
+ "*List of field names and their copletion values.
+If after HEADER-FIELD the value is not a string, the rest value is evaluated.
+HEADER-FIELD must not contain colon.
+
+Format:
+ '((HEADER-FIELD (COMPLETION-STRING COMPLETION-STRING ..)
+ (HEADER-FIELD EVAL-FORM)
+ ..)
+
+Notes
+
+ The EVAL-FORM must set `tinymail-:complete-key-return-value' to non-nil
+ if it does not return a list of completions, but otherwise handles
+ the completions itself. This stops running other completion functions.
+
+Example:
+
+If you want to to complete header `Class' with values Urgent, Note, Memo,
+FYI, Announce.
+
+In addition completing the Gnus Gcc and Newsgroup header is easy. Some notes
+about the EVAL-FORM used: the form is called in function
+`tinymail-complete-simple', so all variables used there are visible in
+EVAL-FORM. The `string' is the read word from current point, which you
+should use when searching completions.
+
+ (setq tinymail-:table-header-complete
+ '((\"Class\"
+ (\"Urgent\" \"Note\" \"Memo\" \"FYI\" \"Announce\"))
+
+ (\"Gcc\"
+ (when (and (featurep 'gnus) (stringp string))
+ (all-completions
+ string
+ gnus-active-hashtb 'gnus-valid-move-group-p)))
+
+ (\"Newsgroups\"
+ (when (and (featurep 'gnus) (stringp string))
+ (all-completions
+ string
+ gnus-active-hashtb
+ (gnus-read-active-file-p))))))"
+ :type '(repeat
+ (list
+ (string :tag "Field")
+ (repeat (string :tag "value"))))
+ :group 'TinyMail)
+
+;;}}}
+;;{{{ setup: Sendmail like PLUS Address configuration
+
+(defcustom tinymail-:from-field-plus-separator "+"
+ "The string to separate `user-full-name' from plus information.
+Note: some MTAs may not accept '+' character. An alternative
+could be '--'.
+
+ login+plus-information@example.com
+
+ login@example.com (First Surname+plus-information)"
+ :type 'string
+ :group 'TinyMail)
+
+(defcustom tinymail-:from-field-enable-flag t
+ "*Non-nil means that From: field generation is allowd.
+The function to generate the from field is `tinymail-from-set-field'."
+ :type 'boolean
+ :group 'TinyMail)
+
+(defcustom tinymail-:from-anti-ube-regexp "games\\|ibm"
+ "*If Regexp match Newsgroups header, generate anti-ube email From address.
+Generated address is based un `user-mail-address' with hashed words in
+the address. The generated email is made with `ti::mail-email-make-anti-spam-address'.
+Returned value is different each time.
+
+ me@here.com --> me.ads-hang@here.com, me.hate-ube@here.com ...
+
+References:
+
+ For complete email address control, you want to use
+ `tinymail-:from-info-function'."
+ :type 'regexp
+ :group 'TinyMail)
+
+(defcustom tinymail-:from-info-function nil
+ "*Functon to return the suitable `user-mail-address' for message.
+
+Return value:
+
+ '(email-address [plus-string] [Filername Surname])
+
+ If if function wants to change only the email-address for the message,
+ the return value is in format:
+
+ '(\"foo@bar.com\")
+
+ And if the Plus info and Another user-id FirstName and Surname is
+ wanted, then return value is:
+
+ '(\"foo@bar.com\" \"mail.priv\" \"Mr. Foo\")
+
+ If the return value is nil, the `user-mail-address' is used.
+
+Notes
+
+ Value returned from this function overrides
+
+ `tinymail-:from-table-prefix'
+ `tinymail-:from-table-postfix'
+ `tinymail-:from-anti-ube-regexp'
+
+ If you want to protect yourself from UBE (Unsolicited bulk Email), you
+ can use function `ti::mail-email-make-anti-spam-address' which uses hash table
+ to construct human, but not easily machine decodable address.
+
+Example one:
+
+ Suppose you have some public domain email address, like hotmail
+ and you want to use that in your Usenet postings instead of your normal
+ email address. Here is code to do that:
+
+ (setq tinymail-:from-info-function 'my-tinymail-address)
+
+ (defun my-tinymail-address ()
+ (when (mail-fetch-field \"Newsgroups\")
+ (list \"my-virtual@hotmail.com\")))
+
+Example two:
+
+ Suippose you want to make email harverter's work harder and use non-spam
+ address in the high traffic Usenet groups. Here the ibm and games groups
+ get \"protected\" address, which human can decode if they wish to contact
+ you personally. Other usenet groups use your normal virtual aaddress.
+ All other mail use your default `user-mail-address'.
+
+ (setq tinymail-:from-info-function 'my-tinymail-address)
+
+ (defun my-tinymail-address ()
+ let ((group (or (mail-fetch-field \"Newsgroups\") \"\" ))
+ (addr \"my-virtual@hotmail.com\"))
+ (cond
+ ((string-match \"games\\\\|ibm\" group)
+ (list (ti::mail-email-make-anti-spam-address addr))) ;; grumbled address
+ ((string= \"\" group)
+ (list addr)))) ;; use normal virtual address
+
+ This differ's from `tinymail-:from-anti-ube-regexp' so that you have full
+ control what address is used to generate the anti-ube address."
+ :type 'string
+ :group 'TinyMail)
+
+(defcustom tinymail-:from-table-prefix nil
+ "*If `Newsgroup' header, match regexp, return plus address prefix.
+
+Format:
+
+ '((REGEXP . STRING)
+ (REGEXP . STRING)
+ ..)
+
+Example
+
+ '((\"emacs\\\\|perl\" . \"mail\")
+ (\".\" \"usenet\"))"
+ :type '(repeat (cons regexp string))
+ :group 'TinyMail)
+
+(defcustom tinymail-:from-table-postfix nil
+ "*Rules for constructing COMMENT PLUS part of the From address.
+
+Match the Newsgroup header:
+
+ If there is `Newsgroup' header, match regexp AND combine
+ result of `tinymail-:from-table-prefix' with `tinymail-:from-table-postfix'
+ match
+
+In normal mail
+
+ o Go to the beginning of body, after headers and search body
+ for regexp and return STRING from `tinymail-:from-table-postfix'.
+ `tinymail-:from-table-prefix' IS NOT USED.
+ o If not found, search Gcc Gnus header and use it
+ o Otherwise use no postfix
+
+Format:
+
+ The left hand element can also be FUNCTION, which is called. It must
+ return STRING like in the cdr element.
+
+ '((REGEXP . STRING)
+ (REGEXP . STRING)
+ (FUNCTION)
+ ..)
+
+Example:
+
+ From: foo@bar.com (Foo Bar+mail.emacs)
+ To: somebody@else.com
+ Subject: Re: Emacs keybindings
+ Gcc: nnml:mail.reply
+ --text follows this line--
+
+ ...See function global-set-key and frieds in your Emacs.
+
+Suppose we have above example mail in the buffer. The From line contains
+string +mail.emacs added inside the comment (), because word 'emacs' were
+found from the body of text according to the following varible contents:
+
+ (setq tinymail-:from-table-postfix
+ '(
+ ;; Restrictive regexp first. These are searched from body
+ ;; in normal mail
+
+ (\"[a-z]+\\\\.el\\\\>\\\\|(def\\\\|setq\" . \"mail.emacs\")
+ (\"\\.pl\\\\>\" . \"mail.perl\")
+
+ (\"games\" . \"mail.games\")
+ (\"emacs\" . \"mail.emacs\")
+ (\"perl\" . \"mail.perl\")))"
+ :type '(repeat (cons
+ (choice regexp function)
+ string))
+ :group 'TinyMail)
+
+;;}}}
+;;{{{ setup: Reportmail
+
+(defcustom tinymail-:report-window-system (ti::compat-window-system)
+ "*If non-nil; then never try to use X dragbar to announce mail.
+Display the mail message in echo area instead."
+ :type 'boolean
+ :group 'TinyMail)
+
+(defconst tinymail-:report-asychronous-timeout 3
+ "If non-nil, SECONDS to wait for `tinymail-:report-mail-notify-program' finish.
+If you are in a system where mailbox is over NFS and there are lot of
+periodic NFS mount or access problems (automount failure, hardware
+problem or whatever); then set this variable to number of seconds to timeout
+`tinymail-:report-mail-notify-program'.
+
+If you don't set the timeout in NFS problematic environment, then the
+call to repor tmail is blocked until answer has been received. This may freeze
+your whole Emacs for several minutes.")
+
+(defcustom tinymail-:display-time t
+ "*If non-nil, display the current time, load, and mail flag."
+ :type 'boolean
+ :group 'TinyMail)
+
+(defvar tinymail-:report-spool-buffer "*tinymail-mail-spool*"
+ "*Buffer where to write mail spool information.
+If this value is initially set to nil, no mail reporting is done.
+See `tinymail-:report-spool-buffer-control'.")
+
+(defcustom tinymail-:report-spool-buffer-control 'keep
+ "*How to treat the `tinymail-:report-spool-buffer'.
+Accepted values are:
+
+ 'kill Query mail spool and kill the buffer
+ 'keep Query mail spool but do not kill after query
+ 'raise If there is mail and mail count has changed since the last
+ query; show the buffer in current working frame."
+ :type '(choice
+ (const kill)
+ (const keep)
+ (const raise))
+
+ :group 'TinyMail)
+
+(eval-and-compile
+ (defun tinymail-default-report-mail-command ()
+ "Construct default report mail shell call."
+ (let ((mail (getenv "MAIL"))
+ cmd)
+ (setq
+ cmd
+ (or (and (file-exists-p "~/.procmailrc") ;; [1]
+ (message "\
+TinyMail: [WARNING] autosetup aborted. $HOME/.procmailrc found. Please set
+manually `tinymail-:report-mail-notify-program' to cover incoming mail
+spool folders.")
+ 'procmail-error)
+ (executable-find "from") ;; [2a]
+ (executable-find "mailfrom") ;; [2b]
+ (and mail ;; [3]
+ (or (file-exists-p mail)
+ ;; In pristine system, user may not have received
+ ;; mail yet, but if the leading directory is there,
+ ;; then it's good enough
+ ;;
+ ;; /var/spool/mail/LOGIN => /var/spool/mail/
+ ;;
+ (file-directory-p
+ (file-name-directory mail))
+ (message "TinyMail: [ERROR] Environment variable MAIL is invalid: %s "
+ mail))
+ (executable-find "grep")
+ (format "%s \"^From \" %s"
+ (executable-find "grep")
+ mail))
+ ;; Okay, we give up. This is the fall-through case
+ (let ((function (if (ti::win32-p)
+ 'message
+ 'error)))
+ (funcall function "\ ;; [4]
+TinyMail: [WARNING] Can't guess `tinymail-:report-mail-notify-program'. Set manually.")
+ nil)))
+ (when cmd
+ (cond
+ ((and (ti::win32-p)
+ (stringp cmd)
+ (string-match "\\<bin\\>" (or shell-file-name "")))
+ ;; This system is using Cygwin bash
+ (ti::file-name-forward-slashes-cygwin cmd))
+ ((and (stringp cmd)
+ (ti::emacs-type-unix-like-p)) ;Unix, return as is
+ cmd)
+ ((stringp cmd)
+ (ti::file-name-backward-slashes cmd)))))))
+
+(defcustom tinymail-:report-mail-notify-program
+ (let ((cmd (tinymail-default-report-mail-command)))
+ (when (stringp cmd)
+ cmd))
+ "*A shell call to return entries in the mail spool(s).
+Set to nil if tou have lo local mail folders to scan.
+
+Warning:
+
+ If you're mixing Cygwin32 and DOS shell buffers in your Emacs,
+ you MUST SET THIS variable and not rely on the automatic detection
+ of Cygwin, which is determined by examining `shell-file-name'.
+
+ The call must reflect you `shell-file-name', where paths must be
+ Unix or Win32 styled accordingly.
+
+Program must return entries in following format, which is the Berkeley mailbox
+format or commonly known as Unix MBOX format:
+
+ From login@site.xx Mon Feb 26 14:41:50 EET 1996
+
+See if you can use from(1), mailfrom(1) or equivalent: \"man -k from\".
+Make sure the binary is on your path, possibly located at /usr/ucb/ or
+/usr/bin/. If you use absolute path, this program executes faster.
+
+The `tinymail-:report-mail-notify-program' value can be:
+
+STRING A shell program is called to return the lines
+SYMBOL an Emacs Lisp function is called to return the lines. Lisp function
+ must return list of string or nil. There is default function
+ `tinymail-report-mail-info-spool' which searches all messages in
+ `tinymail-:report-mail-spool-dir'"
+ :type '(choice
+ (string :tag "Shell program")
+ (function :tag "Lisp function"))
+ :group 'TinyMail)
+
+(defcustom tinymail-:report-mail-kill-line-regexp
+ (concat
+ "Command.*finished"
+ "\\|no mail"
+ "\\|can't open")
+ "Kill lines matching this regexp from report mail buffer.
+When `tinymail-:report-mail-notify-program' has finished printing the addresses,
+it may print some garbage into the buffer like: 'command finished'
+'No mail'. With this regexp you can kill these unwanted lines, otherwise
+the line count would have been equal to the pending mail count.
+Below the actual count is (1) and the message should display the
+last message, not the 'Command finished'.
+
+ From login@site2.xx Mon Feb 26 14:41:50 EET 1996
+ From login@site1.xx Mon Feb 26 14:41:50 EET 1996
+ Command finished"
+ :type 'string
+ :group 'TinyMail)
+
+(defcustom tinymail-:report-keep-intact-list
+ '("VM")
+ "*A list of frame names not to change."
+ :type '(repeat string)
+ :group 'TinyMail)
+
+(defcustom tinymail-:report-no-mail-string
+ (if tinymail-:report-window-system
+ " ----"
+ ;; This is better for echo area in non-window emacs
+ "-- No Mail --")
+ "*String to be printed to dragbar when no mail is pending.
+If this string is nil, then nothing is displayed in
+the echo area if Emacs is running in non-windowed envinronment."
+ :type 'string
+ :group 'TinyMail)
+
+(defcustom tinymail-:report-format-string
+ '(concat
+ tinymail-:report-old-frame-string
+ " "
+ ;; Use (display-time) in you ~/.Emacs to define display-time-string
+ (if (and (boundp 'display-time-string) ;may not exist ?
+ (stringp display-time-string)) ;XEmacs has vector
+ display-time-string
+ "")
+ tinymail-:report-mail-info-string)
+ "*Customize your display string layout here."
+ :type 'sexp
+ :group 'TinyMail)
+
+(defcustom tinymail-:report-mail-info-shorten-regexp nil
+ "*Regexp to match local site address.
+When you're in local host and receive mail internally, you
+propably want to display user's account name only instead of full
+email name. This is REGEXP that is tried upon arrived email address,
+if it matches, the email address is truncated to account name."
+ :type '(string :tag "Regexp")
+ :group 'TinyMail)
+
+;;}}}
+;;{{{ Setup: private
+
+(defvar tinymail-:report-old-frame-string nil
+ "Private.")
+
+(defvar tinymail-:report-old-mail-info-string nil
+ "Private.")
+
+(defvar tinymail-:report-timer-object nil
+ "Private. When package is activated this hold the timer object ativated.")
+
+(defvar tinymail-:report-mail-info-string nil
+ "Private. Mail message information string.
+This variable has one leading and trailingspace around the message.")
+
+(defvar tinymail-:timer-elt nil
+ "Timer element is stored here.")
+
+(defvar tinymail-:y-or-n-p nil
+ "Andwered key from `tinymail-y-or-n-p'")
+
+(defvar tinymail-:tm-mode-name ""
+ "TM MIME message split indicator.")
+
+(defvar tinymail-:message-type nil
+ "Private flag. The initial message type in mail buffer.
+When tinymail is first turned on, it checks if the message
+is composed with \\[mail] or if you have replied to someone
+else's message with 'r' from some mail mode. This initial
+message type determines how \\[tinymail-mail] call behaves in the buffer.")
+
+(put 'tinymail-:message-type 'permanen-local t)
+(make-variable-buffer-local 'tinymail-:message-type)
+(setq-default tinymail-:message-type nil)
+
+(defvar tinymail-:last-to-field nil
+ "Private. Last to: field value.")
+(make-variable-buffer-local 'tinymail-:last-to-field)
+
+(defvar tinymail-:mail-aliases-alist nil
+ "Private. Cached aliases.
+Run function `tinymail-update-mail-abbrevs' if you change your
+~/.mailrc so that this variable gets updated.
+
+Format: ((\"ALIAS\" . \"EXPANDED\") ..)")
+
+(defvar tinymail-:temp-buffer " *tinymail-tmp*"
+ "Temporary buffer.")
+
+(defvar tinymail-:password-alist nil
+ "Private. Password file in assoc form: '((LOGNAME . PASSWD-ENTRY)).")
+
+(defvar tinymail-:password-completion-alist nil
+ "Private. Completion table of login names.")
+
+(defvar tinymail-:user-mail-address nil
+ "This is made local to mail buffer.
+Only ised if `tinymail-from-anti-ube-maybe' is in effect.")
+
+;;}}}
+;;{{{ setup: private
+
+(defvar tinymail-:complete-key-return-value nil
+ "Value set to non-nil in `tinymail-:table-header-complete' EVAL-FORM.")
+
+;;}}}
+;;{{{ setup: version
+
+;;;###autoload (autoload 'tinymail-version "tinymail" "Display commentary." t)
+
+(eval-and-compile
+ (ti::macrof-version-bug-report
+ "tinymail.el"
+ "tinymail"
+ tinymail-:version-id
+ "$Id: tinymail.el,v 2.88 2007/08/03 20:16:25 jaalto Exp $"
+ '(tinymail-:version-id
+ timer-idle-list
+ timer-list
+ itimer-list
+ write-file-hooks
+ message-mode-hook
+ message-setup-hook
+ message-header-setup-hook
+ mail-mode-hook
+ mail-setup-hook
+ mail-send-hook
+ mh-letter-mode-hook
+ tinytab-:tab-insert-hook
+ ;; This list is automatically generated by tinylisp-mode "$ v"
+ tinymail-:load-hook
+ tinymail-:process-hook
+ tinymail-:feature-hook
+ tinymail-:complete-key-hook
+ tinymail-:complete-body-hook
+ tinymail-:send-mail-hook-list
+ tinymail-:citation-message-id-function
+ tinymail-:y-or-n-p
+ tinymail-:tm-mode-name
+ tinymail-:message-type
+ tinymail-:last-to-field
+ tinymail-:mail-aliases-alist
+ tinymail-:temp-buffer
+ tinymail-:password-alist
+ tinymail-:password-completion-alist
+ tinymail-:table-keymap-list
+ tinymail-:enter-mail-hook-list
+ tinymail-:dead-mail-file
+ tinymail-:confirm-mailrc-regexp
+ tinymail-:cc-kill-regexp
+ tinymail-:password-mode
+ tinymail-:password-file
+ tinymail-:password-cat-cmd
+ tinymail-:complete-bbdb-fuzzy-method
+ tinymail-:complete-bbdb-case-fold-search
+ tinymail-:complete-mode
+ tinymail-:table-fcc
+ tinymail-:table-gcc
+ tinymail-:table-header-complete
+ tinymail-:from-field-plus-separator
+ tinymail-:from-field-enable-flag
+ tinymail-:from-anti-ube-regexp
+ tinymail-:from-info-function
+ tinymail-:from-table-prefix
+ tinymail-:from-table-postfix
+ tinymail-:report-window-system
+ tinymail-:display-time
+ tinymail-:report-spool-buffer
+ tinymail-:report-spool-buffer-control
+ tinymail-:report-mail-notify-program
+ tinymail-:report-mail-kill-line-regexp
+ tinymail-:report-keep-intact-list
+ tinymail-:report-no-mail-string
+ tinymail-:report-format-string
+ tinymail-:report-mail-info-shorten-regexp
+ tinymail-:report-old-frame-string
+ tinymail-:report-old-mail-info-string
+ tinymail-:report-timer-object
+ tinymail-:report-mail-info-string
+ tinymail-:complete-key-return-value)
+ '(tinymail-:debug-buffer)))
+
+;;;### (autoload 'tinymail-debug-toggle "tinymail" "" t)
+;;;### (autoload 'tinymail-debug-show "tinymail" "" t)
+
+(eval-and-compile (ti::macrof-debug-standard "tinymail" "-:"))
+
+;;}}}
+;;{{{ code: install
+
+;;;###autoload (autoload 'tinymail-mode "tinymail" "" t)
+;;;###autoload (autoload 'turn-on-tinymail-mode "tinymail" "" t)
+;;;###autoload (autoload 'turn-off-tinymail-mode "tinymail" "" t)
+;;;###autoload (autoload 'tinymail-commentary "tinymail" "" t)
+
+(eval-and-compile
+ (ti::macrof-minor-mode-wizard
+ "tinymail-" " tm" "\C-ct" "tm" 'TinyMail "tinymail-:" ;1-6
+
+ "Mail enchancements.
+For Documentation, run \\[tinymail-version]
+
+Defined keys:
+
+Prefix key to access the minor mode is defined in `tinymail-:mode-prefix-key'
+
+\\{tinymail-:mode-prefix-map}"
+
+ "Tinymail"
+ (progn
+ (cond
+ (tinymail-mode
+ (if buffer-read-only
+ (error "TinyMail: Buffer is read-only, cannot turn on mode")
+ (tinymail-mail)))
+ (t
+ (tinymail-mail 'disable))))
+ "Mail enchancement mode"
+ (list
+ tinymail-:mode-easymenu-name
+ ["TO field tracking on/off" tinymail-on-off-toggle t]
+ ["Complete by guessing" tinymail-complete-guess t]
+ ["Complete in body" tinymail-complete-guess-in-body t]
+ ["Complete passwords mode" tinymail-complete-password-mode t]
+ ["Abbrev expand at point" expand-abbrev t]
+ ["Abbrev rebuild (.mailrc)" tinymail-update-mail-abbrevs t]
+ ["Deactivate and set address"
+ tinymail-deactivate-and-send-to-you t]
+ ["Toggle Gnus plugged state"
+ tinymail-gnus-agent-toggle-plugged t]
+ "----"
+ ["Debug toggle" tinymail-debug-toggle t]
+ ["Debug show" tinymail-debug-show t]
+ "----"
+ ;; ["Keyboard menu" tinymail-menu-main t]
+ ["Package version" tinymail-version t]
+ ["Package commentary" tinymail-commentary t]
+ ["Mode help" tinymail-mode-help t]
+ ["Mode off (exit)" turn-off-tinymail-mode t])
+ (progn
+ (define-key root-map "\t" 'tinymail-complete-key-interactive)
+;;; (define-key root-map " " 'tinymail-expand-abbrev)
+ (define-key map "dd" 'tinymail-debug-toggle)
+ (define-key map "ds" 'tinymail-debug-show)
+ (define-key map "j" 'tinymail-gnus-agent-toggle-plugged)
+ (define-key map "p" 'tinymail-complete-password-mode)
+ (define-key map "u" 'tinymail-update-mail-abbrevs)
+ (define-key map "t" 'tinymail-on-off-toggle)
+ (define-key map "\t" 'tinymail-complete-guess-in-body)
+ (define-key map "x" 'turn-off-tinymail-mode)
+ (define-key map "?" 'tinymail-mode-help)
+ (define-key map "Hm" 'tinymail-mode-help)
+ (define-key map "Hc" 'tinymail-commentary)
+ (define-key map "Hv" 'tinymail-version))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-modeline-update (&rest plugged-status)
+ "Udate `tinymail-:mode-name' to show ! in plugged state."
+ (let* ((status (if (not (zerop (length plugged-status)))
+ (car plugged-status)
+ (ti::mail-plugged-p))))
+ (if status
+ (unless (string-match "!" tinymail-:mode-name)
+ (setq tinymail-:mode-name (concat tinymail-:mode-name "!")))
+ (when (string-match "^\\([^!]+\\)!" tinymail-:mode-name )
+ (setq tinymail-:mode-name (match-string 1 tinymail-:mode-name ))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-gnus-agent-toggle-plugged (&optional mode)
+ "Toggle Gnus plugged state if Gnus has been loaded."
+ (interactive "P")
+ (if (not (fboundp 'gnus-agent-toggle-plugged))
+ (message "Can't change plugged staus. Gnus Agent is not loaded.")
+ (let ((status (ti::mail-plugged-p)))
+ (ti::bool-toggle status mode)
+ (if status
+ (ti::funcall 'gnus-agent-toggle-plugged t)
+ (ti::funcall 'gnus-agent-toggle-plugged nil))
+ (tinymail-modeline-update (ti::mail-plugged-p)))))
+
+;;; ----------------------------------------------------------------------
+;;; #todo: is this really needed
+;;;
+(defun tinymail-expand-abbrev (&optional arg)
+ "Call `abbrev-expand' if cursor is inside header or `self-insert-command'.
+If Prefix argument is given, call `self-insert-command' with ARG.
+This function should be bound to SPACE key."
+ (interactive "P")
+ (if (or (not (null arg))
+ (not (and (< (point) (ti::mail-hmax))
+ (fboundp 'expand-abbrev)
+ (expand-abbrev))))
+ (self-insert-command (prefix-numeric-value arg))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-install-hooks (&optional remove verb)
+ "Install needed hooks, optionally REMOVE. VERB."
+ (let* ((list '(
+ ;; tinymail-complete-everything
+ ;; tinymail-complete-bbdb-fuzzy ;honor BBDB first
+ ;; tinymail-complete-bbdb <NO GOOD> because displays
+ ;; BBDB record.
+ tinymail-complete-simple
+ tinymail-complete-guess-in-headers ; then passwd
+ ;; tinymail-complete-bbdb <NO GOOD> because displays
+ ;; BBDB record. fuzzy is better
+ ;; tinymail-complete-bbdb-fuzzy
+ tinymail-complete-headers-nothing-found)))
+ ;; tinymail-complete-guest-packages
+ ;; tinymail-complete-abbrevs
+ ;; tinymail-complete-headers-move-to-next-field
+ (ti::add-hooks 'tinymail-:process-hook
+ '(tinymail-modeline-update)
+ remove)
+ (ti::add-hooks 'kill-emacs-hook 'tinymail-save-dead-mail-maybe remove)
+ ;; Install the default functions only if this hook is initially nil
+ (cond
+ (remove
+ (ti::add-hooks 'tinymail-:complete-key-hook list 'remove))
+ ((null tinymail-:complete-key-hook)
+ ;; The TAB key handler. First remove the hooks, and then add, so that
+ ;; they will be in this order. The order is _very_ important.
+ (ti::add-hooks 'tinymail-:complete-key-hook list 'remove)
+ ;; The first function that runs must be at the end of list
+ (ti::add-hooks 'tinymail-:complete-key-hook (reverse list))))
+ ;; List of hooks where to install us
+ (ti::add-hooks tinymail-:enter-mail-hook-list
+ 'turn-on-tinymail-mode remove)
+ (ti::add-hooks 'write-file-hooks
+ 'tinymail-write-file-hook remove)
+ (ti::add-hooks 'tinymail-:mode-define-keys-hook
+ 'tinymail-mode-define-keys remove)
+ ;; If user has allowed message-mode to run tinymail, then also install
+ ;; this function, which prevents Sender field genearation. (We generate
+ ;; the From field).
+ (when (memq 'message-header-setup-hook tinymail-:enter-mail-hook-list)
+ (ti::add-hooks 'message-mode-hook
+ 'tinymail-message-disable-sender remove))
+ (when verb
+ (if remove
+ (message "TinyMail: hooks removed.")
+ (message "TinyMail: hooks installed")))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-install-table-header-complete-gnus ()
+ "Add Gnus Followup-To, Gcc, Newsgroups to `tinymail-:table-header-complete'."
+ ;; Debian bug report header
+ ;; http://www.debian.org/Bugs/Reporting
+ ;; See http://www.debian.org/Bugs/Developer#severities
+ (aput 'tinymail-:table-header-complete
+ "Severity"
+ (list
+ '("critical" ;; Whole system break, serious data loss
+ "grave" ;; unuseable, data loss, security hole
+ "serious" ;; violation of Debian policy, unsuitable for release.
+ "important" ;; major effect withour completely unusable.
+ "normal" ;; the default value, applicable to most bugs.
+ "minor" ;; doesn't affect the package's usefulness
+ "wishlist" ;; feature request
+ "fixed"))) ;; fixed but should not yet be closed.
+ ;; Debian bug report header
+ (aput 'tinymail-:table-header-complete
+ "Tags"
+ (list
+ '("patch" ;;
+ "wontfix" ;; change will cause other, worse, problems
+ "moreinfo" ;; more information must be provided by the submitter
+ "unreproducible" ;; can't be reproduced on the maintainer's system
+ "fixed" ;; bug is fixed or worked around, needs to be resolved
+ "security" ;: security problem in a package
+ "potato" ;; potato release
+ "woody" ;; woody distribution
+ "s1id"))) ;; architecture that is currently unreleased
+ (aput 'tinymail-:table-header-complete
+ "Followup-To"
+ (list
+ '(when (eq major-mode 'message-mode)
+ (call-interactively 'message-tab)
+ ;; We must stop the other completion function from running
+ (setq tinymail-:complete-key-return-value t)
+ nil)))
+ (aput 'tinymail-:table-header-complete
+ "Gcc"
+ (list
+ '(if (not (featurep 'gnus))
+ (prog1 nil (message "TinyMail: Gcc completion needs Gnus..."))
+ (when (stringp string))
+ (all-completions
+ string
+ gnus-active-hashtb 'gnus-valid-move-group-p))))
+ (aput 'tinymail-:table-header-complete
+ "Newsgroups"
+ (list
+ '(if (not (featurep 'gnus))
+ (prog1 nil
+ (message "TinyMail: Newsgroups completion needs Gnus..."))
+ (when (stringp string))
+ (all-completions
+ string
+ gnus-active-hashtb
+ (gnus-read-active-file-p))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-read-version (sym)
+ "Read version number from variable SYM if variable exists.
+Otherwise return ''."
+ (or (ti::string-match "[0-9][0-9.]+" 0
+ (if (boundp sym) (symbol-value sym) ""))
+ ""))
+
+;;; ----------------------------------------------------------------------
+;;; - This is the main controller "install" that calls all other
+;;; functions.
+;;;
+(defun tinymail-install-to-buffers (&optional remove verb)
+ "Activate or REMOVE tinyamil from mail buffers."
+ (dolist (buffer (buffer-list)) ;; Activate in current Emacs
+ (with-current-buffer buffer
+ (when (and (memq major-mode '(message-mode mail-mode))
+ ;; #todo: vm send mode?
+ (null buffer-read-only))
+ (message "TinyMail: mode %s in buffer %s"
+ (if remove "deactivated" "activated")
+ (buffer-name))
+ (tinymail-mode (if remove -1 1) )))))
+
+;;; ----------------------------------------------------------------------
+;;; - This is the main controller "install" that calls all other
+;;; functions.
+;;;
+(defun tinymail-install (&optional remove)
+ "Install or REMOVE package."
+ (interactive "P")
+ (let ((idle-p (ti::idle-timer-supported-p)))
+ (if (null idle-p)
+ (message "\
+TinyMail: This Emacs does not support idle timers. Using regular timers."))
+ (ti::compat-timer-cancel-function 'tinymail-process)
+ (tinymail-report-mail-install-maybe remove)
+ (tinymail-install-hooks remove)
+ ;; If the idle timer is available, use it. Otherwise we would have
+ ;; no other option but occupy post command hook
+ (unless remove
+;;; 2007-05-18 disabled. FIXME: needed? Too much CPU?
+;;; (if idle-p
+;;; (setq tinymail-:timer-elt
+;;; (ti::funcall
+;;; 'run-with-idle-timer
+;;; tinymail-:idle-timer-seconds
+;;; t
+;;; 'tinymail-process))
+;;; ;; Can't respect tinymail-:idle-timer-seconds,
+;;; ;; so use 20 seconds repeat time.
+;;; (setq tinymail-:timer-elt
+;;; (run-at-time "20 sec" 20 'tinymail-process)))
+ (when (ti::nil-p (user-full-name))
+ (message
+ (concat
+ "TinyMail: [ERROR] please set variable `user-full-name'."
+ "Was [%s]")
+ (prin1-to-string (user-full-name))))
+ (tinymail-install-table-header-complete-gnus)
+ (tinymail-install-to-buffers)
+ (message
+ "TinyMail: Installed. Read documentation with M-x tinymail-version"))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-install-citation ()
+ "Install First line citation function for Mail user agents."
+ (setq message-citation-line-function
+ 'tinymail-message-citation-line-function))
+
+;;}}}
+;;{{{ code: misc
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinymail-y-or-n-p-abort-p ()
+ "Check if `tinymail-y-or-n-p' was abort."
+ (ti::char-in-list-case tinymail-:y-or-n-p '(?q ?Q)))
+
+;;; ------------------------------------------------------------ &misc ---
+;;;
+(defsubst tinymail-field-off-p (header-name &optional header-value)
+ "Check status of HEADER-NAME field which has optional HEADER-VALUE.
+If there is 2 or more leading spaces, then the field is considered 'off'."
+ (when (and (stringp header-name)
+ (stringp header-value))
+ (not (memq (ti::mail-field-space-count header-name header-value)
+ '(0 1)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro tinymail-mail-aliases ()
+ "Return `tinymail-:mail-aliases-alist' or build it if it is empty."
+ (` (or tinymail-:mail-aliases-alist
+ (tinymail-update-mail-abbrevs))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-make-local-hook-available-p ()
+ "Check if `make-local-hook' is really available."
+ (or (ti::xemacs-p) ;Always in XEmacs
+ (and (ti::emacs-p) ;19.30 and up
+ (not (string-match "19.2[0-9]" (emacs-version))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-y-or-n-p (message)
+ "Ask confirmation for MESSAGE. Accept TAB as yes.
+Setq global variable `tinymail-y-or-n-p' to the result."
+ (setq tinymail-:y-or-n-p
+ (ti::read-char-safe-until
+ (concat message " (tab/n or q)")
+ '(?\t
+ ?\ ?y ?Y ?n
+ ;; NO keys
+ ?\b ?\177 ?\C-h ?\127
+ ?N ?q ?Q
+ ?\e ?\n ?\r
+ ;; These keys are usually above the TAB key, so you can answer
+ ;; NO with your left hand.
+ ?\247
+ ?\`
+ ?\~)))
+ ;; YES answers.
+ (ti::char-in-list-case tinymail-:y-or-n-p '(?y ?Y ?\ ?\t ?\n ?\r)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-write-file-hook ()
+ "Rebuild aliases everytime .mailrc is saved."
+ (tinymail-debug "tinymail-write-file-hook" "MODE" major-mode (buffer-name))
+ (when (string-match "\\.mailrc" (or (buffer-file-name) ""))
+ (message "TinyMail: Updating mail aliases and abbrevs...")
+ (build-mail-aliases)
+ (when (fboundp 'build-mail-abbrevs) ;update abbrevs too
+ (ti::funcall 'build-mail-abbrevs))
+ (tinymail-update-mail-abbrevs 'force)
+ (message "TinyMail: Updating mail aliases and abbrevs...done")
+ ;; Hook return value
+ nil))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-update-mail-abbrevs (&optional force)
+ "Build up all aliases to `tinymail-:mail-aliases-alist' cache and return it.
+Optional FORCE builds the list in any case.
+You need to run this function if you change your ~/.mailrc."
+ (interactive)
+ (tinymail-debug "tinymail-update-mail-abbrevs")
+ (when (and (fboundp 'build-mail-abbrevs) ;update abbrevs too
+ (or force (interactive-p)))
+ (ti::funcall 'build-mail-abbrevs))
+ (setq tinymail-:mail-aliases-alist (ti::mail-abbrev-get-alist)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinymail-deactivate-and-send-to-you ()
+ "Deactivate TinyMail and change To field to point to your address.
+This function is normally used when you use mailing lists. See
+documentation in the tinymail.el or call \\[tinymail-version]."
+ (interactive)
+ (tinymail-debug "tinymail-deactivate-and-send-to-you")
+ (if (ti::nil-p user-mail-address)
+ (error "TinyMail: Please set variable `user-mail-address'")
+ (ti::mail-kill-field "^to:" user-mail-address)
+ (tinymail-field-to-off)
+ (if (interactive-p)
+ (message "Address changed to point to you. TinyMail signs off."))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-buffer-email-address-scramble-area ()
+ "Return are of eamil that can be scrambled.
+Exclude patches and attachments."
+ (let ((list
+ (list
+ "^RCS[ \t]+file:.*,v\\|^diff[ \t]+-[^- \t\r\n]"
+ "[<]#part" ;; Gnus attachment
+ "\\[Attachment:"))
+ (point-list (list (point-max)))
+ beg
+ end)
+ (save-excursion
+ (ti::pmin)
+ (when (search-forward (or mail-header-separator
+ "---NOTHING__TO_FIND")
+ nil t)
+ (setq beg (1+ (line-end-position)))
+ (dolist (re list)
+ (when (re-search-forward re nil t)
+ (push (line-beginning-position) point-list)))
+ (setq end (apply 'min point-list))))
+ (when beg
+ (list beg end))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-buffer-email-address-scramble-1 ()
+ "Spam protect email address words.
+Scramble Email addresses do that spammers cannot use them.
+The end position is before text that looks like a patch or `point-max'"
+ (multiple-value-bind (beg end)
+ (tinymail-buffer-email-address-scramble-area)
+ (when beg
+ (save-excursion
+ (goto-char beg)
+ (let ( ;; If there is patch in this buffer, limit changes before it.
+ (regexp
+ (concat
+ ;; Must be separated by space or "<".
+ ;; this email@example.com or <email@example.com>
+ ;; But not http://user@site.com/
+ "\\(^\\|[ \t]\\)"
+ "\\([^ /\t\r\r]+\\)@\\([^ /\t\r\r]+\\.[^ /\t\r\r]+\\)"
+ "\\(^\\|[ \t]\\)")))
+ (while (re-search-forward regexp end t)
+ (replace-match "\\1\\2 AT \\3\\4")))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-buffer-email-address-scramble ()
+ "If `tinymail-:protect-email-addresses' is non-nil, scrable addresses."
+ (if tinymail-:protect-email-addresses
+ (tinymail-buffer-email-address-scramble-1))
+ ;; Hook function. Return nil
+ nil)
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-active-p ()
+ "Check if TinyMail is active in current buffer."
+ tinymail-mode)
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinymail-mail (&optional disable verb)
+ "Prepare mail mode.
+Add or changes Cc, FF, X-Sender-Info fields on the fly while you're
+composing the message.
+
+Input:
+
+ DISABLE Disables package.
+ VERB print verbose message.
+
+References:
+
+ `tinymail-:feature-hook'."
+ (let* ((fid "tinymail-mail")
+ to-list)
+ (unless fid ;; No-op. XEmacs byte compiler silencer
+ (setq fid nil))
+ (tinymail-debug
+ fid "in:"
+ "dis-flag" disable
+ "MODE" major-mode)
+ (when (featurep 'tinytab)
+ ;; - make TinyTab.el work with TinyMail so that they share
+ ;; common TAB key.
+ ;; - Remove and add make sure the function is at the beginning and
+ ;; runs first.
+ (remove-hook 'tinytab-:tab-insert-hook
+ 'tinymail-complete-key-interactive)
+ (add-hook 'tinytab-:tab-insert-hook
+ 'tinymail-complete-key-interactive))
+ (unless disable
+ ;; If you're replying to someone else's message, the TO field
+ ;; must have two spaces to turn off TinyMail so that the remaining
+ ;; Cc fields are not modified.
+ ;;
+ ;; R and r keys don't add Cc field, so we put there only one space.
+ ;;
+ ;; For simple C-x m TO field will be initially empty.
+ (tinymail-debug
+ fid
+ "MAIN STATUS (BEFORE)"
+ "point" (point)
+ "msg type" tinymail-:message-type
+ "to" (ti::mail-get-field-1 "to")
+ "cc" (ti::mail-get-field-1 "cc")
+ "Subject" (ti::mail-get-field-1 "subject")
+ "MODE" major-mode
+ "\n["
+ (buffer-substring (point-min) (point-max))
+ "]\n")
+ (run-hooks 'tinymail-:feature-hook)
+ (cond
+ (tinymail-:message-type
+ ;; User calls us again
+ (if (ti::nil-p (ti::mail-get-field-1 "subject"))
+ (tinymail-field-to-off)))
+ (t
+ ;; We're called from some mail setup hook. See what is the initial
+ ;; state of the buffer...
+ (cond
+ ((setq to-list (ti::mail-to-list-p))
+ (setq tinymail-:message-type 'to-list)
+ (tinymail-field-to-on))
+ ((ti::nil-p (ti::mail-get-field-1 "subject"))
+ ;; simple mail: there is no subject field filled
+ (setq tinymail-:message-type 'simple))
+ (t ;R or r; No cc field
+ (setq tinymail-:message-type 'reply)
+ (tinymail-field-to-on))))))
+ (tinymail-field-to-move-maybe)
+ (unless to-list ;; No-op. XEmacs byte compiler silencer
+ (setq to-list nil))
+ (tinymail-debug
+ fid
+ "MAIN AFTER"
+ "point" (point)
+ "disable" disable
+ "msg type" tinymail-:message-type
+ "to-list" to-list
+ "MODE" major-mode
+ "to" (ti::mail-get-field-1 "to")
+ "Subject" (ti::mail-get-field-1 "subject")
+ "\n["
+ (buffer-substring (point-min) (point-max))
+ "]\n")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-mail-send-to-list ()
+ "Check if message is being sent to mailing list and Fix CC/To.
+This function makes the To to point to mailing list and delete
+any CC. Set Gnus group parameter to take use of this feature: (G p
+in *Group* buffer):
+
+ '(...
+ (to-list . \"discussion-list@list.com\")
+ ...)"
+ (when (eq major-mode 'message-mode)
+ (let* ((fid "tinymail-mail-send-to-list:")
+ (tofield (mail-fetch-field "To"))
+ (ccfield (mail-fetch-field "Cc"))
+ (to (ti::mail-to-list-p))
+ (email (if to
+ (car-safe (ti::mail-email-from-string to)))))
+ (unless fid ;; No-op. XEmacs byte compiler silencer
+ (setq fid nil))
+ (tinymail-debug fid "to" to "email" email)
+ ;; If TO is not in the headers; then this is private reply with
+ ;; "r". A followup will include TO in To or Ccc field.
+ (when (and (string-match "^[ \t]*$" (or tofield ""))
+ (string-match "^[ \t]*$" (or ccfield ""))
+ to
+ email
+ ;; (save-restriction
+ ;; (message-narrow-to-headers)
+ ;; (not (ti::re-search-check email)))
+ (not (tinymail-field-off-p "To" to)))
+ (tinymail-debug fid "TO-LIST SET, killed To/Cc")
+ (ti::mail-kill-field "^To" to)
+ (ti::mail-kill-field "^CC")
+ t))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-resolve-abbrevs (list)
+ "Resolves LIST of mail abbrevs in format '(\"abbrav\" \"abbrev\" ..)
+
+Return:
+
+ ((\"alias\" . \"expansion\") (A . E) .. )
+ alias = the alias definition
+ expansion = expanded alias"
+ (let* ((abbrevs (tinymail-mail-aliases))
+ pre-abbrev-expand-hook ;; prevent recursion
+ exp-list
+ hit)
+ (dolist (elt list)
+ (tinymail-debug "tinymail-resolve-abbrevs" elt)
+ ;; Returns (ABBR . ABBR-EXPANDED)
+ (if (not (setq hit (assoc elt abbrevs)))
+ (message "TinyMail: Can't find abbrev '%s', is it in ~/.mailrc ?" elt)
+ (if (not (member hit exp-list))
+ (push hit exp-list))))
+ exp-list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-password-save (&optional load verb)
+ "Save passwd completions to file `tinymail-:password-file'. Optionally LOAD.
+If that variable is nil, then do nothing. VERB."
+ (let* ((file tinymail-:password-file)
+;;; (list tinymail-:password-completion-alist)
+ (list2 tinymail-:password-alist))
+ (ti::verb)
+ (tinymail-debug "tinymail-password-save" file load verb)
+ (when (stringp file)
+ (if (string-match "\\.gz$\\|\\.Z$" file)
+ (ti::use-file-compression))
+ (cond
+ (load
+ (if (not (file-exists-p file)) ;Create file then
+ (tinymail-password-define-variables 'force))
+ (ti::load-file-with-wrapper file)
+ (if verb (message "TinyMail: passwd completions loaded.")))
+ (t
+ (if (null list2)
+ (message "\
+TinyMail: `tinymail-:password-alist' is empty, nothing to save.
+Call `tinymail-password-define-variables' with argument FORCE.")
+ (ti::write-file-variable-state
+ file "TinyMail.el password completions"
+ '(tinymail-:password-completion-alist tinymail-:password-alist))
+ (if verb
+ (message "TinyMail: passwd completions saved."))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-password-define-variables (&optional force no-save)
+ "Defines passwd variables.
+Read definitions from `tinymail-:password-file' if FORCE is nil.
+
+Input:
+
+ FORCE flag, if non-nil, read passwd table and reset all variables.
+ NO-SAVE flag, if non-nil, do not save passwd completions to file.
+
+Return:
+
+ non-nil if password completion can be used.
+
+References:
+
+ `tinymail-:password-mode'"
+
+ (tinymail-debug "tinymail-password-define-variables"
+ 'force force
+ 'no-save no-save
+ 'passwd-file tinymail-:password-file)
+ (when (and tinymail-:password-mode
+ tinymail-:password-cat-cmd)
+ (cond
+ ;; .................................................... cond-save ...
+ ((or force
+ (and tinymail-:password-file
+ (not (file-exists-p tinymail-:password-file)))
+ (and (null tinymail-:password-file)
+ (null tinymail-:password-alist)))
+ (message "TinyMail: Buildig password completions...")
+ (setq tinymail-:password-alist
+ (ti::file-passwd-build-alist tinymail-:password-cat-cmd))
+ (message "TinyMail: Buildig password completions...done"))
+ ;; .................................................... cond-load ...
+ ((and (file-exists-p tinymail-:password-file)
+ (null tinymail-:password-alist))
+ (tinymail-password-save 'load)))
+ ;; ......................................................... build ...
+ (when (or force
+ (null tinymail-:password-completion-alist))
+ (setq tinymail-:password-completion-alist
+ (mapcar (function
+ (lambda (x) (cons (car x) 1)))
+ tinymail-:password-alist))
+ (if (null no-save)
+ (tinymail-password-save)))
+ tinymail-:password-completion-alist))
+
+;;}}}
+;;{{{ Completion
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-complete-password-mode (&optional mode)
+ "Toggle `tinymail-:password-mode' on or off."
+ (interactive "P")
+ (ti::bool-toggle tinymail-:password-mode mode)
+ (when (interactive-p)
+ (message "TinyMail: Password complete mode is now %s"
+ (if tinymail-:password-mode "on" "off"))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-complete-string-read ()
+ "Return completion string from current point or nil.
+The String must be delimited by comma as in mail header are.
+
+Return:
+ (beg-marker end-marker string)"
+ (let* ((fid "tinymail-complete-string-read")
+ (point (point))
+ (heder-p (ti::mail-point-at-header-p))
+ string
+ beg-marker
+ end-marker)
+ (unless fid ;; No-op. XEmacs byte compiler silencer
+ (setq fid nil))
+ (when (and (not (bolp)) ;Nothing to read
+ (not (char-equal (char-syntax (preceding-char)) ?\ )))
+ (ti::narrow-safe (line-beginning-position) (line-end-position)
+ (goto-char point)
+ ;; First, go away from whitespace so that match-end gets
+ ;; length in next case statement
+ (skip-chars-forward " \t")
+ (cond
+ ((or (if (not heder-p)
+ (skip-chars-backward "^ \t")
+ (or (re-search-backward ",[ \t]*" nil t)
+ (and (re-search-backward "^[^:]+:" nil t)
+ (goto-char (match-end 0)))
+ ;; continued line
+ ;;
+ ;; Cc: this,
+ ;;
+ ;;
+ ;;
+ ;; here_is_point
+ ;;
+ (re-search-backward "[:, ][ \t]*" nil t))))
+ (skip-chars-forward " ,\t") ;Goto word
+;;; (ti::d! 1 (buffer-substring (point) (line-end-position)))
+ nil)
+ ((re-search-backward "^[ \t]*" nil t)
+;;; (ti::d! 2 (buffer-substring (point) (line-end-position)))
+ (goto-char (1+ (point)))))
+ (setq beg-marker (point-marker))
+;;; (ti::d! beg (looking-at "[^\n\t ,:]+") (buffer-substring beg (line-end-position)))
+ ;; There must be somthing, not just empty lines
+ (when (looking-at "[^\n\t ,:]+")
+ (cond
+ ((re-search-forward " *," nil t)
+ (setq end-marker (make-marker))
+ (move-marker end-marker (match-beginning 0)))
+ ((re-search-forward "[ \t]*,\\|[ \t]*$" nil t)
+ (setq end-marker (make-marker))
+ (move-marker end-marker (match-beginning 0)))))
+
+ (if (and beg-marker end-marker)
+ (setq string (buffer-substring-no-properties
+ (marker-position beg-marker)
+ (marker-position end-marker)))))
+ (tinymail-debug fid "RET" string beg-marker end-marker)
+ (if (null string)
+ (setq beg-marker nil ;; Kill possible markers
+ end-marker nil)
+ (list
+ beg-marker
+ end-marker
+ string)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-complete-list-mail-aliases (&optional mode data)
+ "Return '(match match ...) from mail aliases.
+
+Input MODE:
+
+ The default match is made against all the alias expansion ('string mode).
+ With 'alias, only the alias names are matched."
+ (let* ((fid "tinymail-complete-guess-2-choices: ")
+ (list (tinymail-mail-aliases))
+ (mail (ti::mail-mail-p))
+ elt
+ beg
+ end
+ str)
+ (unless fid ;; No-op. XEmacs byte compiler silencer
+ (setq fid nil))
+ (tinymail-debug fid "in" mode 'mail-p mail)
+ (when mail
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... .. get word ...
+ (cond
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... second mode ..
+ ((eq mode 'alias)
+ (save-excursion
+ (when (< (skip-chars-backward "^ \t\n") 0)
+ (setq beg (point))
+ (when (> (skip-chars-forward "^ \n\t") 0)
+ (setq end (point)))))
+ (if (and beg end)
+ (setq str (buffer-substring beg end))
+ (setq str nil)))
+ (t
+ (or data
+ (setq data (tinymail-complete-string-read)))
+ (if data
+ (setq beg (nth 0 data)
+ end (nth 1 data)
+ str (regexp-quote (nth 2 data))))))
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... .. find matches ...
+ ;;#todo: this code must be rewritten, ti::list-find and `function'
+ ;;is flow combination.
+
+ (when (and (not (ti::nil-p str))
+ (setq elt
+ (ti::list-find
+ list str
+ (function
+ (lambda (arg elt)
+ (if (eq mode 'string)
+ (string-match arg (cdr elt))
+ (string-match (concat "^" arg)
+ (car elt)))))
+ 'all-matches)))
+ (tinymail-debug fid "after type" beg end str)
+ (mapcar 'cdr elt)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-complete-guess-1 (&optional mode verb)
+ "Try to expand using underlying characters.
+Look completion from `mail-aliases'. If there is more than 1 match,
+ask which one to use.
+
+If MODE is 'string, then text read from buffer must be separated by
+
+ LEFT-COLON: txt [COMMA,WHITESPACE]
+ LEFT-ALL-WHITESPACE txt [COMMA,WHITESPACE]
+ COMMA txt [COMMA,WHITESPACE]
+
+If MODE is 'alias then text is read direcly under point separated
+by spaces. This function does nothing if the first line doesn't contain
+
+ KEYWORD:
+
+Indicating a mail like mode. VERB prints verbose messages.
+
+Return:
+
+ t completed
+ nil"
+ (let* ((fid "tinymail-complete-guess-2: ")
+ (list (tinymail-mail-aliases))
+ (mail (ti::mail-mail-p))
+ (check-regexp tinymail-:confirm-mailrc-regexp)
+ user-selected-p
+ data
+ elt
+ beg end str
+ done
+ ret)
+ (unless fid ;; No-op. XEmacs byte compiler silencer
+ (setq fid nil))
+ (tinymail-debug fid "in" mode verb mail)
+
+ (when mail
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... .. get word ...
+ (cond
+ ((eq mode 'string)
+ (setq data (tinymail-complete-string-read))
+ (if data
+ (setq beg (nth 0 data)
+ end (nth 1 data)
+ str (regexp-quote (nth 2 data)))))
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... second mode ..
+ ((eq mode 'alias)
+ (save-excursion
+ (when (< (skip-chars-backward "^ \t\n") 0)
+ (setq beg (make-marker))
+ (when (> (skip-chars-forward "^ \n\t") 0)
+ (setq end (make-marker)))))
+ (if (and beg end)
+ (setq str (buffer-substring
+ (marker-position beg)
+ (marker-position end)))
+ (setq str nil))))
+ (tinymail-debug fid "after type" beg end str)
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... .. find matches ...
+ (when (and (not (ti::nil-p str))
+ (setq elt
+ (ti::list-find
+ list str
+ (function
+ (lambda (arg elt)
+ (if (eq mode 'string)
+ (string-match arg (cdr elt))
+ (string-match (concat "^" arg)
+ (car elt)))))
+ 'all-matches)))
+ (setq str nil)
+ (tinymail-debug fid "ELT matches" (length elt) (cdr (car elt)) elt)
+ ;; ............................................... any matches ...
+ ;; How many matches?
+ (cond
+ ((eq 1 (length elt))
+ (setq elt (car elt))) ; '( (alias . string) ) --> (a . s)
+ (elt
+ (let (completion-ignore-case)
+ (setq str
+ (completing-read
+ (format "%d Choose: " (length elt))
+ (ti::list-to-assoc-menu (mapcar 'cdr elt))
+ nil ;; predicate
+ (not 'match-it))))
+
+ (if (ti::nil-p str)
+ (setq elt nil) ;User didn't select anything
+ (setq user-selected-p t
+ elt (rassoc str elt)
+ ret t))))
+ (tinymail-debug fid "ELT" elt)
+ ;; .............................................. select match ...
+ ;; Now we have a MATCH unless user cancelled the choices
+ (when elt
+ (if (eq mode 'string)
+ (setq str (cdr elt))
+ (setq str (car elt))))
+ (tinymail-debug fid "SELECTION" mode str elt)
+ (unless (ti::nil-p str)
+ ;; For some strings, ask confirmation.
+ ;; Ie. Give a chance to discard this completions and move on...
+
+ (tinymail-debug fid
+ "CHECK" check-regexp
+ (string-match check-regexp str))
+ ;; *) If user already did selected this match from several
+ ;; choices, then go ahead
+ ;; *) If we found only one match, then confirm that match
+
+ (when (or user-selected-p
+ (not (stringp check-regexp))
+ (or (null (string-match check-regexp str))
+ (and (string-match check-regexp str)
+ (tinymail-y-or-n-p (concat "TinyMail: " str)))))
+ (goto-char (marker-position beg))
+ (delete-region (marker-position beg) (marker-position end))
+ (setq beg nil end nil) ;; Kill markers
+ (insert str)
+ (setq done t ret t)))) ;; when-nil-var
+ (cond
+ ((and verb (null done) str)
+ (message (format "TinyMail: no completion match on '%s'" str)))
+ ((and verb str done (eq mode 'alias))
+ (message (cdr (car elt)))))
+ (tinymail-debug fid "RET" ret)
+ ret)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-complete-passwd (&optional force verb)
+ "Complete names in passwd in header area, otw do nothing.
+
+Input:
+
+ FORCE Complete anyway
+ VERB enable verbose messages.
+
+Return:
+
+ t completed
+ nil nothing done"
+ (interactive "P")
+ (let* ((fid "tinymail-complete-passwd")
+ (header-p (< (point) (ti::mail-hmax) ))
+ ret
+ table
+ word
+ str
+ completions)
+ (unless fid ;; No-op. XEmacs byte compiler silencer
+ (setq fid nil))
+ (ti::verb)
+ (save-excursion
+ (forward-char -1) ;move over some char
+ (setq word (ti::buffer-read-word "[-_+a-zA-Z0-9]" 'strict)))
+ (when (and (or force header-p)
+ (not (ti::nil-p word))
+ (tinymail-password-define-variables))
+ (setq table tinymail-:password-completion-alist)
+ (setq completions (all-completions word table))
+ (tinymail-debug fid "COMPLETIONS" word completions)
+ (cond
+ ((eq 1 (length completions))
+ (setq str (car completions))
+ (if (null (tinymail-y-or-n-p (format "Accept Passwd match: %s " str)))
+ (tinymail-y-or-n-p-abort-p)
+ ;; We only insert the missing part to the buffer.
+ ;; abcDEF
+ ;; * if tab was pressed after abc
+ (insert (substring (car completions) (length word)))
+ (setq ret t)))
+ ((setq completions (tinymail-password-grep word 'verb))
+ (tinymail-display-list completions)
+ ;; Show the matched entries from passwd table, sometimes
+ ;; User doens't want to use them but continue calling other
+ ;; functions. Ask what's up.
+ (setq ret
+ (not
+ (tinymail-y-or-n-p
+ "TinyMail: Continue calling more completion functions?"))))))
+ (tinymail-debug fid "RET" ret word)
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-complete-guess (&optional verb)
+ "Complete using .mailrc and passwd.
+Optional VERB allows displaying messages.
+
+References:
+
+ The completion type is determined by variable `tinymail-:complete-mode',
+ which can be 'alias or 'string
+
+ This function is part of the other completion possibilities run by
+ `tinymail-complete-key' and installed in `tinymail-:complete-key-hook'.
+
+Return:
+
+ non-nil Completion handled
+ nil Not completed"
+ (interactive "*")
+ (let ((mode tinymail-:complete-mode)
+ (pmode tinymail-:password-mode)
+ ret)
+ (ti::verb)
+ (cond
+ ((eq mode 'alias)
+ (and (null (setq ret (tinymail-complete-guess-1 'alias verb)))
+ pmode
+ (setq ret (tinymail-complete-passwd nil verb))))
+ ((eq mode 'string)
+ (and (null (setq ret (tinymail-complete-guess-1 'string verb)))
+ pmode
+ (tinymail-field-in-to-cc-p)
+ (setq ret (tinymail-complete-passwd nil verb))))
+ (t
+ (error "TinyMail: Unknown mode %s" mode)))
+ (tinymail-debug "tinymail-complete-guess" mode "PASS-MODE" pmode "RET" ret)
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-complete-everything (&optional verb)
+ "Gather list of possible completions and let user choose."
+ (interactive)
+ (let ((data (tinymail-complete-string-read)))
+ (when (and data
+ ;; It doesn't make sense to search items that already
+ ;; look like email, this@here.com
+ (not (string-match "@" (nth 2 data))))
+ (let* ((fid "tinymail-complete-everything:")
+ (check-regexp tinymail-:confirm-mailrc-regexp)
+ (mode tinymail-:complete-mode)
+ matches
+ (beg (nth 0 data))
+ (end (nth 1 data))
+ choice
+ done
+ ret
+ user-selected-p)
+ (unless fid ;; No-op. XEmacs byte compiler silencer
+ (setq fid nil))
+ ;; .......................................... clean duplicates ...
+ (dolist (results (list
+ (tinymail-complete-list-mail-aliases mode data)
+ (tinymail-complete-list-bbdb mode data)
+ (tinymail-complete-list-passwd mode data)))
+ (dolist (address results)
+ (pushnew address matches :test 'string=)))
+ ;; ............................................... any matches ...
+ ;; How many matches?
+ (cond
+ ((eq 1 (length matches))
+ (setq choice (car matches)))
+ (matches
+ (setq choice
+ (completing-read
+ (format "%d Choose: " (length matches))
+ (ti::list-to-assoc-menu matches)
+ nil
+ (not 'must-match)))
+ (if (ti::nil-p choice)
+ (setq choice nil)
+ (setq user-selected-p t
+ ret t))))
+ (tinymail-debug fid "CHOICE" choice)
+ ;; .............................................. select match ...
+ ;; Now we have a MATCH unless user cancelled the choices
+ (when choice
+ (tinymail-debug fid 'mode mode "CHOICE" choice)
+ ;; For some strings, ask confirmation.
+ ;; Ie. Give a chance to discard this completions and move on...
+ (tinymail-debug fid
+ "CHECK" check-regexp
+ (string-match check-regexp choice))
+ ;; *) If user already did selected this match from several
+ ;; choices, then go ahead
+ ;; *) If we found only one match, then confirm that match
+ (when (or user-selected-p
+ (not (stringp check-regexp))
+ (or (null (string-match check-regexp choice))
+ (and (string-match check-regexp choice)
+ (tinymail-y-or-n-p (concat "TinyMail: " choice)))))
+ (goto-char (marker-position beg))
+ (delete-region (marker-position beg) (marker-position end))
+ (setq beg nil end nil) ;; Kill markers.
+ (insert choice)
+ (setq done t ret t)))
+ (if (and verb (null done) choice)
+ (message (format "TinyMail: no completion match on '%s'" choice)))
+ (tinymail-debug fid "RET" ret)
+ ret))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-complete-guess-in-headers (&optional arg)
+ "Like `tinymail-complete-guess', but complete only in headers. Ignore ARG."
+ (interactive)
+ (ti::mail-point-in-header-macro
+ (when (ti::mail-field-email-address-p)
+ (tinymail-debug 'tinymail-complete-guess-in-headers
+ 'ARG arg 'MODE major-mode 'POINT (point))
+ (tinymail-complete-everything))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-complete-guess-in-body (&optional arg)
+ "Like `tinymail-complete-guess', but complete only in body. Ignore ARG."
+ (interactive)
+ (when (>(point) (ti::mail-hmax))
+ (let* ((fid "tinymail-complete-guess-in-body")
+ (hook tinymail-:complete-body-hook)
+ (data (tinymail-complete-string-read))
+ ret)
+ (unless fid ;; No-op. XEmacs byte compiler silencer
+ (setq fid nil))
+ (tinymail-debug 'tinymail-complete-guess-in-body
+ 'ARG arg
+ 'MODE major-mode
+ 'POINT (point)
+ 'data data
+ 'hook hook)
+ (dolist (func hook)
+ (tinymail-debug fid 'FUNC func)
+ (when (cond
+ ((not (fboundp func))
+ (tinymail-debug fid 'FUNC func "not exist")
+ nil)
+ (t
+ (funcall func data)))
+ (setq ret t)
+ (return)))
+ ret)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-complete-bbdb (&rest args)
+ "Call bbdb-complete-name' if is bbdb loaded and ignore ARGS."
+ (when (and (fboundp 'bbdb-complete-name)
+ (tinymail-field-in-to-cc-p))
+ (let* ((point (point)))
+ (call-interactively 'bbdb-complete-name)
+ (if (eq (point) point)
+ nil ;Point not moved, not completed
+ ;; point moved, completed
+ t))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-bbdb-parse-to-string ()
+ "Parse BBDB to a fast search format."
+ (let ((str "")
+ record
+ tmp)
+ (mapatoms
+ (function
+ (lambda (sym &optional symbol val name notes)
+ (setq symbol (symbol-name sym))
+ (setq record (bbdb-gethash symbol))
+ (if (and (listp record)
+ (vectorp (setq tmp (car-safe record))))
+ (setq record tmp))
+ (when record
+ (setq name (bbdb-record-name record))
+
+ (setq str (concat str (format "\C-m%s\C-j%s"
+ name
+ (prin1-to-string record)))))))
+ (bbdb-hashtable))
+ str))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinymail-bbdb-record-fix (record)
+ "Fix BBDB RECORD to pure vector.
+Upgrading from v3 to v5 BBDB database, the
+entries are returned as ([ ... ]) by
+bbdb-gethash, but this format is not suitable for
+calling (bbdb-record-net record)
+
+The code below removes the extra () and only
+leaves RECORD [ .. ]."
+ (let (tmp)
+ (if (and (listp record)
+ (vectorp (setq tmp (car-safe record))))
+ tmp
+ record)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-bbdb-data-read ()
+ "Read user information based on current line in `bbdb-file'."
+ (let* ((fid "tinymail-bbdb-data-read:")
+ (point (point))
+ (case-fold-search
+ tinymail-:complete-bbdb-case-fold-search)
+ one
+ two
+ key
+ record)
+ (unless fid ;; No-op. XEmacs byte compiler silencer
+ (setq fid nil))
+ (beginning-of-line)
+ ;; ["Jack E." "Den" nil nil nil
+ ;; | |
+ ;; one two
+ (when (looking-at "^.\"\\([^\n\r\"]+\\)[ \t\"]+\\([^ \t\"]+\\)")
+ (setq one (match-string 1)
+ two (match-string 2))
+ (if (string= one "nil")
+ (setq one nil))
+ (if (string= two "nil")
+ (setq two nil))
+ (cond
+ ((and one two)
+ (setq key (format "%s %s" one two)))
+ (one
+ (setq key one))
+ (two
+ (setq key two)))
+ (setq record (bbdb-gethash (downcase key))))
+ (goto-char point) ;; faster than save-excursion
+ (if tinymail-:debug
+ (tinymail-debug fid one two 'key key '=> record))
+ record))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-bbdb-record-net-completions (record)
+ "Construct email completions for RECORD."
+ (let* ((fid "tinymail-bbdb-record-net-completions:")
+ completion
+ tmp
+ name
+ list)
+ (unless fid ;; No-op. XEmacs byte compiler silencer
+ (setq fid nil))
+ (dolist (net (bbdb-record-net record))
+ (when (and (stringp net)
+ (string-match "@" net))
+ (setq completion
+ ;; If user has given a custom name to a NET,
+ ;; Like: Customer Support -- Phone Number <@>
+ ;; Then use that. Otherwise
+ ;; combine name and plain address
+ (if (string-match "[<>]" net)
+ net
+ (setq name (bbdb-record-name record))
+ ;; DO NOT ADD name "John doe" if address already
+ ;; has those in john.doe@some.com because it looks
+ ;; funny to read "john doe john.doeEMAIL" multiple times
+ (if tinymail-:debug
+ (tinymail-debug fid
+ "\n\t" 'SPLIT
+ (split-string name) net))
+ (if (and (setq tmp (split-string name))
+ (> (length tmp) 1)
+ (string-match (regexp-quote (nth 0 tmp)) net)
+ (string-match (regexp-quote (nth 1 tmp)) net))
+ net
+ (format "%s <%s>" name net))))
+ (push completion list)))
+ (if tinymail-:debug
+ (tinymail-debug fid "\n\t" 'RET list))
+ list))
+
+;;; ----------------------------------------------------------------------
+;;; Switched to another implementation (2). Read the matches
+;;; directly from the BBDB data buffer, because it is faster than reading
+;;; with `mapatoms' => obarray.
+;;;
+(defun tinymail-complete-list-bbdb-2 (regexp &optional check)
+ "Return list of strings that match REGEXP in BBDB hash table.
+
+Input:
+
+ REGEXP Regexp to match for mail fields
+ CHECK See `tinymail-:complete-bbdb-fuzzy-method'."
+ (let ((fid "tinymail-complete-list-bbdb-2: ")
+ buffer
+ list
+ str
+ record)
+ (unless fid ;; No-op. XEmacs byte compiler silencer
+ (setq fid nil))
+ ;; The BBDB intrface code is filled with condition statements:
+ ;;
+ ;; (if tinymail-:debug
+ ;; (tinymail-debug
+ ;;
+ ;; This prevents function call to happen, so that
+ ;; the BBDB interface is as fast as possible.
+ (when (and (featurep 'bbdb)
+ (setq buffer (find-buffer-visiting bbdb-file)))
+ (with-current-buffer buffer
+ ;; Don't want to see text properties in this buffer.
+ (if (and (boundp 'font-lock-mode)
+ (symbol-value 'font-lock-mode))
+ (font-lock-mode -1))
+ (ti::pmin)
+ (while (re-search-forward regexp nil t)
+ (if tinymail-:debug
+ (tinymail-debug fid
+ 'found (ti::buffer-read-space-word)
+ (ti::read-current-line)
+ "\n"))
+ (when (setq record (tinymail-bbdb-data-read))
+ (setq record (tinymail-bbdb-record-fix record))
+ ;; ......................................... field match ...
+ (if (null check)
+ nil ;; (setq ok t)
+ (dolist (func check)
+ (when (and (functionp func)
+ (setq str (funcall func record))
+ (cond
+ ((stringp str)
+ (string-match regexp str))
+ ((and (listp str)
+ ;; '((field . "str") ..)
+ (ti::consp (car-safe str)))
+ (dolist (elt str)
+ (setq elt (cdr elt))
+ (when (and (stringp elt)
+ (string-match regexp elt))
+ (return t))))
+ ((and (listp str)
+ (stringp (car-safe str)))
+ (dolist (s str)
+ (when (string-match regexp s)
+ (return t))))))
+ (if tinymail-:debug
+ (tinymail-debug fid 'MATCH regexp func str))
+ (return))))
+ ;; .................................... make completions ...
+ (dolist (elt (inline
+ (tinymail-bbdb-record-net-completions
+ record)))
+ ;; Previously used `pushnew' to to remove duplicates.
+ ;; push is faster. See `tinymail-complete-everything'
+ ;;
+ ;; (pushnew elt list :test 'string=)
+ (push elt list)))
+ (forward-line 1))))
+ (if tinymail-:debug
+ (tinymail-debug fid 'RET list))
+ list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-complete-list-bbdb-1 (regexp &optional fields)
+ "Return list of strings that match REGEXP and @ in BBDB hash table.
+
+Input:
+
+ REGEXP Regexp to match for mail fields
+ FIELDS See `tinymail-:complete-bbdb-fuzzy-method'."
+ (let ((fid "tinymail-complete-list-bbdb-1: ")
+ list
+ record
+ completion
+ tmp)
+ (unless fid ;; No-op. XEmacs byte compiler silencer
+ (setq fid nil))
+ (when (featurep 'bbdb)
+ (mapatoms
+ (function
+ (lambda (sym &optional symbol val name notes)
+ (setq symbol (symbol-name sym))
+ ;; Look at all atoms in BBDB and try to find email addresses
+ ;; that have string that would match.
+ (setq record (bbdb-gethash symbol))
+ ;; NOTE: upgrading from v3 to v5 BBDB database, the
+ ;; entries are returned as ([ ... ]) by
+ ;; bbdb-gethash, but this format is not suitable for
+ ;; calling (bbdb-record-net record)
+ ;;
+ ;; The code below removes the extra () and only
+ ;; leaves RECORD [ .. ]
+ (if (and (listp record)
+ (vectorp (setq tmp (car-safe record))))
+ (setq record tmp))
+ (when record
+ (setq name (bbdb-record-name record)
+ notes (bbdb-record-notes record)))
+ ;; .......................................... select record ...
+ (when fields
+ ;; If ANYTHING has been set:
+ ;; -- Compare element in BBDB if it is string
+ ;; -- Require at least 3 characters to compare
+ ;; (it makes no sense to complete one character "a")
+ ;; -- Match the element
+ ;; ["John" "Doe" nil nil nil nil ("jdoe@example.com")
+ ;; ((creation-date . "2000-09-09") (timestamp . "2000-09-09")
+ ;; (notes . "that.el"))
+ ;; ["John Doe" nil #<marker at 114932 in bbdb-data.el> nil]])
+ (when (and fields record)
+ ;; #todo: Is there function to `dolist' over vector list?
+ (let* ((i 0)
+ (len (if (integerp fields)
+ fields
+ 3))
+ (max (1- (length record)))
+ elt)
+ (when (>= (length regexp) len)
+ (while (< i max)
+ (setq elt (aref record i))
+ (incf i)
+ (if (not (listp elt))
+ (setq elt (list elt)))
+ (dolist (item elt)
+ ;; Try CDR: (notes . "value")
+ ;; or CAR: ("string")
+ (if (listp item)
+ (setq item (or (cdr-safe item)
+ (car-safe item))))
+ (when (and (stringp item)
+ (string-match regexp item))
+ (tinymail-debug fid 'ANYTHING regexp elt)
+ (setq max (1+ max))
+ (return))))))))
+ ;; ..................................... make completions ...
+ (when (and record
+ name
+ (prog1 t (tinymail-debug fid 'BBDB-SCAN record))
+
+ ;; If there is case sensitive search in effect, check that,
+ ;; before adding to completion list
+
+ (let ((case-fold-search
+ tinymail-:complete-bbdb-case-fold-search))
+ (or (string-match regexp symbol)
+ (string-match regexp name)
+ (string-match regexp (or notes ""))))
+ (setq val (bbdb-record-net record)))
+ (tinymail-debug fid
+ 'MATCHED-OK
+ "REGEXP" regexp
+ "SYMBOL" symbol
+ "ATOM " val
+ "RECORD" record
+ "NET" val
+ "NOTES" notes)
+ (dolist (net val)
+ (when (and (stringp net)
+ (string-match "@" net))
+ (setq completion
+ ;; If user has given a custom name to a NET,
+ ;; Like: Customer Support -- Phone Number <@>
+ ;; Then use that. Otherwise
+ ;; combine name and plain address
+ (if (string-match "[<>]" net)
+ net
+ ;; DO NOT ADD name "John doe" if address already
+ ;; has those in john.doe@some.com because it looks
+ ;; funny to read NAME EMAIL multiple times
+ (tinymail-debug fid
+ "\n\t" 'SPLIT
+ (split-string name) net)
+ (if (and (setq tmp (split-string name))
+ (> (length tmp) 1)
+ (string-match (regexp-quote (nth 0 tmp)) net)
+ (string-match (regexp-quote (nth 1 tmp)) net))
+ net
+ (format "%s <%s>" name net))))
+ (pushnew completion list :test 'string=)))) ;; When-end
+ (setq record nil)))
+ (bbdb-hashtable))
+
+ (tinymail-debug fid 'RETURN-COMPLETIONS list)
+ list)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-complete-list-bbdb (mode data)
+ "Return list of matches from BBDB.
+
+Input:
+
+ MODE is the value of `tinymail-:complete-mode'.
+ DATA can contain values returned from `tinymail-complete-string-read'."
+ (when (or data
+ (setq data (tinymail-complete-string-read)))
+ (setq data (regexp-quote (nth 2 data)))
+ (tinymail-complete-list-bbdb-2
+ data
+ tinymail-:complete-bbdb-fuzzy-method)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-complete-bbdb-fuzzy (&optional info &optional force)
+ "Scan through BBDB 'net for partial matches and offer completion list.
+
+Input:
+
+ INFO '(beg end STRING) of the completion word
+ FORCE Normally this function completes only in Header To/Cc fields< but if
+ this is non-nil, complete at point."
+ (when (and (featurep 'bbdb)
+ (or force (tinymail-field-in-to-cc-p))
+ (eq tinymail-:complete-mode 'string))
+ (tinymail-debug 'tinymail-complete-bbdb-fuzzy info 'FORCE force)
+ (let* ((fid "tinymail-complete-bbdb-fuzzy:")
+ (string (nth 2 info))
+ (list (and string
+ (tinymail-complete-list-bbdb-2
+ (regexp-quote string)))))
+ (unless fid ;; No-op. XEmacs byte compiler silencer
+ (setq fid nil))
+ (tinymail-debug fid 'LIST list 'STRING string)
+
+ (when list
+ (cond
+ ((eq 1 (length list))
+ (if (tinymail-y-or-n-p (concat "TinyMail bbdb accept: " (car list)))
+ (tinymail-complete-insert-completion (car list) info)
+ (tinymail-y-or-n-p-abort-p)))
+ (list
+ (setq string (completing-read
+ (format "TinyMail bbdb fuzzy %d (empty to cancel): "
+ (length list))
+ (ti::list-to-assoc-menu list)))
+ (unless (ti::nil-p string)
+ (tinymail-complete-insert-completion string info)
+ t)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-complete-bbdb-fuzzy-at-point (info)
+ "Call tinymail-complete-bbdb-fuzzy with INFO and `FORCE' argument."
+ (tinymail-complete-bbdb-fuzzy info 'force))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-complete-insert-completion (string info)
+ "Replace the content with STRING by using the INFO.
+INFO contains list '(begin-point end-point text-between-points)."
+ (interactive)
+ (delete-region (nth 0 info) (nth 1 info))
+ (insert string)
+ (skip-chars-backward " ")
+ t)
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-header-complete-choices (field)
+ "Return completion choices for HEADER-FIELD."
+ (let* ((fid "tinymail-header-complete-choices:")
+ (ret (nth 1 (assoc field tinymail-:table-header-complete))))
+ (unless fid ;; No-op. XEmacs byte compiler silencer
+ (setq fid nil))
+ (tinymail-debug fid 'CHOICES-RAW ret)
+ ;; If the first element is string, then suppose list of strings
+ ;; If not, evaluate `choices' to get list of strings.
+ (when ret
+ (if (not (stringp (car ret)))
+ (setq ret (eval ret))))
+ (tinymail-debug fid 'CHOICES-FINAL ret)
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-complete-simple (&optional info)
+ "Complete according to `tinymail-:table-header-complete'.
+INFO is '(string beg end) of the completion word"
+ (interactive)
+ (ti::mail-point-in-header-macro
+ (let* ((fid "tinymail-complete-simple: ")
+ (field-1 (ti::remove-properties (ti::mail-current-field-name)))
+ (field (and field-1
+ (capitalize field-1))) ;; gcc -> Gcc
+ (field-info (or info
+ (tinymail-complete-string-read)))
+ multi-word
+ complete-list
+ tmp
+ choices
+ string
+ ret)
+ (unless fid ;; No-op. XEmacs byte compiler silencer
+ (setq fid nil))
+ ;; The EVAL-FORM may set this if it does not return `choices'
+ (setq tinymail-:complete-key-return-value nil)
+ ;; The STRING is dynamically bound and visible for EVAL CHOICES
+ (when (stringp (setq string (nth 2 field-info)))
+ (setq choices (tinymail-header-complete-choices field)))
+ (tinymail-debug fid
+ 'INFO info
+ 'FIELD field
+ 'STRING string
+ 'CHOICES choices)
+ ;; ............................................... check choices ...
+ (when choices
+ (cond
+ ((null string) ;; Empty field, user expects all completions
+ (setq string (completing-read
+ (concat field ": ")
+ (ti::list-to-assoc-menu choices)))
+ (unless (ti::nil-p string)
+ (insert string)
+ (setq ret t)))
+ (t
+ (setq choices (ti::list-to-assoc-menu choices))
+ ;; Forget choices that are multiwords "val val"
+ (unless (string-match " " string)
+ (setq complete-list (all-completions string choices))
+ ;; This is the common string at the beginning
+ (setq tmp (try-completion string choices))
+ (tinymail-debug fid
+ 'COMPLETE-LIST complete-list
+ 'TRY tmp
+ 'str string)
+ (dolist (completion complete-list)
+ (when (string-match " " completion)
+ (setq multi-word t)
+ (return)))
+ ;; ....................................... completion-list ...
+ (cond
+ ((null complete-list)
+ (message "TinyMail: no simple completions matching `%s'" string))
+ ((or (and (eq 1 (length complete-list)) ;; ONE found
+ (setq string (car complete-list))) ;; that's it
+ (and tmp
+ ;; Don't accept partial match from "Multi Word"
+ ;; completion strings.
+ multi-word
+ (not (ti::nil-p
+ (setq string
+ (completing-read
+ "Complete: "
+ (ti::list-to-assoc-menu complete-list)
+ nil
+ nil
+ ;; initial value
+ tmp))))))
+ (tinymail-complete-insert-completion string info)
+ (setq ret t))
+
+ ((and tmp (not (string= tmp string)))
+ ;; there was common denominator, complete further
+ (tinymail-complete-insert-completion tmp info)
+ (message "Tinymail complete: %s"
+ (ti::list-to-string complete-list ", " ))
+ (setq ret t))
+ (complete-list
+ (let (ret)
+ (setq ret (completing-read
+ (concat field ": ")
+ (ti::list-to-assoc-menu complete-list)
+ nil
+ nil
+ string))
+ (unless (ti::nil-p ret)
+ (tinymail-complete-insert-completion ret info)))
+ ;; More than 1, stop and return t
+ (setq ret t)))))))
+ (tinymail-debug fid
+ "RET" ret
+ "GLOBAL COMPLETE VALUE"
+ tinymail-:complete-key-return-value)
+ ;; Return status if we did something in this function
+ (or ret
+ tinymail-:complete-key-return-value))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-complete-guest-packages (&optional arg)
+ "Support minor modes like tinytab and tinyindent which also use TAB key.
+Ignore ARG."
+ (interactive "P")
+ (let* ((fid "tinymail-complete-guest-packages:")
+ (ch last-command-char))
+ (unless fid ;; No-op. XEmacs byte compiler silencer
+ (setq fid nil))
+ (tinymail-debug fid 'ARG arg 'MODE major-mode 'POINT (point))
+ ;; The TinyTab minor mode overrides tab, return nil
+ ;; so that it can proceed
+ (cond
+ ((and (featurep 'tinytab)
+ (symbol-value 'tinytab-mode)
+ (fboundp 'tinytab-tab-key))
+ (tinymail-debug fid 'tinytab-tab-key tinytab-:tab-insert-hook)
+ (ti::funcall 'tinytab-tab-key))
+ ((and (featurep 'tinyindent)
+ (symbol-value 'tinyindent-mode)
+ (fboundp 'tinyindent-tab-key))
+ (tinymail-debug fid 'tinyindent-tab-key)
+ (ti::funcall 'tinyindent-tab-key))
+ (t
+ (when ch
+ (self-insert-command 1)
+ t)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-complete-list-passwd (&optional mode data force)
+ "Return list of matches from password file.
+
+Input:
+
+ MODE is the value of `tinymail-:complete-mode'.
+ DATA can contain values returned from `tinymail-complete-string-read'."
+ (let* ((fid "tinymail-complete-list-passwd")
+ str
+ table
+ completions)
+ (unless fid ;; No-op. XEmacs byte compiler silencer
+ (setq fid nil))
+ (when (or data
+ (setq data (tinymail-complete-string-read)))
+ (setq str (regexp-quote (nth 2 data))))
+ (if (or force
+ (null tinymail-:password-completion-alist))
+ (tinymail-password-define-variables))
+ (setq table tinymail-:password-completion-alist)
+ (setq completions (all-completions str table))
+ (tinymail-debug fid str "COMPLETIONS" completions)
+ completions))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-display-list (list &optional flash)
+ "Display LIST or alist in `tinymail-:temp-buffer' or FLASH in echo area."
+ (when list
+ (if flash
+ (message (ti::list-to-string (mapcar 'car list)))
+ (let* ((buffer (ti::temp-buffer tinymail-:temp-buffer 'clear)))
+ (with-current-buffer buffer
+ (dolist (elt list)
+ (insert (format "%-10s %s\n" (car elt) (or (cdr elt) "")))))
+ (display-buffer buffer)
+ (ti::save-excursion-macro ;; Go and make displayed buffer small
+ (select-window (get-buffer-window buffer))
+ (shrink-window-if-larger-than-buffer))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-password-grep (match &optional verb)
+ "Grep USER from passwd.
+
+Input:
+
+ MATCH String, to grep
+ DISPLAY flag, display results in separate buffer.
+ VERB flag, Verbose messages"
+ (interactive "sUser regexp: ")
+ (let ((fid "tinymail-password-grep")
+ alist)
+ (unless fid ;; No-op. XEmacs byte compiler silencer
+ (setq fid nil))
+ (ti::verb)
+ (tinymail-debug fid match verb)
+ (if (null tinymail-:password-alist)
+ (tinymail-password-define-variables))
+ ;; Force loading it if not exist
+ (if verb (message "Grepping passwd contents..."))
+ (setq alist (ti::file-passwd-grep-user-alist
+ match nil tinymail-:password-alist))
+ (if verb (message "Grepping...done"))
+ alist))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-complete-headers-move-to-next-field (&rest ignore)
+ "Move to next field if cursor is at the end of field in header."
+ (interactive)
+ (ti::mail-point-in-header-macro
+ (let* ((str (buffer-substring (line-beginning-position) (point)))
+ (max (ti::mail-text-start)))
+ (when (and (not (ti::nil-p str))
+ (eolp))
+ (when (re-search-forward ":." max t)
+ (end-of-line))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-complete-headers-nothing-found (&rest ignore)
+ "Display 'No completions found' in header and return t. IGNORE arguments.
+Advance by 4 spaces if there is only spaces to the left."
+ (interactive)
+ (ti::mail-point-in-header-macro
+ ;; User started a continuing line. Point is at mark (!)
+ ;;
+ ;; CC: some@example.com
+ ;; !
+ ;; To: him@there.at
+ ;;
+ (cond
+ ((or (ti::nil-p (buffer-substring (line-beginning-position) (point)))
+ (char-equal (char-syntax (preceding-char)) ?\ ))
+ (insert " "))
+ ((ti::mail-point-at-header-p)
+ ;; this message is displayed only when cursor is next to character
+ ;; (forward-word 1)
+ (message "TinyMail: No completions found.")
+ t)
+ (nil))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-complete-abbrevs (&optional info)
+ "Complete using abbrevs. INFO."
+ ;; Actually we don't need this because SPACE already expands abbrevs
+ ;; if abbrev mode is on.
+ ;; (expand-abbrev)
+ nil)
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-complete-key-remove-itself ()
+ "Remove calls from `tinytab-:tab-insert-hook'. See
+Source code of `tinymail-complete-key' why. "
+ ;; In calling function this variable is `let' bound, so the
+ ;; change is temporary.
+ (let (clean-hook)
+ (when (boundp 'tinytab-:tab-insert-hook)
+ (dolist (function tinytab-:tab-insert-hook)
+ (if (not (string-match "tinymail"
+ (or (symbol-name function) "")))
+ (push function clean-hook)))
+ (setq tinytab-:tab-insert-hook (nreverse clean-hook)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-tab-to-tab-stop (&rest args)
+ "Ignore ARGS and call `tab-to-tab-stop'."
+ (tab-to-tab-stop))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-complete-key (&optional header-check)
+ "Run functions in `tinymail-:complete-key-hook'.
+Te first function that return non-nil terminates calling the rest of the
+functions. Each function is passed the word info at point: '(BEG END STRING)."
+ (interactive)
+ (tinymail-debug 'tinymail-complete-key
+ 'BEGIN
+ tinymail-:complete-key-hook)
+ ;; It makes no use to call this function anywhere elase than in Mail
+ ;; buffer. (this prevent's double call from tinytab.el too)
+ (when (ti::mail-mail-p)
+ (tinymail-debug 'tinymail-complete-key
+ 'HEADER-CHECK header-check
+ (save-excursion
+ (concat "\n************ START **********\n"
+ (buffer-substring
+ (progn (forward-line -2) (point))
+ (progn (forward-line 2) (point)))
+ "\n************ END **********\n")))
+ (let* ((fid "tinymail-complete-key:")
+ ;; Make copies of these
+ (tinytab-:tab-insert-hook
+ (if (boundp 'tinytab-:tab-insert-hook)
+ (symbol-value 'tinytab-:tab-insert-hook)))
+ (tinymail-:complete-key-hook tinymail-:complete-key-hook)
+ string
+ ret)
+ (unless fid ;; No-op. XEmacs byte compiler silencer
+ (setq fid nil))
+ ;; Avoid resursive calls by removing all tinymail entries
+ (tinymail-complete-key-remove-itself)
+ ;; It doesn't make sense to run mail completions inside BODY,
+ ;; remove unnecessary hooks
+ (cond
+ ((ti::mail-point-at-body-p)
+ (tinymail-debug 'tinymail-complete-key 'POINT-INSIDE-BODY)
+ ;; Leaves
+ ;;
+ ;; tinymail-complete-abbrevs
+ ;; tinymail-complete-guest-packages
+ (ti::add-hooks 'tinymail-:complete-key-hook
+ '(tinymail-complete-everything
+ tinymail-complete-simple
+ tinymail-complete-guess-in-headers
+ tinymail-complete-headers-nothing-found
+ tinymail-complete-headers-move-to-next-field)
+ 'remove)
+ (cond
+ ((and (boundp 'tinytab-mode)
+ tinytab-mode
+ (fboundp 'tinytab-indent-by-tab-width))
+ (add-hook 'tinymail-:complete-key-hook
+ 'tinytab-indent-by-tab-width))
+ (t
+ (add-hook 'tinymail-:complete-key-hook
+ 'tinymail-tab-to-tab-stop)))
+ (tinymail-debug fid 'BODY-AREA tinymail-:complete-key-hook))
+ (t
+ (tinymail-debug 'tinymail-complete-key 'POINT-INSIDE-HEADER)
+ (setq string (tinymail-complete-string-read))
+ ;; Complete only in CC, Bcc, To .. fields. If not there,
+ ;; remove function
+ (when (and header-check
+ (not (ti::mail-field-email-address-p)))
+ (tinymail-debug 'tinymail-complete-key 'NOT-IN-TO-CC-BCC)
+ (tinymail-debug fid 'header-check 'REMOVED
+ 'tinymail-complete-everything)
+ (remove-hook 'tinymail-:complete-key-hook
+ 'tinymail-complete-everything))))
+ ;; .................................................... cond-end ...
+ (tinymail-debug fid 'LOOPING-LIST tinymail-:complete-key-hook)
+ (dolist (func tinymail-:complete-key-hook)
+ (tinymail-debug fid 'FUNC func string)
+ (when (cond
+ ((not (fboundp func))
+ (tinymail-debug fid 'FUNC func "not exist")
+ nil)
+ (t
+ (funcall func string)))
+ (setq ret t)
+ (return)))
+ (tinymail-debug fid fid 'RET ret)
+ ret)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-complete-key-interactive ()
+ "See `tinymail-complete-key'. Comlete only in header."
+ (interactive)
+ (tinymail-complete-key 'only-complete-in-headers))
+
+;;}}}
+;;{{{ advice
+
+;;; .......................................................... &advice ...
+
+;; Old message has autosave name "*message*", but that does not work in
+;; Win32 platform (C-x m M-x message-mode and C-x s and Emacs
+;; dies on error)
+
+(when (ti::win32-p)
+ (require 'message)
+ (if (string-match
+ "[*]message"
+ (prin1-to-string
+ (symbol-function 'message-set-auto-save-file-name)))
+ (defadvice message-set-auto-save-file-name (around tinymail act)
+ "\
+Replace function. Change the autosave name from *message* to #message# due to Win32"
+ (when message-auto-save-directory
+ (if (gnus-alive-p)
+ (setq message-draft-article
+ (nndraft-request-associate-buffer "drafts"))
+ (setq buffer-file-name
+ (expand-file-name "#message#"
+ message-auto-save-directory))
+ (setq buffer-auto-save-file-name (make-auto-save-file-name)))
+ (clear-visited-file-modtime)
+ (setq buffer-file-coding-system message-draft-coding-system)))))
+
+;;}}}
+;;{{{ Extra
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-save-dead-mail-maybe ()
+ "Call `tinymail-save-dead-mail' only if RMAIL is used as MUA.
+All other Agents have some sort of 'todo' message save feature."
+ ;; VM after sending, keeps the corresponding mail
+ ;; buffer which implies that the dead letter facility
+ ;;
+ ;; Gnus has also Gcc feature; but we can't know if User uses it for mail?
+ ;; User may only read News.
+ (when (featurep 'rmail)
+ (tinymail-save-dead-mail)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-save-dead-mail ()
+ "Save mail buffers to `tinymail-:dead-mail-file' on Emacs exit."
+ (ti::dolist-buffer-list
+ (memq major-mode '(mail-mode
+ message-mode))
+ 'loop-temp-buffers
+ nil
+ (progn
+ ;; In message.el is possible to "save a draft" in normal manner:
+ ;; C-x C-s. If the mail buffer has already been saved, we ignore
+ ;; that buffer.
+ (when (buffer-modified-p)
+ (set-buffer-modified-p nil) ;"no changes in this buffer"
+ (append-to-file
+ (point-min)
+ (point-max)
+ tinymail-:dead-mail-file)))))
+
+;;}}}
+
+;;{{{ Email notification (old Dragbar Time package)
+
+;;; ...................................................... &reportmail ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-report-get-email-word (str)
+ "Return first word, separated by space from STR."
+ (let* ((word str)) ;set default
+ (when (string-match "From \\([^ ]+\\) " str)
+ (setq word (substring str (match-beginning 1) (match-end 1))))
+ word))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-report-break-email (str)
+ "Break email STR into two words.
+Return:
+ (ACCOUNT SITE) or nil"
+ (let* (w1
+ w2
+ ret)
+ (when (string-match "[@!]" str)
+ (setq w1 (substring str 0 (match-beginning 0))
+ w2 (substring str (1+ (match-beginning 0))))
+ ;; Some sites has "from" command that sends the info in format:
+ ;; "From site.com!login Mon Feb 26 15:50:18 1996"
+ ;;
+ ;; And not in traditional format
+ ;; "From login@site.com Mon Feb 26 15:50:18 1996"
+ ;;
+ ;; We have to swap the order
+ (cond
+ ((string-match "!" str)
+ ;; then swap order, since word1 = site, w2 = account
+ (setq ret (list w2 w1)))
+ (t
+ (setq ret (list w1 w2)))))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-report-mail-info-1 (shell-call)
+ "Run SHELL-CALL to get information about arrived mail.
+
+Input:
+
+ SHELL-CALL If string, run `shell-command'.
+
+ If function, call function with no arguments.
+
+ Otherwise eval it.
+
+ The SHELL-CALL must return Mailbox From information
+ to current empty buffer. Oldest entries first, newest last.
+
+Return:
+
+ list (line line ..) Berkeley MBOX 'From ' lines. Oldest first.
+ nil No new mail"
+ (let* ((default-directory default-directory)
+ (buffer (get-buffer-create tinymail-:report-spool-buffer))
+ (kill-p (eq tinymail-:report-spool-buffer-control 'kill))
+;;; #todo: not yet used
+;;; (timeout tinymail-:report-asychronous-timeout)
+ (tmp-dir "/tmp/")
+ (kill-re tinymail-:report-mail-kill-line-regexp)
+ ret)
+ (unwind-protect
+ (with-current-buffer buffer
+ (erase-buffer)
+ ;; - launch up the process and restore the directory setting
+ ;; - The output is like:
+ ;;
+ ;; From aa@zig.com Thu May 11 19:05:36 EET 1995
+ ;; From bb@zag.com.edu Thu May 11 18:55:59 EET 1995
+ (setq default-directory tmp-dir)
+ (cond
+ ((stringp shell-call)
+ (shell-command shell-call buffer))
+ ((fboundp shell-call)
+ (funcall shell-call))
+ (t
+ (eval shell-call)))
+ (when (stringp kill-re)
+ (ti::pmin)
+ (flush-lines kill-re))
+ (unless (eq (point-min) (point-max)) ;No output ?
+ ;; - Now read persons email delimited by spaces
+ ;; - Read the last line to get newest mail arrival
+ (ti::pmin)
+ (while (not (eobp))
+ (push (ti::read-current-line) ret)
+ (forward-line 1))))
+ ;; Unwind
+ (when (and kill-p (buffer-live-p (setq buffer (get-buffer buffer))))
+ (with-current-buffer buffer
+ (set-buffer-modified-p nil)) ;No confirmations
+ (kill-buffer buffer)))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-report-mail-info ()
+ "Run `tinymail-:report-mail-notify-program'."
+ (and tinymail-:report-mail-notify-program
+ (tinymail-report-mail-info-1 tinymail-:report-mail-notify-program)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-report-get-mail-info-string ()
+ "Return mail string: last sender and mail count."
+ (let* ((list (tinymail-report-mail-info))
+ (re tinymail-:report-mail-info-shorten-regexp)
+ (ret tinymail-:report-no-mail-string)
+ last-line
+ email
+ count)
+ (tinymail-debug 'tinymail-report-get-mail-info-string list)
+ (cond
+ ((ti::listp list)
+ (setq count (length list)
+ last-line (car (nreverse list))
+ email (tinymail-report-get-email-word last-line))
+ ;; does user want shortened version ?
+ (when (and (stringp re) ;no regexp
+ (string-match re email)
+ (setq list (tinymail-report-break-email email)))
+ (setq email (nth 0 list)))
+ (setq ret (concat " " email " " (number-to-string count))))
+ ((not (null list))
+ (message "TinyMail: *** tinymail-report-mail-info didn't return list")))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun turn-on-tinymail-report-mail (&optional verb)
+ "Call `tinymail-report-mail-install-maybe'."
+ (ti::verb)
+ (tinymail-report-mail-install-maybe verb))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun turn-off-tinymail-report-mail (&optional verb)
+ "Call `tinymail-report-mail-install' with prefix argument."
+ (interactive)
+ (ti::verb)
+ (tinymail-report-mail-install 'uninstall verb))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-report-update (&rest args)
+ "Update mail status information.
+Update the frame's status line, or in non-X show the message in echo area.
+ARGS are ignored."
+ (let* ((buffer (and (stringp tinymail-:report-spool-buffer)
+ (get-buffer-create tinymail-:report-spool-buffer)))
+ (raise (and buffer
+ (eq tinymail-:report-spool-buffer-control 'raise)))
+ str
+ mail-info
+ display-string)
+ (when buffer
+ ;; Save the contents of frame name, e.g. host name only once
+ (if (and tinymail-:report-window-system
+ (null tinymail-:report-old-frame-string))
+ (setq tinymail-:report-old-frame-string
+ (ti::compat-set-frame-name nil nil 'get)))
+ (when (stringp (setq mail-info (tinymail-report-get-mail-info-string)))
+ (setq tinymail-:report-mail-info-string (format " %s " mail-info))
+ (setq display-string (eval tinymail-:report-format-string)))
+ (cond
+ ;; ..................................................... windowed ...
+ (tinymail-:report-window-system
+ (dolist (elt (frame-list)) ;Update frames that are not exluded
+ (if (not (member
+ (ti::compat-set-frame-name nil nil 'get)
+ tinymail-:report-keep-intact-list))
+ (ti::compat-set-frame-name display-string elt))))
+ ;; ...................................................... non-win ...
+ ;; Do nothing if this is nil, user doesn't want to see evel "No mail"
+ ;; message.
+ ((null mail-info))
+ ;; ................................................. non-windowed ...
+ (t
+ (if (and (stringp tinymail-:report-no-mail-string)
+ (not (string= mail-info tinymail-:report-no-mail-string)))
+ (setq str "Mail: "))
+ (cond
+ ((and (not (ti::compat-executing-macro))
+ ;; printing message while user is in minibuffer
+ ;; makes it impossible to see what he's doing.
+ (not (eq (selected-window) (minibuffer-window)))
+ (sit-for 0.50))
+ (message "%s%s" (or str "") display-string)
+ ;; make sure user sees it
+ (sleep-for 1)))))
+ ;; .......................................................... beep ...
+ ;; Notify about new mail ?
+ (unless (stringp tinymail-:report-old-mail-info-string)
+ (setq tinymail-:report-old-mail-info-string
+ tinymail-:report-no-mail-string))
+;;; (ti::d!! mail-info tinymail-:report-no-mail-string tinymail-:report-old-mail-info-string "\n")
+ (when (and (stringp mail-info)
+ (stringp tinymail-:report-no-mail-string)
+ (not (string= mail-info
+ tinymail-:report-no-mail-string))
+ (not (string= mail-info
+ tinymail-:report-old-mail-info-string)))
+ (setq tinymail-:report-old-mail-info-string mail-info)
+ (beep)
+ (sit-for 0.15)
+ (beep)
+ (if raise
+ (display-buffer buffer)))
+ (setq tinymail-:report-old-mail-info-string mail-info))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-report-mail-install (&optional uninstall verb)
+ "Install or UNINSTALL mail watchdog (report mail).
+References:
+ `tinymail-:report-window-system'"
+ (interactive "P")
+ (ti::verb)
+ (if (featurep 'reportmail)
+ (message "\
+TinyMail: tinymail-report-mail-install: 'reportmail feature found, install ignored.")
+ (let* (process-connection-type) ;Nicer process communication
+ (if tinymail-:display-time
+ (display-time))) ;; time.el
+ ;; In XEmacs the frame must be configured by hand
+ (when (and tinymail-:report-window-system (ti::xemacs-p))
+ ;; make sure it's list
+ (setq frame-title-format (ti::list-make frame-title-format))
+ (if uninstall
+ (delete 'tinymail-:report-mail-info-string frame-title-format)
+ (pushnew 'tinymail-:report-mail-info-string
+ frame-title-format
+ :test 'equal)))
+ ;; Delete old timer
+ (ti::compat-timer-cancel-function 'tinymail-report-update)
+ (setq tinymail-:report-timer-object nil)
+ (unless uninstall
+ (setq tinymail-:report-timer-object
+ (run-at-time "1 min" (* 60 10) 'tinymail-report-update)))
+ (when verb
+ (message "TinyMail: Report mail feature is %s"
+ (if uninstall
+ "OFF"
+ "ON")))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-report-mail-install-maybe (&optional uninstall verb)
+ "Don't call `tinymail-report-mail-install' if there already exists reporter.
+E.g. in XEmacs you can use package reportmail.el."
+ (interactive "P")
+ (ti::verb)
+ (cond
+ ;; #todo: Any other report features we should check?
+ ((featurep 'reportmail)
+ (message "TinyMail: reportmail.el present, not installing."))
+ (t
+ (tinymail-report-mail-install uninstall verb))))
+
+;;}}}
+;;{{{ From-address generator (sendmail PLUS emulation)
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-from-anti-ube-maybe ()
+ "Return anti-ube address if `newsgroups' match `tinymail-:from-anti-ube-regexp'"
+ (when (and (stringp tinymail-:from-anti-ube-regexp)
+ (stringp user-mail-address)
+ user-mail-address)
+ (let* ((group (mail-fetch-field "Newsgroups")))
+ (when (string-match tinymail-:from-anti-ube-regexp
+ (or group ""))
+ ;; - Because the anti-ube returns different email every
+ ;; time it is called, cache the first value.
+ ;; - The changing value would otherwise cause indication
+ ;; "Headers have changed".
+ (make-local-variable 'tinymail-:user-mail-address)
+ (let ((addr (or tinymail-:user-mail-address
+ (ti::mail-email-make-anti-spam-address
+ user-mail-address))))
+ (setq tinymail-:user-mail-address addr)
+ addr)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-from-field-value-plus ()
+ "Return special plus address emulation (RFC Comment)."
+ (let* ((fid "tinymail-from-field-value-plus:")
+ (news (mail-fetch-field "newsgroups"))
+ (prefixes tinymail-:from-table-prefix)
+ (postfixes tinymail-:from-table-postfix)
+ ;; Posting from Gnus, so get the Group name
+ ;;
+ ;; backend:mail.xxx --> mail.xxx
+ (grp (ti::mail-news-group))
+ (group (and (stringp grp)
+ (eq major-mode 'message-mode)
+ (or (ti::string-match ":\\(.*\\)" 1 grp)
+ grp)))
+ prefix
+ postfix
+ ret
+ msg-postfix
+ condition)
+ (unless fid ;; No-op. XEmacs byte compiler silencer
+ (setq fid nil))
+ (cond
+ ;; ............................................... news followup ...
+ (news
+ ;; Direct some mesages to my "mail" group, others to
+ ;; general usenet group.
+ (setq prefix (cdr-safe (ti::list-find prefixes news )))
+ (setq postfix "")) ;; (cdr-safe (ti::list-find prefixes news )))
+ (group
+ ;; If posting from inside Group, add Group based PLUS address
+ ;;
+ ;; list.xxx --> '("list" "xxx")
+ ;; For Imap folders; INBOX.list.foo => list.foo
+ (when (string-match "INBOX\\.\\(.+\\)" group)
+ (setq group (match-string 1 group)))
+ (setq prefix (ti::string-match "^\\([^.]+\\)" 1 group)
+ postfix (ti::string-match "\\.\\(.+\\)" 1 group))))
+ ;; ................................ according to message content ...
+ (setq msg-postfix
+ (save-excursion
+ (dolist (elt postfixes)
+ (ti::mail-text-start 'move)
+ (setq condition (car elt))
+ (when (if (stringp condition)
+ (re-search-forward condition nil t)
+ (setq ret (funcall condition)))
+ (unless ret
+ (tinymail-debug fid 'point (point) 'LOOP-SELECT elt )
+ (setq ret (cdr elt)))
+ (return)))
+ ret))
+ ;; ............................................... guess mail type ...
+ ;; If not yet set, look at message and decide right postfix
+ (setq ret
+ (cond
+ (msg-postfix ;Always obey this
+ msg-postfix)
+ ((and (ti::nil-p prefix) postfix)
+ postfix)
+ ((and (ti::nil-p postfix) prefix)
+ prefix)
+ ((and prefix postfix)
+ (concat prefix "." postfix))))
+ (tinymail-debug fid 'ret ret
+ 'NEWS news
+ 'GROUP group
+ 'msg-postfix msg-postfix
+ 'prefix prefix 'postfix postfix )
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-from-field-value ()
+ "Make From Address.
+
+References:
+
+ `user-full-name'
+ `user-mail-address'
+ `tinymail-:from-info-function'
+ `tinymail-:from-field-plus-separator'"
+ (interactive)
+ (let* ((fid "tinymail-from-field-value:")
+ (separator tinymail-:from-field-plus-separator)
+ (info (and (fboundp tinymail-:from-info-function)
+ (funcall tinymail-:from-info-function)))
+ (address (or (and (listp info)
+ (nth 0 info))
+ (tinymail-from-anti-ube-maybe)
+ (or (stringp user-mail-address)
+ (error
+ "TinyMail: Please set `user-mail-address'."))))
+ (name (or (user-full-name)
+ (error "TinyMail: Please set `user-full-name'")))
+ (plus (or (and (listp info)
+ (nth 1 info))
+ (tinymail-from-field-value-plus)))
+ localpart
+ domain
+ ret)
+ (unless fid ;; No-op. XEmacs byte compiler silencer
+ (setq fid nil))
+ ;; With procmail you can have plus addresses:
+ ;;
+ ;; login+additional-info@site.com
+ ;;
+ ;; But you can accomplish the same with RFC comment syntax
+ ;;
+ ;; login@site.com (Foo Bar+additional-info)
+ ;;
+ ;; The extra "+" is just added there to mark that this is
+ ;; PLUS addess.
+ (cond
+ ((and (not (ti::nil-p plus))
+ (not (ti::nil-p name)))
+ (setq plus (format " (%s%s%s)" name separator plus )))
+ ((not (ti::nil-p name)) ;If no plus info, use normal address
+ (setq plus (format " (%s)" name))))
+ (when (stringp address)
+ (setq localpart (or (ti::string-match "^[^@]+" 0 address) "")
+ domain (or (ti::string-match "@.*" 0 address) ""))
+ ;; RFC 1036/2.1.1 Says that following address formats are preferred in
+ ;; USENET posts
+ ;;
+ ;; From: mark@cbosgd.ATT.COM
+ ;; From: mark@cbosgd.ATT.COM (Mark Horton)
+ ;; From: Mark Horton <mark@cbosgd.ATT.COM>
+ (setq ret (format "%s%s%s" localpart domain (or plus "") )))
+ (tinymail-debug fid
+ 'info-function tinymail-:from-info-function
+ 'info info
+ 'localpart localpart
+ 'domain domain
+ 'name
+ 'RETURN ret)
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-message-disable-sender ()
+ "Disable Sender field generation permanently."
+ ;; Gnus message-mode
+ ;; Don't generate Sender address, but trust From address
+ (interactive)
+ (when (boundp 'message-syntax-checks)
+ (let* ((syntaxes (and (boundp 'message-syntax-checks)
+ (symbol-value 'message-syntax-checks)))
+ ;; Gnus Group / Agent J S comamdn set this to
+ ;; value 'dont-check-for-anything-just-trust-me
+ ;; => skip any checks
+ (list-p (ti::listp syntaxes))
+ (pointer (and list-p
+ (assq 'sender syntaxes))))
+ (when list-p
+ (if pointer
+ (setcdr pointer 'disabled)
+ (add-to-list 'message-syntax-checks '(sender . disabled)))))))
+
+;;}}}
+
+;;{{{ code: Cc, X-Sender-Info
+
+;;; ............................................................. &fld ...
+
+(defun tinymail-field-cc-kill-by-regexp ()
+ "Kill entry from CC field that match `my-:email-regexp'"
+ ;; don't touch CC field if user has put two spaces in front.
+ (when (and (mail-fetch-field "CC")
+ (not (tinymail-field-off-p "CC"))
+ (stringp tinymail-:cc-kill-regexp))
+ (let* ((cc (mail-fetch-field "cc"))
+ (cc-list (and cc (split-string cc ",[ \t\n]*")))
+ (count 0)
+ ccl)
+ (when cc-list
+ (dolist (elt cc-list)
+ (unless (string-match tinymail-:cc-kill-regexp elt)
+ (incf count)
+ (setq ccl (format "%s\n %s," (or ccl "") elt))))
+
+ (when (and cc-list (not (stringp ccl)))
+ (ti::mail-kill-field "^CC")) ;All CC memebers killed. Wipe field
+
+ (when (and (stringp ccl)
+ (not (eq count (length cc-list)))) ;items removed
+ ;; delete leading \n and trailing comma
+ (setq ccl (substring ccl 1 (1- (length ccl))))
+ (ti::mail-kill-field "^CC" ccl)
+ ;; we did something
+ t)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-field-in-to-cc-p ()
+ "Check if point is at field To, Bcc, Cc."
+ (and (< (point) (ti::mail-hmax))
+ (save-excursion
+ (and (ti::mail-next-field-start 'move 'back)
+ (looking-at "CC\\|BCC\\|To")))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-field-to-move-maybe ()
+ "Move cursor to the end of TO field if it is empty."
+ (when (save-excursion (beginning-of-line) (looking-at "To: *$"))
+ (end-of-line)
+ (tinymail-debug "TO-move:" (ti::read-current-line) (point))))
+
+;;}}}
+;;{{{ code: Fcc handling
+
+;;; ......................................................... &fld-fcc ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-field-fcc-determine (&optional type hsize)
+ "Look if default folder must be changed.
+Tries to find RE given in `tinymail-:table-fcc' by looking at header area.
+
+Input:
+
+ TYPE nil: Find Fcc folder. 'gcc: Find Gcc folder.
+ HSIZE The header size precalculated.
+
+Return:
+
+ string suggested folder
+ nil"
+ (let* ((fid "tinymail-field-fcc-determine: ")
+ (ptr (if type
+ tinymail-:table-gcc
+ tinymail-:table-fcc))
+ (sym (if type 'gcc 'fcc))
+ (get-hsize (get 'tinymail-:table-fcc 'hsize))
+ (get-sym (get 'tinymail-:table-fcc sym))
+ hmax
+ ret
+ re
+ folder)
+ (unless fid ;; No-op. XEmacs byte compiler silencer
+ (setq fid nil))
+ (or hsize
+ (setq hsize (ti::mail-header-area-size)))
+ (tinymail-debug fid "IN"
+ "SYM" sym
+ "HSIZE" hsize
+ "GET HSIZE" get-hsize
+ "GET SYM" get-sym)
+ (when (not (and (eq hsize get-hsize)
+ ;; Previous folder value
+ (setq ret get-sym)))
+ ;; Header are has changed; calculate new field and update values
+ (put 'tinymail-:table-fcc 'hsize hsize)
+ (put 'tinymail-:table-fcc sym nil)
+ (when (setq hmax (ti::mail-hmax)) ;header end must be found
+ (save-excursion
+ (ti::pmin)
+ (dolist (elt ptr)
+ (setq re (nth 0 elt)
+ folder (nth 1 elt))
+ (when (re-search-forward re hmax t)
+ (setq ret folder)
+ (return)))))
+ (if (and (stringp ret)
+ (string-match "gz$\\|Z$" ret))
+ (ti::use-file-compression))
+ (put 'tinymail-:table-fcc sym ret)
+ (tinymail-debug fid "SET hmax" hmax "ret" ret "re" re))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-field-fcc (&optional type hsize)
+ "Set right [GF]cc folder if there is match in `tinymail-:table-[gf]cc'.
+
+Input:
+
+ TYPE nil: Find Fcc folder. 'gcc: Find Gcc folder.
+ HSIZE The header size precalculated."
+ (let* ((fid "tinymail-field-fcc: ")
+ fld
+ sym
+ str
+ folder
+ prev)
+ (unless fid ;; No-op. XEmacs byte compiler silencer
+ (setq fid nil))
+ (tinymail-debug fid "in TYPE" type "HSIZE" hsize)
+ (or hsize
+ (setq hsize (ti::mail-header-area-size)))
+ (cond
+ (type (setq fld "GCC" sym 'gcc-old))
+ (t (setq fld "FCC" sym 'fcc-old)))
+ (setq prev (get 'tinymail-:table-fcc sym))
+ (setq folder (tinymail-field-fcc-determine type hsize))
+ (tinymail-debug fid fld type hsize
+ "PREV-FLD" prev
+ "FLD" folder
+ "CHECK" (if folder
+ (ti::re-search-check (regexp-quote folder)))
+ "MODE" major-mode)
+
+ (when (and (stringp folder)
+ (or (not (stringp prev))
+ (not (ti::re-search-check (regexp-quote folder)))
+ (not (string-match (regexp-quote prev) folder)))
+ (setq str (mail-fetch-field fld))
+ (not (tinymail-field-off-p nil str)))
+ (put 'tinymail-:table-fcc sym folder)
+ (ti::save-line-column-macro nil nil
+ (tinymail-debug fid "SET" folder (current-buffer))
+ (ti::mail-kill-field (concat "^" fld) folder)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-field-to-off (&optional count field)
+ "Disable TinyMail by space COUNT for FIELD.
+2 spaces disables Cc tracking
+3 spaces disables both Cc and other tracking."
+ (let* (str)
+ (setq str (make-string (or count 2) ?\ ))
+ (setq field (or field "to"))
+ (tinymail-debug "tinymail-field-to-off, count, field" count field)
+ (save-excursion
+ (ti::pmin)
+ (when (re-search-forward
+ (concat "^" field ":\\([ \t]*\\)")
+ (ti::mail-hmax)
+ t)
+ (if (match-beginning 1)
+ (ti::replace-match 1 str) ;There is spaces
+ (insert str)) ;There is no spaces
+ t))
+ (tinymail-field-to-move-maybe)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-field-to-on ()
+ "Keep activated by making sure the To: field has only one space."
+ (tinymail-debug "tinymail-field-to-on")
+ (tinymail-field-to-off 1))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinymail-on-off-toggle (&optional arg)
+ "Toggle TinyMail mode on and off by Changing spacing of To field.
+This affects automatic Cc and X-Sender-Info tracking.
+ARG behaves like mode argument.
+
+Without arg, this toggless Cc tracking, with prefix argument,
+it toggless both Cc and X-Sender-Info tracking."
+ (interactive "P")
+ (if arg
+ (setq arg 3)) ;3 spaces turn off completely.
+ (if (null arg)
+ (cond
+ ((save-excursion
+ (ti::pmin)
+ (re-search-forward "^to: " nil t))
+ (tinymail-field-to-on)
+ (message "TinyMail: mail field tracking mode on."))
+ (t
+ (tinymail-field-to-off arg)
+ (message "TinyMail: mail field tracking mode off.")))
+ (tinymail-field-to-off arg)
+ (message "TinyMail: mail field tracking mode off.")))
+
+;;}}}
+;;{{{ code: citation
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-iso8601-date-value ()
+ "Read Date field and return ISO 8601 date: WEEKDAY YYYY-MM-DD."
+ (let* ((date "")
+ yyyy
+ mm
+ dd
+ week-day)
+ (when (setq date (or (mail-fetch-field "date")
+ (and (featurep 'message)
+ message-reply-headers
+ (mail-header-date message-reply-headers))))
+ (setq date (ti::date-parse-date date))
+
+ (setq yyyy (nth 0 date)
+ mm (nth 1 date)
+ dd (nth 2 date)
+ week-day (nth 4 date))
+
+ (setq date
+ (format "%s%s%s%s"
+ (or week-day "")
+ (if yyyy (concat (if week-day " " "") yyyy))
+ (if (and yyyy mm) (concat "-" mm) "")
+ (if (and yyyy mm dd) (concat "-" dd) ""))))
+ date))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-citation-who-said (str)
+ "Formats sender line reference. Input is From/To field.
+
+Return:
+
+ str formatted line, without 'From:'
+ nil if cannot format"
+ (let ((limit (- 75 13)) ; line-lenght - date ==> limit
+ ;; Get the group name only when posting from GNUS
+ ;; gnus-group-real-name
+ (grp (replace-regexp-in-string
+ ".*:" "" (or (ti::mail-news-group) "")))
+ list
+ fn ; first name
+ sn ; surname
+ email
+ ret)
+ (setq ret str)
+ (when ret
+ ;; Remove quotes: "Mr. this" <email@example.com>
+ (setq ret (replace-regexp-in-string "['\"]+" "" ret))
+ ;; Remove Middle names: Foo X. Bar
+ (setq ret (replace-regexp-in-string " [A-Z]\\." "" ret)))
+ ;; If the line is exessive long, say;
+ ;; "Mr. Foo the most spectacular..." <foo@camel.com>
+ ;; Then we make it smaller.
+ (when (> (length ret) limit)
+ ;; Get only the email, and drop all others
+ (setq list (ti::mail-parse-name str))
+ (setq email (or (car-safe (ti::mail-email-from-string str)) ""))
+ (when list
+ (setq fn (nth 0 list) sn (nth 1 list)) ;; first/surname
+ ;; this should suffice
+ (setq ret (concat fn " " sn " <" email ">"))))
+ ;; Does the group name fit in too ?
+ (if (and grp
+ (< (+ (length ret) (length grp) 1) limit))
+ (setq ret (concat ret " " grp)))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-message-id-value ()
+ "Return Google group url."
+ (let ((id (mail-fetch-field "References")))
+ (and id
+ ;; There are several Message-Id's in a thread. Pick latest.
+ (setq id (car (nreverse (split-string id))))
+ (ti::string-match "<\\([^ \t\n>]+\\)>" 1 id))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-url-reference-google-group ()
+ "Return Google group url."
+ (let* ((id (tinymail-message-id-value))
+ (group (and id
+ (mail-fetch-field "Newsgroups"))))
+ (when (and (stringp group)
+ ;; See http://groups.google.com/
+ (string-match
+ group
+ (concat
+ "^\\(alt\\|biz\\|comp\\|humanities"
+ "\\|misc\\|news\\|rec\\|sci\\|soc\\|talk")))
+ (concat
+ ;; Old format was
+ ;; http://search.dejanews.com/msgid.xp
+ ;; ?MID=%3C3cgd8m0w.fsf@blue.sea.net%3E&format=threaded
+ ;;
+ "<http://groups.google.com/groups?oi=djq"
+ "&as_umsgid=%3C"
+ id
+ ">"))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-url-reference-mailing-list ()
+ "Return maling list URL refence."
+ (when (or (ti::mail-to-list-p)
+ (string-match
+ "^gmane"
+ (or (mail-fetch-field "Newsgroups") "")))
+ (let* ((id (tinymail-message-id-value)))
+ (concat "Message-Id: " id))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-message-id ()
+ "Return message id or empty.
+This function works best with Gnus:
+
+- Mailing lists replies contain Message-Id reference.
+ The mailing list status is indicated by Gnus group property `to-list'.
+- Newsgroup replies contain URL reference.
+- Private mail does _not_ include any extra references."
+ (let* ((url (or (tinymail-url-reference-google-group)
+ (tinymail-url-reference-mailing-list))))
+ (when (stringp url)
+ (concat "* " url "\n"))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-message-citation-line-function ()
+ "Generate citation line.
+
+ * Tue YYYY-MM-DD John Doe <johnd@example.com> mail.emacs
+ * Message-Id: <......>
+ | Thankyou for helping me...
+ | ...
+
+It is important to include the Message-Id reference because then it is
+possible to retrieve whole News thread e.g. from GOOGLE group. Message-Id is
+a handly way to refer to past articles."
+ (let* ((hdrs (if (boundp 'message-reply-headers)
+ (symbol-value 'message-reply-headers)))
+ (from (and hdrs (tinymail-citation-who-said
+ (mail-header-from hdrs))))
+ (date (tinymail-iso8601-date-value)))
+ (delete-horizontal-space)
+ (insert "* " date " " from "\n")
+ (let ((id (funcall tinymail-:citation-message-id-function)))
+ (when (stringp id)
+ (insert id)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-citation-generate ()
+ "Write reference line."
+ (if (eq major-mode 'message-mode)
+ (tinymail-message-citation-line-function)
+ (tinymail-citation-who-said (mail-fetch-field "From"))))
+
+;;}}}
+;;{{{ GPG + BBDB
+
+(defun tinymail-gpg-recipient ()
+ "Check BBDB field gnus-pgp for 'sign' and 'encrypt'."
+ (when (and (eq (major-mode 'message-mode)
+ (featurep 'bbdb)))
+ (when (and (not message-has-gpg)
+ (message-mail-p))
+ (let* ((to-field (mail-fetch-field "to"))
+ (components (mail-extract-address-components to_field t))
+ recipient)
+ (when (= (length components) 1)
+ ;; Only a single recipient
+ (setq recipient (nth 1 (car components)))
+ (let* ((record (bbdb-search-simple nil recipient))
+ gpg)
+ (when record
+ (setq gpg (bbdb-get-field record 'gnus-gpg)))
+ (when (> (length gpg) 0)
+ (cond
+ ((string= gpg "sign")
+ (mml-secure-message-sign-pgpmime))
+ ((string= gpg "encrypt")
+ (mml-secure-message-encrypt-pgpmime))))))))))
+
+;;}}}
+;;{{{ code: main
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-from-set-field (&optional from-field)
+ "Check FROM-FIELD and set From: unless it has two spaces in front."
+ (save-excursion
+ (let ((from (or from-field
+ (ti::mail-get-field-1 "From")))
+ str)
+ (tinymail-debug fid 'initial-from from-field)
+ (cond
+ ;; The field was there, if there in NO two spaces, replace
+ ;; the content with new dynamic value
+ ;;
+ ;; If used puts two spaces at from, he want to modify
+ ;; the field himself
+ ((and (stringp from)
+ (string-match "^ " from-field))
+ (tinymail-debug fid 'from-disabled-space))
+ ((stringp (setq str (tinymail-from-field-value)))
+ ;; Will create if not exists.
+ (mail-position-on-field "From")
+ (ti::mail-kill-field "^From" str))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-process-1 (&optional force)
+ "See `tinymail-process'. If FORCE is non-nil, run immediately.
+This function should be called interactive only when debugging errors:
+C-u M-x tinymail-process-1."
+ (interactive "P")
+ (let* ((fid "tinymail-process: ")
+ (last-to tinymail-:last-to-field)
+ (alias-alist (tinymail-mail-aliases))
+ to
+ from
+ hsize
+ ohsize)
+ (unless fid ;; No-op. XEmacs byte compiler silencer
+ (setq fid nil))
+ ;; - If "To:" field content has two spaces at front, this is signal
+ ;; to stay away.
+ ;;
+ ;; - If To address has remained the same, we do nothing.
+ ;; If we would aways go into expanding and killing the Cc,Fcc
+ ;; fields blindly, user would notice that while he was
+ ;; writing his message. Avoid that as much as posisble
+
+ (setq to (ti::remove-properties
+ (or (ti::mail-get-field-1 "To")
+ (ti::mail-get-field-1 "newsgroups")))
+ from (ti::remove-properties (ti::mail-get-field-1 "From"))
+ hsize (ti::remove-properties (ti::mail-header-area-size))
+ ohsize (get 'tinymail-:process-hook 'old-hsize))
+ ;; Record the values now so that they aren't calculated any more
+ (put 'tinymail-:process-hook 'from from)
+ (put 'tinymail-:process-hook 'to to)
+ (put 'tinymail-:process-hook 'new-hsize hsize)
+ (tinymail-debug fid "TO" to
+ "LAST-TO" last-to
+ "POST-hook" tinymail-:process-hook
+ "hsize" hsize ohsize
+ "MODE" major-mode)
+ (cond
+ ((or (not (stringp to))
+ (tinymail-field-off-p nil to))
+ nil) ;flag DISABLED
+ ((and (not (string= to last-to)) ;not same as previously ?
+ (not (ti::nil-p to)))
+ (save-excursion
+ (ti::mail-abbrev-expand-mail-aliases
+ (point-min) (ti::mail-hmax) alias-alist))
+ ;; what was expanded
+ (setq to (ti::mail-get-field "To"))))
+ (if tinymail-:from-field-enable-flag
+ (tinymail-from-set-field from))
+ ;; ............................................ header changed ...
+ (tinymail-field-cc-kill-by-regexp)
+ (when (not (eq hsize ohsize)) ;; Handle dynamic save to folders
+ (tinymail-field-fcc nil hsize)
+ (tinymail-field-fcc 'gcc hsize)
+ (tinymail-debug
+ fid
+ "Running post hook" tinymail-:process-hook
+ "MODE" major-mode)
+ (setq tinymail-:last-to-field to) ;update
+ (tinymail-debug fid "END" "MODE" major-mode))
+ ;; User's things now
+ (run-hooks 'tinymail-:process-hook)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-process-run-p ()
+ "Return t if `tinymail-process' is allowed to run."
+ (and (get-buffer-window (current-buffer))
+ ;; If buffer is not displayed, do nothing.
+ (not buffer-read-only)
+ (ti::mail-mail-p)
+ tinymail-mode))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymail-process (&optional force)
+ "Expand mail aliases and inserts additional info.
+
+optional FORCE argument causes running post hook now.
+
+If you take advantage of the `tinymail-:process-hook', please remember
+following
+
+- Your hook must run as fast as possible so that it won't disturb
+ writing the text.
+- You can peek contents of the precaculated values instead of reading
+ then again in the buffer
+
+ (get 'tinymail-:process-hook 'to to) ;; To field content
+ (get 'tinymail-:process-hook 'new-hsize) ;; Header size now
+ (get 'tinymail-:process-hook 'old-hsize) ;; old header size"
+ (when (or force
+ (and (tinymail-process-run-p)
+ ;; If this doesn't look like mail, don't bother
+ (ti::mail-mail-p)))
+ (condition-case error
+ (tinymail-process-1 force)
+ (error
+ (message "TinyMail: post-command error: %s
+Spot the error by turning on Emacs debug and calling
+(tinymail-process-1 'force) or C-u M-x tinymail-process-1"
+ (prin1-to-string error))
+ (ding)
+ (sit-for 5) ;Make sure user notices this ;
+ (message "TinyMail: (error watch) Please Check *Messages* buffer.")))))
+
+;;}}}
+
+(provide 'tinymail)
+(run-hooks 'tinymail-:load-hook)
+
+;;; tinymail.el ends here
--- /dev/null
+;;; tinymailbox.el --- Berkeley style aka std. mailbox browsing minor mode
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 1997-2007 Jari Aalto
+;; Keywords: tools
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program, call M-x tinymailbox-version.
+;; Look at the code with folding.el.
+
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;; ....................................................... &t-install ...
+;; Put this file on your Emacs-Lisp load path, add following into your
+;; ~/.emacs startup file. Code can be extracted with function
+;; tinylib.el/ti::package-rip-magic
+;;
+;; (add-hook 'tinymailbox-:load-hook 'tinymailbox-install)
+;; (require 'tinymailbox)
+;;
+;; Or you can also use the preferred way: autoload
+;;
+;; (add-hook 'tinymailbox-:load-hook 'tinymailbox-install)
+;; (autoload 'tinymailbox-mode "tinymailbox "" t)
+;; (autoload 'turn-on-tinymailbox-mode "tinymailbox "" t)
+;; (autoload 'turn-off-tinymailbox-mode "tinymailbox "" t)
+;;
+;; You can toggle the mode with `M-x' `tinymailbox-mode'. The default
+;; mailbox type files are liested in `tinymailbox-:auto-mode-alist'.
+;; To add more mailbox files for the mode, use code like:
+;;
+;; (require 'cl)
+;; (pushnew '("\\.spool\\'" . turn-on-tinymailbox-mode-maybe)
+;; auto-mode-alist
+;; :test 'equal)
+;; (pushnew '("\\.mbo?x\\'" . turn-on-tinymailbox-mode-maybe)
+;; auto-mode-alist
+;; :test 'equal)
+;;
+;; If you have any questions, use this function to contact author
+;;
+;; M-x tinymailbox-submit-bug-report
+
+;;}}}
+;;{{{ Documentation
+
+;; ..................................................... &t-commentary ...
+;;; Commentary:
+;;
+;; Preface, sep 1997
+;;
+;; It is possible to use Procmail <http://www.procmail.org/> to
+;; manage growing incoming mail. But sometimes your recipes go
+;; wrong and mail ends up folders that you dind't intend to.
+;; People usually direct UBE, UCE and Spam mail to different
+;; folders, but sometimes procmail filter just guesses wrong and
+;; it sends perfetly valid mail into one of these reject folders.
+;; It is good to check the Spam mailboxes manually for valid mail
+;; and then extract it out of them. Not very nice job to do. At
+;; the the time Gnus was not available for managing multiple
+;; forlders so I decided to pull out some old code and make it a
+;; package.
+;;
+;; Overview of features
+;;
+;; o Browse standard unix mailbox .mbox .mbx .spool
+;; o Kill, copy messages from mailbox. Copy message bodies.
+;; o Highlighting and defcustom supported.
+;; o Hide or show headers during mailbox browsing.
+;; o Simple summaries can be done with `occur' command. Eg. to browse
+;; messages based on `From' or `Subject' Headers.
+;;
+;; Showing and hiding headers
+;;
+;; When you browse a mail folder, it has lot of attached headers,
+;; which don't interest you at all when you want to look at the
+;; messages itself. for example, here is one typical header from
+;; a test message
+;;
+;; From nobody Sun Sep 28 20:57:48 1997
+;; To: nobody
+;; Subject: Re: bandwidth (was: [RePol] check this issue)
+;; References: <tbd8lwmfid.fsf@totally-fudged-out-message-id>
+;; From: Foo bar <judgeDredd@marylyn.com>
+;; Date: 28 Sep 1997 20:57:47 +0300
+;; In-Reply-To: Jeff's message of "Tue, 23 Sep 1997 01:35:26 -0400"
+;; Message-ID: <tbiuvlmick.fsf@marylyn.com>
+;; X-Mailer: Quassia Gnus v0.11/Emacs 19.34
+;; Lines: 3
+;; Xref: marylyn.com junk-test:4
+;; X-Gnus-Article-Number: 4 Sun Sep 28 20:57:48 1997
+;;
+;; When you go from this message with `tinymailbox-forward', the headers
+;; that you're interested in are only shown according to
+;; `tinymailbox-:header-show-regexp'. The messages headers are collapsed
+;; as you move around the messages. This approach was chosen, so that
+;; parsing a big message file (Gnus nnfolder backend) wouldn't put you
+;; on hold while the headers were collapsed. Now the headers are
+;; handled while you browse forward and backward. The above headers
+;; lookes like this after
+;; processing it:
+;;
+;; To: nobody
+;; Subject: Re: bandwidth (was: [RePol] check this issue)
+;; From: Foo bar <foo@example.com>
+;; Date: 28 Sep 1997 20:57:47 +0300
+;; X-Mailer: Quassia Gnus v0.11/Emacs 19.34
+;; X-Gnus-Article-Number: 4 Sun Sep 28 20:57:48 1997
+;;
+;; By default all the `X-' headers are shown, so you may want to make
+;; the `tinymailbox-:header-show-regexp' a bit more restrictive if
+;; messages contain too many X-headers. You can toggle this message
+;; hiding feature with
+;;
+;; C-c ' C-q or tinymailbox-header-hide-mode
+;;
+;; Copying or deleting messages
+;;
+;; When you browse the mailbox, you can perform copy or delete on
+;; the current message with following commands.
+;;
+;; C-c ' RET tinymailbox-copy
+;; C-c ' SPC tinymailbox-copy-body
+;; C-c ' d tinymailbox-delete
+;;
+;; Moving between the messages
+;;
+;; There are couple of movement commands that let you jump from
+;; one message to another. See also variable `tinymailbox-:move-header-regexp'
+;;
+;; C-p tinymailbox-forward-body or Ctrl-home
+;; C-n tinymailbox-backward-body or Ctrl-end
+;; home tinymailbox-forward (see tinymailbox-:move-header-regexp)
+;; end tinymailbox-backward
+;;
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+;;{{{ setup: require
+
+(require 'tinylibm)
+;; (require 'sendmail)
+
+(eval-when-compile (ti::package-use-dynamic-compilation))
+
+(eval-and-compile
+ (defvar mail-yank-prefix) ;; Byte compiler silencer
+ (autoload 'mail-fetch-field "mail-utils")
+ (autoload 'mail-position-on-field "mail-utils")
+ (autoload 'string-rectangle "rect" "" t))
+
+(ti::package-defgroup-tiny TinyMailbox tinymailbox-: tools
+ "Mailbox management minor mode.
+ Overview of features
+
+ o Browse standard unix mailbox .mbox .mbx .spool
+ o Kill, copy messages from mailbox. Copy message bodies.
+ o Highlighting and defcustom supported.
+ o Hide or show headers during mailbox browsing.
+ o Simple summaries can be done with `occur' command. Eg. to browse
+ messages based on `From' or `Subject' Headers.")
+
+;;}}}
+;;{{{ setup: variables
+
+;;; ......................................................... &v-hooks ...
+
+(defcustom tinymailbox-:load-hook nil
+ "*Hook run when package has been loaded."
+ :type 'hook
+ :group 'TinyMailbox)
+
+(defcustom tinymailbox-:mail-setup-hook nil
+ "*Hook run when mail has been composed.
+The point is at the beginning of message."
+ :type 'hook
+ :group 'TinyMailbox)
+
+;;; ......................................................... &private ...
+
+(defvar tinymailbox-:last-file nil
+ "Last file used by `tinymailbox-message-to-folder'.")
+
+(defvar tinymailbox:-header-begin-regexp
+ "\n\n[A-Z][a-z]: +\\|^From "
+ "Regexp of beginning of message headers")
+
+;;; ........................................................ &v-public ...
+
+(defcustom tinymailbox-:font-lock-keywords
+ '(("From:[ \t]*\\(.*\\)"
+ (1 font-lock-function-name-face))
+
+ ("Reply-To:[ \t]*\\(.*\\)"
+ (1 font-lock-function-name-face))
+
+ ("Subject:[ \t]*\\(.*\\)"
+ (1 font-lock-keyword-face))
+
+ ("^\\(X-[A-Za-z0-9-]+\\|Date\\):[ \t]*\\(.*\\)"
+ (1 font-lock-reference-face)))
+ "*Font lock keywords."
+ :type 'sexp
+ :group 'TinyMailbox)
+
+(defcustom tinymailbox-:auto-mode-alist
+ '(("\\.mbo?x\\'" . turn-on-tinymailbox-mode-maybe)
+ ;; Gnus spool file: Incoming
+ ("Incoming" . turn-on-tinymailbox-mode-maybe)
+ ;; Gnus `nnml' backend where procmail should deliver output to
+ ;; xxx..xxxx.spool, like mail.private.spool, junk.spam.spool,
+ ;; junk.bounce.spool
+ ("\\.spool\\'" . turn-on-tinymailbox-mode-maybe))
+ "Items to add to `auto-mode-alist' to turn mode on when file is loaded."
+ :type '(repeat
+ (list
+ (string :tag "File Regexp")
+ (const 'tinymailbox-mode)))
+ :group 'TinyMailbox)
+
+(defcustom tinymailbox-:move-header-regexp "^Subject:"
+ "Regexp that is use in movement commands. See `tinymailbox-forward'."
+ :type 'string
+ :group 'TinyMailbox)
+
+(defcustom tinymailbox-:header-show-regexp
+ "^Subject:\\|^To:\\|^From:\\|^Newsgroups:\\|^X-\\|^Date:"
+ "Regexp to show the interesting headers. Others will be hidden."
+ :type 'string
+ :group 'TinyMailbox)
+
+(defcustom tinymailbox-:header-hide-mode t
+ "If non-nil then uninteresting headers are hidden while you move."
+ :type 'boolean
+ :group 'TinyMailbox)
+
+;;; .......................................................... &v-menu ...
+
+(defcustom tinymailbox-:menu-use-flag t
+ "*Non-nil means to use echo-area menu."
+ :type 'boolean
+ :group 'TinyMailbox)
+
+(defvar tinymailbox-:menu-main
+ (list
+ '(format
+ "%sTinyMbx: hdr)+-C-q copy)RETSPC m)ail oO)ccur f)ld F)ile ?H) d)el x)mode off"
+ (if current-prefix-arg
+ (format "%s " (prin1-to-string current-prefix-arg)) "" ))
+ '(
+ (?+ . ( (call-interactively 'tinymailbox-header-show)))
+ (?- . ( (call-interactively 'tinymailbox-header-hide)))
+ (?\C-q . ( (call-interactively 'tinymailbox-header-hide-mode)))
+ (?d . ( (call-interactively 'tinymailbox-delete)))
+ (?\C-m . ( (call-interactively 'tinymailbox-copy)))
+ (?\ . ( (call-interactively 'tinymailbox-copy-body)))
+ (?m . ( (call-interactively 'tinymailbox-mail-send-at-point)))
+ (?o . ( (call-interactively 'tinymailbox-occur)))
+ (?O . ( (call-interactively 'tinymailbox-occur-subject)))
+ (?f . ( (call-interactively 'tinymailbox-message-to-folder)))
+ (?F . ( (call-interactively 'tinymailbox-message-write-file)))
+ (?? . 'tinymailbox-:menu-help)
+ (?H . 'tinymailbox-:menu-help)
+ (?x . ( (call-interactively 'turn-off-tinymailbox-help)))))
+ "*TinyMailbox echo menu.
+
+Header controls:
+
+ + Show headers
+ - Hide headers
+ C-q Toggle header mode
+
+Message options
+
+ RET Copy message
+ SPC Copy body
+
+Transfer options
+
+ d Delete message
+ m Send mail with current message
+ f Append message to a folder
+ F Write message to a file
+
+Miscellaneous
+
+ o Run M-x occur on all lines
+ O Run M-x occur for Subject matches only.
+ ? Help menu
+ H Help menu
+ x Exit mode")
+
+;;;###autoload (autoload 'tinymailbox-version "tinymailbox" "Display commentary" t)
+(eval-and-compile
+ (ti::macrof-version-bug-report
+ "tinymailbox.el"
+ "tinymailbox"
+ tinymailbox-:version-id
+ "$Id: tinymailbox.el,v 2.79 2007/05/06 23:15:20 jaalto Exp $"
+ '(tinymailbox-:version-id
+ tinymailbox-:load-hook
+ tinymailbox-:last-file
+ tinymailbox-:font-lock-keywords
+ tinymailbox-:auto-mode-alist
+ tinymailbox-:move-header-regexp
+ tinymailbox-:header-show-regexp
+ tinymailbox-:header-hide-mode
+ tinymailbox-:menu-use-flag
+ tinymailbox-:menu-main)
+ '(tinymailbox-:debug-buffer)))
+
+;;}}}
+;;{{{ minor mode
+
+;;;###autoload (autoload 'tinymailbox-install-mode "tinymailbox" "" t)
+;;;###autoload (autoload 'tinymailbox-mode "tinymailbox" "" t)
+;;;###autoload (autoload 'turn-on-tinymailbox-mode "tinymailbox" "" t)
+;;;###autoload (autoload 'turn-off-tinymailbox-mode "tinymailbox" "" t)
+;;;###autoload (autoload 'tinymailbox-commentary "tinymailbox" "" t)
+
+(eval-and-compile
+ (ti::macrof-minor-mode-wizard
+ "tinymailbox-" " Mbx" "\C-c'" "Mbx" 'TinyMailbox "tinymailbox-:"
+
+ "Unix mailbox minor mode.
+
+You use this minor mode to browse your .mbx and .mbox files or any file
+hich is stored in standard unix mailbox format (like news articles). The
+file format is as follows. notice that there is no mistake, the first
+'From ' field marks the message biginning and there is no colon.
+
+ From Foo Wee Gee <Gee@this.is>
+ Subject: Swiss Yodddla-laddli-duu
+ Newsgroups: nothing.interesting
+
+ BODY 1 OF MESSAGE
+
+ From Foo Wee Gee <Gee@this.is>
+ Subject: Swiss Yodddla-laddli-duu
+ Newsgroups: nothing.interesting
+
+ BODY 2 OF MESSAGE
+
+Mode description:
+
+Prefix key to access the minor mode is defined in `tinymailbox-:mode-prefix-key'
+
+\\{tinymailbox-:mode-map}"
+
+ "TinyMailbox"
+
+ (progn ;Some mode specific things? No?
+ (when (and tinymailbox-mode
+ (not (get 'tinymailbox-install 'install-done)))
+ ;; User called us directly and forgot tu run install. Do it now
+ (tinymailbox-install))
+ (tinymailbox-font-lock)
+ ;; When mode is turned off, we must kill the text properties we used
+ (unless tinymailbox-mode
+ (save-excursion
+ (ti::text-property-search-and-modify '(owner timbx) nil))))
+
+ "Mailbox mode"
+ (list ;arg 10
+ tinymailbox-:mode-easymenu-name
+ "----"
+ ["Message forward" tinymailbox-forward t]
+ ["Message backward" tinymailbox-backward t]
+ ["Body forward" tinymailbox-forward-boby t]
+ ["Body backward" tinymailbox-backward-body t]
+ "----"
+ ["Header Hide" tinymailbox-header-hide t]
+ ["Header Show" tinymailbox-header-show t]
+ ["Header show/hide mode" tinymailbox-header-hide-mode t]
+ "----"
+ ["Copy message" tinymailbox-copy t]
+ ["Copy message body" tinymailbox-copy-body t]
+ ["Delete message" tinymailbox-delete t]
+ "----"
+ ["Append to file" tinymailbox-message-to-folder t]
+ ["Write to file" tinymailbox-message-write-file t]
+ ["Send email at point" tinymailbox-mail-send-at-point t]
+ "----"
+ ["Make Summary (occur)" tinymailbox-occur t]
+ ["Make Summary (occur subject)" tinymailbox-occur-subject t]
+ "----"
+ ["Keyboard menu" tinymailbox-menu-main t]
+ ["Package version" tinymailbox-version t]
+ ["Package commentary" tinymailbox-commentary t]
+ ["Mode help" tinymailbox-mode-help t]
+ ["Mode off" turn-off-tinymailbox-mode t])
+ (progn
+ (cond
+ (tinymailbox-:menu-use-flag
+ ;; Using menu to remeber commands is easier if you don't use
+ ;; menu bar at all.
+ (define-key root-map [(home)] 'tinymailbox-backward)
+ (define-key root-map [(end)] 'tinymailbox-forward)
+ (define-key root-map "\C-p" 'tinymailbox-backward-body)
+ (define-key root-map "\C-n" 'tinymailbox-forward-body)
+ (define-key root-map [(control home)] 'tinymailbox-backward-body)
+ (define-key root-map [(control end)] 'tinymailbox-forward-body)
+ (define-key root-map p 'tinymailbox-menu-main))
+ (t
+ (define-key root-map [(home)] 'tinymailbox-backward)
+ (define-key root-map [(end)] 'tinymailbox-forward)
+ (define-key root-map "\C-p" 'tinymailbox-backward-body)
+ (define-key root-map "\C-n" 'tinymailbox-forward-body)
+ (define-key root-map [(control home)] 'tinymailbox-backward-body)
+ (define-key root-map [(control end)] 'tinymailbox-forward-body)
+ (define-key map "+" 'tinymailbox-header-show)
+ (define-key map "-" 'tinymailbox-header-hide)
+ (define-key map "\C-q" 'tinymailbox-header-hide-mode)
+ (define-key map "d" 'tinymailbox-delete)
+ (define-key map "\C-m" 'tinymailbox-copy)
+ (define-key map " " 'tinymailbox-copy-body)
+ (define-key map "m" 'tinymailbox-mail-send-at-point)
+ (define-key map "o" 'tinymailbox-occur)
+ (define-key map "O" 'tinymailbox-occur-subject)
+ (define-key map "f" 'tinymailbox-message-to-folder)
+ (define-key map "F" 'tinymailbox-message-write-file)
+ (define-key map "?" 'tinymailbox-help)
+ (define-key map "Hm" 'tinymailbox-mode-help)
+ (define-key map "Hc" 'tinymailbox-commentary)
+ (define-key map "Hv" 'tinymailbox-version)
+ (define-key map "x" 'turn-off-tinymailbox-mode)
+ (message "TinyMailbox: Use home/end to move between messages."))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymailbox-menu-main (&optional arg)
+ "Show echo area menu and pass ARG to `ti::menu-menu'."
+ (interactive "P")
+ (ti::menu-menu 'tinymailbox-:menu-main arg))
+
+;;}}}
+;;{{{ Install
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymailbox-mode-candidate-p ()
+ "Return non-nil if buffer is candidate for `tinymailbox-mode'."
+ (and (not (or (memq major-mode
+ '(vm-mode
+ rmail-mode
+ article-mode
+ message-mode
+ mail-mode
+ gnus-summary-mode))
+ (string-match
+ ;; Do not activate on
+ ;;
+ ;; *.log
+ ;; *.tmp
+ ;; .procmailrc (dot files in general)
+ ;;
+ "^\\.\\|\\.\\(log\\|tmp\\)$\\|VM\\|RMAIL"
+ (or (buffer-name) ""))))
+ (ti::mail-mailbox-p)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun turn-on-tinymailbox-mode-maybe ()
+ "Turn on `tinymailbox-mode' if buffer looks like a Berkeley mailbox.
+Ignore big mailboxes."
+ (when (and (tinymailbox-mode-candidate-p)
+ ;; Font-locking is too slow for big mailboxes
+ (< (buffer-size) (* 2 1000 1000)))
+ (turn-on-tinymailbox-mode)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinymailbox-install (&optional uninstall verb)
+ "Install mode, or optionally UNINSTALL and print messages with VERB."
+ (interactive "P")
+ (unless uninstall
+ ;; Signal that we were called. This is checked inside mode wizard
+ (put 'tinymailbox-install 'install-done t))
+ (ti::assoc-replace-maybe-add 'auto-mode-alist
+ tinymailbox-:auto-mode-alist
+ uninstall)
+ (ti::add-hooks 'find-file-hooks
+ 'turn-on-tinymailbox-mode-maybe
+ uninstall)
+ (when (or verb
+ (interactive-p))
+ (message "TinyMailbox %s"
+ (if uninstall
+ "uninstalled"
+ "installed"))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinymailbox-uninstall ()
+ "Uninstall mode."
+ (tinymailbox-install 'uninstall (interactive-p)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymailbox-font-lock ()
+ "Add/remove font lock support if `font-lock-mode' exists."
+ (interactive)
+ (let* ((sym 'font-lock-keywords)
+ orig)
+ (when (and (boundp sym)
+ (ti::colors-supported-p))
+ (cond
+ (tinymailbox-mode
+ (ti::string-syntax-kill-double-quote)
+ (make-variable-buffer-local 'tinymailbox-:font-lock-keywords)
+ (unless (get 'tinymailbox-:font-lock-keywords 'original)
+ (put 'tinymailbox-:font-lock-keywords
+ 'original
+ (symbol-value sym)))
+ (set sym tinymailbox-:font-lock-keywords)
+ (turn-on-font-lock))
+ (t
+ (when (ti::listp
+ (setq orig
+ (get 'tinymailbox-:font-lock-keywords 'original)))
+ (set sym orig))))
+ (when (and (boundp 'font-lock-mode)
+ (symbol-value 'font-lock-mode))
+ ;; fontify approx. 50 lines or until point-max
+ (save-excursion
+ (font-lock-fontify-region
+ (point)
+ (min (+ (point) (* 80 50)) (point-max))))))))
+
+;;}}}
+;;{{{ Macros
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinymailbox-message-move-beginning ()
+ "Move to message beginning."
+ (re-search-backward tinymailbox:-header-begin-regexp nil t))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinymailbox-message-macro 'lisp-indent-function 0)
+(put 'tinymailbox-message-macro 'edebug-form-spec '(body))
+(defmacro tinymailbox-message-macro (&rest body)
+ "Do BODY on message. You can refer to `beg' and `end' for message region."
+ (`
+ (let* ((opoint (point))
+ beg
+ end)
+ ;; Just to make byteCompiler happy
+ (if (null opoint) (setq opoint nil))
+ (if beg (setq beg t))
+ (if end (setq end t))
+ (tinymailbox-begin 'backward)
+ (setq beg (point))
+ ;; Go forward
+ (tinymailbox-begin)
+ ;; txt txt
+ ;; Last line of previous message is here....
+ ;;
+ ;; From asdasdasdadas
+ ;; X-Header: blah
+ ;; ...
+;;; (if (looking-at "From ")
+;;; (backward-line 1)) ;Fix position a bit
+ (setq end (point))
+;;; (error beg end)
+ (,@ body))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinymailbox-header-macro 'lisp-indent-function 0)
+(defmacro tinymailbox-header-macro (&rest body)
+ "Do BODY on message. You can refer to `beg' and `end' for message region."
+ (`
+ (let* (beg
+ end)
+ ;; Just to make byteCompiler happy
+ (if beg
+ (setq beg t))
+ (if end
+ (setq end t))
+ (tinymailbox-begin 'backward) (setq beg (point))
+ (re-search-forward "^[ \t]*$")
+ (beginning-of-line)
+ (setq end (point))
+ (,@ body))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinymailbox-paragraph-macro 'lisp-indent-function 0)
+(defmacro tinymailbox-paragraph-macro (&rest body)
+ "Set paragraph values locally while executing BODY."
+ (`
+ (let* ((sentence-end "[.?!]*[ \n]+")
+ (paragraph-start "^[ \t]*$")
+ (paragraph-separate paragraph-start))
+ (,@ body))))
+
+;;}}}
+;;{{{ misc
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymailbox-header-p ()
+ "Check if point is inside header."
+ (interactive)
+ (save-excursion
+ (beginning-of-line)
+ (looking-at "^[A-Z][^:]+: ")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymailbox-overlay (act &optional beg end)
+ "If ACT is 'hide, hide overlay, otherwise highlight BEG END."
+ (let* ((ov
+ (if (boundp 'mouse-drag-overlay) ;Emacs, use this by default
+ 'mouse-drag-overlay
+ 'primary-selection-extent)))
+ (cond
+ ((eq act 'hide)
+ (ti::compat-overlay-move ov 1 1)
+ (pop-mark))
+ (t
+ (ti::compat-overlay-move ov beg end)
+ (setq ov (symbol-value ov))
+ (when (ti::emacs-p)
+ (push-mark
+ (if (ti::emacs-p)
+ (ti::funcall 'overlay-start ov)
+ (ti::funcall 'extent-start-position ov))
+ t t)
+ (push-mark
+ (if (ti::emacs-p)
+ (ti::funcall 'overlay-end ov)
+ (ti::funcall 'extent-end-position ov))
+ t t)) ;; when
+ (setq this-command 'set-mark)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymailbox-header-next ()
+ "Find next header forward."
+ (if (looking-at "^[^ \t\n]")
+ (forward-line 1))
+ (while (and (not (eobp)) (looking-at "^[ \t]"))
+ (forward-line 1)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymailbox-header-show-or-hide ()
+ "Check `tinymailbox-:header-hide-mode' and act according to it."
+ (if tinymailbox-:header-hide-mode
+ (tinymailbox-header-hide)
+ (tinymailbox-header-show)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymailbox-header-show ()
+ "Call `tinymailbox-header-hide' with argument SHOW."
+ (interactive)
+ (tinymailbox-header-hide 'show))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymailbox-header-hide (&optional show)
+ "Hide or SHOW headers according to `tinymailbox-:header-show-regexp'."
+ (interactive "P")
+ (let* ((re tinymailbox-:header-show-regexp)
+ (prop 'invisible)
+ (propl (list 'owner 'timbx
+ 'tinymailbox-stat 'hidden
+ prop t
+ 'rear-nonsticky t))
+ (prop-stat 'tinymailbox-stat)
+ (opoint (point))
+ point
+ status-property
+ put-property)
+ (tinymailbox-header-macro
+ (with-buffer-modified
+ (goto-char beg)
+ ;; The hide on/off information is stored to the message beginning
+ ;; - We look if it says 'hidden or 'shown
+ ;; - If the user wants hidden headers, but they are already
+ ;; hidden, then this function does nothing.
+ (setq status-property
+ (memq prop-stat (text-properties-at (point))))
+ (cond
+ (show
+ (setq put-property 'shown)
+ (when (or (null status-property)
+ ;; If text is already shown, then do nothing.
+ (and status-property
+ (not (eq (nth 1 status-property) 'shown))))
+ (ti::text-property-search-and-modify
+ '(owner timbx) nil beg end)))
+ (t
+ (setq put-property 'hidden)
+ (when (or (null status-property)
+ (and status-property
+ (not (eq (nth 1 status-property) 'hidden))))
+ (while (< (point) end)
+ (cond
+ ((and (not (looking-at re))
+ ;; If this point has already marked visible, do nothing.
+ (or (null (eq 'timbx
+ (get-text-property (point) 'owner)))
+ (null (get-text-property (point) prop))))
+ (setq point (point))
+ (tinymailbox-header-next)
+ (with-buffer-modified
+ (let (buffer-read-only)
+ (set-text-properties point (point) propl))))
+ (t
+ (forward-line 1)))))))
+ (put-text-property beg (1+ beg) 'owner 'timbx)
+ (put-text-property beg (1+ beg) prop-stat put-property)))
+ (goto-char opoint)))
+
+;;}}}
+;;{{{ move
+
+;;; ----------------------------------------------------------------------
+;;;
+(eval-and-compile
+ (defun tinymailbox-fmacro-move-1 (func doc move-func re msg &rest body)
+ "Use `tinymailbox-fmacro-move with FUNC DOC MOVE-FUNC RE MSG and BODY."
+ (let* ((sym (intern (symbol-name (` (, func))))))
+ (`
+ (defun (, sym) (&optional arg)
+ (, doc)
+ (interactive "P")
+ (let* ((Opoint (point))
+ stat)
+ (if (eq (, move-func) 're-search-backward)
+ (beginning-of-line)
+ (end-of-line))
+ (cond
+ ((setq stat (funcall (, move-func) (, re) nil t))
+ (goto-char (match-end 0)))
+ (t
+ (goto-char Opoint)))
+ (tinymailbox-header-show-or-hide)
+ (,@ body)
+ (if (interactive-p)
+ (recenter 3))
+ (when (and (null stat) (interactive-p))
+ (message (, msg)))
+ stat)))))
+
+ ) ;; eval-and-compile
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro tinymailbox-fmacro-move (func doc move-func re msg &optional body)
+ "Create Move function FUNC DOC MOVE-FUNC RE MSG and BODY.
+Created function arguments: (&optional arg)"
+ (` (, (tinymailbox-fmacro-move-1
+ func doc move-func re msg body))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload (autoload 'tinymailbox-forward "tinymailbox" "Go to next message." t)
+(tinymailbox-fmacro-move
+ tinymailbox-forward
+ "Go to next message."
+ 're-search-forward tinymailbox-:move-header-regexp
+ "TinyMailbox: message forward stop.")
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload (autoload 'tinymailbox-backward "tinymailbox" "Go to previous message." t)
+(tinymailbox-fmacro-move
+ tinymailbox-backward
+ "Go to previous message."
+ 're-search-backward tinymailbox-:move-header-regexp
+ "TinyMailbox: message backward stop.")
+
+;;; ----------------------------------------------------------------------
+;;;
+(tinymailbox-fmacro-move
+ tinymailbox-forward-body
+ "Go to next message body."
+ 're-search-forward "^From "
+ "TinyMailbox: body forward stop."
+ (and stat
+ (setq stat (re-search-forward "^[ \t]*$" nil t))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymailbox-backward-body ()
+ "Go to previous message body."
+ (interactive)
+ (let* ((opoint (point))
+ stat)
+ ;; We must move to message beginning first.
+ (tinymailbox-message-move-beginning)
+ (forward-line -1)
+ (if (null (re-search-backward "^From " nil t))
+ (message "TinyMailbox: body backward stop.")
+ (setq stat (re-search-forward "^[ \t]*$" nil t)))
+ (if (and stat
+ (interactive-p))
+ (recenter 3))
+ ;; If none found, return to original position
+ (when (and (null stat)
+ (not (eq (point) opoint)))
+ (message "TinyMailbox: body backward stop.")
+ (goto-char opoint))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymailbox-header-hide-mode (arg &optional verb)
+ "Toggle header hiding mode with ARG when moving between messages. VERB."
+ (interactive "P")
+ (ti::verb)
+ (ti::bool-toggle tinymailbox-:header-hide-mode)
+ (when verb
+ (message "Header hiding mode is %s"
+ (if tinymailbox-:header-hide-mode "on" "off")))
+ (tinymailbox-header-show-or-hide))
+
+;;}}}
+;;{{{ copy; delete
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinymailbox-begin (&optional backward)
+ "Move to next message begin. Optionally BACKWARD."
+ (interactive "P")
+ (let* ((re tinymailbox:-header-begin-regexp)
+ case-fold-search)
+ (cond
+ (backward
+ (if (re-search-backward re nil t)
+ (skip-chars-forward "^a-z") ;; Go to character
+ (ti::pmin)))
+ (t
+ (goto-char (line-end-position))
+ (unless (re-search-forward re nil t)
+ (ti::pmax))))
+ (beginning-of-line)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinymailbox-delete ()
+ "Delete current message. point must be inside message."
+ (interactive)
+ (buffer-enable-undo)
+ (tinymailbox-message-macro
+ (forward-line 2)
+ (kill-region beg (point))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinymailbox-copy ()
+ "Copy current message. point must be inside message."
+ (interactive)
+ (tinymailbox-message-macro
+ (copy-region-as-kill beg end)
+ (tinymailbox-overlay 'show beg end)
+ (sit-for 0.5)
+ (tinymailbox-overlay 'hide beg end)
+ (if (interactive-p)
+ (message "TinyMailbox: Message copied as kill."))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinymailbox-copy-body ()
+ "Copy body of current message. point must be inside message."
+ (interactive)
+ (buffer-enable-undo)
+ (tinymailbox-message-macro
+ ;; body starts after all headers.
+ (goto-char beg)
+ (re-search-forward "^[ \t]*$")
+ (forward-line 1)
+ (setq beg (point))
+ (copy-region-as-kill beg end)
+ (tinymailbox-overlay 'show beg end))
+ (if (interactive-p)
+ (message "TinyMailbox: Message body copied.")))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinymailbox-message-to-folder (file)
+ "File current message by appending it to FILE."
+ (interactive
+ (list
+ (read-file-name
+ "Append to folder: "
+ (if tinymailbox-:last-file
+ (file-name-directory tinymailbox-:last-file))
+ nil
+ nil
+ (if tinymailbox-:last-file
+ (file-name-nondirectory tinymailbox-:last-file)))))
+ (tinymailbox-message-macro
+ (setq tinymailbox-:last-file file)
+ (append-to-file beg (min (1+ end) (point-max)) file)
+ (goto-char opoint)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinymailbox-message-write-file (file)
+ (interactive
+ (list
+ (read-file-name
+ "Write to file: "
+ (if tinymailbox-:last-file
+ (file-name-directory tinymailbox-:last-file))
+ nil
+ nil
+ (if tinymailbox-:last-file
+ (file-name-nondirectory tinymailbox-:last-file)))))
+ (tinymailbox-message-macro
+ (setq tinymailbox-:last-file file)
+ (write-region beg (min (1+ end) (point-max)) file)
+ (goto-char opoint)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymailbox-occur (regexp)
+ "Create Simple `Summary' buffer by running REGEXP `occur'.
+Try Subject: or From:"
+ (interactive "sTinyMailbox: run occur by regexp: ")
+ (cond
+ ((ti::nil-p regexp)
+ (when (interactive-p)
+ (message "TinyMailbox: Occur cancelled. No REGEXP given.")))
+ (t
+ (save-excursion
+ (ti::pmin)
+ (occur regexp)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymailbox-occur-subject ()
+ "Generate Subject summary."
+ (interactive)
+ (tinymailbox-occur "^Subject:.*"))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinymailbox-user-mail-address-regexp ()
+ "Return regexp from `user-mail-address' and `user-full-name'."
+ (concat
+ (or user-mail-address "####none###")
+ "\\|"
+ (or user-full-name "###none###")
+ "\\|"
+ (if user-login-name
+ (concat user-login-name "@")
+ "###none###")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinymailbox-mail-send-filter (list &optional regexp)
+ "Remove all strings from LIST that match current user or REGEXP."
+ (let ((user (tinymailbox-user-mail-address-regexp)))
+ (remove-if (lambda (x)
+ (or (string-match user x)
+ (and (stringp regexp)
+ (string-match regexp x))))
+ list)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymailbox-mail-send-at-point ()
+ "Compose mail using current message.
+References:
+ `mail-mode-hook'"
+ (interactive)
+ (let* ((buffer (current-buffer))
+ from
+ from-email
+ to-dest
+ to
+ to-list
+ cc
+ cc-list
+ references
+ subject
+ start
+ body)
+ ;; We must "require", because `mail-yank-prefix' is not otherwise
+ ;; defined.
+ (if (not (boundp 'mail-yank-prefix))
+ (require 'sendmail))
+ (tinymailbox-message-macro
+ (ti::narrow-safe beg end
+ (ti::pmin)
+ (setq from (mail-fetch-field "From")
+ from-email (car-safe (ti::mail-email-from-string from))
+ to (mail-fetch-field "to")
+ reply-to (mail-fetch-field "reply-to")
+ to-list (and to
+ (tinymailbox-mail-send-filter
+ (split-string
+ to
+ "[ \t\r\n]*,[ \t\r\n]*")
+ from-email))
+ cc (mail-fetch-field "CC")
+ cc-list (and cc
+ (tinymailbox-mail-send-filter
+ (split-string
+ cc
+ "[ \t\r\n]*,[ \t\r\n]*")
+ (regexp-quote from-email)))
+ references (mail-fetch-field "References")
+ subject (mail-fetch-field "Subject")))
+ (setq to-dest (or reply-to from))
+ ;; Sometimes the To field contains multiple addresses
+ ;; To: me@here.at, other@there.com
+ ;; => Move them to CC
+ (dolist (elt to-list)
+ (unless (dolist (eltc cc-list)
+ (if (string= elt eltc)
+ (return t)))
+ (push elt cc-list)))
+ (if cc-list
+ (setq cc (mapconcat 'concat cc-list ", ")))
+ (ti::pmin)
+ (when (re-search-forward "^[ \t]*$")
+ (forward-line 1)
+ (setq body (buffer-substring (point) (point-max))))
+ (if (and subject
+ (not (ti::string-match-case "re:" subject 'ignore-case)))
+ (setq subject (concat "Re: " subject))))
+ (mail nil to-dest subject nil cc)
+ (when references
+ (mail-position-on-field "References")
+ (insert references))
+ (ti::pmax)
+ (setq start (point))
+ (insert (or body ""))
+ (string-rectangle
+ start
+ (point-max)
+ (if (stringp mail-yank-prefix)
+ mail-yank-prefix
+ "| "))
+ (goto-char start)
+ (run-hooks 'tinymailbox-:mail-setup-hook)))
+
+;;}}}
+
+(add-hook 'tinymailbox-:mode-define-keys-hook 'tinymailbox-mode-define-keys)
+(provide 'tinymailbox)
+
+(run-hooks 'tinymailbox-:load-hook)
+
+;;; tinymailbox.el ends here
--- /dev/null
+;;; tinymy.el --- Collection of simple solutions.
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 1995-2007 Jari Aalto
+;; Keywords: tools
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program, call M-x tinymy-version.
+;; Look at the code with folding.el
+
+;; COPYRIGHT NOTICE
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;;; Install:
+
+;; ....................................................... &t-install ...
+;; Put this file on your Emacs-Lisp load path, add following into your
+;; ~/.emacs startup file.
+;;
+;; (require 'tinymy)
+;; (tinymy-compile-run-command-advice) ;; Activate smart M-x compile
+;;
+;; If you get key binding conflict when you load this package, either
+;; relocate keys, modify `tinymy-:define-key-table' or use forced bindings
+;; by adding this statement prior `require' command.
+;;
+;; (setq tinymy-:define-key-force t)
+;;
+;; AUTOLOAD SETUP INSTRUCTIONS
+;;
+;; This package can't be autoloaded easily, because it installs timers
+;; and many global bindings. One possible way to autoload this package is
+;; to rely on the fact that you will most likely use function to match
+;; parens: like "(this)". The autoload below is quite tricky, see if
+;; you can learn from it. What if effective does, is a) put temporary
+;; function under key "%", when you press it b) function gets called
+;; and tinymy.el is loaded c) it wipes itself away and assigns
+;; function `tinymy-vi-type-paren-match' to the "%" key.
+;;
+;; global-set-key "%"
+;; (ti::definteractive
+;; (let ((function (lookup-key global-map "%")))
+;; (global-unset-key "%") ;; tinymy.el doesn't complain
+;; (require 'tinymy)
+;; ;; Now run whatever user had there.
+;; (if function
+;; (funcall function)
+;; (self-insert-command 1))
+;; ;; Second time, direc calls here
+;; (global-set-key
+;; "%"
+;; 'tinymy-vi-type-paren-match))))
+;;
+;; There are some scripts included in this module and you can unpack them
+;; with following commands. You need `pgp' and `tar' executable in path for
+;; this to work. The extra scripts are for compile command C-z c c,
+;; but you don't need them necessarily.
+;;
+;; M-x load-library RET tinymy RET
+;;
+;; Modify the following variable and put your own installation there if the
+;; default setting is interfering your setup. Please remember to look the
+;; _source_ code of `tinymy-define-keys' which is run when package loads.
+;; Function overrides some default Emacs key bindings.
+;;
+;; tinymy-:define-key-table
+;;
+;; ;; Redefine hook so that it doesn't
+;; ;; override Emacs keys. Define them somewhere else.
+;;
+;; (add-hook 'tinymy-:load-hook 'tinymy-install)
+;; (add-hook 'tinymy-:load-hook 'tinymy-alias)
+;;
+;; If you have any questions, use 'submit' function. In case of error
+;; or misbehavior, turn on the debug too and send the debug result and
+;; describe what you did and where went wrong.
+;;
+;; M-x tinymy-debug-toggle
+;; M-x tinymy-submit-bug-report
+
+;;}}}
+;;{{{ Documentation
+
+;; ..................................................... &t-commentary ...
+;;; Commentary:
+
+;; Preface, Nov 1995
+;;
+;; Emacs startup files started to look quite interesting:
+;;
+;; emacs-rc-tips emacrs-rc-el emacrs-rc-el
+;; emacs-rc-18 emacs-rc-19 emacs-rc-abb emacs-rc-compile
+;; emacs-rc-debug emacs-rc-default emacs-rc-font emacs-rc-ding
+;; emacs-rc-font.b emacs-rc-gnus emacs-rc-hooks
+;; emacs-rc-init emacs-rc-init2 emacs-rc-mail
+;; emacs-rc-o emacs-rc-o-19 emacs-rc-out
+;; emacs-rc-path emacs-rc-pc emacs-rc-prog emacs-rc-set
+;; emacs-rc-test emacs-rc-time emacs-rc-tips emacs-rc-vc
+;; emacs-rc-w3 emacs-rc-x-menu emacs-rc-xe
+;; emacs-rc-dired
+;; ..
+;;
+;; Private functions seemed to grow all the time, most of which were
+;; turned into packages, but sometimes it was just function or two
+;; that made a life with Emacs easier. What you see here is a
+;; selection of so called general *my* functions. The term *my* does
+;; not refer to *mine*, but has a background in function
+;; naming. Remember? All user functions are recommended to be named
+;; so, that the first word is `my-', like `my-FUNC-NAME-HERE'
+;;
+;; Overview of features
+;;
+;; Timer processes
+;;
+;; o RMAIL/other buffers saved in regular intervals.
+;; o Revert buffer in background and ask confirmation, if file
+;; has changed on disk. By <duthen@cegelec-red.fr>
+;; (Jacques Prestataire) This feature is automatically disabled
+;; if autorevert.el is present and running.
+;; o Mail lock watchdog. If you have this lock in your file system,
+;; you cannot receive mail.
+;;
+;; Buffer
+;;
+;; o Cursor changes shape according to `overwrite-mode'
+;; o Rename any buffer with one key `C-z' `n' to be able to launch
+;; e.g. new *shell* or *mail* buffer.
+;; o Scroll command goes to window end/beginning and does not scroll
+;; immediately. See variable `tinymy-:scroll-mode' for more.
+;; o Trim trailing whites paces from the buffer when file
+;; is saved. This featue is automatically disabled if
+;; whitespace.el is noticed.
+;; o Gzip or unzip current file buffer.
+;; o Add up numbers in rectangle area
+;;
+;; Compile
+;;
+;; o Guess compile command by looking at the buffer content
+;; Configure variable `tinymy-:compile-table' and
+;; `tinymy-:compile-command-c-code'. The compile command you
+;; chose is buffer local and lasts until you change it.
+;; This is different than hitting M-x compile, because compile
+;; Does not "remember" each buffer's correct compile command.
+;;
+;; Files
+;;
+;; o Toggle write/read-only file permissions on disk with
+;; C-x q or `M-x' `tinymy-buffer-file-chmod'
+;; o If file saved had #!, it is automatically made chmod u+x.
+;; This feature is not installed if function
+;; `executable-make-buffer-file-executable-if-script-p'
+;; is noticed.
+;;
+;; Gnus, mail
+;;
+;; o Save lisp package in buffer like *mail* to file: find
+;; package regions.
+;; o Copy current buffer's contents to new mail buffer and
+;; set subject line. You can send diff buffers and file buffers
+;; conveniently this way: `C-z' `m' (Zend buffer as Mail)
+;;
+;; Keys
+;;
+;; o Jump to matching paren "{([". _Bound_ to key "%".
+;; o Better word movement: LikeThisInC++Mode.
+;; Moving forward/backward always keeps cursor at the
+;; beginning of word. See also `c-forward-into-nomenclature'
+;; _Bound_ to keys `C-left', `C-right' in X and `Esc-b', `Esc-f'
+;; in non-windowed Emacs.
+;; o PgUp and PgDown behave differently; they jump to
+;; window's beg/end first and only next key hit scrolls.
+;; _Bound_ to keys `prior' and `next'. Check if your keyboard
+;; produces another pgUp and PgDown events.
+;;
+;; Line formatting
+;;
+;; o Fix all backslash(\) lines in current paragraph to the
+;; same column as the starting line. Very useful in makefile mode,
+;; shell mode or when writing C/C++ macros. It even inserts missing
+;; backslashes.
+;;
+;; Mouse
+;;
+;; o Point window and it gets cursor focus: The frame is
+;; raised and window selected. No need to click window any more.
+;; o Show File information in echo-area: Point mouse near
+;; the end of window and Displayed info contains
+;; BUFFER MODES SIZE PATH. You do not consume your mode line
+;; or frame title any more for buffer specific information.
+;; Example output:
+;;
+;; TinyMy: -rw-r--r-- 108k /users/jaalto/elisp/tinymy.el
+;;
+;; Shell
+;;
+;; o Easy shar/tar/UU commands. configure variables
+;; `tinymy-:shar-command' and `tinymy-:tar-command'
+;;
+;; vc
+;;
+;; o Key C-x C-q now won't call vc blindly. To prevent mistakes,
+;; a confirmation will be asked. You can also just toggle the
+;; buffer's read-only flag, without engaging vc.
+;;
+;; Window
+;;
+;; o Flip the order of two windows
+;;
+;; Minor modes in this package
+;;
+;; Sort minor mode
+;;
+;; If you have data in columns, use `C-cmS' or `M-x' `tinymy-sort-mode'
+;; to toggle sort mode on and off. With it you can sort columns 1-9
+;; easily. Mode line indicator is "S"
+;;
+;; Features immediately activated when package loads
+;;
+;; Configure variable `tinymy-:save-buffer-modes' and
+;; `tinymy-:save-buffer-regexp'
+;; o You mailbox lock is kept on eye on, if the lock remains,
+;; you won't be able to receive mail. (safety measure).
+;; o If you use procmail you want to configure
+;; `tinymy-:mail-check-inbox-file-permissions'
+;; otherwise, your mailbox's mode permissions are kept eye on:
+;; "Permission error: -rw-------" warning will be show if the
+;; mailbox doesn't have right modes.
+;; o Automatic window selection when you point it with mouse cursor.
+;; See `tinymy-:install-select-window-auto'.
+;; o When buffer that has `#!' to indicate shell
+;; script, is save, the +x flag is set on for the file.
+;;
+;; What commands are defined when you load this file?
+;;
+;; It's better to look at the code of this file, than to explain all the
+;; key definitions here, because I may not remember update this
+;; text section every time I add new interactive commands to the file.
+;;
+;; All the new interactive commands can be found from these two
+;; functions:
+;;
+;; tinymy-define-keys
+;; tinymy-mail-common-keys
+;;
+;; See their description, or alternatively hit
+;;
+;; C-h m ;; to view all bindings
+;; M-x delete-non-matching-lines tinymy ;; show bound keys
+;;
+;; Key bindings
+;;
+;; When you load this package, you can also install global
+;; key-bindings that if you set the load hook:
+;;
+;; (add-hook 'tinymy-:load-hook 'tinymy-install)
+;; (add-hook 'tinymy-:load-hook 'tinymy-define-keys)
+;; (add-hook 'tinymy-:load-hook 'tinymy-define-key-extra)
+;; (add-hook 'tinymy-:load-hook 'tinymy-alias)
+;;
+;; If you want to use your own bindings, use it like this:
+;;
+;; (add-hook 'tinymy-:load-hook 'tinymy-install
+;; (add-hook 'tinymy-:load-hook 'tinymy-alias)
+;; (add-hook 'tinymy-:load-hook 'my-tinymy-keys)
+;;
+;; (defun my-tinymy-keys ()
+;; <define my own global key mappings>)
+;;
+;; There is table of global bindings which you can modify if the
+;; bindings clash: the auto install will warn you about this
+;; automatically and your own bindings are not replaced by default.
+;; See variable: `tinymy-:define-key-table'
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+;;{{{ setup: require
+
+;;; ......................................................... &require ...
+
+(require 'tinylibm)
+
+(eval-and-compile
+ (defvar track-mouse) ;ByteComp silencer for XEmacs
+ (ti::package-package-require-timer)
+ (autoload 'compile-internal "compile")
+ (autoload 'operate-on-rectangle "rect")
+ (defvar gnus-article-buffer)
+ (defvar gnus-original-article-buffer)
+ (defvar gnus-summary-buffer))
+
+(eval-when-compile
+ (ti::package-use-dynamic-compilation)
+ (require 'advice))
+
+(ti::package-defgroup-tiny TinyMy tinymy-: tools
+ "Collection of small so called 'my' utility functions.
+The full feature list is in the source code documentation, read it well.")
+
+;;}}}
+;;{{{ setup: variables
+
+;;; .......................................................... &v-bind ...
+;;; Change this table if you have conflicting bindings.
+;;;
+
+(defcustom tinymy-:define-key-force nil
+ "*If non-nil; assign keys without any check."
+ :type 'boolean
+ :group 'TinyMy)
+
+(defcustom tinymy-:define-key-table
+ '(
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. C-x . .
+ ;; The 'rectangle' map. This sould be free
+
+ ("\C-xrA" . tinymy-add-rectangle)
+
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. C-c . .
+ ;; minor modes in 'm' map
+
+ ("\C-cmS" . tinymy-sort-mode)
+
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. C-z . .
+ ;; Pick "c" for all (c)ompile commads, now define additional
+ ;; "c" for this particular command
+
+ ("\C-zcc" . tinymy-compile-run-command)
+
+ ("\C-zm" . tinymy-mail-buffer)
+ ("\C-zS" . ti::buffer-surround-with-char)
+
+ ;; Oher miscellaneout to "x" extra map
+
+ ("\C-zxc" . tinymy-copy-file) ;; Make backup (RCS version included)
+
+ ("\C-zxf" . tinymy-package-save-to-file)
+ ("\C-zxt" . tinymy-trim-blanks)
+
+ ("\C-zxw" . tinymy-flip-windows)
+ ("\C-zxz" . tinymy-buffer-file-gzip)
+
+ ;; 's' for shell commands
+
+ ("\C-zxss" . tinymy-shar)
+ ("\C-zxst" . tinymy-tar))
+ "*Define command to `global-map' keys.
+See also source code for `tinymy-define-keys' which will overwrite
+default Emacs keybindings if installed in `tinymy-:load-hook'.
+
+Format:
+
+ '((KEY . FUNCTION)
+ ...)"
+
+ :type '(repeat
+ (cons
+ (string :tag "Key Bind sequence")
+ function))
+ :group 'TinyMy)
+
+;;; ......................................................... &v-hooks ...
+
+(defcustom tinymy-:load-hook '(tinymy-install)
+ "*Hook that is run when package is loaded.
+The default value is '(tinymy-install)"
+ :type 'hook
+ :group 'TinyMy)
+
+(defcustom tinymy-:mail-buffer-hook nil
+ "*This hook run last in `tinymy-mail-buffer' function."
+ :type 'hook
+ :group 'TinyMy)
+
+;;; ....................................................... &vu-config ...
+;;; all "vu" -- "variable user" sections are meant for user configurable
+
+(defcustom tinymy-:install-select-window-auto 'no
+ "*Variable is used only in window system.
+The automatic window selection function selects window by pointing
+at it with mouse . No clicking is needed. However if you use menu bar, it is
+a bit difficult to use this automatic selection feature, because the
+menu bar reflects the current window: When you are at lower window and reach
+for the menu bar, the upper window gets selected and the menu bar reflects
+that window. You never get menu bar for the other windows but for the
+topmost one. (Well, you can go round of Emacs, and then reach for
+menu-bar, but that's a bit awkward)
+
+Values in this variable:
+
+ 'yes
+ 'no
+ 'ask"
+ :type '(choice
+ (const yes)
+ (const no)
+ (const ask))
+ :group 'TinyMy)
+
+(defcustom tinymy-:register ?r
+ "*An Emacs register where to put results of commands.
+User can then afterwards yank the result into desired buffer."
+ :type 'character
+ :group 'TinyMy)
+
+(defcustom tinymy-:scroll-mode 'window
+ "*If non-nil, then `tinymy-scroll-down' does not immediately scroll.
+The following happen if variable is non-nil.
+o up: if the cursor is not at the window's start line, go there
+o up: if cursor is at window's top, line, now scroll
+o down: --''-- behaves same as up"
+ :type 'boolean
+ :group 'TinyMy)
+
+(defcustom tinymy-:copy-file-suffix ".original"
+ "Suffix to add when making copy of file with `tinymy-copy-file'.
+This variable is only used in interactive call. Default extension
+is \".original\", same as used by Unix 'patch' program to save original
+working file.
+
+If the version number can be found from file, that is suggested instead
+of this suffix."
+ :type 'string
+ :group 'TinyMy)
+
+;;; ...................................................... &v-matching ...
+
+(defcustom tinymy-:vi-type-paren-match-special-list '( ?\" ?\' ?\$ )
+ "*List of special character to matched in \\[tinymy-vi-type-paren-match].
+If the sentence delimited by these chars spread multiple lines,
+the missing part is searched backward.
+
+If you call \\[tinymy-vi-type-paren-match] with optional arg, then
+the search is forced FORWARD."
+ :type '(repeat character)
+ :group 'TinyMy)
+
+;; This could have been (CH . CH) list but because XEmacs20
+;; has different character handling that Emacs; we prefer to check
+;; strings.
+;;
+;; This is not configurable variable right now, because the match
+;; function uses hard coded regexps.
+
+(defconst tinymy-:vi-type-paren-match-list
+ '( ( "(" . ")" )
+ ;; NOPE, DO NOT add these. It won't work - the reason is currently unknown.
+ ;;
+ ;; ( "<" . ">" )
+ ( "{" . "}" )
+ ( "[" . "]" ))
+ "List of character string pairs to match.
+
+Format:
+
+ ((BEGIN-CHARACTER-PAIR-STR . END-CHARACTER-PAIR-STR)
+ (B . E)
+ ..)
+
+Example:
+
+ '( ( \"(\" . \")\" )
+ ( \"{\" . \"}\" )
+ ( \"[\" . \"]\" )))")
+
+;;; ......................................................... &vu-word ...
+
+(defcustom tinymy-:move-word-set "-[]_$%@#&*\":;,.{}()<>/\\ \t\n"
+ "*How to move forward/backward word. This is character set."
+ :type '(string :tag "Charset")
+ :group 'TinyMy)
+
+(defcustom tinymy-:move-word-case-set "-[]_$%@#&*\":{}()<>/\\ \t\na-z"
+ "*How to move forward/backward word. This is character set.
+used only over mixed case words."
+ :type '(string :tag "Charset")
+ :group 'TinyMy)
+
+(defcustom tinymy-:move-word-case-modes
+ '(c-mode
+ c++-mode
+ cc-mode
+ java-mode
+ sh-mode
+ bash-mode
+ csh-mnode
+ ksh-mode
+ jde-mode
+ jdee-mode
+ perl-mode
+ cperl-mode
+ php-mode
+ jsp-mode
+ text-mode)
+ "*Modes where `tinymy-:move-word-case-set' is used."
+ :type '(repeat function)
+ :group 'TinyMy)
+
+;;; ........................................................ &vu-shell ...
+
+(defcustom tinymy-:tar-command "tar -cf"
+ "*Tar create command, e.g. used in `tinymy-tar'."
+ :type '(string :tag "Shell command")
+ :group 'TinyMy)
+
+(defcustom tinymy-:shar-command "shar -a -c -C -e -t -u"
+ "*Shar command used by `tinymy-shar'.
+In HP-UX:
+
+ -a do not protect them specially (uu)
+ -c data-integrity check using wc
+ -C Insert a line of the form --- cut here ---
+ -e code that prevents shar .. overwrite existing files.
+ -t Write diagnostics to stdout
+ -u Assume that the remote site has uudecode"
+ :type '(string :tag "Shell command")
+ :group 'TinyMy)
+
+;;; ...................................................... &vu-compile ...
+
+(defcustom tinymy-:compile-table
+ (list
+ '("perl" . "perl -w %s")
+ '("code-shell-sh" . "sh -x %s")
+ '("code-shell-bash" . "bash -x %s")
+ '("code-shell-t?csh-" . "csh -x %s")
+ '("code-shell-ksh" . "ksh -x %s")
+ '("awk" . "awk -f %s")
+ '("xml" . tinymy-compile-xml-command)
+ '("c[+]+\\|^cc?-\\|code-c" . tinymy-compile-cc-command)
+ '("bat" . "%s")
+ '("text-white-paper" . tinymy-compile-tinytf-command)
+ (cons "lisp"
+ (concat
+ (if (ti::emacs-p)
+ "emacs"
+ "xemacs")
+ " -batch -f batch-byte-compile %s"))
+ '("java" . "javac %s")
+ (cons "php"
+ (let ((php (executable-find "php"))
+ (php4 (executable-find "php4")))
+ (if (or php php4)
+ (concat (or php php4) " %s"))))
+
+ '("sql" . tinymy-compile-sql))
+ "*Compilation table, how to run the code through interpreters.
+The command is put into %s in the COMPILE-COMMAND part.
+
+format:
+
+ '((REGEXP-for-buffer-type . COMPILE-COMMAND)
+ (REGEXP-for-buffer-type . COMPILE-COMMAND)
+ ..)
+
+REGEXP
+
+ The regexp is like 'code-c' 'code-pascal' or alternatively a
+ `mode-name' if buffer content can't be identified. See
+ tinylibid.el and function `ti::id-info' for more.
+
+COMPILE-COMMAND
+
+ STRING with %s where `buffer-file-name' is inserted.
+
+ -- If string, then this command is suggested for file.
+ -- if something else, the content is evaled and it should return
+ compile command STRING with %s for file name.
+ -- If function, function must return complete compile command,
+ with _no_ %s.
+
+Example:
+
+ Suppose you have several perl interpreters and you want to use the
+ shebang interpreter (first line in the script) for your project's perl
+ scripts. The following code:
+
+ -- Looks up the existing perl compile command and stores it to ELT
+ -- Changes the right hand COMPILE-COMMAND to Lisp form that
+ determines the perl command according to file name. Function
+ `ti::buffer-shebang' reads the command interpreter from the first line.
+
+ (add-hook 'tinymy-load-hook 'my-tinymy-compile-customisations)
+ (autoload 'aput \"assoc\")
+
+ (defun my-tinymy-compile-customisations ()
+ (aput 'tinymy-:compile-table
+ \"perl\"
+ '(if (string-match \"project\" buffer-file-name)
+ (concat (or (ti::buffer-shebang) \"perl\") \" -w %s\")
+ \"perl -w %s\")))
+
+ If you always want to use the shebang command interpreter, then you
+ would simply write
+
+ (add-hook 'tinymy-load-hook 'my-tinymy-compile-customisations)
+ (autoload 'aput \"assoc\")
+
+ (defun my-tinymy-compile-customisations ()
+ (aput 'tinymy-:compile-table
+ \"perl\"
+ '(concat (or (ti::buffer-shebang) \"perl\") \" -w %s\")))
+
+ After this package has been loaded. (Place customizations like this
+ to `tinymy-:load-hook'."
+ :type '(retpeat
+ (string :tag "Regexp")
+ (string :tag "Shell command"))
+ :group 'TinyMy)
+
+;;}}}
+;;{{{ setup: other, version
+
+(defvar tinymy-:buffer-info-cache nil
+ "Cached buffer data values in function `tinymy-buffer-info'.
+Format:
+ '((buffer-pointer size message-string)
+ ...)")
+
+;;;###autoload (autoload 'tinymy-version "tinymy" "Display commentary." t)
+
+(eval-and-compile
+ (ti::macrof-version-bug-report
+ "tinymy.el"
+ "tinymy"
+ tinymy-:version-id
+ "$Id: tinymy.el,v 2.86 2007/05/07 10:50:08 jaalto Exp $"
+ '(tinymy-:version-id
+ tinymy-:debug
+ tinymy-:vi-type-paren-match-list
+ tinymy-:define-key-force
+ tinymy-:define-key-table
+ tinymy-:load-hook
+ tinymy-:mail-buffer-hook
+ tinymy-:install-select-window-auto
+ tinymy-:register
+ tinymy-:scroll-mode
+ tinymy-:copy-file-suffix
+ tinymy-:vi-type-paren-match-special-list
+ tinymy-:move-word-set
+ tinymy-:move-word-case-set
+ tinymy-:move-word-case-modes
+ tinymy-:tar-command
+ tinymy-:shar-command
+ tinymy-:compile-table
+ tinymy-:save-buffer-modes
+ tinymy-:save-buffer-regexp
+ tinymy-:force-revert
+ tinymy-:revert-in-progress
+ tinymy-:revert-buffer-info-list
+ tinymy-:window-previous)
+ '(tinymy-:debug-buffer)))
+
+;;;### (autoload 'tinymy-debug-toggle "tinymy" t t)
+
+(eval-and-compile (ti::macrof-debug-standard "tinymy" "-:"))
+
+;;}}}
+;;{{{ install: main
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinymy-define-keys ()
+ "Install keys."
+ (interactive)
+
+ (when (boundp 'shared-lisp-mode-map)
+ (defvar shared-lisp-mode-map nil) ;; Byte compiler silencer
+ (define-key shared-lisp-mode-map "%" 'tinymy-vi-type-paren-match))
+
+ (define-key emacs-lisp-mode-map "%" 'tinymy-vi-type-paren-match)
+ (define-key lisp-mode-map "%" 'tinymy-vi-type-paren-match)
+
+ ;; was C-xq was kbd-macro-query
+
+ (global-set-key "\C-xq" 'tinymy-buffer-file-chmod)
+
+ ;; Redefine scroll keys, we don't confirm these...
+
+ (global-set-key [(prior)] 'tinymy-scroll-up)
+ (global-set-key [(next)] 'tinymy-scroll-down)
+
+ ;; In XEmacs these already have default bindings, but we override them.
+
+ (global-set-key [(control right)] 'tinymy-word-forward)
+ (global-set-key [(control left)] 'tinymy-word-backward)
+ (global-set-key [(control up)] 'tinymy-beginning-of-defun)
+ (global-set-key [(control down)] 'tinymy-end-of-defun)
+
+ (unless (ti::compat-window-system)
+ (global-set-key [(meta f)] 'tinymy-word-forward)
+ (global-set-key [(meta b)] 'tinymy-word-backward))
+
+ ;; Use C-z prefix because it is most user friendly to pinky
+ ;; Pretty useless in X-windowed Emacs, and in windowed
+ ;; Emacs you seldom use suspend-emacs because emacs has M-x shell
+
+ (ti::use-prefix-key global-map "\C-z")
+
+ ;; Set global keys, confirm these
+
+ (mapcar
+ (function
+ (lambda (x)
+ (if tinymy-:define-key-force
+ (define-key global-map (car x) (cdr x))
+ (ti::define-key-if-free global-map
+ (car x)
+ (cdr x)
+ 'tinymy-define-key-error))))
+ tinymy-:define-key-table)
+
+ ;; .................................................... &emacs-modes ...
+
+ (add-hook 'makefile-mode-hook 'tinymy-makefile-mode-hook)
+
+ (defun tinymy-makefile-mode-hook ()
+ "Define key C-c/ to adjust \\ continuing lines."
+ (define-key
+ (symbol-value 'makefile-mode-map) "\C-c\\"
+ 'ti::buffer-backslash-fix-paragraph)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinymy-define-keys-extra ()
+ "Define extra global keys."
+ (interactive)
+ (global-set-key "%" 'tinymy-vi-type-paren-match)
+ (global-set-key "\C-x\C-q" 'tinymy-buffer-read-only))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymy-install-mouse-movement-handler (&optional uninstall)
+ "Install or UNINSTALL `tinymy-mouse-movement-handler'
+References:
+ `tinymy-:install-select-window-auto'."
+
+ (when (and (not uninstall)
+ (ti::compat-window-system))
+ (let ((ok
+ (or (eq tinymy-:install-select-window-auto 'yes)
+ (and
+ (eq tinymy-:install-select-window-auto 'ask)
+ (null
+ (y-or-n-p
+ (concat
+ "TinyMy: Are you sure? "
+ "This feature conflicts with menubar usage")))))))
+ (cond
+ ((and ok
+ (ti::emacs-p)
+ (ti::win32-p) ;; Bug in Win32; works in Unix Emacs
+ (ti::emacs-type-win32-p) ;; Cygwin Emacs is ok
+ (string-match "^21" emacs-version))
+ ;; Bug in Win32 21.[123] makes Emacs to behave starangely
+ ;; when mouse-movement tracking is enabled.
+ ;;
+ ;; Use this code to check your Emacs: Start fresh emacs, and run it.
+ ;; If the Frame's menu-bar
+ ;; line constantly flickers, then Emacs is broken. This code
+ ;; does not work in XEmacs (there is no track-mouse)
+ ;;
+ ;; (progn
+ ;; (defun test (event)
+ ;; (interactive "e")
+ ;; (message "mouse movement ok")
+ ;; (discard-input))
+ ;; (setq track-mouse t)
+ ;; (global-set-key [(mouse-movement)] 'test))
+ ;;
+ (message "Tinymy: [NOTICE] `mouse-movement' \
+has changed in Emacs 21.x. Unable to install handler."))
+ ((and ok
+ (ti::emacs-p))
+ (setq track-mouse t) ;This is essential
+ ;; Make sure that this handler is not occupied yet
+ (if (memq (lookup-key global-map [(mouse-movement)])
+ '(tinymy-mouse-movement-handler
+ tooltip-mouse-motion
+ ignore
+ nil))
+ (global-set-key [(mouse-movement)]
+ 'tinymy-mouse-movement-handler)
+ (message "\
+** tinymy.el: can't install mouse-movement handler, already occupied.")))
+ ((and ok
+ (ti::xemacs-p))
+ ;; See also package mode-motion+.el
+ ;;
+ ;; `mode-motion-hook' is buffer local. Hm. And it is called from
+ ;; `default-mouse-motion-handler' inside `save-window-excursion'.
+ ;; Not good. Window can't be changed form that hook, so we must
+ ;; replace function in `mouse-motion-handler'.
+ ;;
+ (defvar mouse-motion-handler nil) ;ByteComp silencer in Emacs
+ (if (eq (symbol-value 'mouse-motion-handler)
+ 'default-mouse-motion-handler)
+ (defconst mouse-motion-handler
+ 'tinymy-default-mouse-motion-handler-xemacs)
+ (message "\
+** tinymy.el: Can't install: `mouse-motion-handler' is not default."))
+ (defun tinymy-default-mouse-motion-handler-xemacs (event)
+ "Call `default-mouse-motion-handler' and
+`tinymy-mouse-movement-handler'."
+ (prog1 (ti::funcall 'default-mouse-motion-handler event)
+ (tinymy-mouse-movement-handler event))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinymy-install-after-save-hook (&optional uninstall)
+ "Intall or UNINSTALL functions to `after-save-hook'."
+ (let ((func 'executable-make-buffer-file-executable-if-script-p))
+ (when (and (fboundp func)
+ (memq func after-save-hook))
+ ;; #todo: Watch Emacs version when this is fixed.
+ ;; Latest Emacs versons have this in executable.el
+ ;; Un fortortunately Emacs 21.3 has bug for Ange-FTP remote
+ ;; files, where this signals error, so don't use it.
+ (message
+ (concat
+ "TinyMy: `%s' does not work for remote files. Removed from"
+ " `after-save-hook'.")
+ (symbol-name func)))
+ (remove-hook 'after-save-hook func))
+ (ti::add-hooks 'after-save-hook
+ 'tinymy-maybe-make-file-executable
+ uninstall))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinymy-install (&optional uninstall)
+ "Intall or UNINSTALL package. Configure Emacs variables and bindings."
+ (interactive)
+ (when (ti::compat-window-system)
+ (tinymy-install-mouse-movement-handler uninstall))
+ (tinymy-install-after-save-hook uninstall))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymy-define-key-error (key def)
+ "Call back function. Warn about conflicting key binding for KEY and DEF."
+ (message "TinyMy: Cannot auto-install, key already occupied: %s %s"
+ key def))
+
+;;}}}
+;;{{{ buffer: chmod
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinymy-buffer-file-chmod (&optional verb)
+ "Toggle current buffer's Read-Write permission permanently on disk. VERB.
+Does nothing if buffer is not visiting a file or file is not owned by us."
+ (interactive)
+ (let* ((file (buffer-file-name))
+ stat)
+ (ti::verb)
+ (when (and file (file-modes file)) ;File modes is nil in Ange-ftp
+ (setq stat (ti::file-chmod-w-toggle file))
+ (when verb
+ (cond
+ ((eq stat 'w+)
+ (message "TinyMy: chmod w+")
+ (setq buffer-read-only nil))
+ ((eq stat 'w-)
+ (message "TinyMy: chmod w-")
+ (setq buffer-read-only t))
+ (t
+ (message "TinyMy: couldn't chmod")))
+ (ti::compat-modeline-update)))))
+
+;;}}}
+;;{{{ buffers: gzip
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymy-buffer-file-gzip ()
+ "Compress or uncompress current file buffer with gzip."
+ (interactive)
+ (save-buffer)
+ (let* ((gzip "gzip"))
+ (cond
+ ((or (not (stringp buffer-file-name))
+ (null (file-modes buffer-file-name))) ;Ange ftp
+ (message "timy. Can't gzip this buffer."))
+ ((or (ti::vc-rcs-file-exists-p buffer-file-name)
+ (and (fboundp 'vc-registered)
+ (ti::funcall 'vc-registered buffer-file-name)))
+ (message "TinyMy: This file is VC controlled. No gzip allowed."))
+ ((string-match "\\.gz$" buffer-file-name)
+ (call-process gzip nil nil nil "-d" buffer-file-name)
+ (setq buffer-file-name (replace-regexp-in-string
+ "\\.gz$" "" buffer-file-name))
+ (rename-buffer (file-name-nondirectory buffer-file-name))
+ (set-visited-file-modtime))
+ (t
+ (call-process gzip nil nil nil "-9" buffer-file-name)
+ (unless (string-match "\\.gz$" buffer-file-name)
+ (setq buffer-file-name (concat buffer-file-name ".gz")))
+ (rename-buffer (file-name-nondirectory buffer-file-name))
+ (set-visited-file-modtime)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymy-buffer-read-only ()
+ "Put buffer in `view-mode' if read-only is turned on.
+
+Important, If file is vc controlled:
+
+ This function is ment for changing the
+ buffer characteristics without changing the version control state.
+
+ Normally \\[toggle-read-only] would do CheckOut if the file was
+ read-only, but sometimes it is convenient to put buffer to read-only
+ state to prevent changing anything in there for a while."
+ (interactive)
+ (let* ((fid "tinymy-buffer-read-only")
+ (key-func (if (or (featurep 'vc)
+ (featurep 'vc-hooks))
+ 'vc-toggle-read-only
+ 'toggle-read-only))
+ state
+ call
+ turn-mode)
+ (unless fid ;; No-op. XEmacs byte compiler silencer
+ (setq fid nil))
+ (tinymy-debug fid
+ "VC" (featurep 'vc)
+ "mode" major-mode
+ key-func
+ "FILE" buffer-file-name)
+ (ti::save-line-column-macro nil nil
+ (cond
+ ((memq major-mode '(dired-mode)) ;plain C-x C-q for these modes...
+ (toggle-read-only))
+ (t
+ (cond
+ ((and (eq key-func 'vc-toggle-read-only)
+ buffer-file-name ;maybe *temp* buffer ?
+ (vc-name buffer-file-name)) ;is file registered ?
+
+ (if (y-or-n-p "Call vc? ")
+ (call-interactively 'vc-toggle-read-only)
+ (toggle-read-only)))
+ (t
+ (call-interactively key-func)))
+ (tinymy-debug fid "STATE after" buffer-read-only)
+ (setq state buffer-read-only) ;what happened ?
+ (setq turn-mode ;can't use nil, because it toggles
+ (if state 1 0))
+ (view-mode turn-mode))))))
+
+;;}}}
+;;{{{ buffers: other
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymy-flip-windows ()
+ "Switch window order. There must be only 2 windows."
+ (interactive)
+ (when (> (count-windows) 1)
+ (let ((first-buffer (window-buffer (selected-window)))
+ (second-buffer (window-buffer (next-window (selected-window)))))
+ (set-window-buffer (selected-window) second-buffer)
+ (set-window-buffer (next-window (selected-window)) first-buffer))))
+
+;;}}}
+;;{{{ Mouse, cursors
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymy-cursor-set-type (cursor &optional frame)
+ "Set the CURSOR type for the named FRAME."
+ (if (not frame)
+ (setq frame (selected-frame)))
+ ;; Do the modification.
+ (modify-frame-parameters
+ frame
+ (list (cons 'cursor-type cursor))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymy-cursor-overwrite-mode ()
+ "Set the cursor-type according to the insertion mode"
+ (cond
+ (overwrite-mode
+ (let ((cursor (or (frame-parameter (selected-frame) 'cursor-type)
+ 'block)))
+ (put 'tinymy-cursor-overwrite-mode 'saved-cursor-type cursor)
+ ;; The type is going to change to 'bar, but if user has it
+ ;; on by default, pick the opposite.
+ (tinymy-cursor-set-type (if (equal cursor 'bar)
+ 'block
+ 'bar))))
+ (t
+ (tinymy-cursor-set-type
+ (get 'tinymy-cursor-overwrite-mode 'saved-cursor-type)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(if (fboundp 'overwrite-mode-hook)
+ (add-hook 'overwrite-mode-hook 'tinymy-cursor-overwrite-mode-hook)
+ (defadvice overwrite-mode (around tinymy act)
+ "Change cursor to 'block or 'bar according to `overwrite-mode'."
+ ad-do-it
+ (tinymy-cursor-overwrite-mode)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinymy-buffer-info-cache-string (buffer)
+ "If same size, return cached string from `tinymy-:buffer-info-cache'."
+ (when (and (setq buffer (assq buffer tinymy-:buffer-info-cache))
+ (or (eq (nth 1 buffer) (buffer-size))
+ ;; It it's modified, it hasn't been written to disk yet,
+ (buffer-modified-p)))
+ (nth 2 buffer)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymy-buffer-info-1 ()
+ "Display buffer information:
+If buffer is associated to file: -rwx-rw-r-- 20k /absolute/path/file.txt
+If no file: SIZEk SIZE-IN-BYTES"
+ (interactive)
+ (let* ((file buffer-file-name)
+ (ssize (buffer-size))
+ (size (/ ssize 1000)) ;; well, it's 1024 to exact but this suffices
+ (modes "")
+ lines)
+ ;; E.g. Gnus defines `buffer-file-name' for Draft messages,
+ ;; but the file is not actually written, so we test for existense
+ ;; to prevent suprises from happening.
+ (cond
+ ((and (memq major-mode '(dired-mode vc-dired-mode))
+ (boundp 'dired-directory))
+ (setq lines (- (count-lines (point-min) (point-max)) 2))
+ (format "Tinymy: count %d %s"
+ lines
+ (symbol-value 'dired-directory)))
+ (file
+ (or (string-match "@" file) ;; Ange-ftp file is ok.
+ (and (file-exists-p file)
+ (setq modes
+ (ti::file-access-mode-to-string (file-modes file)))))
+ (format "%s %dk %s" (or modes "") size file))
+ (t
+ (format "buffer size %dk (%d bytes)" size ssize)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymy-buffer-info ()
+ "Display buffer information."
+ (let ((old-message (tinymy-buffer-info-cache-string (current-buffer))))
+ (if old-message
+ (message old-message)
+ (setq old-message (tinymy-buffer-info-1))
+ (setq tinymy-:buffer-info-cache
+ (delq (current-buffer) tinymy-:buffer-info-cache))
+ (push (list
+ (current-buffer)
+ (buffer-size)
+ old-message)
+ tinymy-:buffer-info-cache))))
+
+;;; ----------------------------------------------------------------------
+;;; >How can I get the selected window to change as I move the mouse cursor
+;;; >into that window? In other words, I don't want to have to click the
+;;; >mouse in the new window every time I move between windows (windows, not
+;;; >frames, this is not a click-to-focus window manager question).
+;;;
+;;; This function was elp'ed to see how heavy it is for `mouse-handler'.
+;;; In byte compiled format the results in HP 10.20/9000/715
+;;;
+;;; Function Name Call Count Elapsed Time Average Time
+;;; =========================== ========== ============ ============
+;;; tinymy-mouse-movement-handler 29 0.0571780000 0.0019716551
+
+(defvar tinymy-:window-previous nil
+ "Used in `tinymy-mouse-movement-handler'.")
+
+(defun tinymy-mouse-movement-handler (event)
+ "Nice mouse movement EVENT handler.
+
+Change window automatically:
+
+ If you point a nother window where cursor was, the new window is
+ automatically made active.
+
+Show information on echo-area:
+
+ If you point mouse near the end of botton line (right hand corner),
+ a brief file information is shown in echo area. If window is bigger
+ than the text that is at the beginning of it, pointing to the end
+ of text is sufficient. Example output:
+
+ TinyMy: -rw-r--r-- 108k /users/jaalto/elisp/tinymy.el"
+
+ (interactive "e")
+ (let* ((case-fold-search t)
+ frame
+ win
+ mini
+ bottom
+ point
+ p)
+ (cond
+ ((and (fboundp 'event-window)
+ (eventp event))
+ ;; XEmacs calls us from motion hook
+ ;; #<motion-event 644, 221>
+ (setq win (ti::funcall 'event-window event)))
+ ((and (fboundp 'posn-window)
+ (fboundp 'event-start)
+ (eventp event))
+ (setq win (posn-window (event-start event))))
+ (t
+ ;; Unknown Emacs or interface changed radically
+ (message "Tinymy: tinymy-mouse-movement-handler error.\
+Contact maintaner with M-x tinymy-submit-bug-report.")))
+
+ (setq bottom (and win (window-end))
+ point (posn-point
+ (if (ti::emacs-p)
+ (event-start event)
+ event)))
+ ;; ............................................ auto window select ...
+ ;; The WIN could be frame pointer too, that's why we check it.
+ (cond
+ ((null win)) ;; WE HAVE NO WINDOW INFORMATION, stop.
+ ;; ............................................. different window ...
+ ((and (windowp win)
+ (window-live-p win)
+ ;; Motion in same window as prereviously?
+ (not (eq tinymy-:window-previous win)))
+ (setq tinymy-:window-previous win
+ mini (window-minibuffer-p win))
+ ;; 1. Select window if it's not minibuffer
+ ;; 2. if it's minibuffer, select it _only_ if it's active
+ (when (or (not mini)
+ (minibuffer-window-active-p win))
+ (setq frame (window-frame (select-window win)))
+ (raise-frame frame)
+ ;; FIXME: Is this really needed?
+ (select-frame frame)))
+ ;; ....................................... Special 'info' handler ...
+ ((and (not (window-minibuffer-p (selected-window)))
+ (not (eq (point-min) (point-max)))) ;Not empty buffer?
+ ;; ........................................... pointing with mouse ...
+ (when (integerp point) ;POINT could be 'mode-line
+ (setq p point) ;Crossing window border
+ ;; (message "%d %d %d " p bottom (- bottom p) )
+ ;; Threshold of NN characters, near the right hand lower corner.
+ ;; Make the call `inline' because `tinymy-mouse-movement-handler'
+ ;; is called very often
+ (when (and p (< (- bottom p) 50))
+ (inline (tinymy-buffer-info))
+ ;; mic paren: If your cursor is at end of defun
+ ;; parenthesis, and this function is called, the
+ ;; mic-paren will still display the beginning of function
+ ;; info. Out info is not show...
+ (defvar mic-paren-backw-overlay nil) ;No-op, ByteComp
+ (if (and (featurep 'mic-paren)
+ ;; This overlay exists if cursor was on paren
+ mic-paren-backw-overlay)
+ (sit-for 2))))))
+ ;; Integrate with Emacs 21.3
+ (when (fboundp 'tooltip-mouse-motion)
+ (ti::funcall 'tooltip-mouse-motion event))))
+
+;;}}}
+;;{{{ elisp: package saving from mail, gnus
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymy-package-save-get-file-name ()
+ "See `tinymy-package-save-to-file'. Find out package file name.
+Return '(file-name point)."
+ (let* ((fid "tinymy-package-save-get-file-name:")
+ ;; - the file start and it's name
+ ;; - The regexp will jump until there is a-zA-Z0-9
+ (com "^\\(#\\|;;+\\)")
+ (re1 (concat com "[ \t]+\\([^ \t]+\\.el\\)[ \t]+[-][-]+"))
+ (re2 (concat com "[ \t]+\\([^ \t]+\\)[ \t]+[-][-]+[ \t]"))
+ (re3 (concat com "[ \t]+\\(.*\\)[ \t]+[-][-]+"))
+ (re4 (concat com "[ \t]+\\(.*\\)[ \t]+[-]+"))
+ (re5 "^\\(;;;*\\)[ \t]+\\([^ \t\n]+\\.el\\)[ \t]+")
+ file
+ point)
+ (unless fid ;; No-op. XEmacs byte compiler silencer
+ (setq fid nil))
+ (save-excursion
+ (ti::pmin)
+ ;; See if we can detect the package name in this buffer
+ (when (dolist (re (list re5 re1 re2 re3 re4))
+ (when (re-search-forward re nil t)
+ (tinymy-debug fid 'MATCH re 'LINE (ti::read-current-line) "\n")
+ (return t)))
+ (setq file (match-string 2)
+ com (match-string 1)
+ point (line-beginning-position))
+ ;; Verify that we found correct point
+ (goto-char point)
+ (when (or (looking-at "^.*end.*here")
+ ;; If the point is near the end of file, reject it
+ (> (- (point-max) (* 3 80))
+ point))
+ ;; Nope, wrong position found. Try again.
+ (goto-char (point-min))
+ (when (re-search-forward "^;;;")
+ (setq point (line-beginning-position))))
+ ;; Suppose this is a lisp file, because comment mark is colon(;)
+ ;; make sure the filename has .el at the end
+ (tinymy-debug fid 'BUFFER (buffer-name) 'FILE file "\n")
+ (beginning-of-line)
+ (when (looking-at "^[ \t]*;")
+ (setq file (ti::string-verify-ends file "\\.el" ".el")
+ file (or (locate-library file) file)))))
+ (tinymy-debug fid 'BUFFER (current-buffer) 'RET file 'POINT point)
+ (cond
+ (file
+ (list file point))
+ (t
+ (message "TinyMy: (package save) No proper File header found.")
+ nil))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymy-package-save-to-file-buffer-beginning (file)
+ "Find proper file beginning point.
+
+Return:
+
+ point or nil."
+ (let* ((fid "tinymy-package-save-to-file-buffer-beginning:")
+ (fname (file-name-sans-extension (file-name-nondirectory file)))
+ (ext (file-name-extension file))
+ (regexp
+ ;; file\\(.ext\\)? -- description
+ ;; ;;; @(#) file.ext --- description
+ ;; |
+ ;; see unix SunOS what(1) command
+ (format "^\\([^ \t\n:,.-]+\\) +\\(%s[ \t]*\\)?%s[ \t]+-+[ \t]+"
+ (regexp-quote "@(#)")
+ (concat
+ (regexp-quote fname)
+ "\\(\\." (regexp-quote ext) "\\)?")))
+ point)
+ (unless fid ;; No-op. XEmacs byte compiler silencer
+ (setq fid nil))
+ (save-excursion
+ (ti::pmin)
+ (when (re-search-forward regexp nil t)
+ (setq point (line-beginning-position))))
+ (tinymy-debug fid
+ 'FILE file
+ 'BUFFER (current-buffer)
+ 'REGEXP regexp
+ 'POINT point)
+ point))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymy-package-save-to-file-buffer-ending (&optional start-point)
+ "Find proper file ending starting from START-POINT.
+Return point or nil."
+ (let* ((fid "tinymy-package-save-to-file-buffer-ending:")
+ ;; - the file start and it's name
+ ;; - The regexp will jump until there is a-zA-Z0-9
+ (com "^\\(#\\|;;+\\)")
+ (regexp (concat
+ com
+ "[ \t]+\\(end[ \t]+of[ \t]\\(file\\)?\\|^;.*&eof\\)"
+ "\\|^;;+[ \t]+.*ends here"))
+ ;; Yes, it really does have trailing space
+ ;; "- -- \n" is for PGP signed message which breaks the
+ ;; dashes.
+ (signature-end "^\\(- \\)?-- \n")
+ end-point)
+ (unless fid ;; No-op. XEmacs byte compiler silencer
+ (setq fid nil))
+ (save-excursion
+ (if start-point
+ (goto-char start-point)
+ (ti::pmin))
+ (cond
+ ((re-search-forward regexp nil t)
+ (beginning-of-line)
+ (tinymy-debug fid 'REGEXP regexp (point) (ti::read-current-line))
+ (setq end-point (line-beginning-position)))
+ ((progn
+ (ti::pmax)
+ (re-search-backward signature-end start-point t))
+ (tinymy-debug fid 'SIGNATURE (point))
+ (setq end-point (line-beginning-position)))))
+ end-point))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymy-package-save-to-file-buffer ()
+ "Return correct code buffer, usually `current-buffer'.
+For Gnus this is `gnus-original-article-buffer'."
+ (cond
+ ((and (featurep 'gnus)
+ (or (string= (buffer-name)
+ gnus-article-buffer)
+ (and (equal (current-buffer) gnus-summary-buffer)
+ (not (string-match
+ "Dead "
+ (buffer-name gnus-summary-buffer))))))
+ (let ((buffer (get-buffer gnus-original-article-buffer)))
+ (if (and buffer
+ (y-or-n-p "TinyMy: Use unformatted *Original Article Buffer*? "))
+ ;; For Gnus, use the unformatted buffer
+ buffer
+ (current-buffer))))
+ (t
+ (current-buffer))))
+
+;;; ----------------------------------------------------------------------
+;;; - Imagine that you're reading gnu.emacs.sources and want to get
+;;; that package in the post.
+;;; - Or you receive a package in private mail message...
+;;; - This does the job of saving that package to file very easily.
+;;;
+(defun tinymy-package-save-to-file (file &optional code-buffer save-start)
+ "Save FILE in current buffer starting at optional SAVE-START.
+
+The file is supposed to have special heading and when the heading
+is found the file ends at `point-max' or when the footer is found
+The following are valid heading. See unix what(1) for the second line.
+
+ ;; file.el -- description
+ # @(#) file.txt -- description
+
+If function can't find footer
+
+ End of XXX.txt
+ End of file XXX.txt
+ &eof
+ XXX ends here
+
+it'll add one and include everything to the end of buffer,
+before writing."
+ (interactive
+ (let ((buffer (tinymy-package-save-to-file-buffer)))
+ (with-current-buffer buffer
+ (multiple-value-bind (file point buf)
+ (tinymy-package-save-get-file-name)
+ (unless file
+ (error
+ "TinyMy: Can't find filename. Select a region, M-x write-region."))
+ (list
+ (read-file-name "Save to file: "
+ (file-name-directory file)
+ nil ;; users null string
+ (not 'must-match)
+ (file-name-nondirectory file))
+ buffer
+ point)))))
+ (let* ((fid "tinymy-package-save-to-file:")
+ (orig-point (point))
+ p1
+ p2
+ ans
+ str
+ point)
+ (unless fid ;; No-op. XEmacs byte compiler silencer
+ (setq fid nil))
+ (or code-buffer
+ (setq code-buffer
+ (tinymy-package-save-to-file-buffer)))
+ ;; See if we can detect the package name in this buffer
+ (when file
+ (with-current-buffer code-buffer
+ (ti::pmin)
+ (setq p1 (or save-start
+ (tinymy-package-save-to-file-buffer-beginning file)
+ (point))
+ p2 (point-max))
+ ;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ end ^^^
+ (setq point (tinymy-package-save-to-file-buffer-ending p1))
+ (cond
+ (point
+ (setq p2 point))
+ (t
+ (setq str "TinyMy: Hm, No proper save ending. Using point-max ")
+ (tinymy-debug fid str)
+ (message str)
+ (sit-for 1)))
+ ;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ existing file ^^^
+ (when (file-exists-p file)
+ (setq ans (read-from-minibuffer "overwrite?: " file))
+ (cond
+ ((string= ans file)
+ (delete-file file))
+ ((ti::nil-p ans)
+ (error "TinyMy: Aborted."))
+ (t
+ (setq file ans))))
+ (tinymy-debug fid 'SAVE-FROM code-buffer p1 p2 'TO file)
+ (when (or (eq p1 p2)
+ (> p1 p2))
+ (error "\
+TinyMy: [ERROR] Can't find region. Save manually (See M-x tinymy-version)."))
+ ;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ saving ^^^
+ (with-temp-buffer
+ (insert-buffer-substring code-buffer p1 p2)
+ (ti::pmin)
+ (when (string-match "\\.\\(zip\\|gz\\)$" file)
+ (ti::use-file-compression))
+ (write-file file) ;jka handles compressing
+ (not-modified)
+ (message (concat "TinyMy: Package saved to " file)))
+ ;; Restore point
+ (goto-char orig-point)))))
+
+;;}}}
+;;{{{ file
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymy-maybe-make-file-executable ()
+ "If file's first line starts with #!, make file executable.
+Ignores file whose `file-modes' can't be read, e.g. for ange-ftp files."
+ (let* ((file (buffer-file-name))
+ (mode (and file
+ (not (ti::file-name-remote-p file))
+ (file-modes file))))
+ (when (and file
+ mode
+ (save-excursion
+ (ti::pmin)
+ (let ((stat (looking-at "^#!")))
+ (if (and (not stat)
+ (looking-at
+ (concat
+ "^"
+ ;; Do not use ".+", because it overflows
+ ;; Emacs egexp matcher in files which are
+ ;; one big line, like in Gnus
+ ".?.?.?.?.?.?.?.?.?.?.?.?.?.?.?"
+ "#!")))
+ (message "Tinymy: Suspicious #! first line."))
+ stat)))
+ (unless (eq 64 (logand 64 mode))
+ (set-file-modes file (ti::file-mode-make-executable mode))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymy-trim-blanks ()
+ "Delete trailing blanks from all lines; including lines from end of buffer."
+ (interactive)
+ (save-excursion
+ (unless buffer-read-only
+ (ti::buffer-trim-blanks (point-min) (point-max))
+ ;; Now delete extra lines from the end of buffer
+ (goto-char (point-max))
+ (when (not (zerop (skip-chars-backward " \t\n")) )
+ (forward-char 1) ;Leave newline
+ (unless (eq (point) (point-max))
+ (delete-region (point-max) (point))))))
+ (if (interactive-p)
+ (message "TinyMy: Blanks trimmed"))
+ nil) ;Clean return code
+
+;;; ----------------------------------------------------------------------
+;;; - Especially when I'm making diff to the Author I find this
+;;; very useful.
+;;;
+;;;
+(defun tinymy-copy-file (file1 file2 &optional arg)
+ "Make copy of current buffer FILE1 to FILE2 (FILE1.orig or FILE1.VER).
+Function tries to find possible RCS version.
+You usually make backup if you make a change and send diff to author.
+
+If you supply PREFIX ARG, then
+
+ C - u remove the copy files; namely, (buffer-file-name).*
+ nbr Copy back: this like doing
+ FILE.VER --> FILE
+ FILE.orig --> FILE
+
+ If you had made a safe copy previously, this restores
+ the safe copy to original file."
+ (interactive
+ (let* ((suf tinymy-:copy-file-suffix)
+ (ver (or (ti::vc-rcs-buffer-version)
+ ;; No rcs string found, then try Regular lisp package
+ ;; syntax.
+ ;;
+ ;; Version: 2.37
+ (ti::re-search-check
+ "^;+[ \t]+Version:[ \t]*\\([0-9.]+\\)" 1 nil 'read)))
+ (file1 (or (buffer-file-name)
+ (error "Buffer does not visit a file.")))
+ (ext (if ver
+ (concat "." ver)
+ suf))
+ file2)
+ (if current-prefix-arg
+ (list file1 nil current-prefix-arg)
+ (setq file2 (read-from-minibuffer "Make copy to: " (concat file1 ext)))
+ (list file1 file2))))
+
+ (let* ((re (format "^%s\\." (file-name-nondirectory file1)))
+ (file-list (ti::directory-files (file-name-directory file1)
+ re 'abs t)))
+ (cond
+ ((null arg)
+ (cond
+ ((or (not (file-exists-p file2))
+ (and (file-exists-p file2)
+ (y-or-n-p (format "%s exists. Remove? " file2))
+ (progn
+ (delete-file file2)
+ t)))
+ (ti::file-delete-safe file2)
+ (copy-file file1 file2)
+ (message "TinyMy: safe copy done."))
+ (t
+ (message "TinyMy: sorry; cannot decide how to do the copying."))))
+ ((equal arg '(4))
+ (if (null file-list)
+ (message "TinyMy: There are no safe copy files matching %s" re)
+ (dolist (file1 file-list)
+ (if (y-or-n-p (format "Delete %s ? " file1))
+ (delete-file file1)))))
+ ((integerp arg)
+ (cond
+ ((null file-list)
+ (message "TinyMy: There is no safe copy for %s" file1))
+ ((eq 1 (length file-list))
+ (when (y-or-n-p
+ (message "TinyMy: Found safe copy %s; copy it over original? "))
+ (delete-file file1) ;copy-file barfs otherwise
+ (copy-file (car file-list) file1)
+ (message "TinyMy: Safe copy restored.")))
+ ((> (length file-list) 1)
+ (setq file2
+ (completing-read
+ "Don't know which one to use as source, complete: "
+ (ti::list-to-assoc-menu
+ (mapcar 'file-name-nondirectory file-list))
+ nil 'must-match))
+ (setq file2 (concat (file-name-directory file1) file2))
+ (delete-file file1)
+ (copy-file file2 file1)
+ (message "TinyMy: Safe copy restored: %s --> %s"
+ (file-name-nondirectory file2 )
+ (file-name-nondirectory file1))))))))
+
+;;}}}
+;;{{{ key: % matching
+
+;;; ----------------------------------------------------------------------
+;;; All the posts so far in the internet to make the "%" match parens
+;;; right in every possible _mode_ failed. That's why I started writing
+;;; my own function, which you see here.
+;;;
+(defun tinymy-vi-type-paren-match (&optional arg)
+ "Match engine: find {[( or )]} pairs. ARG is character repeat count.
+See also 'tinymy-:vi-type-paren-match-special-list
+
+References:
+ `tinymy-:vi-type-paren-match-list'
+ `tinymy-:vi-type-paren-match-special-list'"
+ (interactive "P")
+ (let* ((p (point))
+ (ptable (syntax-table)) ;previous, the original
+ (ch (following-char))
+ (ch-next (ti::buffer-read-char nil 1))
+ (ch-prev (preceding-char))
+ (pairs tinymy-:vi-type-paren-match-list)
+ (left (car-safe (assoc (char-to-string ch) pairs)))
+ (right (car-safe (rassoc (char-to-string ch) pairs)))
+ (m-list tinymy-:vi-type-paren-match-special-list) ;match list
+ (spread-limit (* 10 60)) ;approx 10 lines of code.
+ table
+ s-func add-func max-func bigger-func
+ self-insert
+ go
+ max)
+ (catch 'terminate
+ ;; check if the parens are "closed", ie. there is nothing beween them
+ (cond
+ ((and (ti::char-in-list-case ch m-list) ch-next)
+ (setq self-insert
+ (not (string= (char-to-string ch-next) (char-to-string ch)))))
+ (right
+ ;; If NEXT == RIGHT
+ (setq self-insert
+ (string= (char-to-string ch-prev) left)))
+ (left
+ (setq self-insert
+ (string= (char-to-string ch-next) right))))
+ (when (and ch self-insert)
+ (self-insert-command (or arg 1))
+ (throw 'terminate t))
+ ;; already calculated ? No ?
+ (unless (setq table (get 'tinymy-:vi-type-paren-match-list 'syntax-table))
+ (setq table (make-syntax-table))
+ ;; We want everything to look like word
+ (ti::dotimes counter 0 255 (modify-syntax-entry counter "w" table))
+ (mapcar
+ (function
+ (lambda (x)
+ (modify-syntax-entry (string-to-char (car x)) "(" table)
+ (modify-syntax-entry (string-to-char (cdr x)) ")" table)))
+ pairs)
+ (put 'tinymy-:vi-type-paren-match-list 'syntax-table table))
+ ;; In lisp; only () are matched.
+ (when (not (string-match "lisp" (symbol-name major-mode)))
+ (set-syntax-table table))
+ (unwind-protect
+ (condition-case nil
+ (cond
+ ;; ........................................ handle quotes ...
+ ((ti::char-in-list-case ch m-list)
+ (setq ch (regexp-quote (char-to-string ch)))
+ (setq s-func 're-search-forward
+ add-func '+
+ max-func 'point-max
+ bigger-func '>)
+ (cond
+ ((looking-at (concat ch "[ \t]*$"))
+ ;; Only search backward if no ARG given.
+ ;; if the " char is at the end of line,
+ ;; then it propably is the 'closing' one.
+ (if (null arg)
+ (setq s-func 're-search-backward
+ add-func '-
+ max-func 'point-min
+ bigger-func '<))))
+ ;; Do not go too far away....
+ (setq go (funcall add-func p spread-limit))
+ (setq max (funcall max-func))
+ (setq max
+ (if (funcall bigger-func go max)
+ max go))
+ ;; ... ... ... ... ... ... ... ... ... ... ... do search . .
+ (if (eq s-func 're-search-forward)
+ (forward-char 1)) ;move out of way
+ (funcall s-func ch go t)
+ ;; This is funny, it both a) restores the position
+ ;; if search failed, b) adjusts the "after" search
+ ;; point back to char.
+ (if (eq s-func 're-search-forward)
+ (forward-char -1)))
+ ;; ..................................... handle BEG pairs ...
+ ((looking-at "[[({<]")
+ (forward-sexp 1)
+ (backward-char)
+ (cond ((not (looking-at "[])}>]"))
+ (error "..booomerang"))))
+ ;; ..................................... handle END pairs ...
+ ((looking-at "[])}>]")
+ (forward-char 1)
+ (forward-sexp -1)
+ (when (not (eq p (point))) ;moved ?
+ ;; In lisp, jumping from closing ) to starting
+ ;; "'(lambda" puts cursor at "'"?? Correct it.
+ (if (and (not (eq (following-char) ?\( ))
+ (looking-at ".[]({<]"))
+ (forward-char 1))))
+ ;; ...................................... no special char ...
+ (t
+ (self-insert-command (or arg 1))))
+ (error
+ (goto-char p) ;restore position
+ (message "TinyMy: No match.")))
+ ;; make sure we restore this
+ (set-syntax-table ptable)))))
+
+;;}}}
+;;{{{ mail
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymy-mail-subject-get ()
+ "Look buffer content and return subject for mail message.
+
+diff buffer:
+
+ 'context diff file.txt'
+
+rcsdiff buffer:
+
+ 'diff 1.23 --> 1.25 file.txt'
+
+Regular buffer:
+
+ '1.25 file.txt' ;; possibly without version information
+
+buffer with no filename:
+
+ nil"
+ (let* ((rcs-re "retrieving revision +\\(.*\\)")
+ (v1 "")
+ (v2 "")
+ type
+ ver
+ file
+ msg)
+ (save-excursion
+ (ti::pmin)
+ (cond
+ ;; See if this is rcsdiff
+ ;;
+ ;; RCS file: RCS/tinylib.el,v
+ ;; retrieving revision 1.95
+ ;; retrieving revision 1.97
+ ;; diff -c -r1.95 -r1.97
+ ;; *** 1.95 1997/03/22 12:26:59
+ ;; --- 1.97 1997/03/22 15:17:22
+ ((re-search-forward "^RCS file:[^/]*/?\\(.*\\),v" nil t)
+ (setq file (match-string 1))
+ (and (re-search-forward rcs-re nil t)
+ (setq v1 (match-string 1))
+ (re-search-forward rcs-re nil t)
+ (setq v2 (match-string 1)))
+ (setq msg (format "patch: %s --> %s %s" v1 v2 file)))
+ (buffer-file-name
+ ;; Regular file, see if this one has RCS version information
+ (if (setq ver (ti::vc-rcs-buffer-version))
+ (setq ver (concat " " ver " ")))
+ (setq msg (concat
+ (or ver "")
+ (file-name-nondirectory buffer-file-name))))
+ ((setq type (ti::buffer-diff-type-p))
+ ;; *** /users/jaalto/T.orig Sun Mar 23 16:37:43 1997
+ ;; --- /users/jaalto/T Sat Mar 22 14:44:34 1997
+ (save-excursion
+ (ti::pmin)
+ (if (or (re-search-forward "^--- \\([^ \t\n]+\\)" nil t)
+ (re-search-forward "^\\*\\*\\* \\([^ \t\n]+\\)" nil t)
+ (re-search-forward "^\\+\\+\\+ \\([^ \t\n]+\\)" nil t))
+ (setq file (match-string 1))))
+ (setq msg (format "%s diff %s"
+ (prin1-to-string (car type))
+ (if file
+ (file-name-nondirectory file )
+ ""))))))
+ msg))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymy-mail-buffer ()
+ "Mail current buffer.
+The subject line is constructed by looking at the buffer content:
+eg if buffer contains rcsdiff of diff,
+The subject line will tell the versions."
+ (interactive)
+ (let* ((data-buffer (current-buffer))
+ subj)
+ (setq subj (tinymy-mail-subject-get))
+ (compose-mail)
+ ;; This package gives nice alias expansion
+ (ti::package-require-mail-abbrevs)
+ (ti::mail-text-start 'move)
+ (insert "\n\n\n\n")
+ (save-excursion (insert-buffer data-buffer))
+ ;; Make sure the outlline/folding is opened first
+ (ti::buffer-outline-widen)
+ (if subj
+ (ti::mail-kill-field "Subject:" subj))
+ (ti::pmin)
+ (end-of-line) ;"TO:" field
+ (run-hooks 'tinymy-:mail-buffer-hook)))
+
+;;}}}
+;;{{{ Programming: function bounds, debug
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymy-function-bounds (&optional forward)
+ "Find function area. Return (beg . end).
+The search is first done backward, unless FORWARD is given,
+to find function beginning.
+
+Notes:
+ All function start lines must be left flushed, ie. no empty spaces before
+ function name declaration. Functions must start/end with left flushed
+ \"{\" and \"}\".
+
+Supported modes:
+ C/C++
+ perl
+ awk
+ lisp"
+ (let* ((mode (or (ti::id-info) (symbol-name major-mode)))
+ (max-lines 1500) ;rows, function cannot be bigger
+ (skip-lines 1300) ;maximum skip lines backward
+ (start (point))
+ beg end
+ range point
+ fwd-flag)
+ (cond
+ ((string-match "lisp" mode)
+ ;; Only lisp has decent find functions
+ (save-excursion
+ (if forward
+ (ignore-errors
+ (end-of-defun)
+ (forward-line 2)
+ (setq fwd-flag t)))
+ (ignore-errors
+ (beginning-of-defun)
+ (setq beg (point)))
+ (if (or (and beg (null forward))
+ (and beg forward fwd-flag))
+ (ignore-errors
+ (end-of-defun)
+ (setq end (point))))))
+ ((string-match "perl\\|awk" mode)
+ (save-excursion
+ (cond
+ (forward
+ (if (re-search-forward "^sub\\|^function" nil t)
+ (setq fwd-flag t))))
+ (cond
+ ((and (or (null forward)
+ (and forward fwd-flag))
+ (re-search-backward "^sub\\|^function" nil t))
+ (beginning-of-line)
+ (setq beg (point))
+ (if (re-search-forward "^}" nil t)
+ (setq end (point)))))))
+ ((string-match "code-c\\|c-\\|cc-\\|c[+]" mode)
+ ;; The opening block says where is function start, this is only
+ ;; possible for NEW styled programming, not K&R styled 'hanging'
+ ;;
+ ;; C++: int funtion() { ;; nope, too diffucult to detect.
+ ;; perl sub funtion { ;; allowed
+ (save-excursion
+ (cond
+ (forward
+ (if (re-search-forward "^{" nil t)
+ (setq fwd-flag t))))
+ (cond
+ ((and (or (null forward)
+ (and forward fwd-flag))
+ (re-search-backward "^{" nil t)
+ (re-search-backward "(" nil t)) ;find parameter list beginning
+ ;; There is a problem in writing the C++ funcs:
+ ;;
+ ;; // Comment
+ ;; /* Comment
+ ;; */
+ ;; int
+ ;; functionName
+ ;; ( parameters
+ ;;
+ (beginning-of-line)
+ (setq point (point))
+ ;; We just search line by line backward until no comment,
+ ;; or empty line
+ (while (not (looking-at " *//+\\| *[*]+/\\| *[*]+ \\|^[ \t]*$"))
+ (forward-line -1))
+ (if (not (eq point (point))) ;if the while loop moved.
+ (forward-line 1)) ;go to func beginning.
+ (setq beg (point))
+ (if (re-search-forward "^}" nil t) ;; This is easy.
+ (setq end (point))))))))
+ (if (and beg end
+ ;; must not be too far away from current point
+ (< (count-lines beg start) skip-lines))
+ (setq range (count-lines beg end)))
+ ;; The return value
+ (if (and range (< range max-lines))
+ (cons beg end)
+ nil)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymy-beginning-of-defun (&optional end-of-fun)
+ "See `tinymy-function-bounds'. END-OF-FUN must be nil or t."
+ (interactive)
+ (let* ((bounds (tinymy-function-bounds end-of-fun))
+ (beg (car-safe bounds))
+ (end (cdr-safe bounds))
+ (point (if end-of-fun end beg)))
+ (if (null bounds)
+ (message "TinyMy: Sorry, can't find function.")
+ (goto-char point))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymy-end-of-defun ()
+ "See `tinymy-function-bounds'."
+ (interactive)
+ (tinymy-beginning-of-defun 'end))
+
+;;}}}
+;;{{{ rectangle
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymy-add-rectangle (START END &optional insert)
+ "Add or Multiply columns in rectangle in START END.
+With optional arg INSERT, insert the sum and product to
+the current point."
+
+ (interactive "r\nP")
+ (require 'rect)
+ (let ((sum 0)
+ (rownum 0)
+ (prod 1)
+ (rowval 0))
+ (operate-on-rectangle
+ (lambda (POS BEFORE AFTER)
+ (setq rownum (1+ rownum))
+ (setq rowval (string-to-number (buffer-substring POS (point))))
+ (setq sum (+ sum rowval))
+ (setq prod (* prod rowval)))
+ START END 't)
+ (if (interactive-p)
+ (message "TinyMy: For %d rows, sum=%f, product=%f" rownum sum prod))
+ (if insert
+ (insert (format "%0.2f %0.2f" sum prod)))))
+
+;;}}}
+;;{{{ scrolling
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymy-scroll-up ()
+ "Call `tinymy-scroll-down'."
+ (interactive)
+ (tinymy-scroll-down 'up))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymy-scroll-down (&optional up)
+ "Scrolls down, optionally UP. No errors generated.
+Cursor is positioned at first call to the top or bottom of window and
+and only next call scrolls the window. If possible, cursor in kept at the
+yop or bottom line of window. (Caveat: for long lines, this cannot be done)."
+ (interactive "P")
+ ;; Don't know which Emacs version introduced this function.
+ ;; Use old trusted implementation if it doesn't exist
+ (let ((point (point)))
+ (if (not (fboundp 'move-to-window-line))
+ (tinymy-scroll-old up)
+ (cond
+ ((and up (ti::window-pmin-visible-p))
+ (ti::pmin))
+ ((and up (eq (point) (window-start)))
+ (scroll-down)
+ (move-to-window-line 0))
+ (up
+ (move-to-window-line 0)
+ (when (eq point (point))
+ ;; Point didn't move? Use Emacs function.
+ (ignore-errors
+ (scroll-down))
+ (move-to-window-line 0)))
+ ;;
+ ;; Down movements
+ ;;
+ ((ti::window-pmax-visible-p)
+ (ti::pmax))
+ ((eq (point) (ti::window-pmax-line-bol))
+ (scroll-up)
+ ;; Keep cursor at bottom
+ (move-to-window-line -1))
+ ((move-to-window-line -1)
+ (beginning-of-line)
+ (when (eq point (point))
+ ;; Point didn't move? Use Emacs function.
+ (ignore-errors
+ (scroll-up))
+ (move-to-window-line -1))))
+ ;; Make sure point is at the beginning
+ (move-to-column 0))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymy-scroll-old (&optional up)
+ "Scrolls down, optionally UP. No errors generated.
+This function behaves like DOS/windows scroll commands, where cursor jumps
+to the end or beginning of window first and only next scrolls. It also
+keeps the cursor in the bottom or top of window according to the direction
+of scroll.
+
+Note:
+
+ This function does not work properly if the lines in the window
+ exceed the length of the window. If the current line is longer than
+ window length, then normal Emacs scroll command will be called."
+
+ ;; - the 'error' call is most disturbing if you have
+ ;; - debug-on-error t
+ ;; - This is for *interactive* only! Lisp manual forbids using scroll
+ ;; command in normal lisp code.
+
+ (interactive "P")
+ (let* ((mode tinymy-:scroll-mode)
+ lines)
+ (cond
+ ((ti::line-wrap-p)
+ ;; ............................................. wrapping line ...
+ (cond
+ (up
+ (if (ti::window-pmin-visible-p)
+ (ti::pmin)
+ (scroll-down)))
+ (t
+ (if (ti::window-pmax-visible-p)
+ (ti::pmax)
+ (scroll-up)))))
+ (t
+ ;; ........................................... non wrapping line ...
+ (cond
+ (up
+ (if (bobp)
+ (message "TinyMy: beg of buffer.")
+ (if (ti::window-pmin-visible-p) ;if top is visible
+ (goto-char (point-min))
+ (if (or (null mode)
+ (and mode
+ (ti::window-pmin-line-p)))
+ (scroll-down))
+ (goto-char (window-start))
+ (beginning-of-line))))
+ (t
+ (if (eobp)
+ (message "TinyMy: end of buffer.")
+ (if (ti::window-pmax-visible-p)
+ (goto-char (point-max))
+
+ (if (or (null mode)
+ (and mode
+ (ti::window-pmax-line-p)))
+ (progn
+ ;; - if outline/folding mode is on, we can't determine
+ ;; line count with count-lines function
+ ;; - The count gives 1 extra line, check with M-x =
+ ;; around the window region
+ (setq lines
+ (1-
+ (count-char-in-region
+ (window-start) (window-end) ?\n)))
+ ;; the scroll command does not update window points
+ ;; in 19.28! That means that the function window-end
+ ;; can't be trusted. only when this function ends,
+ ;; the window is updated.
+ (scroll-up)
+ ;; We must manually go to the end line
+ ;; - The cursor is always left in the line 2, after
+ ;; scrolling in window. We have to go N lines downward
+ ;; to put cursor at window end line
+ ;; - next-line is used, because it hanbdles folding/outline.
+ ;; forward-line can't be used.
+ ;;
+ ;; Note:
+ ;; - If the lines are longer than window-width; then this
+ ;; whole next-line call may end anywhere...can't help
+ ;; that
+ ;; - The safe do is here in case this calls error,
+ ;; which it does if the buffer size has changes, like
+ ;; in live *Messages* buffer
+ (ignore-errors (next-line (- lines 1))))
+ (goto-char (ti::window-pmax-line-bol)))))))))))
+
+;;}}}
+;;{{{ shell -- shar, tar, uu
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymy-shar (single-or-list)
+ "Generate SHAR file using SINGLE-OR-LIST.
+List of files can include shell regexps. The result is put into
+`tinymy-:register'."
+ (interactive
+ (let* (arg1)
+ (setq arg1
+ (ti::file-complete-filename-minibuffer-macro
+ (read-from-minibuffer
+ (format "[%s] Shar files: " default-directory)
+ nil
+ map)))
+ (list arg1)))
+ (let* ((cmd (concat tinymy-:shar-command " "))
+ (register tinymy-:register)
+ (verb (interactive-p))
+ out)
+ (if (ti::nil-p single-or-list)
+ (error "Missing args")
+ (setq out
+ (shell-command-to-string
+ (format "cd %s; %s %s"
+ default-directory
+ cmd
+ (ti::list-to-string (ti::list-make single-or-list)))))
+ (set-register register out)
+ (if verb
+ (message (format "TinyMy: Register %s has shar"
+ (char-to-string register)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymy-tar (tar-file file-list)
+ "Generate TAR-FILE using FILE-LIST.
+Return:
+ t or nil if tar created."
+ (interactive
+ (let* ((default-directory default-directory)
+ (default-tar-name "pkg.tar")
+ (default-tar (concat default-directory default-tar-name))
+ arg1 arg2
+ tar-dir)
+ (setq arg1
+ (ti::file-complete-filename-minibuffer-macro
+ (read-from-minibuffer
+ (format "[%s] Tar name: " default-tar)
+ nil map)))
+ (cond
+ ((ti::nil-p arg1)
+ (setq arg1 default-tar))
+ ((file-directory-p arg1)
+ (setq arg1 (concat arg1 default-tar))))
+
+ (setq tar-dir (or (file-name-directory arg1)
+ default-directory))
+ (setq default-directory tar-dir)
+ (setq
+ arg2
+ (ti::file-complete-filename-minibuffer-macro
+ (read-from-minibuffer
+ (format "[%s] Files: " arg1)
+ nil
+ map)))
+ (list arg1 arg2)))
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... ... ... main . .
+ (if (or (ti::nil-p tar-file)
+ (ti::nil-p file-list))
+ (error "Missing args"))
+ (let* ((tar-cmd (concat tinymy-:tar-command " "))
+ (edir (file-name-directory
+ (expand-file-name tar-file)))
+ (cmd (concat "cd " edir "; "
+ tar-cmd
+ (file-name-nondirectory tar-file)
+ " " file-list))
+ ret)
+ ;; ................................................... then case ...
+ (if (and (file-exists-p edir) ;; must exist
+ (or (not (file-exists-p tar-file)) ;; good if not exist
+ (and (file-exists-p tar-file) ;; we have to remove it
+ (y-or-n-p "Tar exists, remove ? ")
+ (progn
+ (delete-file tar-file) t))))
+ (progn
+ (setq cmd (read-from-minibuffer "cmd: " cmd))
+ (shell-command cmd)
+ (setq ret (file-exists-p tar-file)))
+ (message "TinyMy: Aborted"))
+ ret))
+
+;;}}}
+;;{{{ compilation
+
+;;; ----------------------------------------------------------------------
+;;; Some special compile commands for C/C++, which usually
+;;; have .mak files
+;;;
+(defun tinymy-compile-command-search (type)
+ "Search match car of `tinymy-:compile-table' against TYPE and return cdr."
+ (dolist (elt tinymy-:compile-table)
+ (when (string-match (car elt) type)
+ (return (cdr elt)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymy-compile-tinytf-command ()
+ "Compile .txt file into HTML."
+ (concat "perl -S t2html.pl --Out --print-url "
+ (file-name-nondirectory
+ (buffer-file-name))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymy-compile-xml-command ()
+ "Compile .xml file by running validator."
+ ;; #todo: incomplete
+ (let ((list '(("xmlwf") ;; Expat, included in Cygwin
+ ( ;; http://xml.coverpages.org/rxpWindows19991018.html
+ ;; Richard Tobin "rxp XML parser"
+ ;; -> Compiles under Cygwin
+ "rxp"
+ ;; verbose, Validate
+ "-v -V"))))
+ (dolist (elt list)
+ (multiple-value-bind (cmd args)
+ elt
+ (when (executable-find cmd)
+ (return (format "%s %s %s"
+ cmd
+ (or args "")
+ (file-name-nondirectory
+ (buffer-file-name)))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymy-compile-sql ()
+ "Compile .sql file.
+The correct SQL compile command is determined by
+
+1) searching first word from the file that matches string:
+ PostgreSQL, MySQL, Oracle.
+
+2) Or if the last part of the directory contains portion
+ /pg /postgre /postgres /postgresql
+ /mysql
+ /oracle
+
+E.g. file in location ~/sql/pg/my-file.sql is supposed to belong
+to PostgreSQL."
+ (when buffer-file-name
+ (let* ((file buffer-file-name)
+ (last (and file
+ (ti::directory-part-last
+ (file-name-directory file))))
+ cmd)
+ (flet ((type-p (regexp1 regexp2)
+ (or (ti::re-search-check regexp1)
+ (string-match regexp2 (or last "")))))
+ (or (and (type-p "postgreSQL"
+ "\\(^pg$\\|postgres?\\|postgresql\\)")
+ (executable-find "psql")
+ (setq cmd
+ "psql -h HOST -U user -d database < %s"))
+;;; ;; PostgreSQL is native Cygwin application
+;;; ;; and must see Cygwin path.
+;;; (if (and (ti::win32-p)
+;;; (ti::emacs-type-win32-p))
+;;; (w32-cygwin-dos-path-to-cygwin file)
+;;; file))))
+ (and (type-p "MySQL" "mysql")
+ (executable-find "mysql")
+ (setq cmd "mysql -h HOST -u USER database < %s"))
+ (and (type-p "Oracle" "oracle")
+ (executable-find "sqlplus")
+ (setq cmd "sqlplus USER/LOGIN@DATABASE < %s")))
+ (or (and cmd
+ (if (string-match "%" cmd)
+ (format cmd (file-name-nondirectory buffer-file-name))
+ cmd))
+ "")))))
+
+;;; ----------------------------------------------------------------------
+;;; Some special compile commands for C/C++, which usually
+;;; have .mak files
+;;;
+(defun tinymy-compile-cc-command ()
+ "Construct C/C++ compile command"
+ (let* ( ;; Check if there are any .mak files in directory ?
+ (file (file-name-nondirectory (buffer-file-name)))
+ (make-files (and file
+ (ti::directory-files
+ (file-name-directory (buffer-file-name))
+ "\\.make?$\\|makefile$\\|Makefile$")))
+ (cc-cmd (or (getenv "CC") "gcc"))
+ (flags (or (getenv "CFLAGS") "-g")))
+ (if make-files
+ "make"
+ (format "%s %s %s -o %s "
+ cc-cmd
+ file
+ flags
+ ;; Drop extension
+ (ti::string-match "^[^.]+" 0 file)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymy-compile-command-for-buffer (mode &optional buffer value)
+ "Use MODE to control BUFFER' compile command VALUE.
+If mode is 'get, recall the buffer's value.
+If mode is 'clear, clear previous compile command.
+Any other value is equal to 'put with BUFFER and VALUE.
+
+References:
+
+ `tinymy-:compile-table' Values are stored to property list
+ '(<buffer> compile-command ..)"
+ (or buffer
+ (setq buffer (current-buffer)))
+ (cond
+ ((eq mode 'get)
+ (get 'tinymy-:compile-table buffer))
+ ((eq mode 'clear)
+ (put 'tinymy-:compile-table buffer nil))
+ (t
+ (put 'tinymy-:compile-table buffer value))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymy-compile-command-for-buffer-clear ()
+ "Clear buffer's compile command."
+ (tinymy-compile-command-for-buffer 'clear))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymy-compile-run-command-ask (&optional clear)
+ "Run current buffer through compile buffer.
+This function remembers what command you have used for each buffer
+and offers it next time you call it.
+
+Parameter CLEAR instructs to \"forget\" any previously
+acched command try the search again from fresh. You can
+supply the \\[universal-argument\\] if you have made changes
+to `tinymy-:compile-table'.
+
+If mode 'text' or 'fundamental'
+
+ Do not try to identify buffer, but ask compile command directly
+
+If mode is not 'text' or 'fundamental'
+
+ Try to find suitable compile command by identifying the buffer
+ and looking at the command table.
+
+ For C/C++ code the default command suggested if 'mak', but if there
+ is no makefile in the directory, then a normal compile command
+ is proposed.
+
+References:
+
+ `tinymy-:compile-table'
+ `tinymy-:compile-command-c-code'"
+ (interactive "P")
+ (if clear
+ (tinymy-compile-command-for-buffer-clear))
+ (let* ( ;; We change this so that compile goes to right dir
+ (fid "tinymy-compile-run-command")
+ (file (buffer-file-name))
+ (mname (symbol-name major-mode))
+
+ (type (or (ti::id-info)
+ mname))
+
+ (buffer (current-buffer))
+ elt
+ run-it
+ filename ;without directory part
+ cmd)
+ (unless fid ;; No-op. XEmacs byte compiler silencer
+ (setq fid nil))
+ (tinymy-debug fid file "type" type)
+ (if (null file)
+ (message "TinyMy: Can't compile, no file in this buffer.")
+ ;; Try to find last typed commad first, only if there is
+ ;; no previous command, make one.
+ (unless (setq cmd (tinymy-compile-command-for-buffer 'get))
+ (setq filename (file-name-nondirectory file)
+ elt (tinymy-compile-command-search type))
+ (unless filename ;; No-op, XEmacs byte compiler silencer
+ (setq filename nil))
+ (tinymy-debug "No prev cmd" filename elt)
+ ;; .............................................. make command ...
+ ;; Only if the compile command is constant string: save it
+ ;; Dynamically evaled compile commands cannot be saved.
+ (setq cmd
+ (cond
+ ((stringp elt)
+ (format elt file))
+ ((functionp elt)
+ (funcall elt))
+ ((setq elt (eval elt))
+ (format elt file))))) ;; unless
+ ;; ............................................... ask from user ...
+ (setq run-it
+ (ti::file-complete-filename-minibuffer-macro
+ (read-from-minibuffer
+ "Compile: " (or cmd "make")
+ map
+ nil
+ 'compile-history)))
+ ;; ......................................... per buffer cmd save ...
+ ;; Save command per buffer basis
+ (tinymy-debug "CMD" cmd)
+ (when (or (not (setq cmd (tinymy-compile-command-for-buffer 'get)))
+ ;; User gave different command. Update
+ (not (string= cmd run-it)))
+ (tinymy-compile-command-for-buffer 'put buffer run-it))
+ run-it)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymy-compile-run-command (&optional clear)
+ "See `tinymy-compile-run-command-ask'."
+ (interactive "P")
+ (let* ((cmd (tinymy-compile-run-command-ask clear)))
+ (when (not (ti::nil-p cmd))
+ (compile-internal cmd "No more errors.")
+ (pop-to-buffer "*compilation*"))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defadvice compile (around tinymy dis)
+ "Change interactive SPEC to determine default compile command.
+See `tinymy-compile-run-command-ask'."
+ (interactive
+ (list
+ (or (tinymy-compile-run-command)
+ (if (or compilation-read-command
+ current-prefix-arg)
+ (read-from-minibuffer "Compile command: "
+ (eval compile-command) nil nil
+ '(compile-history . 1))
+ (eval compile-command)))))
+ ad-do-it)
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinymy-compile-run-command-advice (&optional disable)
+ "Activate or DISABLE smart compile command vie \\[compile\\].
+See `tinymy-compile-run-command-ask' for more."
+ (interactive "P")
+ (ti::advice-control 'compile "^tinymy"
+ disable 'verb
+ "TinyMy: smart M-x compile advice support "))
+
+;;}}}
+;;{{{ word movement
+
+;;; --------------------------------------------------- &word-movement ---
+;;; #todo: Uhm; rewrite sometime.
+;;;
+(defun tinymy-word-move-1 (&optional back)
+ "Low level word movement control. Optionally move BACK."
+ (let* ((up-case (memq major-mode tinymy-:move-word-case-modes))
+ (regexp "[a-z0-9]*[A-Z]+[a-z0-9]+[A-Z]+")
+ (case-fold-search (not up-case))
+ (charset
+ (cond
+ ((and up-case
+ (or (if back
+ (save-excursion
+ (cond
+ ((not (eq 0 (skip-chars-backward "a-z")))
+ (let (case-fold-search)
+ (string-match
+ "[A-Z]"
+ (char-to-string (preceding-char)))))
+ ((not (eq 0 (skip-chars-backward " \t")))
+ (bolp))))
+ (looking-at regexp))
+ ;; Cursor is at the end of word
+ (and
+ (member (char-to-string (char-syntax (preceding-char)))
+ '("w" "."))
+ (not
+ (member (char-to-string (char-syntax (following-char)))
+ '("w" "."))))))
+ ;; This Upcase charset is only used if the cursor is
+ ;; within AnUpCaseWord.
+ tinymy-:move-word-case-set)
+ (t
+ tinymy-:move-word-set))))
+ (cond
+ ;; Skip to the end of word if at EOL
+ ;; (this-he-is-word sse-it-now?)
+ ;; * cursor here
+ ;; * after
+ ;; otherwise it would skip to next line's word begin.
+ ((and (null back)
+ (or (looking-at "\\([A-Z]+\\)[^a-zA-Z \t]*$")
+ (looking-at "\\([a-z]+\\)[^a-zA-Z \t]*$")
+ (looking-at "\\([A-Z][a-z]+\\)[^a-zA-Z \t]*$")))
+ (goto-char (match-end 1)))
+ (t
+ (ti::buffer-word-move charset back)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymy-word-move-2 (&optional back)
+ "If at whitespace, skip to next non-whitespace. Optionally BACK.
+Otherwise call `tinymy-word-move-1'."
+ (when (and (looking-at "[ \t\f\r\n]")
+ (not (ti::buffer-looking-at-one-space)))
+ (cond
+ (back
+ (skip-chars-backward " \t\f\r\n")
+ (unless (bobp)
+ (forward-char -1)))
+ (t
+ (skip-chars-forward " \t\f\r\n"))))
+ (tinymy-word-move-1 back))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymy-word-backward ()
+ "Word backward See `tinymy-:move-word-case-set'."
+ (interactive)
+ (tinymy-word-move-2 'back))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymy-word-forward ()
+ "Word forward. See `tinymy-:move-word-case-set'."
+ (interactive)
+ (tinymy-word-move-2))
+
+;;}}}
+;;{{{ minor mode: sort
+
+;;;### (autoload 'turn-off-tinymy-sort-mode "tinymy" "" t)
+;;;### (autoload 'turn-on-tinymy-sort-mode "tinymy" "" t)
+;;;### (autoload 'tinymy-sort-mode "tinymy" "" t)
+
+(add-hook 'tinymy-sort-:mode-define-keys-hook ;To be sure
+ 'tinymy-sort-mode-define-keys)
+
+(eval-and-compile
+
+ (ti::macrof-minor-mode-wizard
+ "tinymy-sort-" " S" "\C-cS" "Tsort" 'TinySort "tinymy-sort-:" ;1-6
+
+ "Minor mode for sorting lines (by columns) in the buffer easily.
+Remember to select region to sort.
+
+When you sort by columns, the line must have enough columns, e.g.
+if you select following area and try to sort by clumn 3, that is
+not possible. Also, There must be no empty lines inside sorted area.
+
+ 123 123 123
+ 123 123
+ 123 123 123
+
+Mode description:
+\\{tinymy-sort-:mode-map}"
+
+ "TinySort"
+
+ nil
+
+ "Column sort minor mode"
+
+ (list
+ tinymy-sort-:mode-easymenu-name
+ ["By column 1" tinymy-sort-column-1 t]
+ ["By column 2" tinymy-sort-column-2 t]
+ ["By column 3" tinymy-sort-column-3 t]
+ ["By column 4" tinymy-sort-column-4 t]
+ ["By column 5" tinymy-sort-column-5 t]
+ ["By column 6" tinymy-sort-column-6 t]
+ ["By column 7" tinymy-sort-column-7 t]
+ ["By column 8" tinymy-sort-column-8 t]
+ ["By column 9" tinymy-sort-column-9 t])
+ (progn
+ (define-key map "1" 'tinymy-sort-mode-column-1)
+ (define-key map "2" 'tinymy-sort-mode-column-2)
+ (define-key map "3" 'tinymy-sort-mode-column-3)
+ (define-key map "4" 'tinymy-sort-mode-column-4)
+ (define-key map "5" 'tinymy-sort-mode-column-5)
+ (define-key map "6" 'tinymy-sort-mode-column-6)
+ (define-key map "7" 'tinymy-sort-mode-column-7)
+ (define-key map "8" 'tinymy-sort-mode-column-8)
+ (define-key map "9" 'tinymy-sort-mode-column-9)
+ (define-key map "?" 'tinymy-sort-mode-help))))
+
+;; Create functions like this:
+;;
+;; (defun tinymy-sort-column-0 (beg end)
+;; (interactive "*r") (tinymy-sort-column beg end 0))
+(mapcar
+ (function
+ (lambda (x)
+ (let ((sym (intern (format "tinymy-sort-mode-column-%d" x)))
+ def)
+ (setq def
+ (` (defun (, sym) (beg end)
+ (interactive "*r")
+ (tinymy-sort-column beg end (, x) ))))
+ (eval def))))
+ '(1 2 3 4 5 6 7 8 9))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymy-sort-column (beg end nbr)
+ "Sort region BEG END according to column NBR."
+ (interactive "r\np")
+ (let* ((opoint (point)))
+ (untabify beg end)
+ (goto-char (min beg end)) ;Sort breaks otherwise
+ (sort-fields nbr beg end)
+ (goto-char opoint)))
+
+;;}}}
+;;{{{ alias definitions and others
+
+(defun tinymy-alias ()
+ "Install some aliases."
+ ;; Say always y-or-n-p; so that there is no need to type "yes" or "no"
+ (defalias 'yes-or-no-p 'y-or-n-p))
+
+;;; ----------------------------------------------------------------------
+;;; Idea by 1997-11-05 Kevin Rodgers gnu-emacs.help
+;;;
+(defun tinymy-maybe-disable-auto-save ()
+ "If the directory is read only, do not keep auto save files."
+ (when (and (stringp buffer-file-name)
+ (not (file-writable-p
+ (file-name-directory buffer-file-name))))
+ (auto-save-mode nil)
+ (set (make-variable-buffer-local 'auto-save-interval) 0)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinymy-find-file-hook ()
+ "Activate DOS display table for dos files (in UNIX) ."
+ (tinymy-maybe-disable-auto-save)
+ ;; hook return value
+ nil)
+
+;;}}}
+
+(provide 'tinymy)
+(run-hooks 'tinymy-:load-hook)
+
+;;; tinymy.el ends here
--- /dev/null
+;;; tinynbr.el --- Number conversion minor mode oct/bin/hex
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 1997-2007 Jari Aalto
+;; Keywords: tools
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program, call M-x tinynbr-version.
+;; Look at the code with folding.el.
+
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;; ....................................................... &t-install ...
+;; Put this file on your Emacs-Lisp load path, add following into your
+;; ~/.emacs startup file. This must be the very first entry before
+;; any keybindings take in effect.
+;;
+;; (require 'tinynbr)
+;;
+;; You can also use the preferred way: autoload
+;;
+;; (autoload 'tinynbr-mode "tinynbr t t)
+;; ;; Put all minor mode activations below C-c m map
+;; ;;
+;; (global-set-key "\C-cmN" 'tinynbr-mode)
+;;
+;; If you have any questions, use this function to contact author
+;;
+;; M-x tinynbr-submit-bug-report
+
+;;}}}
+;;{{{ Documentation
+
+;; ..................................................... &t-commentary ...
+;;; Commentary:
+;;
+;; Preface, aug 1997
+;;
+;; One day in a laboratory the developer once forgot his desk
+;; calculator in another building. He was examining binary (hex)
+;; files and other electronic documents that used hex and base10
+;; numbers. He shroudly remembered that Unix included some basic
+;; calculator, but he dind't remember what was the name and how
+;; to use it. Whoops. Grin.
+;;
+;; Instead of returning to get the missing calculator, he started
+;; pouring some lisp to make a simple minor mode to help
+;; to get along with the current task at hand. It didn't take
+;; long to make it, and the laboratory day was success.
+;; Ahem. Maybe should look at package calc.el someday.
+;;
+;; Overview of features
+;;
+;; o Int --> hex,oct,bin conversion at current point
+;; o hex,oct,bin --> int conversion at current point
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+;;{{{ setup: require
+
+(require 'tinylibm)
+
+(ti::package-defgroup-tiny TinyNbr tinynbr-: tools
+ "Number conversion minor mode oct/bin/hex.")
+
+(defcustom tinynbr-:load-hook nil
+ "*Hook run when file has been loaded."
+ :type 'hook
+ :group 'TinyNbr)
+
+;;;###autoload (autoload 'tinynbr-version "tinynbr" "Display commentary." t)
+
+(eval-and-compile
+ (ti::macrof-version-bug-report
+ "tinynbr.el"
+ "tinynbr"
+ tinynbr-:version-id
+ "$Id: tinynbr.el,v 2.40 2007/05/01 17:20:51 jaalto Exp $"
+ '(tinynbr-:version-id
+ tinynbr-:load-hook)))
+
+(defun tinynbr-read-number-at-point (&optional reverse base)
+ "Read base 1= or 16 number at point."
+ (if reverse
+ (ti::buffer-read-word "[0-9]+" 'strict)
+ (ti::buffer-read-word
+ "[0-9xXa-fA-F]+" 'strict)))
+
+(defun tinynbr-read-number (&optional reverse)
+ "Read word if point is at non-whitespace. Optional REVERSE."
+ (let* ((char (following-char))
+ (nbr (when char
+ (setq char (char-to-string char))
+ (save-excursion
+ (unless (string-match "[ \t\f\r\n]" char)
+ (tinynbr-read-number-at-point))))))
+ nbr))
+
+;;}}}
+;;{{{ Minor Mode
+
+;;;###autoload (autoload 'tinynbr-mode "tinynbr" "" t)
+;;;###autoload (autoload 'turn-on-tinynbr-mode "tinynbr" "" t)
+;;;###autoload (autoload 'tun-off-tinynbr-mode "tinynbr" "" t)
+;;;###autoload (autoload 'tinynbr-commentary "tinynbr" "" t)
+
+(eval-and-compile
+ (ti::macrof-minor-mode-wizard
+ "tinynbr-" " Tnbr" "z" "Nbr" 'Tnbr "tinynbr-:"
+ "Simple number conversion minor mode.
+
+Mode description:
+
+\\{tinynbr-:mode-prefix-map}"
+
+ "TinyNbr"
+ nil
+ "Number conversion mode"
+ (list ;arg 10
+ tinynbr-:mode-easymenu-name
+ ["int to hex" tinynbr-int-to-hex t]
+ ["int to oct" tinynbr-int-to-bin t]
+ ["int to bin" tinynbr-int-to-oct t]
+ "----"
+ ["hex to int" tinynbr-hex-to-int t]
+ ["oct to int" tinynbr-oct-to-int t]
+ ["bin to int" tinynbr-bin-to-int t]
+ "----"
+ ["Package version" tinynbr-version t]
+ ["Package commentary" tinynbr-commentary t]
+ ["Mode help" tinynbr-mode-help t]
+ ["Mode off" tinynbr-mode t])
+ (progn
+ (define-key map "X" 'tinynbr-hex-to-int)
+ (define-key map "B" 'tinynbr-bin-to-int)
+ (define-key map "O" 'tinynbr-oct-to-int)
+ (define-key map "x" 'tinynbr-int-to-hex)
+ (define-key map "b" 'tinynbr-int-to-bin)
+ (define-key map "o" 'tinynbr-int-to-oct)
+ (define-key map "v" 'tinynbr-version)
+ (define-key map "?" 'tinynbr-mode-help)
+ (define-key map "Hm" 'tinynbr-mode-help)
+ (define-key map "Hc" 'tinynbr-commentary)
+ (define-key map "Hv" 'tinynbr-version))))
+
+;;}}}
+;;{{{ Code
+
+;;; Create functions, and inform autoload generator.
+
+;;;###autoload (autoload 'tinynbr-int-to-hex "tinynbr" "" t)
+;;;###autoload (autoload 'tinynbr-int-to-oct "tinynbr" "" t)
+;;;###autoload (autoload 'tinynbr-int-to-bin "tinynbr" "" t)
+;;;###autoload (autoload 'tinynbr-hex-to-int "tinynbr" "" t)
+;;;###autoload (autoload 'tinynbr-oct-to-int "tinynbr" "" t)
+;;;###autoload (autoload 'tinynbr-bin-to-int "tinynbr" "" t)
+
+(mapcar
+ (function
+ (lambda (x)
+ (let ((sym1 (intern (format "tinynbr-%s-to-int" (car x))))
+ (sym2 (intern (format "tinynbr-int-to-%s" (car x))))
+ (sym3 (intern (format "int-to-%s-string" (car x))))
+ (base (nth 1 x))
+ def)
+ (setq def
+ (` (defun (, sym1) (&optional insert reverse)
+ "If prefix arg INSERT is non-nil, insert result to buffer."
+ (interactive "P")
+ (let* ((nbr (tinynbr-read-number reverse))
+ ret)
+ (when nbr
+ (if (string-match "^0[Xx]\\(.*\\)" nbr)
+ (setq nbr (match-string 1 nbr)))
+ (if (null reverse)
+ (setq ret (radix nbr (, base)))
+ (setq ret ((, sym3) (string-to-int nbr)))))
+ (cond
+ ((null nbr)
+ (message "TinyNbr: Can't find number at current point."))
+ (t
+ (if (not insert)
+ (message "%s => %s %s"
+ nbr
+ ret
+ (cond
+ ((equal (, base) 2)
+ (if reverse "bin - dec" "dec - bin" ))
+ ((equal (, base) 8)
+ (if reverse "oct - dec" "dec - oct" ))
+ ((equal (, base) 16)
+ (if reverse "hex - dec" "dec - hex" ))
+ (t "")))
+ (save-excursion
+ (end-of-line)
+ (insert " " (if (numberp ret)
+ (int-to-string ret)
+ ret))))))))))
+ (eval def)
+
+ (setq def
+ (` (defun (, sym2) (&optional insert)
+ "If prefix arg INSERT is non-nil, insert result to buffer."
+ (interactive "P")
+ ((, sym1) insert 'reverse))))
+ (eval def))))
+ '(
+ (hex 16)
+ (oct 8)
+ (bin 2)))
+
+;;}}}
+
+(add-hook 'tinynbr-:mode-hook 'tinynbr-mode-define-keys)
+(provide 'tinynbr)
+(run-hooks 'tinynbr-:load-hook)
+
+;;; tinynbr.el ends here
--- /dev/null
+;;; tinypad.el --- Emulate Windows notepad with extra menu
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 1997-2007 Jari Aalto
+;; Keywords: emulations
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program, call M-x tinypad-version.
+;; Look at the code with folding.el.
+
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;; ....................................................... &t-install ...
+;; Put this file on your Emacs-Lisp load path, add following into your
+;; ~/.emacs startup file. This must be the very first entry before
+;; any keybindings take in effect.
+;;
+;; (require 'tinypad)
+;;
+;; You can also use the preferred way: autoload
+;;
+;; (autoload 'tinypad-mode "tinypad t t)
+;; ;; Put all minor mode activations below C-c m map
+;; ;; n)otepad emulation mode
+;; ;;
+;; (global-set-key "\C-cmn" 'tinypad-mode)
+;;
+;; If you have any questions, use this function to contact author
+;;
+;; M-x tinypad-submit-bug-report
+
+;;}}}
+;;{{{ Documentation
+
+;; ..................................................... &t-commentary ...
+;;; Commentary:
+;;
+;; Preface, aug 1997
+;;
+;; In gnu newsgroup there was a request that a class had been used to
+;; using Windows notepad and in order to make the transition to Emacs
+;; smooth, Emacs should have some notepad emulation mode so that
+;; pupils wouldnn't get lost completely in new envinronment. And here
+;; is it, a small notepad emulation. It installs one new menu to Emacs
+;; menu bar which is arranged exactly like the Windows notepad. I have
+;; included only the commands that are directly available from inside
+;; emacs and e.g. 'printer setup' is something that is not found there.
+;; But in order to be complete emulation, all the choices as in normal
+;; notepad are available.
+;;
+;; Overview of features
+;;
+;; o Minor mode, but once turned on, occupies every emacs buffer
+;; until turned off.
+;; o Adds menu 'TinyPad' which contains identical
+;; menu definitions that are found from Winbdows notepad
+;; o The keybindings use `Meta' as the Alt key to access the
+;; menu items, so you may need to configure your keyboard
+;; with 'xmodmap' in order to get 'Alt' key produce `Meta'
+;; o Windows specific commands are not emulated, like
+;; `Print' 'Setup'.
+;; o Following famous windows shortcut keys are _not_
+;; Emulated; I was lazy and didn't try to reorganize the
+;; Emacs keys. Erm... for now you have to stick to emacs
+;; equivalents and live without these.
+;;
+;; Undo in Control-z
+;; Cut in Control-x
+;; Copy in Control-c
+;; Paste in Control-v
+;;
+;; Code note
+;;
+;; Why on earth I made this package to use "global" minor mode?
+;; I can't remember the reason. A simple menubar entry may have
+;; sufficed just fine.... Oh, it was that remaping the bindings.
+;; You see, when minor mode is turned on, it conquers the mappings
+;; underneath.
+;;
+;; [1997-10-23] Hey, I just saw pointer to package Map-zxcv.el which
+;; takes care oc mapping the missing zxcv, so I don't have to bother
+;; with those here. Nice. You can ask it from Kim F. Storm
+;; <storm@olicom.dk>
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+;;{{{ setup: require
+
+(require 'tinylibm)
+
+(eval-when-compile (require 'advice))
+
+(ti::package-defgroup-tiny TinyPad tinypad-: tools
+ "Emulate Windows notepad with extra menu")
+
+;;;###autoload (autoload 'tinypad-version "tinypad" "Display commentary." t)
+
+(eval-and-compile
+ (ti::macrof-version-bug-report
+ "tinypad.el"
+ "tipad"
+ tinypad-:version-id
+ "$Id: tinypad.el,v 2.39 2007/05/07 10:50:08 jaalto Exp $"
+ '(tinypad-:version-id tinypad-:load-hook)))
+
+(defcustom tinypad-:load-hook nil
+ "*Hook run when file has been loaded."
+ :type 'hook
+ :group 'TinyPad)
+
+;;}}}
+;;{{{ minor mode
+
+;;;###autoload (autoload 'tinypad-mode "tinypad" "" t)
+;;;###autoload (autoload 'turn-on-tinypad-mode "tinypad" "" t)
+;;;###autoload (autoload 'turn-off-tinypad-mode "tinypad" "" t)
+
+(eval-and-compile
+ (ti::macrof-minor-mode-wizard
+ "tinypad-" " TinyPad" nil "TinyPad" 'TinyPad "tinypad-:"
+ "Emulate Windows Notepad (tm).
+This mode is global to all buffers; allthough it is a minor mode.
+
+Notice that the keybindings follow the Windows convention; where the
+prefix key accesses each submenu; Like Meta-e accesses (e)edit menu.
+If your physical Alt key in your keyboard does not produce `Meta'
+code; then you use ESC to access e.g. Meta-e. Consult the Emacs Faq's
+how you can make your Alt key produce Meta, so that the keybindings work
+like in Windows.
+
+Mode description:
+\\{tinypad-:mode-prefix-map}"
+
+ "Notepad emulation menu"
+
+ (progn ;Some mode specific things? No?
+ (cond
+ (tinypad-mode
+ (put 'tinypad-mode 'global t)
+ (unless (memq 'tinypad-find-file-hook find-file-hooks)
+ (add-hook 'find-file-hooks 'tinypad-find-file-hook )))
+ (t
+ (put 'tinypad-mode 'global nil)
+ (when (memq 'tinypad-find-file-hook find-file-hooks)
+ (remove-hook 'find-file-hooks 'tinypad-find-file-hook ))))
+ (when (null (get 'tinypad-mode 'self-call))
+ (tinypad-mode-action)))
+ "Tiny Notepad mode"
+ (list ;arg 10
+ tinypad-:mode-easymenu-name
+ (list
+ "F)ile"
+ ["N)ew" erase-buffer t]
+ ["O)pen" find-file t]
+ ["S)ave" save-buffer t]
+ ["Save A)s" write-file t]
+ ["P)rint" print-buffer t]
+ ["Page Set)up" tinypad-ignore t]
+ ["Pr)int Setup" tinypad-ignore t]
+ "----"
+ ["M)ode off" tinypad-mode t]
+ ["Ex)it Emacs" save-buffers-kill-emacs t])
+ (list
+ "E)dit"
+ ["U)ndo" undo t]
+ ["Cut)" kill-region t]
+ ["C)opy" copy-region-as-kill t]
+ ["P)aste" yank t]
+ ["De)lete" backward-delete-char t]
+ "----"
+ ["Select A)ll" mark-whole-buffer t]
+ ["Time/D)ate" tinypad-insert-time t]
+ "----"
+ ["W)ord wrap" tinypad-ignore t])
+ (list
+ "S)earch"
+ ["F)ind" isearch-forward t]
+ ["Find N)ext" tinypad-ignore t])
+ (list
+ "H)elp"
+ ["C)ontents" info t]
+ ["S)earch for help on" apropos t]
+ ["H)ow to use help" info t]
+ ["A)bout Tinypad" tinypad-version t]
+ ["V)ersion, mode desc." tinypad-mode-help t]))
+ (progn
+;;; (set map (setq tinypad-:mode-map (make-keymap)))
+ (define-key root-map [(meta f) (n)] 'tinypad-erase-buffer)
+ (define-key root-map [(meta f) (o)] 'find-file)
+ (define-key root-map [(meta f) (s)] 'save-buffer)
+ (define-key root-map [(meta f) (a)] 'write-file)
+ (define-key root-map [(meta f) (p)] 'print-buffer)
+ (define-key root-map [(meta f) (t)] 'tinypad-ignore)
+ (define-key root-map [(meta f) (m)] 'tinypad-mode)
+ (define-key root-map [(meta f) (x)] 'save-buffers-kill-emacs)
+ (define-key root-map [(meta e) (u)] 'undo)
+ (define-key root-map [(meta e) (t)] 'kill-region)
+ (define-key root-map [(meta e) (c)] 'copy-region-as-kill)
+ (define-key root-map [(meta e) (p)] 'yank)
+ (define-key root-map [(meta e) (e)] 'backward-delete-char)
+ (define-key root-map [(meta e) (a)] 'mark-whole-buffer)
+ (define-key root-map [(meta e) (d)] 'tinypad-insert-time)
+ (define-key root-map [(meta e) (w)] 'tinypad-ignore)
+ (define-key root-map [(meta e) (f)] 'isearch-forward)
+ (define-key root-map [(meta e) (n)] 'tinypad-ignore)
+ (define-key root-map [(meta h) (c)] 'info)
+ (define-key root-map [(meta h) (s)] 'apropos)
+ (define-key root-map [(meta h) (h)] 'info)
+ (define-key root-map [(meta h) (a)] 'tinypad-version)
+ (define-key root-map [(meta h) (v)] 'tinypad-mode-help)
+ ;;
+ ;; Bad idea beacuse C-x/C-x are the crucial prefix keys in
+ ;; emacs and occupying it causes havoc and grief
+ ;;
+;;; (define-key root-map [(control z)] 'undo)
+;;; (define-key root-map [(control x)] 'kill-region)
+;;; (define-key root-map [(control c)] 'copy-region-as-kill)
+;;; (define-key root-map [(control v)] 'yank)
+ ;;
+ (define-key root-map [(f5)] 'tinypad-insert-time)
+ (define-key root-map [(f3)] 'isearch-forward))))
+
+;;}}}
+;;{{{ Code
+
+;;; ----------------------------------------------------------------------
+;;;
+(defadvice switch-to-buffer (after tipad act)
+ "Turn on `tinypad-mode' if if global Pad mode is non-nil."
+ (when (and (interactive-p)
+ (get 'tinypad-mode 'global)
+ (null tinypad-mode))
+ (setq tinypad-mode 1)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypad-ignore ()
+ "Display that command does not exist."
+ (interactive)
+ (message "TinyPad: No eq WinNotepad emulation in Emacs for this command.")
+ (sit-for 2))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypad-erase-buffer ()
+ "Erase buffer with confirmation."
+ (interactive "*")
+ (when (or (null (buffer-file-name))
+ (and (buffer-file-name)
+ (not (buffer-modified-p)))
+ (and (buffer-file-name)
+ (buffer-modified-p)
+ (y-or-n-p "Buffer modified, continue erasing? ")))
+ (erase-buffer)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypad-find-file-hook ()
+ "Turn on tipad mode if `tinypad-:mode-global' is non-nil."
+ (when (and (get 'tinypad-mode 'global)
+ (null tinypad-mode))
+ (setq tinypad-mode 1)))
+
+;;; ------------------------------------------------------------ &main ---
+;;;
+(defun tinypad-mode-action ()
+ "Activate `tinypad-mode' on or off everywhere, depending on var `tinypad-mode'."
+ (unless (get 'tinypad-mode 'self-call)
+ (run-hooks 'tinypad-:mode-define-keys-hook))
+ (let* ((i 0)
+ tinypad-:mode-define-keys-hook)
+ (unwind-protect
+ (progn
+ ;; Raise the flag to prevent calling us
+ (put 'tinypad-mode 'self-call t)
+ ;; For every buffer, either turn mode on or off.
+ (dolist (buffer (buffer-list))
+ ;; Exclude hidden buffers
+ (incf i)
+ (if (not (string-match "^ " (buffer-name buffer)))
+ (with-current-buffer buffer
+ (if (get 'tinypad-mode 'global)
+ (tinypad-mode 1)
+ (tinypad-mode 0))))))
+ (message "TinyPad: Stepped through %d buffers" i)
+ (sit-for 1)
+ (put 'tinypad-mode 'self-call nil))))
+
+;;}}}
+
+(add-hook 'tinypad-:mode-define-keys-hook 'tinypad-mode-define-keys)
+
+(provide 'tinypad)
+(run-hooks 'tinypad-:load-hook)
+
+;;; tinypad.el ends here
--- /dev/null
+;;; tinypage.el --- Handling ^L pages, select, cut, copy, head renumber.
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 1996-2007 Jari Aalto
+;; Keywords: tools
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program, call M-x tinypage-version.
+;; Look at the code with folding.el.
+
+;; COPYRIGHT NOTICE
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;; ....................................................... &t-install ...
+;; Put this file on your Emacs-Lisp load path, add following into your
+;; ~/.emacs startup file
+;;
+;; (require 'tinypage)
+;;
+;; or use this; your .emacs loads quicker. Preferred.
+;;
+;; (global-set-key "\C-cmp" 'tinypage-mode) ;; "m" for minor modes
+;; (autoload 'tinypage-mode "tinypage" "" t)
+;;
+;; If you make any changes to keybindings, always run command
+;;
+;; M-x tinypage-mode-install
+;;
+;; to see what this mode offers, look at the mode description
+;;
+;; M-x tinypage-mode
+;; C-h m
+;;
+;; If you have any questions, use this function
+;;
+;; M-x tinypage-submit-bug-report ,send bug report
+;;
+
+;;}}}
+
+;;{{{ Documentation
+
+;; ..................................................... &t-commentary ...
+;;; Commentary:
+
+;; Preface, jun 1996
+;;
+;; I had found paged.el by Michelangelo Grigni <mic@mathcs.emory.edu>
+;; one year or so ago and had liked it very much. Unfortunately
+;; it used narrowing and didn't offer easy page select, copy, cut
+;; actions which belong to basic page editing.
+;;
+;; Paged.el has one nice feature: It can renumber pages and make summary
+;; out of them. If I have time I will include those features to
+;; package too.
+;;
+;; Overview of features
+;;
+;; o Copy, cut, paste, yank (after/before current page) ^L pages.
+;; o Show page-nbr/page-count/page-size in modeline.
+;; o Can renumber numbered header levels, where last level is indicated
+;; with number. Eg. "A.1 A.2" or "1.2.1.1 "1.2.1.2"
+;; o Shows popup in X to jump to headings
+;; o Create table of contents.
+;;
+;; About making pages -- basics
+;;
+;; If you're totally unfamiliar to the concept of page: you make
+;; pages in emacs by adding the linefeed marker in the text, normally
+;; on its own line, just before your topics or headings.
+;;
+;; C-q C-l --> ^L
+;;
+;; That inserts the ^L character in the buffer. That is where your
+;; page starts. The layout of your doc may look like this:
+;;
+;; ^L
+;; 1.0 Topic one
+;; txt txt txt txt txt txt txt txt
+;; txt txt txt txt txt txt txt txt
+;;
+;; ^L
+;; 1.1
+;; txt txt txt txt txt txt ..
+;;
+;; ^L
+;; 1.1.1.1
+;; txt txt txt txt txt txt txt txt
+;; txt txt txt txt txt txt txt ...
+;;
+;;
+;; About renumbering
+;;
+;; This package offers simple renumbering features, but it
+;; won't do everything for you! Let's first tell what it won't
+;; do. Renumbering these is piece of cake:
+;;
+;; 1.1
+;; 1.7.1.5 (1)
+;; 1.5
+;; 1.5.4.1 (2)
+;; 1.5.4.5
+;; 1.9
+;;
+;; The result is
+;;
+;; 1.1
+;; 1.7.1.5
+;; 1.2
+;; 1.5.4.1
+;; 1.5.4.2
+;; 1.3
+;;
+;; tsk-tsk, before you say anything... It went all right.
+;; Now you see what it won't do for you.
+;;
+;; . It can't know that the 1.7.1.5 belongs under previous 1.1,
+;; because no back tracking is done. I won't even try!
+;; [write a separate package if you want that...I won't do it]
+;;
+;; . Same goes here, it can't know that the 1.5.4.1 should actually
+;; start from 1.5.1.1
+;;
+;; The thumb rule is, that you _go_ and make sure all the _first_
+;; level headings (those that end to X.X.1.1) are right before doing
+;; renumbering. In the above case, you should have done these before
+;; calling M-x tinypage-renumber-forward.
+;;
+;; . --> 1.1.1.1
+;; . --> 1.5.1.1 _AND_ do replace M-% 1.5.4 with 1.5.1
+;;
+;; Then all the renumberin would have gone just fine.
+;; Little handy work and this package helps you to number your doc easily.
+;;
+;;
+;; Renumbering -- be cautious
+;;
+;; If you have index section in you file, you have a little problem,
+;; because this package does not know nothing about such things.
+;; If the Index section is at the beginning, just go past it and
+;; use function:
+;;
+;; M-x tinypage-renumber-forward
+;;
+;; Using
+;;
+;; M-x tinypage-renumber-buffer
+;;
+;; Would be disaster. It can only be used for non-index buffers.
+;;
+;; Creating index
+;;
+;; After you have renumbered all, your old index section is useless,
+;; Just call function
+;;
+;; M-x tinypage-toc
+;;
+;; And copy the showed buffer in place of the old index.
+;;
+;; Limitations
+;;
+;; Since the numbering is done according to regexp, there is
+;; no way to avoid the following false hit:
+;;
+;; 1.1 Overview
+;; This is highly technical document concerning the latest
+;; NASA ultrawave reflective shield technique. You should
+;; refer to chapter:
+;;
+;; 1.5
+;;
+;; Where the Daddy-Cool portable sondium emission detector is
+;; described in full...
+;;
+;; The Number 1.5 is unfortunately renumbered to 1.2, and possibly
+;; causing headache in the NASA and in the spying countries...
+;; If you know elegant way to prevent these false hits, please
+;; drop me a mail. At this time I haven't much payed attention to this.
+;;
+;; Code Note
+;;
+;; The renumbering used here uses brute force, so the execution time
+;; is O(n2). If you have more that 30-40 sections, the renumbering
+;; might take 15-40 minutes. If you care to send me more pleasant
+;; numbering I'd be very gratefull and you're name would be carved to
+;; this module. For now, I'm just too lazy to change anything.
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+;;{{{ setup: require
+
+(require 'tinylibm)
+(require 'easymenu)
+
+(eval-and-compile
+ (if (ti::xemacs-p)
+ (or (load "overlay" 'noerr)
+ (message "\n\
+tinypage: ** you need XEmacs overlay.el library.
+ ** TinyPage may not work correctly without it."))))
+
+(eval-when-compile (ti::package-use-dynamic-compilation))
+
+(ti::package-defgroup-tiny TinyPage tinypage-: tools
+ "Minor mode for Handling ^L delimeted text rerions (pages).
+ Overview of features
+ o Copy, cut, paste, yank (after/before current page) ^L pages.
+ o Show page-nbr/page-count/page-size in modeline.
+ o Can renumber numbered header levels, where last level is indicated
+ with number. Eg. \"A.1 A.2\" or \"1.2.1.1\" \"1.2.1.2\"
+ o Shows popup in X to jump to headings
+ o Create table of contents.")
+
+;;}}}
+;;{{{ setup: private
+
+(defcustom tinypage-:load-hook nil
+ "*Hook that is run when package is loaded."
+ :type 'hook
+ :group 'TinyPage)
+
+;;}}}
+;;{{{ setup: private variables
+
+(defvar tinypage-:post-command-wakeup-counter nil
+ "Updated by program.")
+
+(make-variable-buffer-local 'tinypage-:post-command-wakeup-counter)
+
+(defvar tinypage-:buffer-toc "*toc*"
+ "Where to create index.")
+
+;;}}}
+;;{{{ setup: public, user configurable
+
+(defcustom tinypage-:register ?p
+ "*Register used for clipboard."
+ :type 'character
+ :group 'TinyPage)
+
+;;; This is _not_ one char "^L", it is two chars "^" + "L"
+
+(defcustom tinypage-:mode-name-string " ^L"
+ "*Minor mode name. User variable."
+ :type 'string
+ :group 'TinyPage)
+
+(defcustom tinypage-:post-command-wakeup-count 40
+ "*How often to wake up to update modeline info.
+Don't put too low value, since it slows down Emacs."
+ :type ' integer
+ :group 'TinyPage)
+
+(defcustom tinypage-:x-coord 170
+ "*Default X menu coordinate."
+ :type 'integer
+ :group 'TinyPage)
+
+(defcustom tinypage-:y-coord 170
+ "*Default Y menu coordinate."
+ :type 'integer
+ :group 'TinyPage)
+
+(defcustom tinypage-:x-popup-line-len 35
+ "*Maximum line length in popup."
+ :type 'integer
+ :group 'TinyPage)
+
+;; Do not change this ! Unless you know what you do...
+
+(defcustom tinypage-:renumber-format
+ '( "^[ \t]*\\([0-9.]+\\.\\)\\([0-9]+\\)" 1 2)
+ "*Regexp for renumbered lines.
+
+Format is
+
+ (REGEXP SAME-LEVEL RENUM-LEVEL),
+
+where the match in RENUM-LEVEL match must return a valid number.
+Value SAME-LEVEL is examined only once and the _dots_ that is holds
+are counted. The dots tell which mail-level was picked.
+Eg, when renumbering the following, only the last number is incremented.
+
+ 1.2 Section one is here, this is picked first and examined.
+ 1.2.1.1 This subsection is skipped, since it's not in the same level.
+ 1.3 This level will be picked.
+
+There _must_ be dots in the matched level string, because the section
+level is calculated by counting the dots. The following
+section numbers won't do:
+
+ 1
+ 2"
+ :type '(list
+ (string :tag "Regexp")
+ (integer :tag "Submatch in regexp")
+ (integer :tag "Submatch in regexp"))
+ :group 'TinyPage)
+
+(defcustom tinypage-:modeline-function 'tinypage-update-mode-line
+ "*The modeline function that keep it up to date whenever called."
+ :type 'integer
+ :group 'TinyPage)
+
+;;}}}
+;;{{{ version
+
+;;;###autoload (autoload 'tinypage-version "tinypage" "Display commentary." t)
+(eval-and-compile
+ (ti::macrof-version-bug-report
+ "tinypage.el"
+ "tinypage"
+ tinypage-:version-id
+ "$Id: tinypage.el,v 2.47 2007/05/07 10:50:08 jaalto Exp $"
+ '(tinypage-:version-id
+ map
+ tinypage-:load-hook
+ tinypage-:mode-define-keys-hook
+ tinypage-:mode-hook
+ tinypage-mode
+ tinypage-:mode-name
+ tinypage-:mode-menu
+ tinypage-:buffer-toc
+ tinypage-:register
+ tinypage-:mode-name-string
+ tinypage-:mode-menu-name
+ tinypage-:mode-prefix-key
+ tinypage-:post-command-wakeup-count
+ tinypage-:x-coord
+ tinypage-:y-coord
+ tinypage-:x-popup-line-len
+ tinypage-:modeline-function
+ tinypage-:renumber-format
+ tinypage-:post-command-wakeup-counter
+ tinypage-:version-id)))
+
+;;}}}
+;;{{{ Minor Mode
+
+;;;###autoload (autoload 'tinypage-mode "tinypage" "" t)
+;;;###autoload (autoload 'turn-on-tinypage-mode "tinypage" "" t)
+;;;###autoload (autoload 'turn-off-tinypage-mode "tinypage" "" t)
+;;;###autoload (autoload 'tinypage-commentary "tinypage" "" t)
+
+(defvar tinypage-:mode-name " ^L"
+ "Minor mode name. Changed by program. not user variable.")
+
+(make-variable-buffer-local 'tinypage-:mode-name)
+
+(eval-and-compile
+
+;;; Prefix keys is "\" by default: this one
+;;; was nicely non-shifted and near HP-UX return key. You can Change it
+;;; prior loading the package with (setq tinypage-:pref
+
+ (ti::macrof-minor-mode-wizard
+ "tinypage-" " ^L" "\\" "Tpage" 'TinyPage "tinypage-:" ;1-6
+
+ "Paged minor mode. This mode allows you to handle ^L delimited
+region as page: you can e.g. cut, copy, and select it.
+
+The page counter is _not_ updated all the time in the modeline, because
+it'd be too heavy task to monitor user constantly. Please use command
+\\[tinypage-modeline] if you want up to date information.
+
+To adjust the user tracking threshold, modify value:
+
+ `tinypage-:post-command-wakeup-count'
+
+Mode description:
+
+ \\{tinypage-:mode-prefix-map}"
+
+ "Paged ^L mode"
+
+ (progn
+ ;; Make sure it's there...
+ (or (assq 'tinypage-post-command post-command-hook)
+ (add-hook 'post-command-hook 'tinypage-post-command))
+ ;; - We could leave the hook there because it's no-op if
+ ;; the mode variable is nil.
+ ;; - But i think if user looks at post-command-hook's contents
+ ;; to spot some problems, he appreciates if there is no extra
+ ;; functions in the hook -- only those that need to active
+ ;; in the current buffer/modes.
+ (if (null tinypage-mode)
+ (remove-hook 'post-command-hook 'tinypage-post-command)
+ ;; Make sure it's there...
+ (or (assq 'tinypage-post-command post-command-hook)
+ (add-hook 'post-command-hook 'tinypage-post-command)))
+ (tinypage-modeline)
+ (ti::compat-modeline-update))
+ "TinyPage menu"
+ (list
+ tinypage-:mode-easymenu-name
+ ["Cut" tinypage-cut t]
+ ["Copy" tinypage-copy t]
+ ["Select" tinypage-select t]
+ ["Yank" tinypage-yank t]
+ ["Yank before page" tinypage-yank-before t]
+ ["Yank after page" tinypage-yank-after t]
+ "----"
+ ["Renumber buffer" tinypage-renumber-buffer t]
+ ["Renumber forward" tinypage-renumber-forward t]
+ ["Renumber Level forward" tinypage-renumber-level-forward t]
+ "----"
+ ["Index" tinypage-toc t]
+ ["Index occur" tinypage-toc-occur t]
+ ["Index popup" tinypage-toc-x-popup t]
+ "----"
+ ["Update modeline info" tinypage-modeline t]
+ ["Previous heading" tinypage-go-previous t]
+ ["Next heading" tinypage-go-next t]
+ ["Scroll down" scroll-down t]
+ ["Scroll up" scroll-up t]
+ "----"
+ ["Package version" tinypage-version t]
+ ["Package commentary" tinypage-commentary t]
+ ["Mode help" tinypage-mode-help t]
+ ["Mode off" tinypage-mode t])
+ (progn
+ (define-key map "?" 'tinypage-mode-off)
+ (define-key map "Hm" 'tinypage-mode-help)
+ (define-key map "Hc" 'tinypage-commentary)
+ (define-key map "Hv" 'tinypage-version)
+ ;; These are the DOS standard keys, mimic them
+ ;; Alt c = copy
+ ;; Alt t = cut
+ ;; Alt p = paste
+ (define-key map "c" 'tinypage-copy)
+ (define-key map "t" 'tinypage-cut)
+ (define-key map "p" 'tinypage-yank)
+ (define-key map "s" 'tinypage-select)
+ ;; ....................................................... yanking ...
+ ;; Emacs users are more familiar with this
+ (define-key map "y" 'tinypage-yank)
+ ;; Some handy paste commands. Moving pages around
+ ;; See the keyboads: < > which mean before , after
+ ;; I don't want to use shift...
+ (define-key map "," 'tinypage-yank-before)
+ (define-key map "." 'tinypage-yank-after)
+ ;; ..................................................... numbering ...
+ ;; key "n" for numbering.
+ (define-key map "nl" 'tinypage-renumber-level-forward)
+ (define-key map "nf" 'tinypage-renumber-forward)
+ (define-key map "nb" 'tinypage-renumber-buffer)
+ ;; ......................................................... index ...
+ ;; key "i" for indexing
+ ;; I didn't pick "x" for X-popup because it's too far away
+ ;; from the "i" key. The "p" for "popup" is much closer.
+ (define-key map "ii" 'tinypage-toc)
+ (define-key map "io" 'tinypage-toc-occur)
+ (define-key map "ip" 'tinypage-toc-x-popup-keyboard)
+ ;; ...................................................... events ...
+ ;; Too bad the delete key is not standard, we have to define
+ ;; many symbols
+ (define-key map [(delete)] 'tinypage-cut)
+ (define-key map [(del)] 'tinypage-cut)
+ (define-key map [(deletechar)] 'tinypage-cut)
+ (define-key map [(hpDeleteChar)] 'tinypage-cut)
+ (define-key map [(backspace)] 'tinypage-copy)
+ (define-key map [(insert)] 'tinypage-yank)
+ (define-key map [(insertchar)] 'tinypage-yank)
+ (define-key map [(hpInsertChar)] 'tinypage-yank)
+ (if (ti::emacs-p)
+ (define-key map [(mouse-1)] 'tinypage-toc-x-popup)
+ (define-key map [(button1up)] 'tinypage-toc-x-popup))
+ ;; .................................................... go, update ...
+ (define-key map "u" 'tinypage-modeline)
+ (define-key map [(prior)] 'tinypage-go-previous)
+ (define-key map [(next)] 'tinypage-go-next)
+ (define-key map [(control prior)] 'scroll-down)
+ (define-key map [(control next)] 'scroll-up))))
+
+;;}}}
+;;{{{ misc, engine funcs
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypage-modeline ()
+ "Update modeline information."
+ (interactive)
+ (funcall tinypage-:modeline-function))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypage-page-region (&optional verb)
+ "Return region (BEG . END) of page. VERB."
+ (interactive)
+ (let* (beg
+ end
+ ret)
+ (save-excursion
+ (beginning-of-line)
+ (if (looking-at "^[ \t]*\C-l")
+ (setq beg (point))
+ (setq beg (tinypage-go-next 'back)))
+ (when (setq end (tinypage-go-next))
+ (goto-char end) ;adjust point, do not take ^L
+ (beginning-of-line)
+ (setq end (point))))
+ (if (and beg end)
+ (setq ret (cons beg end))
+ (if verb
+ (message "Couldn't find region")))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypage-count-pages ()
+ "Count page characters ^L."
+ (let* ((count 0))
+ (save-excursion
+ (ti::pmin)
+ (while (re-search-forward "^[ \t]*\C-l" nil t)
+ (incf count)))
+ count))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypage-count-lines-in-page ()
+ "Count lines."
+ (let* ((elt (tinypage-page-region))
+ (beg (car-safe elt))
+ (end (cdr-safe elt))
+ ret)
+ (when elt
+ (setq ret (count-lines beg end)))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypage-current-page ()
+ "Current page."
+ (interactive)
+ (let* ((re "^[ \t]*\C-l")
+ (p (point))
+ (count 0))
+ (save-excursion
+ (ti::pmin)
+ (while (re-search-forward re p t)
+ (incf count)))
+ (if (looking-at re)
+ (incf count))
+ count))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypage-update-mode-line ()
+ "Update modeline info."
+ (interactive)
+ (let* ((mode-string tinypage-:mode-name-string)
+ pages
+ now
+ lines)
+ (setq pages (tinypage-count-pages))
+ (setq now (tinypage-current-page))
+ (setq lines (tinypage-count-lines-in-page))
+ (setq tinypage-:mode-name
+ (format " %s %s/%s/%s" mode-string now pages (or lines "-")))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypage-post-command ()
+ "Keep page info in modeline up to date."
+ (when tinypage-mode ;only now!
+ (if (not (integerp tinypage-:post-command-wakeup-counter))
+ (setq tinypage-:post-command-wakeup-counter 0))
+ (incf tinypage-:post-command-wakeup-counter)
+
+ (when (eq 0 (% tinypage-:post-command-wakeup-counter
+ tinypage-:post-command-wakeup-count))
+ (tinypage-modeline))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypage-overlay (act &optional beg end)
+ "If ACT is 'hide, hide overlay, otherwise highlight BEG END."
+ (let* ((ov (ti::compat-overlay-some)))
+ (cond
+ ((eq act 'hide)
+ (ti::compat-overlay-move ov 1 1))
+ (t
+ (ti::compat-overlay-move ov beg end)
+ (setq ov (symbol-value ov))
+ (push-mark
+ (if (ti::emacs-p)
+ (ti::funcall 'overlay-start ov)
+ (ti::funcall 'extent-start-position ov))
+ t t)
+ (push-mark
+ (if (ti::emacs-p)
+ (ti::funcall 'overlay-end ov)
+ (ti::funcall 'extent-end-position ov))
+ t t)
+ (setq this-command 'set-mark)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypage-page-mark-region (beg end &optional act maybe)
+ "Mark region and do some command act.
+
+Input:
+
+ BEG region beg
+ END region end
+ ACT action name, default is 'copy. Can be also 'cut 'select
+ MAYBE flag to check is BEG END are valid: if not then do
+ nothing. If vallid; then select and do ACT.
+
+References:
+
+ `tinypage-:register'
+
+Return:
+
+ t if successfull
+ nil"
+ (let* ((doit (if maybe
+ (and beg end)
+ t))
+ (reg tinypage-:register))
+ (cond
+ ((null doit)
+ nil)
+ (t
+ (tinypage-overlay 'show beg end)
+ (cond
+ ((eq 'cut act)
+ (delete-region beg end)
+ (goto-char beg))
+ ((memq act '(nil copy))
+ (set-register
+ reg
+ (ti::remove-properties (buffer-substring beg end)))))
+ ;; something done
+ t))))
+
+;;}}}
+;;{{{ application functions
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypage-renumber-level-forward (&optional verb)
+ "Renumber current level starting from current line. VERB.
+Only the last level number is incremented. Put cursor line above
+the level and call this function
+
+ 1.2
+ * <-- cursor here and it'll renumber level 1.2.1.x
+ 1.2.1.1
+
+References:
+
+ `tinypage-:renumber-format'"
+ (interactive "P")
+ (let* ((data tinypage-:renumber-format)
+ (re (nth 0 data))
+ (lev1 (nth 1 data))
+ (lev2 (nth 2 data))
+ nbr
+ counter
+ dots-exact
+ dots
+ level-string
+ orig-level-string)
+ (ti::verb)
+ (save-excursion
+ (while (re-search-forward re nil t)
+ (setq level-string (match-string lev1))
+ (when level-string
+ (setq dots (count-char-in-string ?. level-string)))
+ (when (and (null dots-exact) ;do only once
+ dots)
+ (setq dots-exact dots
+ orig-level-string level-string))
+ (when (and dots-exact
+ (eq dots-exact dots) ;only same level accepted
+ ;; Must have same beginning "1.2.1.1" "1.2.1.x"
+ ;;
+ (string= orig-level-string level-string)
+ (setq nbr (match-string lev2)))
+ (if (null counter) ;first value ?
+ (setq counter (string-to-int nbr))
+ (incf counter)
+ ;; Replace the last number with the right increment
+ (ti::replace-match lev2 (int-to-string counter))))))
+ (when verb
+ (cond
+ ((null counter)
+ (message "No matches."))
+ (t
+ (message "Last heading was %s%s" orig-level-string counter))))
+ counter))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypage-renumber-forward (&optional verb)
+ "Renumber all found headings forward. VERB."
+ (interactive "P")
+ (let* ((data tinypage-:renumber-format)
+ (re (nth 0 data)))
+ (ti::verb)
+ ;; Well, we do lot of extra work here, because the
+ ;; tinypage-renumber-level-forward goes alway to the bottom,
+ ;; but what the heck... it won't take long.
+ ;;
+ ;; And code is much cleaner this way.
+ (if verb
+ (message "Renumbering..."))
+ (while (re-search-forward re nil t)
+ (beginning-of-line)
+ (tinypage-renumber-level-forward)
+ (forward-line 1))
+ (if verb
+ (message "Renumbering...done"))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypage-renumber-buffer ()
+ "Renumber all headings in buffer starting from `point-min'."
+ (interactive)
+ (save-excursion
+ (ti::pmin)
+ (tinypage-renumber-forward 'verb)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypage-get-index-list ()
+ "Return list of strings."
+ (let* ((list (ti::buffer-grep-lines (nth 0 tinypage-:renumber-format)))
+ ret)
+ (dolist (elt list)
+ (push (ti::string-remove-whitespace elt) ret))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypage-toc (&optional ragged no-show)
+ "Create toc to temporary buffer.
+Optional argument RAGGED makes the heading to 'hang'.
+With nil RAGGED, the headings are lined up.
+
+NO-SHOW doesn't show buffer after creating table of content.
+
+Return:
+ buffer"
+ (interactive "P")
+ (let* ((list (ti::buffer-grep-lines (nth 0 tinypage-:renumber-format)))
+ (buffer (ti::temp-buffer tinypage-:buffer-toc 'clear))
+ dots
+ padd
+ heading
+ text)
+ (with-current-buffer buffer
+ (dolist (elt list)
+ (setq elt (ti::string-remove-whitespace elt))
+ (setq heading (ti::string-match "^[^ \t]+" 0 elt))
+ (setq text (or (ti::string-match "^[^ \t]+[ \t]+\\(.*\\)" 1 elt)
+ "<no heading found>"))
+ ;; How to indent this line
+ (setq dots (count-char-in-string ?. heading))
+ (if (<= dots 1)
+ (setq padd "")
+ (setq padd (make-string (* 2 (- dots 2)) ?\ )))
+ ;; Separate 1.0 topics
+ (if (string-match "0$" heading)
+ (insert "\n"))
+ (setq heading (concat padd heading))
+ (if ragged
+ (insert heading " " text "\n")
+ (insert (format "%s %s\n" heading text)))))
+ (unless no-show
+ ;; Display it, but do not select/go to it.
+ ;;
+ (display-buffer buffer)
+ (ti::save-excursion-macro
+ (select-window (get-buffer-window buffer))
+ (shrink-window-if-larger-than-buffer)))
+ buffer))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypage-toc-x-popup-keyboard ()
+ "Create index. Show it in X-popup."
+ (interactive)
+ (tinypage-toc-x-popup
+ (ti::compat-make-fake-event tinypage-:x-coord tinypage-:y-coord)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypage-toc-x-popup (event)
+ "Create index. Show it in X-popup with EVENT."
+ (interactive "e")
+ (let* ((len tinypage-:x-popup-line-len)
+ (title "Index")
+ list
+ val
+ point)
+ (cond
+ ((null (ti::compat-window-system))
+ (message "Sorry, Requires X to use X-popup"))
+ (t
+ (setq list (tinypage-get-index-list))
+ (setq list (mapcar
+ (function
+ (lambda (x)
+ (ti::string-left x len)))
+ list))
+ (when (setq val (ti::compat-popup list event nil title))
+ ;; See if we can find the heading...
+ (ti::save-excursion-macro
+ (ti::pmin)
+ (if (re-search-forward (regexp-quote val) nil t)
+ (setq point (line-beginning-position))
+ (message "Cannot find heading..."))))
+ (if point
+ (goto-char point))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypage-toc-occur ()
+ "Create occur buffer for jumpig to Headings easily."
+ (interactive)
+ (occur (nth 0 tinypage-:renumber-format)))
+
+;;}}}
+;;{{{ interactive funcs
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinypage-region-action (act &optional verb)
+ "Execute action ACT. Return t or nil. VERB."
+ (let* ((elt (tinypage-page-region verb))
+ (beg (car-safe elt))
+ (end (cdr-safe elt)))
+ (ti::verb)
+ (tinypage-page-mark-region beg end act 'maybe)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinypage-select (&optional verb)
+ "Select page. If sitting on page Marker, use page below. VERB."
+ (interactive "P")
+ (ti::verb)
+ (and (tinypage-region-action 'select verb)
+ (if verb
+ (message "Page selected."))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinypage-copy (&optional verb)
+ "Select page. If sitting on page Marker, use page below. VERB."
+ (interactive "P")
+ (ti::verb)
+ (and (tinypage-region-action 'copy verb)
+ (if verb
+ (message "Page copied."))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinypage-cut (&optional verb)
+ "Select page. If sitting on page Marker, use page below. VERB."
+ (interactive "P")
+ (ti::verb)
+ (tinypage-region-action 'cut verb))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinypage-yank (&optional verb)
+ "Yank page from register. VERB."
+ (interactive "P")
+ (insert-register tinypage-:register)
+ (tinypage-overlay 'hide))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinypage-yank-before (&optional verb)
+ "Yank page from register, but _before_ current page. VERB."
+ (interactive)
+ (ti::verb)
+ (tinypage-yank-after 'before "Yanked before this page." verb))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinypage-yank-after (&optional before msg verb)
+ "Yank page from register, but _after_ current page.
+Optionally BEFORE with MSG and VERB."
+ (interactive)
+ (let* ((msg (or msg "Yanked after this page.")))
+ (ti::verb)
+ (ti::save-with-marker-macro
+ (when (tinypage-go-next before verb)
+ (insert-register tinypage-:register)
+ (tinypage-overlay 'hide)
+ (if (and verb msg)
+ (message msg))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinypage-go-previous (&optional verb)
+ "Go to previous page. VERB."
+ (interactive)
+ (ti::verb)
+ (tinypage-go-next 'back verb))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinypage-go-next (&optional back verb)
+ "Go to next page, optionally BACK. Return point if moved. VERB."
+ (interactive)
+ (let* ((point (point))
+ func
+ ret)
+ (ti::verb)
+ (cond
+ (back
+ (setq func 're-search-backward)
+ (beginning-of-line))
+ (t
+ (setq func 're-search-forward)
+ (end-of-line)))
+ (unless (setq ret (funcall func "\C-l" nil t))
+ (goto-char point))
+ (if verb
+ (tinypage-modeline))
+ (if (and verb (null ret))
+ (message "No more page marks."))
+ ret))
+
+;;}}}
+
+(add-hook 'tinypage-:mode-define-keys-hook 'tinypage-mode-define-keys)
+
+(provide 'tinypage)
+(run-hooks 'tinypage-:load-hook)
+
+;;; tinypage.el ends here
--- /dev/null
+;;; tinypair.el --- Self insert character (pa)irs () "" '' <>
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 1995-2007 Jari Aalto
+;; Keywords: extensions
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program, call M-x tinypair-version.
+;; Look at the code with folding.el.
+
+;; COPYRIGHT NOTICE
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;; ....................................................... &t-install ...
+;; Put this file on your Emacs-Lisp load path, add following into your
+;; ~/.emacs startup file.
+;;
+;; ** MINOR MODE IS GLOBALLY ACTIVED WHEN YOU LOAD THIS FILE **
+;;
+;; ;; If you don't want global activation, use
+;; ;; (defvar tinypair-mode nil)
+;;
+;; (require 'tinypair)
+;; (tinypair-pair-type-select 'us) ;; US `style'
+;; (tinypair-pair-type-select 'european) ;; European 'style'
+;;
+;; Or use autoload and your Emacs starts faster
+;;
+;; (autoload 'turn-on-tinypair-mode "tinypair")
+;; (add-hook <your-favourite-mode-hook> 'turn-on-tinypair-mode)
+;;
+;; If you want to turn the pairing off, use this:
+;;
+;; M-x turn-off-tinypair-mode
+;;
+;; If you have any questions, use this function
+;;
+;; M-x tinypair-submit-bug-report
+;;
+;; If you find any incorrect behavior, please immediately
+;;
+;; o Turn on debug M-x tinypair-debug-toggle
+;; o Repeat the task
+;; o Send bug report
+
+;;}}}
+;;{{{ Documentation
+
+;; ..................................................... &t-commentary ...
+;;; Commentary:
+
+;; Preface, 1995
+;;
+;; Pacakge paired-insert.el was posted to gnu.emacs.help group, and
+;; the code was not very well documented, The code showed lot of
+;; promises, but it lacked smart pairing, so this package was born instead.
+;;
+;; Overview of features
+;;
+;; o Minor mode for paired characters.
+;; o [] {} <> '' `' ""
+;;
+;; Pairing control
+;;
+;; *Remember* Always ask youself "Does this character the cursor is
+;; on, belong to _word_ class?", when you wonder why the pairing does
+;; not take in effect around the current character block.
+;;
+;; The pair control is turned off for lisp mode, because it makes
+;; things worse if the pairing is on. The pairing in US style includes
+;;
+;; `'
+;;
+;; But European people almost never use backquote, intead they use:
+;;
+;; ''
+;;
+;; General pairing rules, just some of them
+;;
+;; The pairing is done according to assoc lists in the following way:
+;;
+;; o if there is whitespace in front of char, then pair is inserted
+;; o if character is over pair-end, no pairing takes effect.
+;; Like if you press opening paren when you're sitting on the
+;; closing paren:
+;;
+;; ()
+;; * <-- cursor here, pressing another ( does not pair.
+;;
+;; but this behavior can be controlled through variable
+;;
+;; o if the cursor is at the beginning of the word (see syntax-table):
+;; -- if there is no pairs around the word, the whole word is paired.
+;; -- if there is pair, no pairing takes effect. The char acts as
+;; self-insert-command.
+;;
+;; o if previous character is word. then the ' doesn't pair. Reason
+;; is in english language .........................^
+;;
+;; o if character is repeated with prefix arg, the pairing isn't done,
+;; instead the character is repeated as in self-insert-command.
+;;
+;; Cursor positioning
+;;
+;; By default the cursor is positioned in the "middle" of the inserted
+;; pair chars. But for words, this is impossible, because there is no
+;; middle position. Please see the variables
+;;
+;; tinypair-:word-positioning
+;; tinypair-:word-positioning-function
+;;
+;; which allow you to customize cursor positioning after word pairing.
+;;
+;; Word about syntax tables
+;;
+;; Syntax table play a major part in pairing, especially pairing words
+;; correctly. Suppose you're writing in text mode:
+;;
+;; ...txt txt... (help is the key)
+;; * <-- cursor
+;;
+;; If you now press " to have the word HELP paired, you don't get it,
+;; because normally text mode's syntax table says that "(" belongs
+;; to group "w" (word) too. So the actual word is seen as "(help" and
+;; the program determines that you're inside a word, thus not
+;; allowing the pairing.
+;;
+;; In the other hand, if you were in any other mode, say in C++, the
+;; "(" is defined as open parenthesis syntax and it that case the
+;; seen word seen would have been "help" and the " character would have
+;; been added around the HELP string. Like this:
+;;
+;; ...txt txt... ("help" is the key)
+;; * <-- cursor
+;;
+;; You may propably want quickly to see the syntax definition of
+;; characters; use function from my lisp libraries
+;;
+;; (defalias 'syntax-info 'ti::string-syntax-info)
+;;
+;; To return to this syntax problem in text mode, you could do the
+;; following, to make certain characters out of "w" class.
+;;
+;; (defun my-syntax-default (table )
+;; "My syntax table settings."
+;; (modify-syntax-entry ?[ "_" table)
+;; (modify-syntax-entry ?] "_" table)
+;; (modify-syntax-entry ?{ "_" table)
+;; (modify-syntax-entry ?} "_" table)
+;; (modify-syntax-entry ?( "_" table)
+;; (modify-syntax-entry ?) "_" table)
+;; (modify-syntax-entry ?/ "." table)
+;; (modify-syntax-entry ?\' "\"" table)
+;; (modify-syntax-entry ?\" "\"" table)
+;; (modify-syntax-entry ?_ "w" table))
+;;
+;; Then you just change the definitions of syntax table in hook:
+;;
+;; (setq text-mode-hook 'my-text-mode-hook)
+;; (defun my-text-mode-hook ()
+;; (my-syntax-default text-mode-syntax-table))
+;;
+;; Do you wonder why I put {}()[] into "_" class and not in
+;; corresponding "(" or ")" classes? Well, my stig-paren just went
+;; beserk and started beeping the bell whenever I was nearby
+;; ")" class... The "_" shut it down, so I just chose it. You can
+;; of course put the chars into any class you like.
+;;
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+;;{{{ setup: require
+
+(require 'tinylibm)
+
+(eval-when-compile (ti::package-use-dynamic-compilation))
+
+(ti::package-defgroup-tiny TinyPair tinypair-: extensions
+ "self insert character pairs () \"\" '' <>
+ Overview of features
+
+ o When you hit e.g. \", package will double the character. If you
+ insertion point was on whitespace, the pair is inserted 'as
+ is', but if point was in front of word, the word is surrounded
+ with pair, provided that there we no pair already.
+ o Every pair beginning character may have it's own function
+ to handle the pairing.")
+
+;;}}}
+;;{{{ setup: hook
+
+(defcustom tinypair-:load-hook nil
+ "*Hook that is run when package is loaded."
+ :type 'hook
+ :group 'TinyPair)
+
+;;}}}
+;;{{{ setup: private
+
+(defvar tinypair-:us-alist
+ '((?\( ?\) nil)
+ (?\[ ?\] nil)
+ (?\{ ?\} nil)
+ (?\< ?\> tinypair-c-\<)
+ (?\` ?\' tinypair-c-\')
+ (?\" ?\" tinypair-c-\"))
+ "Default US pairing alist.")
+
+(defvar tinypair-:european-alist
+ '((?\( ?\) nil)
+ (?\[ ?\] nil)
+ (?\{ ?\} nil)
+ (?\< ?\> tinypair-c-\<)
+ (?\' ?\' tinypair-c-\')
+ (?\` ?\` nil) ;in perl, or shell you need backticks
+ (?\" ?\" tinypair-c-\"))
+ "Default European pairing alist.")
+
+(defvar tinypair-:alist tinypair-:us-alist
+ "The pairing alist '((?BEG-CHAR ?END-CHAR FUNC-SYM) ..)
+The FUNC-SYM element is optional. FUNC definition should have form,
+
+accepted args:
+
+ BEG-CHAR
+ END-CHAR
+
+Return values:
+
+ t force immediate pairing
+ nil pairing prohibited, main should insert char \"as is\"
+ nbr return control to main program.
+ sym func handled pairing, main program should terminate.
+
+If the func element is missing, pairing is done always according to main
+function's decision.")
+
+;;; ........................................................ &v-public ...
+;;; User configurable
+
+;; - Since not all people program with perl-mode when coding perl
+;; (I don't use it), the default function here is not always
+;; the best choice.
+;; - For detecting buffer contents in more robust way that just
+;; relying on the major-mode variable, see this
+;;
+;; tinylibid.el -- Identifying buffer regardless of mode
+
+(defcustom tinypair-:all-pairing-disabled-function
+ 'tinypair-check-if-pairing-allowed
+ "*Funtion to determine if any pairing is allowed.
+Takes no args, and must return nil or non-nil.
+If return value is non-nil, pairing is allowed."
+ :type 'function
+ :group 'TinyPair)
+
+(defcustom tinypair-:disable-mode-list
+ '(message-mode
+ gnus-summary-mode
+ gnus-article-mode
+ gnus-group-mode
+ gnus-server-mode
+ rmail-summary-mode
+ rmail-mode
+ vm-summary-mode
+ vm-mode
+ lisp-mode
+ emacs-lisp-mode
+ lisp-interaction-mode
+ compilation-mode
+ compilation-minor-mode
+ gud-mode
+ shell-mode
+ comint-mode
+ dired-mode
+ vc-dired-mode
+ cvs-mode
+ rcs-mode
+ Electric-buffer-menu-mode ;; std emacs ebuff-menu.el
+ Buffer-menu-mode ;; std Emacs
+ bs-mode) ;; bs.el by <Olaf.Sylvester@kiel.netsurf.de>
+ "*List of `major-mode' symbols, where the pairing is prohibited.
+This variable is used by function `tinypair-check-if-pairing-allowed' which is
+the default Manager for pairing. If you
+change `tinypair-:all-pairing-disabled-function', this variable is not used."
+ :type '(repeat symbol)
+ :group 'TinyPair)
+
+(defcustom tinypair-:automatic-word-pairing t
+ "*If non-nil, then the word pairing is allowed.
+Eg when your cursor is at the beginning of word, pressing
+pair-beg char will pair the whole word.
+
+ txt --> (txt)"
+ :type 'boolean
+ :group 'TinyPair)
+
+(defcustom tinypair-:word-positioning-function
+ 'tinypair-word-position-function
+ "*Function to position the cursor after pairing.
+The value can also be a function symbol, which takes care of positioning
+the cursor. Passed parameters are:
+
+ BEG-POINT ,point+1 where the beg-char were inserted
+ BEG-CHAR ,character
+
+If function returns, non-nil it is assumed that function handled the
+positioning. If it returns nil, then the control is returned to calling
+program and the positioning is done according to variable
+`tinypair-:word-positioning'"
+ :type 'function
+ :group 'TinyPair)
+
+(defcustom tinypair-:word-positioning 'end
+ "*How the cursor should be positioned after word pairing.
+'beg ,leave point after beg pair char
+ 'end ,leave point after end pair char"
+ :type '(choice
+ (const beg)
+ (const end))
+ :group 'TinyPair)
+
+(defcustom tinypair-:word-syntax-classes '(?w ?$ ?. )
+ "*List of syntax classes that are treated like WORD while pairing.
+Eg if you have following text in LaTeX mode:
+
+ $x^2+$
+ * <-- cursor here, now you want to pair it with (
+
+You would normally get
+
+ $x^2+()$
+ *
+
+Because the character $ is in class $. (You can check the class with
+function `tinypair-syntax-info'). But when the is defined into this variable's
+list, it is seen as \"word\", and the pairing is done like for word,
+so that you get this:
+
+ $x^2+($)
+ *"
+ :type '(repeat character :tag "syntax class")
+ :group 'TinyPair)
+
+;;}}}
+;;{{{ setup: version
+
+;;;###autoload (autoload 'tinypair-version "tinypair" "Display commentary." t)
+
+(eval-and-compile
+ (ti::macrof-version-bug-report
+ "tinypair.el"
+ "tinypair"
+ tinypair-:version-id
+ "$Id: tinypair.el,v 2.47 2007/05/01 17:20:51 jaalto Exp $"
+ '(tinypair-:version-id
+ tinypair-:debug
+ tinypair-:load-hook
+ tinypair-:us-alist
+ tinypair-:european-alist
+ tinypair-:alist
+ tinypair-:all-pairing-disabled-function
+ tinypair-:disable-mode-list
+ tinypair-:automatic-word-pairing
+ tinypair-:word-positioning-function
+ tinypair-:word-positioning
+ tinypair-:word-syntax-classes)
+ '(tinypair-:debug-buffer)))
+
+;;}}}
+;;{{{ misc
+
+;;; ............................................................ &mode ...
+
+;;;###autoload (autoload 'tinypair-mode "tinypair" "" t)
+;;;###autoload (autoload 'turn-on-tinypair-mode "tinypair" "" t)
+;;;###autoload (autoload 'turn-off-tinypair-mode "tinypair" "" t)
+;;;###autoload (autoload 'tinypair-commentary "tinypair" "" t)
+
+(defvar tinypair-mode t
+ "*Minor mode on/off flag.")
+
+(make-variable-buffer-local 'tinypair-mode)
+
+(ti::macrof-minor-mode-wizard
+ "tinypair-" " p" nil "Pair" 'TinyUrl "tinypair-:"
+ "Paired insert of characters.
+
+Defined keys:
+
+\\{tinypair-:mode-map}"
+
+ "Paired insert"
+ nil
+ ;; The Menubar item takes space and is not useful at least not
+ ;; now, because there is no other functionality in this mode.
+ nil
+ nil
+ (progn
+ (define-key root-map "<" 'tinypair-self-insert-command)
+ (define-key root-map "(" 'tinypair-self-insert-command)
+ (define-key root-map "{" 'tinypair-self-insert-command)
+ (define-key root-map "[" 'tinypair-self-insert-command)
+ (define-key root-map "\"" 'tinypair-self-insert-command)
+ (define-key root-map "'" 'tinypair-self-insert-command)
+ (define-key root-map "`" 'tinypair-self-insert-command)
+ (define-key root-map "\C-c\"" 'tinypair-pair-type-select)))
+
+;;;### (autoload 'tinypair-debug-toggle "tinypair" t t)
+
+(eval-and-compile (ti::macrof-debug-standard "tinypair" "-:"))
+
+(defalias 'tinypair-syntax-info 'ti::string-syntax-info)
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypair-word-class-p (class)
+ "Check if CLASS of part of logical word classes."
+ (memq class tinypair-:word-syntax-classes))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypair-whitespace-p ()
+ "Check that current point is sitting alone. No word next to it."
+ (let ((prev (char-to-string (or (preceding-char) ?\n )))
+ (next (char-to-string (or (following-char) ?\n ))))
+ (and (string-match "[ \000\t\n\f\r]" prev)
+ (string-match "[ \000\t\n\f\r]" next))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypair-word-class-skip (&optional back)
+ "Skip forward all `tinypair-:word-syntax-class' characters. Optionally BACK."
+ (let* ((ptr tinypair-:word-syntax-classes)
+ (func (if back
+ 'skip-syntax-backward
+ 'skip-syntax-forward))
+ (point (point)))
+ (while ptr
+ (funcall func (char-to-string (car ptr)))
+ (if (eq (point) point)
+ (pop ptr)
+ ;; moved, start over.
+ (setq point (point))
+ (setq ptr tinypair-:word-syntax-classes)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypair-word-beginning-paired-on-line (char-string)
+ "Search backward CHAR-STRING and check if it's next to word in current line.
+The point is not preserved.
+See `tinypair-:word-syntax-classes' for word definition."
+ (interactive)
+ (when (search-backward char-string (line-beginning-position) t)
+ (if (tinypair-word-class-p (char-syntax (ti::buffer-read-char nil 1)))
+ t)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypair-elt-beg (elt)
+ "Return begin pair from ELT."
+ (nth 0 elt))
+
+(defun tinypair-elt-end (elt)
+ "Return end pair from ELT."
+ (nth 1 elt))
+
+(defun tinypair-elt-func (elt)
+ "Return func from ELT."
+ (if (= (length elt) 3)
+ (nth 2 elt)
+ nil))
+
+;;}}}
+;;{{{ pair control
+
+;;; ----------------------------------------------------------------------
+;;; "c" refers to "checking func"
+;;;
+(defun tinypair-c-\' (ch1 ch2)
+ "Check if tick ' character can be paired."
+ (setq ch1 ch2) ;; Byte compiler silencer
+ ;; - Check previous character. If it is a word, assume that user is
+ ;; writing regular text, like "I'm, it's, he's"
+ ;; - In fact this test is useful in old perl code too, where
+ ;; one writes "$package'variable".
+ (cond
+ ((tinypair-word-class-p (char-syntax (preceding-char)))
+ nil)
+ (t
+ 1)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypair-c-\< (ch1 ch2)
+ "Check if < character can be paired. In HTML mode when there
+is tag end,\"slash\", it's not desirable to have <>. Several other HTML
+cases are checked too."
+ (setq ch1 ch2) ;; Byte compiler silencer
+ (let* ((ret 1))
+ (cond
+ ((memq (following-char) '(?/ ))
+ (setq ret nil))
+ ((eq major-mode 'shell-mode)
+ (setq ret nil))
+ ((and nil ;; currently disabled
+ (not (tinypair-whitespace-p))
+ (tinypair-word-beginning-paired-on-line "<"))
+ (setq ret nil))
+ ((or (looking-at "a[ \t]+href")
+ (looking-at "hr[ \t]\\(size\\|wid\\)") ;1.1N <hr size=..>
+ (looking-at "\\(th\\|tr\\)[ \t]align") ;1.1N tables
+ (looking-at "p[ \t]+align") ;1.1N <p align=..>
+ (looking-at "\\(link\\|img\\|form\\) "))
+ ;; The word pairing isn't good in sgml/html mode.
+ ;;
+ ;; If we have
+ ;; <A HREF="http://www.interplay.com">Interplay</a>
+ ;; <LINK REV="company" HREF="http://www.interplay.com">
+ ;;
+ (setq ret nil)))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;; It's like you have opened ne quote
+;;; "txt txt txt
+;;; * ,point here, and you want to end the quote..
+;;;
+;;; In this case the pairing isn't desiredable
+;;;
+(defun tinypair-c-\" (ch1 ch2)
+ "Check if \" character can be paired. Looks backward if previous word
+has starting pair.
+"
+ (let* ((ret 1) ;default is main handling
+ prev ;char
+ point)
+ ;; The prev is nil if point is in BOB
+ (setq prev (char-syntax (or (ti::buffer-read-char nil -1) ?\ )))
+ (if (and prev
+ (tinypair-word-class-p prev))
+ (save-excursion
+ (setq point (point))
+ ;; "This statement has been paired"
+ ;; *cursor-here
+ ;;
+ ;; If we find QUOTE next to WORD, then we assume that this
+ ;; is just closing QUOTE and we won't pair it
+ (if (tinypair-word-beginning-paired-on-line "\"")
+ (setq ret nil))
+ (when ret
+ (skip-syntax-backward "w")
+ ;; point must move, because the skip-syntax will skip
+ ;; "txt"
+ ;; 2 1 1= before 2, after
+ ;; and reading that first " require backward char
+ (when (and (not (= point (point))) ;require movement
+ (not (bobp))
+ (prog1 t (forward-char -1)) ;now we can move
+;;; (ti::d! (following-char) ch1)
+ (eq (following-char) ch1))
+ ;; disallow pairing
+ (setq ret nil)))))
+ ret))
+
+;;}}}
+;;{{{ other
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypair-check-if-pairing-allowed ()
+ "Function to determine if pairing is allowed.
+Returns t, when pairing is allowed for buffer."
+ (not (memq major-mode tinypair-:disable-mode-list)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypair-move (count)
+ (cond
+ ((or (not (integerp count))
+ (<= count 1))
+ nil) ;do nothing
+ (t
+ (backward-char (/ count 2)))))
+
+;;; ----------------------------------------------------------------------
+;;; - I used this before, may use it again...
+;;;
+(defun tinypair-move-logical-word (&optional count)
+ "Move forward, skipping `tinypair-:word-syntax-classes' COUNT times."
+ (let* ((i 0)
+ (count (or count 1))
+ (back (if (< count 0)
+ 'back
+ nil))
+ (func (if back 'skip-chars-backward
+ 'skip-chars-forward)))
+ (while (< i count)
+ (funcall func " \f\t\r\n") ;ignore whitespace
+ (tinypair-word-class-skip back)
+ (incf i))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypair-word-position-function (beg char)
+ "Special cursor positioning function.
+BEG is start point and CHAR is starting pair character."
+ (cond
+ ((char= char ?\( )
+ ;; Mostly in minibuffer and for lisp'ish things, put cursor
+ ;; after starting paren.
+ (goto-char beg))
+ ((or (char= char ?\' ) ;Move to next word.
+ (char= char ?\` ))
+ (let (point)
+ (save-excursion
+ (skip-chars-forward " \t\f")
+ (unless (tinypair-whitespace-p)
+ (setq point (point))))
+ (goto-char point)))
+ (t
+ nil)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypair-word-pair (arg ch-beg ch-end)
+ "Insert pair around word(s) ARG times using CH-BEG and CH-END."
+ (let* ((fid "tinypair-word-pair: ")
+ (pos-flag tinypair-:word-positioning)
+ (pos-func tinypair-:word-positioning-function)
+ ch1
+ ch2
+ read-ch
+ count
+ syntax-now syntax-prev
+ tmp
+ beg)
+ (setq syntax-prev (char-syntax
+ (setq ch1 (or (preceding-char) ?\ ))))
+ (setq syntax-now (char-syntax
+ (setq ch2 (or (following-char) ?\ ))))
+ ;; No-ops. XEmacs byte ocmpiler silencers
+ (unless ch2
+ (setq ch2 nil))
+ (unless fid
+ (setq fid nil))
+ (tinypair-debug fid
+ "arg"
+ arg
+ "syntax now"
+ (char-to-string syntax-now)
+ "char syntax prev"
+ (char-to-string syntax-prev)
+ "Is-word-class now"
+ (tinypair-word-class-p syntax-now)
+ "Is-word-class prev"
+ (tinypair-word-class-p syntax-prev)
+ "CH1"
+ (char-to-string ch1)
+ "CH2"
+ (char-to-string ch2))
+ (cond
+ ((and (or (null arg)
+ (integerp arg))
+ (tinypair-word-class-p syntax-now)
+ ;; the $ character is consudered word in programming
+ ;; modes, so treat it specially. So is Perl's %
+ ;;
+ ;; $<cursor>PATH
+ ;;
+ ;; The wanted behavior is
+ ;;
+ ;; ${PATH} not ${}PATH
+ ;;
+ (or (null (tinypair-word-class-p syntax-prev))
+ (ti::char-in-list-case ch1 '(?$ ?%))))
+ (setq count (if (null arg)
+ 1
+ arg))
+ (if (< count 0) ;switch the values
+ (setq tmp ch-beg ch-beg ch-end ch-end tmp))
+ (insert ch-beg)
+ (setq beg (point))
+ (tinypair-move-logical-word count)
+ (setq read-ch (or (ti::buffer-read-char nil 0) ?\ ))
+ (tinypair-debug fid "count" count
+ "point" (point)
+ "read ch end"
+ (char-to-string read-ch)
+ (char-to-string ch-end))
+ (unless (char= read-ch ch-end)
+ (insert ch-end)))
+ ((integerp arg)
+ (insert (ti::string-repeat arg ch-beg)))
+ (t ;default case
+ (tinypair-debug fid "default")
+ (insert ch-beg ch-end)
+ (backward-char 1)
+ (setq pos-flag nil)))
+ ;; ............................................ cursor positioning ...
+ (setq tmp nil) ;"status" of call
+ (and (fboundp pos-func)
+ (integerp beg)
+ (setq tmp (funcall pos-func beg ch-beg)))
+ (tinypair-debug fid "cursor>>" beg (fboundp pos-func) tmp)
+ (cond
+ ((not (null tmp)) ;function handled this.
+ nil)
+ ((eq 'beg pos-flag)
+ (and (integerp beg)
+ (goto-char beg)))
+ (t
+ nil))))
+
+;;}}}
+;;{{{ main
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypair-pair-type-select (&optional arg)
+ "Pairing control center.
+Input:
+ nil 'us 'usa Use US pairing.
+ other value Use European pairing style."
+ (interactive "P")
+ (if (interactive-p)
+ (message "TinyPair: Selected %s pairing style "
+ (if arg "European" "US" )))
+ (cond
+ ((memq arg '(nil us usa))
+ (setq tinypair-:alist tinypair-:us-alist))
+ (t
+ (setq tinypair-:alist tinypair-:european-alist))))
+
+;;; ----------------------------------------------------------------------
+;;; - Original idea in 19.29+ package paired-insert.el. Unfortunately the
+;;; package didn't satisfy my needs, so here is better pairing func.
+;;;
+;;; - the 'pair' variable in this function is purposively set
+;;; many times, although it is not always necessary. It is just eases
+;;; following the program flow.
+;;;
+(defun tinypair-self-insert-command (arg)
+ "Smart pairing. ARG is repeat count of character."
+ (interactive "P")
+ (let* ((fid "tinypair-self-insert-command: ")
+ (nbr (prefix-numeric-value arg))
+ (word-pair tinypair-:automatic-word-pairing)
+ (ch last-command-char)
+ (elt (assoc ch tinypair-:alist))
+ ;; If TinyEf is active in minibuffer prompt, turn ourself off.
+ (pair-allow
+ (if (and (boundp 'tief-mode)
+ (symbol-value 'tief-mode))
+ nil
+ (if (fboundp tinypair-:all-pairing-disabled-function)
+ (funcall tinypair-:all-pairing-disabled-function)
+ t)))
+ (pair nil) ;pair control
+ (status 1) ;see user configuration CHAR-FUNC
+ direction ;character looking at cmd
+ ch-func ;character function
+ ch-beg
+ ch-end
+ syntax-now
+ ch-now)
+ (tinypair-debug fid
+ 'ARG arg
+ 'CHAR (char-to-string ch)
+ ch
+ 'POINT (point)
+ 'PAIR-ALLOW-FLAG pair-allow
+ 'MODE major-mode
+ 'ELT elt)
+ (cond
+ ((null pair-allow)
+ (turn-off-tinypair-mode)
+ ;; This isn't exactly right, e.g. in some modes the "'" or any pairing
+ ;; character is not a self-insert-command, but a keymap prefix.
+ ;; We run `self-insert-command' only if buffer is NOT read-only.
+ (unless buffer-read-only
+ (self-insert-command nbr)))
+ ((null elt) ;Not defined for pairing
+ (self-insert-command nbr))
+ (t
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... .. do pairing . .
+ (setq ch-beg (tinypair-elt-beg elt))
+ (setq ch-end (tinypair-elt-end elt))
+ (setq ch-func (tinypair-elt-func elt))
+ (setq syntax-now (char-syntax (setq ch-now (following-char))))
+ (tinypair-debug fid 'POINT (point) ch-func)
+ (if (fboundp ch-func)
+ (setq status (funcall ch-func ch-beg ch-end)))
+ (tinypair-debug fid
+ "CH-NOW" (char-to-string ch-now)
+ 'POINT (point)
+ "CH-END" (char-to-string ch-end)
+ "STAT" status
+ "CH-FUNC" ch-func
+ "SYNTAX-NOW" (char-to-string syntax-now))
+ (cond
+ ((integerp status)
+ (setq direction
+ (cond
+ ((integerp arg)
+ (if (> arg -1) nil 'back))
+ (t ;C-u forward
+ nil)))
+ ;; No-ops. XEmacs byte compiler silencers
+ (unless direction
+ (setq direction nil))
+ (unless fid
+ (setq fid nil))
+ (tinypair-debug fid "direction" (or direction 'forward)
+ "WORD-PAIR" word-pair)
+ (cond
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... ... ... ...
+ ((char= ch-now ch-end) ;already pair visible
+ (tinypair-debug fid "now = End"))
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... ... ... ...
+ ((char= syntax-now ?\ ) ;whitespace at point
+ (setq pair t) ;ok, do pairing
+ (tinypair-debug fid "Whitespace 1 1 t"))
+ (word-pair
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... words ..
+ ;; the default case
+ ;; handle smart pairing.
+ (setq pair 'word))
+ (t
+ (tinypair-debug fid "default word")
+ (setq arg 1 pair t))) ;main COND
+ ;; ... ... ... ... ... ... ... ... ... ... ... insert chars ? ...
+ (tinypair-debug fid "Doing... ARG; PAIR-flag" arg pair )
+ (cond
+ ((eq pair 'word)
+ (tinypair-word-pair arg ch-beg ch-end))
+ (pair
+ (tinypair-word-pair nil ch-beg ch-end))
+ (t
+ (insert (ti::string-repeat nbr ch-beg)))))
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... other status ..
+ ((eq nil status)
+ (insert ch-beg))
+ ((eq t status)
+ (insert ch-beg ch-end)
+ (backward-char 1))
+ ((symbolp status)
+ nil))))))
+
+;;}}}
+
+(add-hook 'tinypair-:mode-define-keys-hook 'tinypair-mode-define-keys)
+
+(ti::add-hooks '(minibuffer-setup-hook
+ dired-mode-hook
+ cvs-mode-hook
+ gnus-summary-mode-hook
+ gnus-group-mode-hook
+ rmail-mode-hook
+ rmail-summary-mode-hook
+ vm-mode-hook
+ vm-summary-mode-hook)
+ 'turn-off-tinypair-mode)
+
+(if tinypair-mode
+ (turn-on-tinypair-mode))
+
+(provide 'tinypair)
+(run-hooks 'tinypair-:load-hook)
+
+;;; tinypair.el ends here
--- /dev/null
+;;; tinypath.el --- Manage Emacs startup dynamically
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 1999-2007 Jari Aalto
+;; Keywords: extensions
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program, call M-x tinypath-version.
+;; Look at the code with folding.el.
+
+;; COPYRIGHT NOTICE
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;; ....................................................... &t-install ...
+;;
+;; The very fast start
+;;
+;; If you want to do the reading later, follow these steps. No
+;; guarantees that this will work. If it did't, have a coffee near you
+;; and read the whole documentation.
+;;
+;; o Include perl script *emacs-util.pl* in your `PATH'. If you
+;; do not have perl, get it for Unix at http://www.perl.com/ or
+;; install http://www.cygwin.com/ to your Win32 operating system.
+;; o If you use XEmacs, see `tinypath-:core-emacs-load-path-list'
+;; o Make sure all your personal Emacs Lisp files are under any of these
+;; directories: $HOME/elisp, `~/.emacs.d' (newer Emacs), ~/.xemacs.
+;; o Create directory `$HOME/elisp/config' where cache will be saved.
+;; o Include these lines at the top of startup file: `$HOME/.emacs'
+;;
+;; ;; $HOME/.emacs
+;; (require 'cl)
+;;
+;; ;; PLEASE COPY VERBATIM. THERE ARE OPTIMIZATIONS
+;; ;; THAT ACTIVATE IF YOU use absolute path
+;; (pushnew "~/elisp/tiny-tools-NNNN.NNNN/lisp/tiny"
+;; load-path :test 'string=)
+;;
+;; ;; - If you use new XEmacs, that may ship the lisp
+;; ;; files in separate kit, tell where the directories are
+;; ;; => Was used in Win32 native XEmacs 2003.
+;; ;; - See http://www.xemacs.org/Develop/cvsaccess.html
+;; ;; for cvs access and easy update (2003-05-20).
+;;
+;; (when (featurep 'xemacs)
+;; (setq tinypath-:core-emacs-load-path-list
+;; '("/usr/local/share/xemacs/xemacs-packages"
+;; "/usr/local/share/xemacs/site-packages"
+;; "/usr/local/share/xemacs/mule-packages")))
+;;
+;; (load "tinypath.el")
+;;
+;; ;; <the rest of your Emacs setup below this>
+;;
+;; ;; End $HOME/.emacs
+;;
+;; o After Emacs has been started, call `M-x'
+;; `tinypath-cache-problem-report'. In the generated buffer see
+;; `C-h' 'm' mode help for available commands.
+;;
+;; First user note
+;;
+;; You may see message "TinyPath: EXT Process running ...
+;; [may take a while]" and Emacs hangs for a while when you use this
+;; package for the first time. Please wait and read the documentation
+;; about "Faster Emacs configuration" later in this file.
+;;
+;; ********************************************************************
+;; It is preferred that you use the EXT method, because the TRAD(itional)
+;; lisp method has a drawback. It does not support rearranging
+;; paths to order: 1) $HOME 2) site-lisp-files 3) core-emacs-lisp-files
+;; ********************************************************************
+;;
+;; The perl method guarantees, that anything you put into your
+;; private ~/elisp will override and precede any other package
+;; found elswhere in `load-path' hierarchy.
+;;
+;; At any time you can read the manual with `M-x' `tinypath-version'
+;;
+;; Cache file location
+;;
+;; Create a directory where the cache information is saved. The location
+;; can be set by changing `tinypath-:cache-file-prefix' which should be
+;; pathname + file-prefix. The cache size depends on your
+;; installed files, with 600 directories and 8000 lisp files, the
+;; cache size is around 500k and if you use compression, it takes
+;; somewhere 200k.
+;;
+;; mkdir -p ~/elisp/config (in new Emacs: ~/.emacs.d/config)
+;;
+;; Transparent compression
+;;
+;; If space is tight, this package supports transparent
+;; compression. The files can be kept in compressed format
+;; without touching code in startup files. Calls like below are
+;; interpreted as if there were a `.el.gz' or `.el.bz2'
+;; extensions attached to the files. See
+;; `tinypath-:compressed-file-extensions' for more.
+;;
+;; (load "some-file")
+;; (require 'somefile)
+;;
+;; This transparent support however comes with a prolonged search
+;; time, because more attempts must be made in order to find the file.
+;; If all the files are in non-compressed format and you do not plan
+;; to use the compression support, a much better performancs can be
+;; achieved by turning the support off (it's the default). To turn it
+;; on, use:
+;;
+;; (setq tinypath-:compression-support 'default)
+;;
+;; Contact and support
+;;
+;; Call `tinypath-debug-test-run' if you think there is something
+;; odd going on. All the messages will appear in *Messages*
+;; buffer (Emacs); under XEmacs, examine " *Message-Log*"
+;; buffer. If you have any questions, contact maintainer and
+;; don't forget to send contents of the *Messages* buffer.
+;;
+;; ********************************************************************
+;;
+;; IT IS HIGHLY RECOMMENDED THAT YOU VALIDATE YOUR SETUP
+;; AFTER YOU HAVE LOADED THIS PACKAGE
+;;
+;; Start Emacs and call report function to investigate any problems,
+;; like duplicate packages that shadow each other. See documentation
+;; below for more. The general rule is that you should delete
+;; any offending packages (use `C-d' to delete file in the buffer
+;; that displays the problem report)
+;;
+;; C-u M-x tinypath-cache-problem-report (or without C-u argument)
+;;
+;; *******************************************************************
+
+;;}}}
+;;{{{ Documentation
+
+;; ..................................................... &t-commentary ...
+
+;;; Commentary:
+;;
+;; Preface Feb 1999 - How it all begun
+;;
+;; When you have set up your Emacs installation to your liking, a day
+;; comes when you decide that it's time to seriously reconsider the
+;; directory structure of your installed lisp packages. At start, it
+;; is customary to use simple file hierarchy where all private
+;; packages are installed under:
+;;
+;; ~/elisp (in new Emacs: ~/.emacs.d)
+;;
+;; Complete kits are usually installed directly under the root:
+;;
+;; ~/elisp/packages/bbdb-2.00.06/
+;; ~/elisp/packages/psgml-1.0.3/
+;; ~/elisp/packages/pcl-cvs-2.9.2/
+;;
+;; A more sophisticated way is to use symlinks to the latest
+;; versions, so that you don't have to change `load-path' every
+;; time you install a new version. It is only matter of updating
+;; the symlink:
+;;
+;; ~/elisp/packages/pcl-cvs/ --> ~/elisp/packages/pcl-cvs-2.9.2/
+;; |
+;; This path is in the `load-path'
+;;
+;; In network, where Windows is coupled with Unix workstations via SAMBA,
+;; you may have mapped the _H:_ disk to you Unix _$HOME_:
+;;
+;; H: --> Unix $HOME \\SERVER\DIRECTORY\YOUR-LOGIN-DIR
+;;
+;; Now, there is a catch when Unix symlinks are used in `$HOME/elisp'
+;; and the directories are accessed from Windows. Having set PC's
+;; HOME environment variable to point to H:, Emacs can start reading
+;; Unix `$HOME/.emacs' startup file, but there appeared messages
+;; like "Can't load library xxx", which was soon followed by
+;; bigger concerns: "autoloading xxx failed". The problem was the
+;; mounted H: disk. You see, PC's network mount can't distinguish
+;; symlinked directories from real directories, so all symlinked Unix
+;; directories in `load-path' were dead. And that's why most of the
+;; files couldn't be found any more.
+;;
+;; The conclusions
+;;
+;; For cross platform solution it is best not to rely on symlinks,
+;; because they don't work well over a Windows mount. Secondly,
+;; updating `load-path' should not be needed by hand after a new
+;; package installation, after a directory name change, after
+;; directory structure change, etc. A dream package would solve this
+;; all and do the hard work: "There, that is the root(s) of all Emacs
+;; lisp, go and search all the directories and update `load-path'"
+;;
+;; That was what this package originally was all about. Nowadays
+;; it does a little more than that. The `load-path' is updated
+;; automatically without any manual work. Only the start ROOT
+;; path(s) of installed lisp hierarchies need to be known. This
+;; package is highly effective: scanning thousands of files in a
+;; matter of seconds and once the cache has been created, it
+;; takes only a snap to load it in next sessions. All `require'
+;; and `load' commands also execute faster than previously,
+;; because the information about existing files is immediately
+;; available. The speedup is helped through advised functions.
+;;
+;; Overview of features
+;;
+;; Automatic load-path configuration
+;;
+;; o Define list of `root' directories of your Emacs lisp and this
+;; package will recursively add directories which contain .el or
+;; .elc files to `load-path'
+;; o A cache is utilized to remember previous scan and
+;; expired periodically. Using cache speeds up loading files
+;; considerably if you have many directories. The number of lisp
+;; directories doesn't affect the load performance.
+;; This is accomplished by using extra advice code in functions:
+;; `load', `load-library', `require', `locate-library' and
+;; `autoload'.
+;; o When Emacs becomes idle (some 15 minutes of idle time) the
+;; cache and `load-path' is validated for erroneous entries and
+;; rebuilt as needed. This feature should auto-detect changes in
+;; directory structure and help semi auto-installing
+;; new directories (packages) for you.
+;; o The `load-path' is optimized so, that users' files automatically
+;; take precedence first (~/elisp), next any other files found,
+;; and last the core Emacs files in the distribution.
+;;
+;; Automatic Info-default-directory-list configuration
+;;
+;; o If you download packages that include Emacs info files,
+;; the `Info-default-directory-list' is updated at the same time
+;; as the `load-path', when root directories are examined.
+;; o No more manual updating of info files. The missing
+;; `dir' entry is created or updated as needed.
+;; o You can update all _new_ info files in your system by calling
+;; M-x `tinypath-info-scan-Info-default-directory-list'
+;;
+;; If new info filesare added by hand, call function
+;; `tinypath-info-handler' to update your Emacs and update the
+;; `dir' entry. After that reset old information with `M-x'
+;; `tinypath-info-initialize'.
+;;
+;; This feature was designed to be used under Windows where
+;; Cygwin installation provided many manual pages, which would
+;; have been handy to read under Win32 Native Emacs. The catch
+;; was how to mix Cygwin + Native Emacs for manual page and info
+;; page reading. Under *nix this feature is of limited usability,
+;; because info pages are installed in orderly manner by the system
+;; installation scripts.
+;;
+;; Win32 automatic manpath configuration
+;;
+;; o In Unix systems the MANPATH enavironment variable contains
+;; directories where to find manual pages, but in Win32,
+;; there is no default MANPATH and `M-x' `man' does not work.
+;; o If package *woman.el* (Included in latest Emacs
+;; versions) is along `load-path', it is automatically
+;; configured to support to read manual pages. It replaces
+;; the `M-x' `man' command.
+;;
+;; Win32 Cygwin environment support
+;;
+;; o If *cygwin1.dll* (<http://www.cygwin.com/>) is in `exec-path',
+;; automatic detection tries to find the Cygwin root and scan
+;; manual pages and info pages for use with *woman.el*
+;; _Note:_ This feature is for native Win32 Emacs. Nowadays,
+;; there is also native Cygwin Emacs, which behaves just like
+;; the big brother *nix Emacs.
+;;
+;; Compressed lisp file support
+;;
+;; o Overloads commands load, load-library, load-file, require
+;; and autoload to accept `jka-compr' compressed lisp .el files.
+;; o Primarily meant to be used in low quota accounts.
+;; o Compress or decompress lisp files. You don't have to change
+;; a thing in your Emacs startup file, all will work as usual.
+;; o Handle aliased commands that turn out to be
+;; in `autoload' state.
+;;
+;; How to set up your load path
+;;
+;; The `tinypath-:load-hook' should contain function
+;; `tinypath-setup' which starts examining all directories under
+;; `load-path' and `tinypath-:load-path-root' which is set to
+;; reasonable defaults of site wide and personal installations.
+;; If you keep all your lisp files under *$HOME/elisp*, then you
+;; do not need to configure anything for this package to work.
+;; Your `load-path' will be updated after this code at the
+;; beginning of your *$HOME/.emacs*
+;;
+;; (load "~/elisp/tiny/tinypath") ;; Or anywhere you have it installed
+;;
+;; If there are _many_ separate Emacs lisp root directories, like
+;; one for *site-lisp* and one for *site-packages* and one for
+;; *personal* *lisp* files, then those directories should be
+;; added to variable `tinypath-:load-path-root'. Below there is
+;; an example for PC users, where the E: partition replicates
+;; identical Unix tree structure. We suppose for a moment that
+;; Cygwin is installed there. The following actually works for
+;; shared Unix Emacs setup file too, because non-existing
+;; directories will get ignored:
+;;
+;; (setq tinypath-:load-path-root
+;; '("~/elisp" "E:/usr/share/emacs/site-lisp/common"))
+;; (load "~/elisp/tiny/tinypath")
+;;
+;; Peiodic load path syncronization watchdog
+;;
+;; If new lisp packages are installe dand tried reularly when new
+;; development versions are tracked, then the manual need to call
+;; `M-x' `tinypath-cache-regenerate' may become tiresome. There
+;; is a built in idle timer watchdog included in the package, but
+;; it is not activated by default. It's job is to examine load path
+;; every now and them when Emacs is idle to see if the `load-path'
+;; has gone out of synch i.e. new paths have appeared, old ones removed
+;; or new packages has been added. This feature is experimental and
+;; the scanning may be quite resource intensive because disk I/O
+;; is neede to determine the status of the paths and files. To anable
+;; it, you must define the load hook before anything else:
+;;
+;; (setq tinypath-:load-hook
+;; '(tinypath-install tinypath-install-timer))
+;; ... and now the call to 'load' tinypath comes after it ...
+;;
+;; XEmacs and Emacs specific directories
+;;
+;; In spite of great effort from developers to make packages
+;; compatible for both Emacs platforms, there is always some packages
+;; that only work with Emacs or XEmacs. It is assumed that the site
+;; admin has created directories like these to keep the *site-lisp*
+;; installation clean:
+;;
+;; ;; This might be also under /opt/share/site-lisp
+;; ;; Refer to file hierarchy standard at
+;; ;; http://www.pathname.com/fhs/
+;;
+;; /usr/share/emacs/site-lisp/common/ .. XEmacs and Emacs
+;; /usr/share/emacs/site-lisp/emacs/ .. only for Emacs
+;; /usr/share/emacs/site-lisp/xemacs/ .. only for XEmacs
+;;
+;; To take care of the Emacs specific `load-path' setting, use code
+;; similar to this snippet. If you load the setup multiple times, the
+;; `pushnew' ensures that the directories are not added multiple
+;; times.
+;;
+;; (require 'cl)
+;; (dolist (path ("~/elisp"
+;; ;; For both Emacs and XEmacs
+;; "/usr/share/emacs/site-lisp/common"
+;; ;; Select Emacs or XEmacs specific installations
+;; (if (boundp 'xemacs-logo)
+;; "/usr/share/xemacs/site-lisp"
+;; "/usr/share/emacs/site-lisp/emacs")))
+;; (when (stringp path)
+;; (pushnew path tinypath-:load-path-root :test 'string=)))
+;;
+;; ;; PLEASE COPY VERBATIM. THERE ARE OPTIMIZATIONS
+;; ;; THAT ACTIVATE IF YOU ADD THE PATH
+;; (pushnew "~/elisp/tiny/lisp" load-path :test 'string=)
+;; (load "tinypath.el")
+;;
+;; The package will check current emacs version and make sure
+;; that only correct directories are included to the
+;; `load-path'. If you simply instructed to search the whole
+;; site-lisp root `/usr/share/site-lisp', and current emacs
+;; binary is "emacs", then all directories that contain path
+;; portion `/xemacs' are automatically ignored.
+;;
+;; Building part of site-lisp from Internet
+;;
+;; If we continue talking a bit more about site-lisp, there is utility
+;; *mywebget.pl* at <http://perl-webget.sourceforge.net/>. It
+;; includes a *mywebget-emacs.conf* which contains
+;; knowledge where the various lisp developers' home pages are and how
+;; to download all known lisp tools that do not come with Emacs. If
+;; you have lot of disk space and you're interested in getting more
+;; tools to go with your Emacs, follow the instruction laid out
+;; in the above project's page.
+;;
+;; If you are further interested in Emacs packages, see Cvs
+;; version control program available for Unix at
+;; <http://www.cvshome.com/> and for Win32 `cvs' will ship with
+;; the <http://cygwin.com> installation. With Cvs you can track
+;; development of many Emacs projects including Gnus, BBDB,
+;; Mailcrypt etc. Cvs is minimizing network traffic by
+;; transferring only changes. Here is one suggestion where you
+;; could put all your Emacs Lisp Version control downloads:
+;;
+;; /usr/share/emacs/site-lisp/net/cvs-packages
+;;
+;; Now, the overall structure of whole site-lisp might look
+;; something like this:
+;;
+;; ROOT/ ( /usr/share/emacs or equivalent )
+;; |
+;; +--site-lisp/
+;; |
+;; +--emacs/
+;; | | ...Emacs only files
+;; | +--packages/
+;; | | +--pcl-cvs-2.9.9/
+;; | | +-... and so on
+;; | +--win32/
+;; | +--gnuserv/
+;; | +-... and so on
+;; +--net/
+;; | +--users/
+;; | +-LispDeveloperA
+;; | +-LispDeveloperB
+;; | +-... and so on
+;; | +--cvs-packages/
+;; | +--liece/
+;; | +--lookup/
+;; | +--ILISP/
+;; | +--jess-mode/
+;; | +--devel/
+;; | +--emacro/
+;; | +--tnt/
+;; | +--cc-mode/
+;; | +--mailcrypt/
+;; | +--bbdb/
+;; | +--gnus/
+;; | +-... and so on
+;; +--common/
+;; | ...COMMON for both Emacs and XEmacs
+;; | =======================================
+;; | ...Packages that you find posted to the
+;; | ...gnu.emacs.sources and whose author's
+;; | ...do not have a homepage
+;;
+;; For XEmacs, you would add:
+;;
+;; ROOT/ ( /usr/share/xemacs or equivalent )
+;; |
+;; +--site-lisp/
+;; |
+;; +--xemacs/
+;; | ...XEamcs only files
+;; +--cvs-packages/
+;; +--xemacs-packages/
+;;
+;; XEmacs 21.2+ core packages
+;;
+;; Some (Win32) XEmacs versions come with only the very basic
+;; installation. Lisp packages may be distributed in separate
+;; archive *xemacs-packages* (nick named SUMO due to its huge
+;; size). There is also *mule-packages* and *site-packages*
+;; archives. A built-in heuristics tries to guess the location of
+;; these by looking under and near your XEmacs installation. Here
+;; is example from Win32:
+;;
+;; .../XEmacs/XEmacs-NN.N/xemacs-packages
+;; .../XEmacs/xemacs-packages
+;;
+;; If the archives have been installed elsewhere, you have to tell the
+;; location by defining following variable prior loading TinyPath. You
+;; can't put these to `tinypath-:load-path-root' because this is
+;; special information that needs to present during the very initial
+;; boot-up to find crucial packages like *jka-compr.el*.
+;;
+;; (setq tinypath-:core-emacs-load-path-list
+;; '("/usr/share/site-lisp/xemacs/xemacs-packages"
+;; "/usr/share/site-lisp/xemacs/mule-packages"
+;; "/usr/share/site-lisp/xemacs/site-packages"))
+;;
+;; Finding load-path directories
+;;
+;; Supposing only default *$HOME/elisp* is used directory for files, the
+;; `tinypath-:load-path-function' starts recursively searching all
+;; the directories under the root(s) `tinypath-:load-path-root'. Not all
+;; directories are counted in when the search descends below the root(s).
+;; Variable `tinypath-:load-path-ignore-regexp' decides if the directory
+;; should be ignored. By default:
+;;
+;; o Package's additional subdirectories like texinfo, tex, doc, etc,
+;; misc, RCS, CVS, .svn (Subversion), MT (monotone version control),
+;; zip are ignored.
+;; o Any temporary directories named .../t/ .../T/ .../tmp* .../temp*
+;; are ignored.
+;; o Directories that do not contain any files ending to .el or .elc are
+;; ignored. (it's fatser to do the above checks first).
+;;
+;; Gnus and other 3rd party packages
+;;
+;; _Note:_ In latest version of this utility *Gnus* is treated
+;; specially. All Gnus versions are detected along load-path and
+;; the very latest Gnus version is installed to your
+;; `load-path'. This is based on the knowledge in the
+;; `gnus-version' variable and the heuristics will pick the
+;; newest for you. You actually do not have to do anything else,
+;; but to drop latest Gnus somewhere, to be able to use it
+;; immediately.
+;;
+;; Under the hood (old documentation)
+;;
+;; It is important to understand how this package works: It caches
+;; every possible lisp directory it can find. Now, if you have
+;; installed private copy of Gnus, say in `~/elisp/cvs-packages/gnus',
+;; there is a problem, because Emacs distribution also includes Gnus.
+;; There is NO WAY TO TELL OR CHANGE path order when the cache is in
+;; use. This is a design decision and cannot be changed. The old trick,
+;; where a new directory was added in front of `load-path', will not
+;; work because everything goes through cache. What you need to do
+;; instead, is to tell that the "other" Gnus should be ignored during
+;; cache creation, so that it is completely unknown.
+;;
+;; Solution: ignoring directories
+;;
+;; There is very simple way. Put your regular expression to
+;; `tinypath-:ignore-file-regexp-extra' and it will tell which
+;; directories to ignore. Naturally you must put the lisp code
+;; _before_ you load package.
+;;
+;; (setq tinypath-:load-path-ignore-regexp-extra
+;; "\\|[/\\]x?emacs[/\\0-9.]+[/\\]lisp[/\\]gnus")
+;; ;; PLEASE COPY VERBATIM. THERE ARE OPTIMIZATIONS
+;; ;; THAT ACTIVATE If YOU ADD THE PATH
+;; (require 'cl)
+;; (pushnew "~/elisp/tiny/lisp" load-path :test 'string=)
+;; (load "tinypath.el")
+;;
+;; [For advanced Lisp programmers] You can add ignored gnus directory
+;; to `tinypath-:load-path-ignore-regexp' via
+;; `tinypath-:load-path-ignore-regexp-hook'. When the hook is run, the
+;; default value for `tinypath-:load-path-ignore-regexp' is already
+;; available. In hook, append regular expression that excludes the
+;; Gnus directory. Here is an example; make sure that you don't add
+;; the regexp multiple times. The multiple invocations is protected by
+;; setting a plist property and checking it. The ugly [\\/] makes the
+;; regexp compatible with both Unix and win32 paths. System
+;; directories in Unix are typically /emacs/NN.NN/ and in win32
+;; /emacs-NN.NN/, that's why added "-".
+;;
+;; (add-hook 'tinypath-:load-path-ignore-regexp-hook
+;; 'my-tinypath-:load-path-ignore-regexp-hook)
+;;
+;; (defun my-tinypath-:load-path-ignore-regexp-hook ()
+;; ;; Do this only once
+;; (unless (get 'my-tinypath-:load-path-ignore-regexp-hook 'set)
+;; ;; mark as done.
+;; (put 'my-tinypath-:load-path-ignore-regexp-hook 'set t)
+;; (setq tinypath-:load-path-ignore-regexp
+;; (concat
+;; tinypath-:load-path-ignore-regexp
+;; "[/\\]x?emacs[/\\0-9.]+[/\\]lisp[/\\]gnus"))))
+;;
+;; #todo: What about XEmacs public/private Gnus installations?
+;;
+;; Updating new lisp packages
+;;
+;; Suppose you have installed a new version of a package:
+;;
+;; ~/elisp/gnus/pgnus-0.74/
+;; ~/elisp/gnus/pgnus-0.95/ ;; NEW
+;;
+;; Both these directories end up being added to the `load-path',
+;; but that is not preferable. It is the latest version that
+;; should be in the `load-path'. The solution is to move the old
+;; versions under some name that will be ignored by default. It
+;; is recommended that a backup of previous packages are renamed
+;; to start with a word "tmp-". All directories that start with
+;; prefix *tmp* are ignored.
+;;
+;; % mv ~/elisp/gnus/pgnus-0.74/ ~/elisp/gnus/tmp-pgnus-0.74/
+;; ====
+;;
+;; However if you update package in a site-lisp directory, there
+;; may be a distant problem that somebody needs older version of
+;; the package. If you made the backup like above, that user
+;; cannot load the old package any more, because it doesn't show
+;; up in `load-path'
+;;
+;; There is no easy answer to keep old packages. Admin could
+;; announce that: "new version has been installed in DIR, the old
+;; one is in TMP-OLD-DIR" and have users manually arrange their
+;; `load-path' if needed. Following lisp command would solve
+;; their setup. The statement below adds the old directory to the
+;; *beginning* of `load-path' and thus load commands would find the
+;; old version of the package first.
+;;
+;; (load "~/elisp/tiny/tinypath")
+;; ;; Add more directories.
+;; (pushnew "TMP-OLD-OLD-DIR" load-path :test 'string=)
+;; (tinypath-cache-regenerate)
+;;
+;; Remember to mention to users that they need to update cache with
+;; `tinypath-cache-regenerate' (called with prefix argument) to see
+;; the changes.
+;;
+;; Duplicate files in path
+;;
+;; If you have accustomed to putting your path to specific order,
+;; you have to rethink the strategy. The philosophy behind this
+;; utility was that there SHOULD BE NOT NEED TO DO MANUAL WORK TO
+;; UPDATE PATHS. This means that the order of the paths must not
+;; be significant. Now, you may face a situation where library or
+;; package contains a file, which has already been installed.
+;; Take for example, *smtpmail.el*:
+;;
+;; /usr/bin/emacs-20.4/lisp/mail/smtpmail.el
+;; /usr/share/site-lisp/common/packages/semi/flim-1.12.1/smtpmail.el
+;;
+;; There is a problem if FLIM's *smtpmail.el* is not compatible with
+;; the one in Emacs. If it is, then there is no problem. Either one can be
+;; loaded, and the `load-path' order does not matter. But you don't
+;; know that before you get error "function smtpmail-xxxx not defined"
+;; and you start investigating with (locate-library "smtpmail") which
+;; package is actually active.
+;;
+;; Please investigate your path with [C-u] `M-x'
+;; `tinypath-cache-problem-report' and see if you find duplicate
+;; entries. Check each one and possibly move the file to another
+;; name or remove older ones. E.g. in the above situation, the
+;; cure might be moving FLIM's *smtpmail.el* under name
+;; *flim-smtpmail.el* so that it doesn't get loaded with (require
+;; 'smtpmail). The BEST IS TO CONTACT THE MAINTAINER(S) and tell
+;; them about conflicts. Here is a sample of one generated
+;; problem report:
+;;
+;; imenu.el
+;; 323 34073 1998-05-07 16:28:08 /usr/share/site-lisp/common/other/
+;; 910 37169 1999-12-04 02:47:58 /usr/share/site-lisp/common/programming/java/jde/jde-2.1.6beta13/lisp/
+;; 1350 38663 1999-11-28 01:14:38 /usr/bin/emacs/gnu-emacs/emacs-20.4.1/lisp/
+;; base64.el
+;; 515 9943 1999-12-11 19:15:20 /usr/share/site-lisp/common/packages/gnus-5.8.2/lisp/
+;; 807 9892 1999-11-15 00:00:12 /usr/share/site-lisp/common/packages/w3-4.0pre.46/lisp/
+;;
+;; _Explanation:_ Previously *imenu* was installed as a separate
+;; package. Now latest Emacs ships with one, so it is best to delete
+;; the previous one `other/imenu.el.' Keep on eye on the numbers
+;; here: The lower, the more close it is to the beginning of
+;; cache when the directories were searched. The package with
+;; lowest score will get loaded. Another package, *base64.el*
+;; seems to be problematic too. But because Gnus path has lowest
+;; score, it will get loaded before w3's base64.el. This is good,
+;; because Gnus contains the latest version of *base64.el*. In
+;; the buffer `tinypath-report-mode' is turned on to manipulate
+;; reported lines. Unnecessary files can be deleted with
+;; `Control-shift-mouse-1' or `C-c' `C-d'.
+;;
+;; Symlinked directories are ignored
+;;
+;; TODO: Later version might support symlinks. Rethinking this over.
+;;
+;; It has been the tradition to use symlinks a lot in Unix to
+;; arrange easy access to versioned packages. Like how to
+;; ~/elisp/gnus/ no matter what version is currently installed.
+;;
+;; ln -s ~/elisp/packages/gnus-N.NN ~/elisp/packages/gnus
+;;
+;; This package however *skips* those symlinks and records the
+;; absolute path name to the `load-path'. There are couple of
+;; points: a) it is more instructive to peek the `load-path' to
+;; actually see what versions have been installed to the Emacs b)
+;; The symlinks are error prone since there may be several
+;; symlinks that lead to same directory and c) symlinks may not
+;; work well in heterogenous environments where Win32 and Linux
+;; and Unix hosts are networked together. To migrate to this
+;; package you need to examine your symlinks and remove them.
+;;
+;; If you have drawn a symlink to the the current directory from
+;; *SEPARATE* directory, then that directory will never be seen:
+;;
+;; ln -s ~/some-disk/elisp/artist-1.1/ ~/elisp/packages/artist-1.1
+;;
+;; To solve this, instead either _a)_ move the package physically
+;; under the ~/elisp/ from the *~/some-disk/elisp/* so that the
+;; recursive search will record it or _b)_ add the separate
+;; directory *~/some-disk/elisp* to the variable
+;; `tinypath-:load-path-root'.
+;;
+;; Using cache
+;;
+;; Now when you're freed from update burden of the directories in your
+;; disk, you can concentrate organizing the files under sensible
+;; directories. Here is an example how the organizing could go:
+;;
+;; ~/elisp/users/kevinr/ Kevin Rodger's files
+;; ~/elisp/users/ilya/ Ilya Zakharevich's files
+;; ..
+;; ~/elisp/packages/bbdb-2.00.06/ Version-ed packages
+;; ~/elisp/packages/psgml-1.0.3/
+;; ~/elisp/packages/pcl-cvs-2.9.2/
+;; ~/elisp/packages/tiny-19990215/
+;; ...
+;; ~/elisp/other/ All single add-on packages
+;;
+;; All these paths in `load-path' and you can imagine how slow a
+;; standard Emacs would become: it takes even more time to find some
+;; package xxx, when Emacs sees a call (require 'xxx), because Emacs
+;; must start looking into every single directory under `load-path'
+;; until it can determine if it can or cannot load the asked package.
+;; This utility will store all lisp files in cache, and it is
+;; activated by default. The variable `tinypath-:cache-expiry-days'
+;; controls the interval when it is concluded that a new tree
+;; recursion is needed. If you install new packages during those
+;; non-expiry days, it is best to call `C-u' `M-x'
+;; `tinypath-cache-regenerate' to build up to date image of your files
+;; and `load-path' directories.
+;;
+;; If you want one short advice: always call `tinypath-cache-regenerate'
+;; after any lisp file or directory update.
+;;
+;; Cache file and different Emacs versions
+;;
+;; It is important that each Emacs loads correct cache file. The cache
+;; file's name is derived from the emacs version and emacs type, which
+;; can be "xemacs", "win32-xemacs", "emacs" or "win32-emacs".
+;;
+;; tinypath-:cache-file-prefix
+;; + EMACS-TYPE
+;; + HOST
+;; + EMACS-VERSION
+;; + tinypath-:cache-file-postfix
+;;
+;; ~/elisp/config/emacs-config-tinypath-cache-win32-HOST-emacs-20.4.1.el.gz
+;; ========================================== ======
+;; prefix postfix
+;;
+;; Unix hosts and NFS mounts
+;;
+;; In Unix environment, it is also common that several hosts are
+;; NFS mounted so that the home disk is available from every
+;; server. The programs could also be NFS mounted, but many times
+;; programs are stored locally on each server's own disks. Now,
+;; there would be a problem if you logged to host *A* and started
+;; tinypath.el which had made cache in host *B*, because *A* does
+;; not have the same directories as *B* did (site-lisp). This has
+;; been taken care of by including _hostname_ part in the cache
+;; file name. For each host, a separate cache file is
+;; created. Now, suppose all the Unix hosts are same brand, say
+;; Sun OS, Linux, or HP-UX and a good administrator has separated
+;; the programs and the data in their own directory
+;; structures. Furthermore, these directories are NFS mounted and
+;; thus visible to the remote machines. In this scenario, it
+;; would not really matter to which host you log into, because
+;; you would always see the same programs and site-lisp
+;; directories and there would not be need for host specific
+;; cache files. In that case, it is possible to disable the
+;; *HOST* word by setting with:
+;;
+;; (setq tinypath-:cache-file-hostname-function nil)
+;;
+;; Info file support
+;;
+;; In addition to updating the `load-path', the recursive function
+;; has a chance to search for installed info files as well. When you
+;; keep all your site lisp under one directory, it is not uncommon
+;; that the bigger packages include documentation files in info format
+;; as well. Like:
+;;
+;; /usr/share/site-lisp/emacs/pcl-cvs-2.9.9/
+;; /usr/share/site-lisp/common/packages/psgml-1.2.1/
+;;
+;; One possibility is that after you download and uncompress a
+;; package, you copy the info file to some central directory
+;; where you keep all you info files. This is lot of manual work.
+;; (Never mind that in Unix you might use Makefile to install
+;; everything, in Win32 it's all manual work). This package does the
+;; same job by looking for directories that either have info files or
+;; a central info repository called `dir'. If the `dir' file
+;; has all the info files up to date, nothing is done. In other cases:
+;;
+;; o If the central `dir' in the directory does not exits,
+;; it is created.
+;; o If `dir' does not contain entry for info file, it is added.
+;; The entry name is derived from the filename.
+;;
+;; The `Info-default-directory-list' is updated to include any new
+;; directory locations and they are saved to same cache file. When you
+;; call `C-h' `i' you will see the new info entries. Easy and
+;; maintenance friendly. No need to worry about supplied info files any
+;; more, they are automatically integrated to your Emacs. If you have
+;; installed any new packages to your system, Emacs packages or Unix
+;; packages that installed something with "install -c", it is best to
+;; update your info files with `M-x'
+;; `tinypath-info-scan-Info-default-directory-list'. This is also
+;; called if you call: `C-u' `M-x' `tinypath-cache-regenerate'
+;;
+;; Cygwin support (Win32 and woman.el)
+;;
+;; It is common that Emacs in Win32 environment is coupled with
+;; <http://www.cygwin.com> toolkit which contains all the manual pages
+;; for the unix commands and possibly new info pages. This package
+;; will locate `cygwin1.dll' file along PATH and recurse whole cygwin
+;; installation root to find new entries that can be used inside
+;; Emacs. In theory this all should happen automatically and the only
+;; thing you have to do is to ensure that you have proper PATH
+;; settings at your OS level before this package is started. If Cygwin
+;; /bin directory in in PATH, `tinypath-:extra-path-root' will get set
+;; to a correct value at boot time.
+;;
+;; If you have more places where you keep Unix tools which contain
+;; more manual or info pages, like Reed Kotler (old Unix-like env)
+;; http://www.reedkotler.com/ you _must_ manually set variable
+;; `tinypath-:extra-path-root' to the list of search root directories.
+;; If you set this yourself, you _must_ also include the cygwin
+;; installation root directory
+;;
+;; (setq tinypath-:extra-path-root
+;; '("e:/unix-root/cygwin"
+;; "e:/unix-root/reed-kotler"
+;; ...))
+;;
+;; Package *woman.el* will be configured automatically if it is along
+;; `load-path' to handle manual page viewing with command `M-x'
+;; `man'. Please make sure that you do not destroy the pre-defined
+;; `woman-manpath' in your Emacs startup files with lisp commands or
+;; the efforts to find out new manual pages are thrown off the window.
+;; Search you startup files for anything that looks like `setq',
+;; `defvar', `defconst': (setq woman-manpath ... and change the code
+;; to _add_ to the variable instead:
+;;
+;; (require 'cl)
+;; (dolist (path '("one" "two" "three"))
+;; (pushnew (expand-file-name path) woman-manpath :test 'string))
+;;
+;; Faster Emacs configuration (Perl emacs-util.pl)
+;;
+;; Indication of this feature at startup is a message, where
+;; EXT refers to externally launched process. It must be waited
+;; until further processing is done; i.e. Emacs is hung for a while.
+;;
+;; TinyPath: EXT Process running ... [may take a while]
+;;
+;; As this package evolved and more support was added to various
+;; environments, like Cygwin, which required traversing hundred of
+;; directories to find out if they contained info or manual pages,
+;; it came evident that Emacs Lisp method was too slow. An alternative
+;; method was developed using Perl language and written in *emacs-util.pl*
+;; which can traverse directory hierarchies to find relevant
+;; directories for the setup. This interface is automatically used
+;; if two conditions are met in current environment:
+;;
+;; o Binary *perl* must be along PATH. (according `executable-find')
+;; o perl script *emacs-util.pl* must be along PATH. Either copy
+;; the file to suitable place or include Tiny Tool's `/bin'
+;; directory to your PATH.
+;;
+;; If all goes well, a `call-process' to the utility script will
+;; return the file hierarchies much faster than the Emacs Lisp ever
+;; could. The difference is that you don't see the traversing progress
+;; as you would if Emacs Lisp did the same thing. The command line
+;; arguments passed to the utility scripts can be found from the
+;; *Message* buffer and you can run the program yourself if you think
+;; that it returns incorrect listing. Print the script help with
+;; following command:
+;;
+;; % perl emacs-util.pl --help
+;;
+;; Here are some performance statistics of the perl script in action.
+;; (Use --verbose argument to see the statistics)
+;;
+;; o Intel 400MHz, IBM GXP 80G IDE/ATA 100 disk, whole Cygwin
+;; installation scan: 3 min 46 sec, dirs: 2373, files: 35 271
+;; o Same PC, but this time site-lisp directory, subset of Cygwin
+;; hierarchy at /usr/share/site-lisp took:
+;; 0 min 13 sec, dirs: 648, files: 8750
+;;
+;; Let's consider one scenario that you may encounter if you intend to
+;; use Cygwin similarly as the big brother Linux. Let's suppose that
+;; you have dedicated a disk portion where you intend to duplicate
+;; whole Linux-like directory hierarchy. You have ROOT under which you
+;; keep all the files, including anything that is Cygwin-related.
+;;
+;; E:/usr/share/site-lisp Emacs lisp as outlined earlier
+;; E:/usr/share/site-perl Perl packages and scripts
+;; E:/usr/share/site-php PHP code
+;; E:/usr/share/site-cvs Various other external CVS C-packages
+;;
+;; The default heuristics `tinypath-ti::win32-cygwin-p' should find
+;; *cygwin1.dll* installed and report that Cygwin root is *E:/*
+;; This means that `tinypath-:extra-path-root' will get set for
+;; you when package loads. Suppose further that you have set
+;; variable `tinypath-:load-path-root' to point out suitable
+;; locations in *E:/usr/share/site-lisp*. It would seem
+;; that this combination means that the hierarchies would be
+;; traversed multiple times, since the Cygwin root already
+;; includes all the rest:
+;;
+;; E:/ Cygwin root
+;; E:/usr/share/site-lisp/emacs For this emacs...
+;; E:/usr/share/site-lisp/common Emacs and XEmacs compatible tree
+;;
+;; Don't worry. The Perl utility is smart enough to reduce this
+;; to search only *E:/* and discard other roots as redundant. Hm,
+;; what if other lisp files are found _outside_ of the
+;; *E:/usr/share/site-lisp/*, because it searches every dir
+;; starting from *E:/* Say:
+;;
+;; E:/tmp/try/some-file.el
+;;
+;; Will the directory *E:/tmp/try/* reported as lisp `load-path'
+;; candidate and added to search list? Yes and no. Yes, it will be
+;; reported, but no, it will not be added to the `load-path' because it
+;; doesn't match the initial user's idea where to look for lisp files. If
+;; you pump up the `tinypath-:verbose' to level 5, you can see PATH-NOK
+;; messages labeled "candidate" to indicate those rejections. Only files
+;; that reside under `tinypath-:load-path-root' directories are counted
+;; in.
+;;
+;; Updating running Emacs
+;;
+;; Suppose you have downloaded the latest versions of packages X, Y and Z
+;; and you want your current emacs's paths updated, call this function:
+;;
+;; M-x tinypath-cache-regenerate
+;;
+;; Take a bit of skepticism: It is a fortunate event if it all
+;; worked that easily. You see, you already have several packages
+;; loaded in your Emacs and they are using the "old" code. Now
+;; you wiped the old directories away and told Emacs to look for
+;; only "new" directories. After a while you may run into
+;; bizarre dependency problems. I recommend that after any major
+;; package update, which contains _several_ of files (like Gnus),
+;; you:
+;;
+;; o Install package and regenerate cache in current Emacs session
+;; with `M-x' `tinypach-cache-regenerate'.
+;; o Save your current Emacs buffers (see *desktop.el*, *tinydesk.el*)
+;; o Quit, restart Emacs and restore your working desktop.
+;;
+;; Compressed lisp file support
+;;
+;; In order to use the full compression support for autoload
+;; functions as well, set variable
+;; `tinypath-:compression-support' to symbol `all'. The normal
+;; value for compression is 'default which support handling
+;; `require' and `load' commands. The variable must be set before
+;; package is loaded.
+;;
+;; About Jka-compr package
+;;
+;; jka-compr.el has native support to un/compress any file that
+;; have specific extensions. The handling is done via
+;; `file-name-handler-alist' and commands like these will load
+;; properly including any autoloads.
+;;
+;; (load "my-el.gz")
+;;
+;; The problem is that the load statements have to be manually
+;; changed so that they end in .gz so that jka-compr takes care
+;; of loading. What if the file is later uncompressed? Again all
+;; the load commands must be updated. This isn't very nice, since
+;; it should be able to un/compress elisp files and still have
+;; permanent load statements. Basically this is what the
+;; compression support here is all about; there is no need to
+;; worry if the file is compressed or not when advised functions
+;; are in effect. The following statement will work for both file
+;; types:
+;;
+;; (load "my-el")
+;;
+;; How the compressed loading works
+;;
+;; o When user request `load' FILE, try to find some compressed file
+;; that JKA knows about by adding extensions ".gz" and ".Z" and
+;; whatever user has configured JKA to handle. _LIMITATION:_
+;; only .gz .bz2 and the like that compress one file at a time
+;; is currently supported. Don't try using .zip or similar.
+;; o If the FILE is absolute path, then look from that
+;; directory only.
+;; o If no directory is given, find the file along the `load-path'.
+;; o If there was somewhere a compressed file, just load it (because JKA
+;; will transparently uncompress it), eval it, and kill the buffer.
+;; o If NO COMPRESSED file was found, just follow normal
+;; emacs rules.
+;;
+;; Note: Why you should not prefer compressed .elc files
+;;
+;; The purpose of compression support is to make it possible to
+;; have more useful lisp files in an account that has a limited
+;; disk space (quota). Many Unicersity student accounts have this
+;; limitation. Keeping lisp files in compressed format
+;; saves quite a much disk space.
+;;
+;; o Plain text, lisp `.el', files compress better.
+;; o The documentation in comments is important, e.g all the
+;; instruction to use the file are there. Byte compiling
+;; strips away documentation.
+;; o In order to debug or send bug reports you need .el files.
+;; The errors from .elc files are useless.
+;; o The performance ratio that the .elc files offer may not
+;; be a crucial factor (many times you couldn't tell).
+;;
+;; Note: advised emacs commands
+;;
+;; The adviced functions can be further adviced, but
+;; if the redefined function uses `interactive-p' test, it will
+;; not indicate user call (like M-x load-library). The reason why
+;; the advised functions detect it, is that advice.el's
+;; `ad-do-it' macro cannot pass the interactive flag information
+;; to the original functions.
+;;
+;; Trouble shooting
+;;
+;; There is no denying it, this package is potentionally
+;; dangerous. When something goes wrong, it really goes wrong and
+;; your Emacs may be messed up completely. So, here are some
+;; trouble shooting tips, that you might want to try to rescue
+;; the situation or understand what is going on. The most usual
+;; blame is the *cache* content which does not contain the
+;; correct or up to date information.
+;;
+;; Package is not found or loaded?
+;;
+;; Please confirm that the file location is known and is in right
+;; directory by calling `M-x' `locate-library'. If the result is
+;; not correct, please check `tinypath-:load-path-root' and
+;; `tinypath-:extra-path-root'. Try to remedy the situation,
+;; regenerate cache with `C-u' `M-x' `tinypath-cache-regenerate'.
+;;
+;; You don't know what particular package is causing troubles
+;;
+;; Go to the *Message* buffer and clear it (`C-x' `h' followed by
+;; `C-w'). Run the path generation engine with debug `M-x'
+;; `tinypath-debug-external-helper' and study the output. It may
+;; be ignoring some files that you think should be included. Please
+;; check content of `tinypath-:load-path-ignore-regexp' and
+;; `tinypath-:load-path-ignore-regexp-extra'.
+;;
+;; You need to see the internals
+;;
+;; Call function `tinypath-cache-file-find-file' to display the current
+;; cache and use `C-s' and `C-r' to search entries in the file. Remember
+;; that you must not modify this file, because any changes you do, will
+;; get overwritten next time the cache is regenerated. The problem is
+;; somewhere else if you can see incorrect items in the cache file.
+;;
+;; Code note: General
+;;
+;; Because this package is among the first that is loaded from Emacs
+;; startup file, It contains copies of some functions from TinyLib
+;; libraries, to make the package independent until the point where
+;; the `load-path' has been set up and other libraries are available.
+;; In the code you may find marks "#copy:" which indicate code that
+;; has been copied/simplified to be used here. Autoload statements in
+;; this package defer loading functions until the end is reached and
+;; `load-path' is determined and the rest of the functions can be
+;; loaded from the libraries.
+;;
+;; Code note: Where is that emacs package
+;;
+;; If you ever need to know the location of a package that Emacs
+;; would load or has loaded, while this utility is in effect,
+;; use this call:
+;;
+;; (insert (tinypath-cache-p "gnus.el"))
+;;
+;; In fact the regular call yields same result, because
+;; `locate-library' is adviced:
+;;
+;; (insert (locate-library "gnus.el"))
+;;
+;; More easily, with *tinylisp.el*, which takes advantage of
+;; tinypath.el cache, you can load any emacs package for editing
+;; with command:
+;;
+;; M-x load-library RET tinylisp RET
+;; M-x tinylisp-library-find-file
+;; (tinypath cache)Lisp Library: gnus.el RET
+;;
+;; Alternatively there is mode hot-keys $ l f and $ l p :
+;;
+;; M-x load-library RET tinylisp RET
+;; M-x tinylisp-install
+;; M-x tinylisp-mode (in *scratch* buffer, see "E" in modeline)
+;; $ l f
+;; (tinypath cache)Lisp Library: gnus.el RET
+;;
+;; Code note: Internal optimizations
+;;
+;; In the installation section it is instructed that the location of the
+;; package is pushed into the `load-path' before the package is loaded:
+;;
+;; (require 'cl)
+;; (pushnew "~/elisp/tiny/lisp/tiny" load-path :test 'string=)
+;; (load "tinypath.el")
+;;
+;; Please follow this instruction. The reason is that program
+;; tries to use most efficient code to boot everything up and the
+;; first thing it does is to check the location where it has been
+;; saved. This package will use this information to assume that
+;; the Perl program is available somewhere near that that path
+;; (../../bin). If that fails, the Perl program is searched along
+;; `exec-path'. This is usually desirable, situation because
+;; every new installation includes newer version of Perl program
+;; and the one at `exec-path' may not be up to date. The perl
+;; code will speed up booting compared to pure Emacs Lisp
+;; implementation. In addition the Perl code section in this file
+;; (often referred as "external") has extra features included.
+;;
+;; Code note: *Messages*
+;;
+;; This package will print loads of messages to Emacs "*Message*" or
+;; XEmacs " *Message-Log*" buffer. This is a design decisions so that
+;; execution can be easily traced during Emacs load time. It also help
+;; reporting errors. The default `tinypath-:verbose' 3 will log the most
+;; important messages. Even if you set the level to 0 or nil, still
+;; some messages are displayed. Have a look at Message buffer if you have
+;; not much used it before. You may find interesting information to
+;; debug some of your own mis-configurations, like stale directories
+;; in `exec-path'.
+;;
+;; Code note: Custom
+;;
+;; If you have very old Emacs that does not contain *custom.elc*
+;; (Yes, it must be in compiled format, be sure to check), you
+;; can download Noah Friedman's excellent custom emulation
+;; package *cust-stub.el* at
+;; http://www.splode.com/~friedman/software/emacs-lisp/ You have
+;; to load it from absolute location before loading this packages
+;; like this:
+;;
+;; (load "~/elisp/noah/cust-stub")
+;; (load "tinypath")
+;;
+;; Code note: Insinuating packages
+;;
+;; Some packages can be auto-configured when the perl script
+;; reads the contents of the directories. Like package *woman.el*
+;; which needs to know the location of man path directories. For
+;; other packages there are different "installations". Gnus is
+;; one interesting example: Every Emacs and XEmacs release comes
+;; with Gnus version, which is usually outdated and many install
+;; Gnus privately. Multiple Gnus versions in the load paths is a
+;; problem and the wished situation is that there would be only
+;; the latest. Program's logic tries to find out which of the
+;; Gnus packages along `load-path' is the latest and hopefully
+;; after making the right decision (according to gnus-version-*
+;; variable) the other Gnus locations are hidden by modifying
+;; `load-path' and `tinypath-:load-path-ignore-regexp'. This is a
+;; complimentary method to that suggested in this manual section's
+;; topic "3rd party packages".
+;;
+;; Code note: Elp profiling results
+;;
+;; The profiling results were run using method below. It must be note,
+;; that the `tinypath-external-*' is the time when the external perl
+;; program examines all the directories, so EXT time is not significant
+;; because it varies from system to system. The
+;; `tinypath-external-setup-parse-data' is the actual time spent in
+;; parsing the returned data. The functions that are called most of the
+;; time are the ones that must be kept on eye on and they seem to
+;; perform very well. Immediate below are the most important functions
+;; that perform the Parsing after the perl has returned results (these
+;; are not from the total listing, but after tweaking). The listing
+;; below represents timing results somewhere around 2001:
+;;
+;; tinypath-external-output-parse 1 4.89 4.89
+;; tinypath-external-output-parse-1 5 1.09 0.21
+;; tinypath-external-output-parse-1-cache 1 3.79 3.79
+;;
+;;
+;; tinypath-external-setup-parse-data 1 5.77 5.77
+;; tinypath-external-setup-1-load-path 249 0.70 0.002
+;; tinypath-external-setup-1-man-path 44 0.0 0.0
+;; tinypath-exec-path-append 73 0.92 0.012
+;; tinypath-info-handler 31 8.46 0.27
+;; tinypath-external-setup-cache 1 0.0 0.0
+;;
+;; These timing results was taken 2003-05-18 running Cygwin
+;; XEmacs 21.4.10, Pentium 400 Mhz. These profiling results are
+;; from the initial boot phase, before cache is loaded. It's
+;; pretty fast.
+;;
+;; (setq tinypath-:install-flag nil)
+;; (load "elp"
+;; (load "tinypath")
+;; (elp-instrument-package "tinypath-")
+;;
+;; ;; Now run the boot phase ONLY
+;; (tinypath-load-path-initial-value
+;; tinypath-:core-emacs-load-path-list)
+;;
+;; Function Name Count Elap Ave
+;; =============================================== ===== ===== ===
+;; tinypath-load-path-initial-value 1 0.477 0.47
+;; tinypath-load-path-add-subdirs 1 0.463 0.46
+;; tinypath-directory-subdirs 1 0.451 0.45
+;; tinypath-emacs-root-directory 1 0.008 0.00
+;; tinypath-emacs-root-by-load-path 1 0.008 0.00
+;; tinypath-emacs-core-path-p 119 0.004 3.36
+;; tinypath-expand-file-name 5 0.001 0.00
+;; tinypath-load-path-initial-value-xemacs 1 0.001 0.00
+;; tinypath-load-path-string-match 1 0.001 0.00
+;; tinypath-win32-p 5 0.0 0.0
+;; tinypath-emacs-versions 1 0.0 0.0
+;;
+;; Theses timing results was taken 2003-05-18 running Cygwin
+;; XEmacs 21.4.10, Pentium 400 Mhz. The cache with 4500
+;; directories was loaded from configuration file. In this case
+;; `tinypath-:cache-file-postfix' value was '.el'. The timing
+;; information was tested and generated with:
+;;
+;; o `C-x' `C-f' tinypath.el RET -- toad read tinypath.el to Emacs
+;; o `M-x' `load-library' RET tinylisp.el RET
+;; o `M-x' `turn-on-tinylisp-mode' RET
+;; o $ - to eval current buffer
+;; o $ e I to instrument everything (Wtih empty value, scan buffer)
+;; o `M-x' `tinypath-cache-regenerate' RET
+;; o $ e s to show results
+;;
+;;
+;; Function Name Count Elap Ave
+;; =============================================== ===== ===== ===
+;; tinypath-install 1 6.812 6.81
+;; tinypath-cache-setup-main 1 5.76 5.76
+;; tinypath-setup 1 5.76 5.76
+;; tinypath-directory-list-clean 7 3.756 0.53
+;; tinypath-cache-file-load 1 2.552 2.55
+;; tinypath-load-path-clean 1 2.272 2.27
+;; tinypath-cache-file-need-sync-p 1 1.932 1.93
+;; tinypath-load-path-not-in-synch-p 1 1.932 1.93
+;; tinypath-exec-path-clean 2 0.679 0.34
+;; tinypath-exec-path-check-verbose 2 0.597 0.298
+;; tinypath-exec-path-check 2 0.594 0.297
+;; tinypath-load-path-merge 1 0.364 0.364
+;; tinypath-Info-default-directory-list-clean 1 0.218 0.218
+;; tinypath-file-remove-trailing-slash 825 0.121 0.000
+;; tinypath-cache-mode 1 0.082 0.082
+;; turn-on-tinypath-cache-mode 1 0.082 0.082
+;; turn-on-tinypath-cache-mode-maybe 1 0.082 0.082
+;; tinypath-ti::advice-control 1 0.081 0.081
+;; tinypath-install-timer 1 0.007 0.007
+;; tinypath-cache-file-name 2 0.006 0.003
+;; tinypath-exec-path-from-path 2 0.006 0.003
+;; tinypath-ti::compat-timer-cancel-function 1 0.005 0.005
+;; tinypath-ti::compat-timer-elt 2 0.004 0.002
+;; tinypath-cache-warn-if-not-exist 1 0.004 0.004
+;; tinypath-cache-file-old-p 1 0.004 0.004
+;; tinypath-days-old 1 0.002 0.002
+;; tinypath-cache-status-string 2 0.002 0.001
+;; tinypath-cache-status-message 1 0.002 0.002
+;; tinypath-advice-instantiate 1 0.002 0.002
+;; tinypath-expand-file-name 3 0.001 0.000
+;; tinypath-ti::compat-timer-cancel 1 0.001 0.001
+;; tinypath-use-compression-maybe 2 0.001 0.0005
+;; tinypath-exec-path-append 1 0.001 0.001
+;; tinypath-win32-p 6 0.0 0.0
+;; tinypath-emacs-versions 2 0.0 0.0
+;; tinypath-ti::date-time-difference 1 0.0 0.0
+;; tinypath-eval-after-load 1 0.0 0.0
+;; tinypath-time-string 2 0.0 0.0
+;; tinypath-file-compressed-p 2 0.0 0.0
+;; tinypath-emacs-lisp-file-list-cache-clear 1 0.0 0.0
+;; tinypath-autoload-file-name 1 0.0 0.0
+;; tinypath-autoload-require 1 0.0 0.0
+;; tinypath-cache-p 1 0.0 0.0
+;; tinypath-cache-file-hostname 2 0.0 0.0
+;; tinypath-load-path-root-changed-p 1 0.0 0.0
+;;
+;; Same timing test as above, but now using compiled cache file at
+;; Emacs startup. In this case `tinypath-:cache-file-postfix' value was
+;; '.elc'. The speedup is 50%, reducing the load time to mere 3-4
+;; seconds. Notice the dramatic change in `tinypath-cache-file-load':
+;; 0.5 seconds vs. 2.5 seconds non-compiled.
+;;
+;; Function Name Count Elap Ave
+;; =============================================== ===== ===== ===
+;; tinypath-install 1 3.305 3.30
+;; tinypath-cache-setup-main 1 2.017 2.01
+;; tinypath-setup 1 2.017 2.01
+;; tinypath-directory-list-clean 7 1.608 0.22
+;; tinypath-load-path-clean 1 0.904 0.90
+;; tinypath-advice-instantiate 1 0.784 0.78
+;; tinypath-cache-file-load 1 0.549 0.54
+;; tinypath-exec-path-check 2 0.506 0.25
+;; tinypath-exec-path-check-verbose 2 0.506 0.25
+;; tinypath-load-path-not-in-synch-p 1 0.368 0.36
+;; tinypath-cache-file-need-sync-p 1 0.368 0.36
+;; tinypath-exec-path-clean 2 0.326 0.16
+;; tinypath-exec-path-from-path 2 0.154 0.07
+;;
+;; Thoughts
+;;
+;; o In theory it is possible to load remote files with ange-ftp/EFS in
+;; manner of `load-library' RET /user@host:/path/to/file but that
+;; has never been tested.
+;; o It theory it would be possible to add /user@host:/path/to/dir/
+;; to `load-path', but that has never been tested.
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+;;{{{ Require (a)
+
+;;; ......................................................... &require ...
+
+;; While loading this package XEmacs garbage collects like mad.
+;; Ease it up for a while. These values are restored at the end.
+
+(unless (get 'gc-cons-threshold 'tinypath-initial)
+ (put 'gc-cons-threshold 'tinypath-initial gc-cons-threshold))
+
+(put 'gc-cons-threshold 'tinypath gc-cons-threshold)
+(setq gc-cons-threshold (* 1024 1024 10))
+
+;; Why the provide is at the start of file?
+;; Because XEmacs does not record `load-history' entry unless it sees
+;; `provide' statement. There is a check for SELF LOCATION by looking at
+;; the `load-history' in this package
+
+(provide 'tinypath)
+
+(eval-and-compile
+
+ (require 'cl)
+
+ (when (string-match "21.3" (emacs-version))
+ ;; `dolist' is broken in Emacs 21.3 subr.el. Force loading
+ ;; it first, then wipe it with cl-macs.el. This way there
+ ;; is no chance that subr.el would be loaded ever again
+ ;; by some package
+ (load "cl-macs"))
+
+ ;; These variables must be here in order to Byte compiler to see them
+ ;; before they are used.
+
+ (defcustom tinypath-:verbose-info-messages nil
+ "*If non-nil, notify missing environment variables like USER.
+This variable is meant for Win32 environment, where Unix style
+USER and LOGNAME variables are not defined by default.")
+
+ (defvar tinypath-:boot-ignore-directory-regexp
+ ;; #todo: /usr/share/emacs/21.3/lisp/obsolete
+ "\\(CVS\\|RCS\\|info\\|texi\\|\\.svn\\|/MT\\)/?$"
+ "While searching lisp boot subdirs, ignore those that match this regexp.
+Popular version control directories are excluded by default.")
+
+ ;; #todo: Mysterious byte compile bug:
+ ;; Remove all cache files, compile tinypath, launch emacs.
+ ;; => Dies with a message of: "function member* not found".
+
+ (unless (fboundp 'member*)
+ (autoload 'member* "cl-seq"))
+
+ (defconst tinypath-:xemacs-p
+ (or (boundp 'xemacs-logo)
+ (featurep 'xemacs)
+ (string-match "XEmacs" (emacs-version)))
+ "Non-nil if running XEmacs.")
+
+ ;; Mostly for Win32 environment checks
+ (defvar tinypath-:startup-no-messages t
+ "*If non-nil, do not display error message buffer at startup.
+You should set this to `nil' if you begin to use this package first
+time to see messages that may need attention. Alternatively, check
+message buffer.")
+
+ (defvar font-lock-mode) ;; Byte compiler silencers
+ (defvar lazy-lock-mode)
+ (defvar dired-directory)
+
+ (autoload 'ti::macrof-version-bug-report "tinylib" "" nil 'macro)
+
+ (autoload 'pp "pp")
+ (autoload 'assq "assoc")
+ (autoload 'aput "assoc")
+ (autoload 'executable-find "executable")
+
+ ;; Quiet byte compiler. These are checked with `boundp' in the code
+
+ (defvar Info-default-directory-list)
+ (defvar Info-dir-file-attributes)
+ (defvar woman-manpath)
+ (defvar Info-directory-list)
+
+ ;; See find-file.el
+ (defvar ff-search-directories)
+
+ ;; This is just forward declaration for byte compiler
+ ;; It it not sensible to lift `defcustom' definition apart from
+ ;; to the beginning of file due to macros and all which refer to it.
+ ;; => This is a user variable and defcustom should stay in user section.
+ (defvar tinypath-:verbose 3
+ "*Verbosity level"))
+
+(eval-when-compile
+ (require 'advice))
+
+;;}}}
+;;{{{ Environment
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; Basic Environment check and definitions
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defvar tinypath-:win32-p
+ (cond
+ ((memq system-type '(ms-dos windows-nt))) ;; Emacs
+ ((fboundp 'console-type) ;; XEmacs
+ ;; Quiet Emacs byte compiler
+ (memq (funcall (symbol-function 'console-type))
+ '(win32 w32 mswindows)))
+ ((boundp 'window-system)
+ (memq (symbol-value 'window-system) '(win32 w32 mswindows)))
+ (t
+ (message "TinyPath: Internal win32-p check alert, contact maintainer.")
+ nil))
+ "The value is non-nil under Win32 operating system.")
+
+(defvar tinypath-:win32-cygwin-p
+ (and tinypath-:win32-p
+ (let ((case-fold-search t))
+ (string-match "cygwin" (emacs-version))))
+ "The value is non-nil if running under Win32 Cygwin Emacs.")
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-tmp-message (msg)
+ "Print messages to user."
+ (let ((buffer (get-buffer-create "*tinypath.el ERROR*")))
+ (with-current-buffer buffer
+ (goto-char (point-min))
+ (insert msg) ;; Insert message first
+ ;; Make a record to *Messages* buffer as well.
+ (message msg)
+ (unless tinypath-:startup-no-messages
+ (pop-to-buffer buffer)))))
+
+;;; ----------------------------------------------------------------------
+;;; #copy from tinyliba.el
+(defun tinypath-win32-p ()
+ "Check if running under Win32 system."
+ (cond
+ ((memq system-type '(ms-dos windows-nt))) ;; Emacs
+ ((fboundp 'console-type) ;; XEmacs
+ ;; Quiet Emacs byte compiler
+ (memq (funcall (symbol-function 'console-type))
+ '(win32 w32 mswindows)))
+ ((boundp 'window-system)
+ (memq (symbol-value 'window-system) '(win32 w32 mswindows)))
+ ((error "TinyPath: Internal win32-p check alert, contact maintainer."))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-install-environment-home ()
+ "Check environment: HOME."
+ (when (or (not (getenv "HOME"))
+ (not (file-directory-p (getenv "HOME"))))
+ (tinypath-tmp-message
+ (concat
+ "\
+** TinyPath.el: [ERROR] HOME variable error set.
+
+ The variable is either a) not set or b) it points to invalid directory.
+
+ An environment variable named HOME must be set so that Emacs knows where to
+ read initialization file like $HOME/.emacs. The HOME variable is crucial
+ to Emacs functioning and lot of packages depend on its existence.
+
+"
+ (cond
+ (tinypath-:win32-p
+ "")
+ (t
+ "\
+ Hm. This error should not happen under Unix/Linux system.
+ Please recheck your environment and contact your sysadm
+ to determine cause of this.")
+ (t
+ "\
+ In Windows Win95/98/NT: Add this statement to your c:\\AUTOEXEC.BAT file
+ and reboot the computer.
+
+ set HOME=C:\yourname
+
+ The `yourname' is a directory which you must create and it should not
+ contain spaces in the directory name.
+
+ In Windows ME/2000/etc You have to use Start=> Control-Panel=> System
+ icon, select `advanced' tab and button `environment' to alter the
+ values. Click `apply' and `ok' to make new settings effective.\n\n")))))
+ ;; Return value from function
+ (getenv "HOME"))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-install-environment-user ()
+ "Check environment: USER, USERNAME, LOGNAME."
+ (let* ((user (getenv "USER"))
+ (uname (getenv "USERNAME")) ;; W2k variable
+ (log (getenv "LOGNAME"))
+ unix-fix
+ win32-fix)
+ ;; In Unix, require that both LOGNAME and USER is correct
+ ;; Different shells and Unix/Linux systems do not define always
+ ;; both.
+ (cond
+ ((and user
+ (null log))
+ ;; After this, all is ok.
+ (setq unix-fix "LOGNAME")
+ (setenv "LOGNAME" user))
+ ((and log
+ (null user))
+ (setq unix-fix "USER")
+ (setenv "USER" user)))
+ (when (and uname
+ (null user))
+ (setq win32-fix "USER")
+ (setenv "USER" user))
+ ;; Read variables again; the above may have updated something
+ (setq user (getenv "USER")
+ uname (getenv "USERNAME")
+ log (getenv "LOGNAME"))
+
+ (when (and unix-fix
+ tinypath-:verbose-info-messages
+ (not tinypath-:win32-p))
+ (tinypath-tmp-message
+ (format
+ (concat
+ "\
+** TinyPath.el: [INFO] environment variable %s was `%s'
+
+ Hm. This error should not normally happen in Unix environment, but this
+ may be a bash(1) problem, which does not define USER by default.
+ Please check you environment by logging in from a fresh terminal. You
+ can correct it in your shell's startup file or inform System
+ Administrator of your site. Here is an example:
+
+ $HOME/.bashrc: export USER=$LOGNAME # If you have $LOGNAME
+ $HOME/.tcshrc: setenv USER foo")
+ unix-fix (getenv unix-fix))))
+ (when (and win32-fix
+ tinypath-:verbose-info-messages)
+ (tinypath-tmp-message
+ (format
+ (concat
+ "\
+** TinyPath.el: [INFO] environment variable %s set to `%s'
+
+ In this Windows ME/NT/2000 there was variable USERNAME which was copied
+ to USER. Note however, that this only sets Emacs environment, and does
+ not affect outside environment, so you're adviced to define these
+ variables permanetly through Start=> Control-Panel=>
+ SystemIcon/Environment tab/
+
+ If you want to set this locally to your Emacs, add following code
+ to your startup file at $HOME/.emacs
+
+ ;; \"username\" must contain no spaces. Max 8 characters
+ (setenv \"USER\" \"username\")
+
+ In Windows Win95/98/NT: Add this statement to your c:\\AUTOEXEC.BAT file
+ and reboot the computer.
+
+ set USER=johndoe
+ set LOGNAME=johndoe
+
+ The `johndoe' is a short, usually maximum of 8 characters, which must
+ not contain spaces. The value usually is the same as the HOME path's
+ last directory name.
+
+ In Windows ME/2000/etc use Start => Control-Panel => System and
+ select `advanced' tab and `environment' button to alter the values.
+ Fill in the values and click `ok' to activate new environment.\n\n")
+ win32-fix (getenv win32-fix))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-install-environment ()
+ "Check environment variables."
+ (tinypath-install-environment-home)
+ (tinypath-install-environment-user))
+
+;;}}}
+
+;;{{{ Load time functions and macros
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; This section must be before variable definitions.
+;; The functions must be available during the variable
+;; initializations, that's why `eval-and-compile' wrapping.
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; --++-- --++-- --++-- --++-- --++-- --++-- --++-- eval-and-compile --
+
+(eval-and-compile
+
+;;; ----------------------------------------------------------------------
+;;;
+ (defun tinypath-byte-compile-running-p ()
+ "Return non-nil if byte compiling file."
+ (string= (buffer-name) " *Compiler Input*"))
+
+;;; ----------------------------------------------------------------------
+;;; Only some values are recorded as messages to the *Messages* buffer
+;;; Showing the values possibly makes user think if he needs
+;;; to change the defaults.
+;;;
+ (put 'tinypath-set-default-value-macro 'lisp-indent-function 1)
+ (put 'tinypath-set-default-value-macro 'edebug-form-spec '(body))
+ (defmacro tinypath-set-default-value-macro (var &rest body)
+ "Print verbose messages when activating VAR and run BODY."
+ (`
+ (let* (val)
+ ;; This may call several functions.
+ (setq val (,@ body))
+ (unless (tinypath-byte-compile-running-p)
+ (message "TinyPath: Default value for `%s' ... %s"
+ (, var)
+ (prin1-to-string val)))
+ val)))
+
+;;; ----------------------------------------------------------------------
+;;;
+ (put 'tinypath-verbose-macro 'lisp-indent-function 1)
+ (defmacro tinypath-verbose-macro (level &rest body)
+ "When LEVEL is =< `tinypath-:verbose' run BODY."
+ (`
+ (when (and (numberp tinypath-:verbose)
+ (or (= (, level) tinypath-:verbose)
+ (< (, level) tinypath-:verbose)))
+ (,@ body)
+ (when (> tinypath-:verbose 19)
+ (tinypath-log-write)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+ (put 'tinypath-directory-sep-char-macro 'lisp-indent-function 0)
+ (defmacro tinypath-directory-sep-char-macro (&rest body)
+ "Emacs and XEmacs compatibility.
+In let, set `directory-sep-char' to / and run BODY."
+ (`
+ (let ((directory-sep-char ?/))
+ (if (null directory-sep-char) ;; Byte compiler silencer
+ (setq directory-sep-char nil))
+ (,@ body))))
+
+;;; ----------------------------------------------------------------------
+;;;
+ (defsubst tinypath-expand-file-name (path)
+ "Expand filenames and always use forward slashes."
+ (cond
+ ((and (not tinypath-:win32-p)
+ ;; Nothing to do
+ (string-match "^/" path)
+ (not (string-match "\.\." path))))
+ (t
+ (tinypath-directory-sep-char-macro
+ (setq path (expand-file-name path)))))
+ (if tinypath-:win32-p
+ (setq path (downcase path)))
+ path)
+
+;;; ----------------------------------------------------------------------
+;;;
+ (put 'tinypath-expand-file-name-variable-macro 'lisp-indent-function 0)
+ (defmacro tinypath-expand-file-name-variable-macro (var)
+ "Expand list of paths stored in VAR symbol."
+ (`
+ (let (list)
+ (dolist (path (, var))
+;;; (push (tinypath-expand-file-name path) list))
+ (setq list (cons path list)))
+ (setq (, var) (nreverse list)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+ (defun tinypath-message-bug (bug &optional die)
+ "Tell how to report BUG (string) and optionally DIE."
+ (let* ((msg
+ (substitute-command-keys
+ (concat
+ (format
+ "TinyPath: [ERROR] report bug with name [%s]"
+ bug)
+ "See also \\[tinypath-version]"))))
+ (if die
+ (error msg)
+ (message msg)
+ (sit-for 5))))
+
+;;; ----------------------------------------------------------------------
+;;;
+ (defun tinypath-directory-up (dir)
+ "Return precious DIR."
+ (setq dir (file-name-as-directory dir)) ;; Ensure trailing slash
+ (when (stringp dir)
+ (file-name-directory
+ ;; Delete trailing slash
+ (substring dir
+ 0
+ (1- (length dir))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+ (defun tinypath-directory-subdirs (dir)
+ "Return directories under DIR."
+ (let* (list)
+ (when (file-directory-p dir)
+ (dolist (elt (directory-files dir 'full))
+ (if (file-directory-p elt)
+;;; (push elt list)
+ (setq list (cons elt list)))))
+ list))
+
+;;; ----------------------------------------------------------------------
+;;; #copy: tinyliba.el
+;;;
+ (defun tinypath-ti::win32-cygwin-p (&optional use-cache)
+ "Return root if path to cygwin1.dll is found from `exec-path'.
+If USE-CACHE is non-nil, retrieve cached value."
+ (let (ret)
+ (cond
+ ((and use-cache
+ (get 'tinypath-ti::win32-cygwin-p 'cache-set))
+ (setq ret (get 'tinypath-ti::win32-cygwin-p 'cache-value)))
+ (t
+ (put 'tinypath-ti::win32-cygwin-p 'cache-set t)
+ (dolist (path exec-path)
+ (when (and (stringp path)
+ (file-exists-p
+ (concat
+ (file-name-as-directory path) "cygwin1.dll"))
+ (file-exists-p
+ (concat
+ (file-name-as-directory path) "cygpath.exe")))
+ ;; The root directory is one DIR up from bin/cygwin1.dll
+ ;;
+ ;; 1) Drop the trailing slash ../bin
+ ;; 2) Give one directory up ..
+ ;;
+ ;; We have to leave trailing slash, because the resulting
+ ;; directory may be in the worst case C:/
+ ;; (which is NOT recommended place for cygwin install)
+ ;;
+ (when (string-match "^\\(.*\\)[/\\]" path)
+ (setq path
+ (match-string 1 path))
+ (setq ret path)
+ ;; This is native Cygwin Emacs, not a Win32 version
+ ;; if path is empty: /bin => one up => ''
+ (when (string= ret "")
+ (setq ret "/"))
+ (put 'tinypath-ti::win32-cygwin-p 'cache-value ret)
+ (return))))))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;; Earlier XEmacs and Emacs `executable-find' functions are buggy
+;;; and do not find binaries correctly, so we use our own implemantation.
+;;;
+ (defun tinypath-executable-find (file)
+ "Find FILE along path. FILE must be absolute name with possible .exe
+Emacs `executable-find' tries various suffixes in Win32, but this
+function just looks if FILE exists along load path."
+ (let* (ret name)
+ (dolist (path exec-path)
+ (setq name (concat (file-name-as-directory path) file))
+ (when (and (not (file-directory-p name))
+ (file-exists-p name))
+ (setq ret (tinypath-expand-file-name name))
+ (return)))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+ (defun tinypath-executable-find-binary (file)
+ "Try finding binary: FILE or FILE.exe in win32."
+ (if tinypath-:win32-p
+ (tinypath-executable-find (concat file ".exe"))
+ (tinypath-executable-find file)))
+
+;;; ----------------------------------------------------------------------
+;;;
+ (defun tinypath-emacs-versions (&optional noerr cache)
+ "Return possible version numbers for current Emacs. NOERR.
+If CACHE is set, use cached value."
+ (interactive)
+ (if (and cache
+ (get 'tinypath-emacs-versions 'version))
+ (get 'tinypath-emacs-versions 'version)
+ (let* ((str (emacs-version))
+ ;; XEmacs beta has spaces in this variable. Just take
+ ;; the first word from it. There must be no spaces
+ ;; in filename returned from this function
+ ;;
+ ;; emacs-version: "21.2 (beta19) \"Shinjuku\" XEmacs Lucid"
+ (patch (progn
+ (cond
+ ((string-match "patch \\([0-9]+\\)" str)
+ (match-string 1 str))
+ ;; XEmacs 21.1 (beta23)
+ ((string-match "(beta\\([0-9]+\\))" str)
+ (match-string 1 str)))))
+ (major-version-x-x (progn
+ (string-match "[0-9]+\\.[.0-9]" str)
+ (match-string 0 str)))
+ (major-version (progn
+ (string-match "[0-9]+\\.[.0-9]+" str)
+ (match-string 0 str)))
+ (version (concat major-version ;; 20.6.1
+ (if patch
+ (concat "." patch)
+ "")))
+ ret)
+ (dolist (ver (list version major-version major-version-x-x))
+ (when ver
+ (pushnew ver ret :test 'string=)))
+ (when ret
+ (put 'tinypath-emacs-versions 'version ret))
+ (or ret
+ (and (null noerr)
+ (tinypath-message-bug "Can't parse `emacs-version'."))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+ (defun tinypath-emacs-root-by-other-methods ()
+ "Return ROOT of emacs installation directory."
+ (let* ((sym 'invocation-directory)
+ ;; Use `symbol-value' to compile cleanly in all
+ ;; Emacs and XEmacs versions. It just hides the variable form
+ ;; Byte compiler
+ (val (if (and (boundp sym)
+ (stringp (symbol-value sym)))
+ (symbol-value sym)))
+ (dir (and val
+ (file-directory-p val)
+ (file-name-as-directory val))))
+ (when dir
+ (tinypath-directory-up dir))))
+
+;;; ----------------------------------------------------------------------
+;;;
+ (defun tinypath-emacs-core-path-p (path &optional version)
+ "Test if PATH is core Emacs path. VERSION number can be found from path."
+ ;; PATH name must contain version for this emacs and subdirectory "lisp"
+ (and (if version
+ (string-match (regexp-quote version) path)
+ t)
+ ;; /usr/local/share/emacs/20.7/site-lisp
+ (string-match "[/\\]lisp" path)
+ (string-match (concat
+ ;; Win32 installs emacs-20.4
+ "^.*emacs-[0-9]+\\.+[0-9.-]+"
+ ;; Unix installs emacs/20.4
+ "\\|^.*emacs[/\\][0-9]+\\.+[0-9.-]+")
+ path)))
+
+;;; ----------------------------------------------------------------------
+;;;
+ (defun tinypath-emacs-root-by-load-path ()
+ "Return ROOT of emacs installation directory by reading `load-path'.
+Return:
+
+ '(matched-part original-path)."
+ (let* ((ver (car-safe (tinypath-emacs-versions 'noerr 'cache)))
+ ret)
+ (if (null ver)
+ (tinypath-message-bug "root-by-load-path")
+ (dolist (path load-path)
+ (when (and (stringp path)
+ (tinypath-emacs-core-path-p path ver))
+ (return
+ (setq ret (list
+ (match-string 0 path)
+ path))))))
+ (unless ret
+ ;; User has wiped the load-path information by accident,
+ ;; Try doing something about it.
+ ;;
+ ;; #todo: Should we restore part of the path from $EMACSLOADPATH ?
+ ;; --> I'm afraid not many set the variable at all
+ (let ((path (tinypath-emacs-root-by-other-methods)))
+ (if path
+ (setq ret (list path path)))))
+ (tinypath-verbose-macro 7
+ (message "TinyPath: EMACS ROOT %s" (or (car-safe ret) "<nil>")))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+ (defun tinypath-emacs-root-directory ()
+ "Return Emacs installation root directory."
+ (cond
+ ((and invocation-directory
+ ;; In Unix this is /usr/local/bin which is NOT the
+ ;; Emacs installatio place.
+ ;;
+ ;; In Win32 this is c:/.....emacs-21.3/bin/ which
+ ;; can be used
+ (file-directory-p (concat invocation-directory "../lisp")))
+ (tinypath-expand-file-name
+ (concat invocation-directory "../lisp")))
+ (t
+ (car-safe (tinypath-emacs-root-by-load-path)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+ (defun tinypath-load-path-string-match (regexp)
+ "Check if REGEXP is found form load path. Return first match."
+ (dolist (path load-path)
+ (when (and (stringp path)
+ (string-match regexp path))
+ (return path))))
+
+;;; ----------------------------------------------------------------------
+;;;
+ (defun tinypath-load-path-add-subdirs (root &optional verbose)
+ "Add all subdirectories of ROOT to `load-path' with VERBOSE message level.
+ROOT can be a single directory or list of directories."
+ (cond
+ ((stringp root)
+ (setq root (list root)))
+ ((listp root)
+ nil)
+ (t
+ (error "Incorrect ROOT parameter value: %s" root)))
+ (dolist (dir root)
+ (dolist (subdir (tinypath-directory-subdirs dir))
+ ;; Convert forward and backward slashes.
+ (setq subdir
+ (tinypath-expand-file-name subdir))
+ (unless (string-match tinypath-:boot-ignore-directory-regexp subdir)
+ (tinypath-verbose-macro (or verbose 8)
+ (message "TinyPath: add subdir %s" subdir))
+ (pushnew subdir load-path :test 'string=)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+ (defun tinypath-default-load-path-root-user ()
+ "Return user's Emacs Lisp path by guessing various directories."
+ (flet ((msg (m)
+ (message m)
+ (unless tinypath-:startup-no-messages
+ (sit-for 2))
+ nil))
+ (if (null (getenv "HOME"))
+ (msg "TinyPath: [ERROR] Environment variable HOME is not set.")
+ (let* (ret)
+ (dolist (dir (list
+ (if tinypath-:xemacs-p
+ "~/.xemacs.d")
+ (if tinypath-:xemacs-p
+ "~/.xemacs")
+ "~/.emacs.d" ;; New Emacs
+ "~/elisp"
+ "~/lisp"
+ "~/.elisp"
+ "~/.lisp"
+ "~/.emacs"))
+ (when (and (stringp dir)
+ (file-directory-p dir))
+ (setq ret dir)))
+ (unless ret
+ ;; Try to scan all of home for lisp. Hm, Ugh.
+ ;; Perhaps a user who starts Emacs for the first time, or
+ ;; a Windows, where HOME is not set.
+ (tinypath-verbose-macro 3
+ (msg (format
+ (concat "TinyPath: [WARN] Can't determine personal "
+ "lisp package directory. $HOME/elisp was expected. "
+ "This is probably harmless; "
+ "see variable tinypath-:load-path-root for more."
+ "Environment variable HOME is [%]")
+ (or (getenv "HOME")
+ "<not set>")))))
+ ret))))
+
+;;; ----------------------------------------------------------------------
+;;;
+ (defun tinypath-default-load-path-root-dirs ()
+ "Find default directories for `tinypath-:load-path-root'."
+ (let (list)
+ (dolist (dir
+ (list
+ (tinypath-default-load-path-root-user)
+
+ ;; site wide configuration
+ ;; #todo: where is XEmacs installed by default?
+ (if (not tinypath-:xemacs-p)
+ (concat
+ "/usr/local/share/emacs/"
+ (if (string-match "[0-9]+\\.[0-9]+" emacs-version)
+ (match-string 0 emacs-version)
+ "")
+ "/lisp"))
+ ;; Cygwin
+ "/var/share/site-lisp"
+ ;; Debian
+ "/usr/local/lib/emacs/site-lisp"
+ "/usr/local/share/emacs/site-lisp"
+ "/usr/local/share/site-lisp"
+ "/opt/share/site-lisp"
+ "/opt/local/share/site-lisp"
+ "/opt/local/share/emacs/site-lisp"))
+ (when (stringp dir)
+ (message "TinyPath: default tinypath-:load-path-root => %s %s"
+ dir
+ (if (file-directory-p dir)
+ "OK"
+ "NOT EXIST"))
+ (if (file-directory-p dir)
+ (push dir list))))
+ list))
+
+;;; ----------------------------------------------------------------------
+;;;
+ (defun tinypath-directory-search (dir list &optional verb bug)
+ "Search DIR in the hierarchy of directories upward.
+
+Input:
+
+ DIR Directory to search. This can be nil.
+
+ LIST List of possible search directories.
+ -- A simple string means absolute location/DIR
+ -- Directory enclosed in (dir count) means that the directory is
+ also searched `count' levels upward.
+ -- Directory enclosed in (dir 'abs) means absolute location
+ without using parameter DIR.
+
+ For example with value:
+
+ '(/dir1 (/some/more/of/dir2 2) (/this/location abs) /dir3 ...)
+
+ The choices searched are:
+
+ /dir1/DIR
+ /some/more/of/dir2/DIR
+ /some/more/of/DIR
+ /this/location
+ /dir3/DIR
+
+ VERB Verbose messages.
+ BUG If set, and DIR not found, call `tinypath-message-bug'."
+ (let* (found)
+ (flet ((check-dir
+ (try dir)
+ (setq try (tinypath-expand-file-name
+ (concat (file-name-as-directory try)
+ dir)))
+ (if verb
+ (message "TinyPath: directory search ... %s" try))
+ (when (file-directory-p try)
+ (if verb
+ (message "TinyPath: directory search ... found %s" try))
+ try)))
+ (or dir
+ (setq dir ""))
+ (dolist (try list)
+ (cond
+ ((stringp try)
+ (if (setq found (check-dir try dir))
+ (return)))
+ ((listp try)
+ (multiple-value-bind (path count) try
+ (cond
+ ((and (stringp path)
+ (eq count 'abs))
+ (if (setq found (check-dir path dir))
+ (return)))
+ ((and (stringp path)
+ (integerp count))
+ (while (and (stringp path)
+ (not (zerop count))
+ (> count 0))
+ (if (setq found (check-dir path dir))
+ (return))
+ (decf count)
+ (setq path
+ (tinypath-directory-up path)))))))))
+
+ (cond
+ (found ;;#todo: anything to do here?
+ t)
+ (t
+ ;; Hope people that have it in non-standard locations
+ ;; will tell it to maintainer.
+ (when (and verb bug)
+ (message "TinyPath: [WARNING] %s not found." dir)
+ (tinypath-message-bug
+ (format "Directory lookup fail %s" dir)))))
+ found)))
+
+;;; ----------------------------------------------------------------------
+;;;
+ (defun tinypath-load-path-initial-value-xemacs (root &optional force)
+ "Add XEmacs installation lisp directories to `load-path'.
+
+Input:
+
+ ROOT XEmacs installation root directory.
+ See function `tinypath-emacs-root-directory'.
+
+ FORCE Try to locate xemacs-packages even if that directory is
+ found from `load-path'. The force option unconditionally
+ adds all found directories to `load-path'. No duplicates
+ are added though. This option is able to fix broken
+ `load-path'."
+ ;; Latest XEmacs does not include all of its packages in the
+ ;; standard installation, but in a huge archive called "SUMO", which
+ ;; contains subdirectory "xemacs-packages".
+ ;;
+ ;; We have no way of knowing where that directory has been unpacked, but
+ ;; try few guesses anyway.
+ (when (and tinypath-:xemacs-p
+ (boundp 'emacs-major-version)
+ ;; The `symbol-value' is just a byte compiler silencer
+ ;; after the above `boundp' test.
+ (> (symbol-value 'emacs-major-version) 20)
+ (or force
+ (null (tinypath-load-path-string-match
+ "xemacs-packages"))))
+ (message "TinyPath: load-path auto-boot [XEmacs] ...")
+ (let* (found
+ xemacs-packages)
+ ;; Search under standard location
+ ;; <XEmacs-root>/xemacs-packages or
+ ;; XEmacs/XEmacs-21.2/xemacs-packages
+ (dolist (lisp '("xemacs-packages"
+ "mule-packages"
+ "site-packages"))
+ (setq lisp (concat lisp "/lisp"))
+ (when (setq found
+ (tinypath-directory-search
+ lisp
+ (list (list root 3))
+ 'verb
+ 'bug))
+ (if (string= lisp "xemacs-packages/lisp")
+ (setq xemacs-packages found))
+ (tinypath-load-path-add-subdirs found)))
+ ;; Still not found? Try few more alternatives. This time
+ ;; we only try to find the "xemacs-packages"
+ (unless xemacs-packages
+ (when (setq found
+ (tinypath-directory-search
+ "xemacs-packages/lisp"
+ (list
+ ;; The first is historical location
+ ;; of a vanilla-configured XEmacs
+ '("/usr/local/lib/xemacs" abs)
+ ;; Try more guesses
+ '("/usr/share/lib/xemacs" abs)
+ '("/usr/lib/xemacs" abs)
+ '("~/.xemacs-packages/lisp" abs)
+ '("~/.xemacs")
+ '("~" abs)
+ '("~/site-lisp" abs)
+ '("~/lisp")
+ '("~/elisp"))
+ 'verb
+ 'bug))
+ (tinypath-load-path-add-subdirs found)))
+ (message "TinyPath: load-path auto-boot [XEmacs]... done."))))
+
+;;; ----------------------------------------------------------------------
+;;;
+ (defun tinypath-load-path-initial-value (&optional dir-list)
+ "Add Emacs installation lisp directories to `load-path'.
+This is solely used for booting up tinypath.el package, so that
+`require' commands can be satisfied. Without the core packages available
+in `load-path' it is not possible to use Emacs.
+
+The DIR-LIST is location of additional directories to consider as
+Emacs core-lisp installation directories."
+ (let* ((root-base (tinypath-emacs-root-directory))
+ (dir-p (and root-base
+ (file-directory-p root-base)))
+ root)
+ (message "TinyPath: load-path auto-boot (Emacs install dir)... %s"
+ (if root-base
+ root-base
+ "[can't find Emacs install root]")
+ (if dir-p
+ "(dir nok)"
+ "(dir ok)"))
+ (when (and root-base
+ dir-p)
+ ;; Why this booting is even needed? Isn't `load-path' already
+ ;; set, when Emacs starts? Not quite. Emacs does not include term/
+ ;; directory in `load-path', because it has peculiar way of
+ ;; requiring (load "term/vt100"). This boot section will ensure
+ ;; that all paths are included in `load-path'.
+ ;;
+ (message "TinyPath: load-path auto-boot [running]")
+ (setq root-base (file-name-as-directory root-base))
+ ;;
+ ;; Make ROOT/lisp directory. This is the same for all
+ ;; Emacs versions. Win32 conversion to lowercase
+ ;;
+ (setq root (tinypath-expand-file-name (concat root-base "lisp")))
+ ;;
+ ;; This is just ultimate safeguard. We did find the
+ ;; root, but that doesn't mean it is included in the `load-path'
+ ;; E.g. there may be directories /ROOT/lisp/something
+ ;;
+ ;; It is still possible that member fails, because
+ ;;
+ ;; - Win32 can have mixed case paths, C:/ and c:/ are
+ ;; different to pushnew
+ ;; - Win32 slashes c:\ c:/ confuse pushnew.
+ ;;
+ ;; These will be handled in the final install phase,
+ ;; see function `tinypath-load-path-clean'
+ ;;
+ (unless (or (member root load-path)
+ (member (file-name-as-directory root) load-path))
+ (pushnew root load-path :test 'string=)
+ (message "TinyPath: load-path auto-boot [%s added]." root))
+ ;;
+ ;; We might have included this line inside the above `unless',
+ ;; after `pushnew' but we do not do that. It's not a guarantee
+ ;; that subdirectories are there if ROOT was there.
+ ;;
+ (message "TinyPath: booting standard Emacs lisp paths.")
+ (tinypath-load-path-add-subdirs root 2)
+ (tinypath-load-path-initial-value-xemacs root-base)
+ ;; Add user supplied additional paths.
+ (when dir-list
+ (message "TinyPath: booting user supplied lisp paths.")
+ (tinypath-load-path-add-subdirs dir-list))
+ (message "TinyPath: load-path auto-boot... done"))))
+
+;;; ----------------------------------------------------------------------
+;;;
+ (defun tinypath-tmp-find-root-home ()
+ "Return suitable root user HOME directory. /home/root etc."
+ (let (ret)
+ (dolist (path (list
+ (if (and (not tinypath-:win32-p)
+ (eq (user-uid) 0))
+ (getenv "HOME"))
+ "/home/root"
+ "/users/root"
+ "/root"
+ "/"))
+ (when (and (stringp path)
+ (file-directory-p path))
+ (message "TinyPath: tinypath-tmp-find-root-home [%s]" path)
+ (setq ret path)
+ (return)))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+ (defun tinypath-tmp-find-writable-dir (&optional file)
+ "Find writable directory and append FILE to it. Only used at startup.
+This function sets initial values for variable
+`tinypath-:cache-file-prefix'.
+
+User should `setq' this variable before calling tinypath.el
+
+References:
+
+ `tinypath-:cache-file-prefix'
+ `tinypath-:load-path-dump-file'"
+ (let ((root-home (tinypath-tmp-find-root-home))
+ (root-user-p (and (not tinypath-:win32-p)
+ (eq (user-uid) 0)))
+ (user (or (getenv "USER")
+ (getenv "LOGNAME")
+ (if (boundp 'user-login-name) ;; Not in XEmacs 21.4
+ user-login-name)
+ (let ((home (expand-file-name "~")))
+ (if (string-match "\\([^/\\]+\\)$" home)
+ (match-string 1 home)))
+ ""))
+ ret)
+ (when (and (not (file-directory-p "~/tmp"))
+ (not (file-directory-p "c:/"))) ;; Non-Win32 system
+ (message "TinyPath: [WARNING] Cannot find $HOME/tmp directory."))
+ (dolist (dir '("~/.emacs.d/config/"
+ "~/elisp/config/"
+ "~/elisp/conf/"
+ "~/lisp/config/"
+ "~/lisp/conf/"
+ "~/.xemacs/config/"
+ "~/tmp/"
+ "~"
+ "/tmp/"
+ "/var/tmp/"
+ "c:/temp/"
+ "c:/tmp/"
+ "c:/"))
+ ;; The ROOT user is special case. (expand-file-name "~")
+ ;; may return plain "/".
+ ;; check if SysAdm has created
+ ;; /home/root, /users/root etc. directory.
+ (cond
+ ((and root-user-p
+ (string-match "~" dir))
+ (setq dir
+ (if (string= root-home "/")
+ ;; ~ => ""
+ (replace-match "" nil nil dir)
+ ;; ~/tmp => /home/root/tmp
+ (replace-match root-home nil nil dir))))
+ (t
+ (setq dir (file-name-as-directory
+ (expand-file-name dir)))))
+ (when (and (file-directory-p dir)
+ (file-writable-p
+ (concat dir
+ (or file "###tinypath.el-test###"))))
+ ;; In multi-user environment, we must say /tmp/-USER-file
+ (when (string= dir "/tmp/")
+ (setq dir (concat dir "-" user "-" )))
+ (setq ret (concat dir (or file "")))
+ (return)))
+ ;; Last thing to do. If User has set his HOME to point to
+ ;; C:/, that is not a good idea. Move cache file under C:/TEMP
+ (when (and (string-match "^[Cc]:[/\\]?$" ret)
+ (file-directory-p "C:/temp"))
+ (message
+ "TinyPath: [WARNING] find-writable-dir Using c:/temp instead of c:/")
+ (setq ret "c:/temp"))
+ (if ret
+ ret
+ (error "TinyPath: Can't find writable directory for %s" file))))
+
+ ) ;; --++-- --++-- --++-- --++-- --++-- --++-- --++-- eval-and-compile +--
+
+;;}}}
+;;{{{ variables
+
+;;; ......................................................... &v-hooks ...
+
+(defcustom tinypath-:load-hook '(tinypath-install)
+ "*Hook run when package is loaded.
+Please make sure that this hook contains function `tinypath-install'
+or nothing will be set up to Emacs when you load tinypath.el.
+
+Other suggested function could be put to this hook:
+ `tinypath-exec-path-check-verbose-fix'
+ `tinypath-install-timer'."
+ :type 'hook
+ :group 'TinyPath)
+
+(defcustom tinypath-:load-path-function 'tinypath-load-path-setup
+ "*Function define all additional paths to the `load-path'."
+ :type 'function
+ :group 'TinyPath)
+
+(defcustom tinypath-:report-mode-define-keys-hook
+ '(tinypath-report-mode-default-bindings)
+ "*List of functions to run which define keys to `tinydesk-mode-map'."
+ :type 'hook
+ :group 'TinyPath)
+
+(defcustom tinypath-:report-mode-hook nil
+ "*Hook run after the `tinypath-report-mode' is turned on."
+ :type 'hook
+ :group 'TinyPath)
+
+(defcustom tinypath-:cache-duplicate-report-hook nil
+ "*Hook run after the `tinypath-cache-duplicate-report' function.
+The point is at the beginning of `tinypath-:report-buffer' when
+the hook is run."
+ :type 'hook
+ :group 'TinyPath)
+
+(defcustom tinypath-:load-path-ignore-regexp-hook nil
+ "*Hook run after the `tinypath-:load-path-ignore-regexp' is defined.
+You can use this to add more ignore regexps to the default value.
+See Manual for the details M-x tinypath-version and \"Gnus\"."
+ :type 'hook
+ :group 'TinyPath)
+
+;;; ........................................................ &v-public ...
+;;; User configurable
+
+(defcustom tinypath-:load-path-accept-criteria t
+ "*Control which incarnation of the installed package is respected.
+When Emacs is installed, it contains many packages that may be
+maintained out of Emacs core. (e.g. in CVS)
+You may find or install more up to date version from developer's site.
+
+Example: cperl-mode.el
+
+ Take for example cperl-mode.el which is avalable at
+ http://cpan.perl.org/modules/by-authors/Ilya_Zakharevich/cperl-mode/
+
+ The package is installed in Emacs kit at location:
+
+ <root>/emacs-20.7/lisp/progmodes/cperl-mode.el
+
+ For ystem wide installation, more up to date package could
+ be found at:
+
+ /usr/local/share/site-lisp/net/users/zakharevich-ilya/cperl-mode.el
+
+ and private user may keep the package in
+
+ ~/elisp/cperl-mode.el
+
+Which package loads?
+
+ nil First one that is in `load-path', when the cache was built.
+ See `tinypah-cache-problem-report'.
+
+ t Choose package under $HOME, or one at site wide or
+ one in the default installation.
+
+ function If this is a callable function, pass LIST of paths
+ to it to choose the correct package. Function must
+ return string PATH or nil.")
+
+(defcustom tinypath-:compression-support nil
+ "*Type of compression support: 'default, 'all or 'none.
+
+'default
+
+ Files ending to .gz and .bz2 files are counted in when
+ a load command is issued.
+
+'all
+
+ In addition to 'default, also autoloaded functions can be found from
+ compressed files. This means that statements like these will work:
+
+ (autoload 'jka-compr \"jka-compr\")
+
+ The recommendation is that you set this value to 'all if you keep your lisp
+ files in compressed format to save space.
+
+nil
+
+ Do not use compression support. Seach only .el and .elc files.
+ This is the recommended setting in case there is no need for
+ compressed files. It will speed searching considerably.
+
+ Variable `tinypath-:compressed-file-extensions' is not used.
+
+'none
+
+ Do not use cache at all. Use this if the cache is broken. In Total
+ emergency, call M-x -1 `tinypath-cache-mode' to disable all advises.
+
+This value must be set once, before package is loaded. Changing it afterwards
+has no effect."
+ :type '(choice (const default)
+ (const all)
+ (const none))
+ :group 'TinyPath)
+
+(when (and (boundp 'command-line-args)
+ (member "-debug-init" (symbol-value 'command-line-args)))
+ (put 'tinypath-:verbose 'debug-init tinypath-:verbose)
+ (message "tinypath: VERBOSE 10; Emacs option was -debug-init")
+ (setq tinypath-:verbose 10))
+
+(defcustom tinypath-:cache-expiry-days
+ (tinypath-set-default-value-macro
+ "tinypath-:cache-expiry-days"
+ 14)
+ "*How many days until expiring `load-path' cache and rescan paths.
+If set to nil; do not use cache feature, but scan directories at startup."
+ :type 'integer
+ :group 'TinyPath)
+
+(defcustom tinypath-:report-mode-name "TinyPathReport"
+ "*The name of the `tinypath-report-mode'."
+ :type 'string
+ :group 'TinyPath)
+
+(defcustom tinypath-:verbose
+ (tinypath-set-default-value-macro
+ "tinypath-:verbose"
+ 3)
+ "*If number, bigger than zero, let user know what's happening.
+In error situations you can look old messages from *Messages* buffer.
+If you want all messages, set value to 10.
+
+If you want killer-logging, select 20. All this will also save
+everything to `tinypath-:log-file'."
+ :type '(integer :tag "Verbose level 0 ... 10")
+ :group 'TinyPath)
+
+(defcustom tinypath-:verbose-timing
+ (tinypath-set-default-value-macro
+ "tinypath-:verbose-timing"
+ nil)
+ "*If non-nil, dispaly laod time of each `load' `load-library' `require' call.
+This variable is obsolete and not used.")
+
+(eval-and-compile
+
+ (defun tinypath-cygwin-p ()
+ "Return Cygwin installation root if Cygwin is along PATH."
+ (let ((cygwin-p
+ (cond
+ ((locate-library "executable-find")
+ (autoload 'executable-find "executable-find")
+ ;; Should be in /bin/cygrunsrv.exe
+ ;; The funcall just hides this from idiot byte compiler
+ ;; Which doesn't see autoload definition.
+ (funcall (symbol-function 'executable-find) "cygrunsrv"))
+ ((let (file)
+ (dolist (dir exec-path)
+ (setq file
+ (concat (file-name-as-directory dir)
+ "cygrunsrv.exe"))
+ (if (file-exists-p file)
+ (return file))))))))
+ (when cygwin-p
+ ;; X:/SOME/PREFIX/bin/cygrunsrv.exe => X:/SOME/PREFIX/
+ (when (string-match "^\\(.*\\)/[^/]+/" cygwin-p)
+ (match-string 1 cygwin-p)))))
+
+ (defun tinypath-info-default-path-list ()
+ "Return default Info path candidate list."
+ (let ((cygwin-p (tinypath-cygwin-p))
+ (list
+ '("/usr/info"
+ "/usr/local/info"
+ "/usr/info/"
+ "/doc/info"
+ "/usr/share/info"
+ "/usr/local/share/info"
+ "/opt/info"
+ "/opt/share/info"))
+ ret)
+ ;; Add more default info paths to search
+ (when cygwin-p
+ (dolist (elt '("usr/info" "usr/local/info"))
+ (push (concat (file-name-as-directory cygwin-p) elt) list)))
+ ;; Drop non-existing directories
+ (dolist (elt list)
+ (when (file-directory-p elt)
+ (push elt ret)))
+ ret))
+
+ (defcustom tinypath-:Info-default-directory-list
+ (tinypath-info-default-path-list)
+ "*Additional INFO directories to check for inclusion.
+Any new entries in these directories are checked and
+fixed and added to `Info-default-directory-list'."
+ :type '(list directory)
+ :group 'TinyPath)) ;; eval-and-compile end
+
+(message "TinyPath: [VAR] tinypath-:Info-default-directory-list %s"
+ (prin1-to-string tinypath-:Info-default-directory-list))
+
+;; We can't use `ti::package-config-file-prefix' NOW, because the tinylibm.el
+;; is not yet loaded - `load-path' is not yet know for sure.
+;;
+;; #todo: this is hard coded location. If Emacs ever defines similar function
+;; #todo: then we can start using it to put config files to common place.
+
+(defcustom tinypath-:compressed-file-extensions
+ (delq
+ nil
+ (cond
+ (tinypath-:win32-cygwin-p
+ ;; We know that Cygwin contains programs for these
+ '(".gz" ".bz2"))
+ (t
+ (list
+ ;; The order is important. Put most likely first
+ (if (tinypath-executable-find-binary "bzip2") ".bz2")
+ (if (tinypath-executable-find-binary "gzip") ".gz")))))
+ ;; 2003-05-18 commented out. the "Z" compression is way too obsolete
+ ;; it is also faster to check only 2 extensions
+ ;; (if (tinypath-executable-find-binary "compress") ".Z")))
+ "*List of supported compressed file extensions.
+The default list is built dynamically by checking the binary in `exec-path'.
+The default list is:
+
+\(setq tinypath-:compressed-file-extensions '( \".gz\" \".bz2\"))
+
+References:
+ `tinypath-:compression-support'."
+ :type '(list string)
+ :group 'TinyPath)
+
+(message "TinyPath: [VAR] tinypath-:compressed-file-extensions %s"
+ (prin1-to-string tinypath-:compressed-file-extensions))
+
+(defcustom tinypath-:cache-file-prefix
+ ;;
+ ;; Can't use `ti::package-config-file-prefix', because the library
+ ;; is not loaded yet. USER MUST SETQ THIS VARIABLE
+ ;;
+ (tinypath-set-default-value-macro
+ "tinypath-:cache-file-prefix"
+ (tinypath-tmp-find-writable-dir "emacs-config-tinypath-cache"))
+ "*File where to store `tinypath-:cache'. See `tinypath-:cache-file-postfix'.
+This is only a prefix for filename. The whole filename is returned by
+function `tinypath-cache-file-name' which appends emacs version id after
+this prefix string.
+
+An example: /home/some/elisp/config/tinypah-cache-"
+ :type 'string
+ :group 'TinyPath)
+
+(message "TinyPath: [VAR] tinypath-:cache-file-prefix %s"
+ (prin1-to-string tinypath-:cache-file-prefix))
+
+(defcustom tinypath-:cache-file-hostname-function
+ 'tinypath-cache-file-hostname
+ "*Function to return HOST for the cache file name.
+
+You're interested on this variable only if you're running several networked
+machines and 1) you always have same, ONE mounted $HOME directory 2) and
+each machine has its own run-files, like site-lisp.
+
+Use value nil to disable using hostname in cache file name:
+
+ (setq tinypath-:cache-file-hostname-function nil)
+
+To activate the hostname portion in cache name, set variable to like this:
+This makes each HOST have its own cache.
+
+ (setq tinypath-:cache-file-hostname-function 'tinypath-cache-file-hostname)
+
+See manual \\[tinypath-version] for more information."
+ :type 'function
+ :group 'TinyPath)
+
+(message "TinyPath: [VAR] tinypath-:cache-file-hostname-function %s"
+ (prin1-to-string tinypath-:cache-file-hostname-function))
+
+;; We select the compressed file to save space if we can detect gzip
+;; in this environment.
+
+(defcustom tinypath-:cache-file-postfix
+ (if t
+ ".elc"
+ ;; 2000-01 Disabled for now
+ (if (tinypath-executable-find-binary "gzip")
+ ".el.gz"
+ ".el"))
+ "*Extension for `tinypath-:cache'. See also `tinypath-:cache-file-prefix'.
+The xtension may be compiled version \".elc\" or non-compiled \".el\".
+Even with compiled version, the .el file is also retained, because it's
+the only readable file and in emergencies you can fix it and load it by hand.
+
+You could also set this to \".el.gz\" if space is crucial, but that makes
+startup lot slower. This is be\81´cause package must arrange loading jka-compr.el
+before anything else and the load time will increase with compression.
+
+Do not st this to \".elc.gz\", it's not supported."
+ :type 'string
+ :group 'TinyPath)
+
+(message "TinyPath: [VAR] tinypath-:cache-file-postfix %s"
+ (prin1-to-string tinypath-:cache-file-postfix))
+
+(defcustom tinypath-:load-path-dump-file
+ ;;
+ ;; Can't use `ti::package-config-file-prefix', because the library
+ ;; is not loaded yet. USER MUST SETQ THIS VARIABLE
+ ;;
+ (tinypath-tmp-find-writable-dir "emacs-config-tinypath-dump.el")
+ "*Where to store dumped load path. See `tinypath-load-path-dump'."
+ :type 'file
+ :group 'TinyPath)
+
+(defcustom tinypath-:cache-duplicate-report-ignore-functions
+ '(tinypath-cache-duplicate-report-ignore-function)
+ "*Functions called with FILE. Return t to ignore FILE in duplicate report.
+Called from function `tinypath-cache-duplicate-report'."
+ :type 'function
+ :group 'TinyPath)
+
+(message
+ "TinyPath: [VAR] tinypath-:cache-duplicate-report-ignore-functions %s"
+ (prin1-to-string
+ tinypath-:cache-duplicate-report-ignore-functions))
+
+(defcustom tinypath-:ignore-file-regexp nil
+ "*Prohibit loading lisp file if regexp matches absolute path.
+If \"\\\\.elc\" ignore all compiled files and load only source files.
+
+This regexp is matched against absolute filename being loaded and
+if it matches, the file is ignore. An error is signaled
+if there is no single choice available after exclude.
+
+There may be reasons why you would always load only the non-compiled
+version and ignore compiled versions:
+
+-- You are developing packages or debugging packages and you
+ want your Emacs to load only non-compiled versions. The *Backtrace*
+ buffer output is more sensible with non-compiled functions.
+
+ ==> Setting value to \".\" will ignore all compiled files.
+
+-- You have share some site-lisp files with Emacs and XEmacs, but
+ you primarily use GNU Emacs and the compiled files are for it.
+ XEmacs must not load the compiled versions.
+
+ ==> Set this regexp in your $HOME/.emacs when XEmacs is loaded, to
+ match the directory part of file which is located in shared lisp
+ directory for Emacs and Xemacs."
+ :type 'regexp
+ :group 'TinyPath)
+
+(defcustom tinypath-:manpath-ignore-regexp
+ "terminfo"
+ "*Regexp to exclude directories for MANPATH additions.
+It really isn't very serious if MANPATH contains few faulty directories,
+do don't worry. You can see the final results in `tinypath-:extra-manpath'."
+ :type 'regexp
+ :group 'TinyPath)
+
+(defcustom tinypath-:exec-path-ignore-regexp nil
+ "*Regexp to exclude directories for `exec-path' additions.
+The automatic Perl utility will find every directory under
+`tinypath-:extra-path-root' which contain executable files and them to
+`exec-path. Set this variable to ignore certain directories."
+ :type 'regexp
+ :group 'TinyPath)
+
+(defcustom tinypath-:load-path-ignore-regexp
+ (concat
+ "[/\\]" ;; windows or unix dir separator start
+ "\\(" ;; START grouping
+ ;; Skip Distributed help files
+ "tex\\(i\\|info\\)$"
+ "\\|doc[/\\]"
+ ;; Skip Other directories
+ "\\|RCS[/\\]\\|CVS[/\\]\\|zip\\|\\.svn\\|/MT/"
+ ;; Skip Perl or other build directories
+ "\\|\\.\\(cpan\\|build\\|s?inst\\)"
+ ;; Skip temporary directories /T/ /t/ /tmp* /temp*
+ "\\|[Tt][/\\]\\|te?mp"
+ ;; Skip build directories
+ "\\|\\.\\(build\\|s?inst\\)"
+ (if (and (not tinypath-:xemacs-p)
+ (not (string< emacs-version "21"))) ;; > 21
+ "\\|psgml"
+ "")
+ (if (and (not tinypath-:xemacs-p)
+ (not (string< emacs-version "21"))) ;; > 21
+ "\\|pcl-cvs" ;Emacs 21.2 - under name pcvs.el
+ "")
+ (if (and (not tinypath-:xemacs-p)
+ (not (string< emacs-version "21")))
+ "\\|artist-[0-9.]+" ;artist is in Emacs 21.2
+ "")
+ (if tinypath-:xemacs-p ;EFS doesn't work in Emacs
+ ""
+ "\\|efs")
+ ;; 20.x has custom lib, so we don't want to install private
+ ;; custom.el copy that we used for 19.x Emacs
+ ;; (if (> emacs-major-version 19) "\\|custom" "")
+ ;; Do not use TM in latest Emacs. Gnus and VM has MIME handling.
+ ;; SEMI might be ok.
+ ;; (if (> emacs-major-version 19) "\\|tm/\\|tm-[^/]+" "")
+ "\\)")
+ "*Regexp to match directories which to ignore. Case sensitive.
+If `tinypath-:load-path-ignore-regexp-extra' is string, it is appended ONCE
+to this default regexp.
+
+This variable is case sensitive."
+ :type '(string :tag "Regexp")
+ :group 'TinyPath)
+
+(eval-and-compile
+ (defvar tinypath-:install-flag t
+ "If non-nil, install package.
+Should only be used in cases of maintenance and debug.
+To start debugging the package, set this variable nil before loading. Nothing
+is done until function `tinypath-install-main' is called.
+
+ (defun my-tinypath-debug-prepare ()
+ (require 'elp)
+ (require 'edebug)
+ (setq debug-on-error t)
+ (setq debug-ignored-errors nil)
+ (setq tinypath-:install-flag nil)
+ (setq tinypath-:cache-file-postfix \".elc\")
+ (setq tinypath-:load-hook nil)
+ (setq tinypath-:verbose 5)
+ (setq tinypath-:load-path-root)))
+ '(
+ ;; \"~/elisp\" ;; Commented out while debugging
+ ;; Run statements one by one with C-x C-e
+ (my-tinypath-debug-prepare)
+ (load \"/path/t/tinypath\")
+ ;; <at this point, you could instrument tinypath functions using elp>
+ (tinypath-load-path-initial-value
+ tinypath-:core-emacs-load-path-list)
+ (tinypath-install-main)
+ ;; Do something and then call this:
+ (tinypath-install)
+
+The above is just an example how to prepare to debug package."))
+
+(defvar tinypath-:load-path-ignore-regexp-extra nil
+ "*String to add to `tinypath-:load-path-ignore-regexp'.
+Remember to start the regexp with OR-statement \\\\| because the regexp
+is added to existing value.
+
+Value of this regexp is added every time the file is loaded.
+See Manual for explanation: M-x tinypath-version and \"Gnus\".")
+
+;; Append to default value. This is the easiest this way.
+
+(when (and (stringp tinypath-:load-path-ignore-regexp)
+ (stringp tinypath-:load-path-ignore-regexp-extra))
+ (setq tinypath-:load-path-ignore-regexp
+ (concat tinypath-:load-path-ignore-regexp
+ tinypath-:load-path-ignore-regexp-extra)))
+
+;; Experienced users have a chance to add more regexps to the variable
+
+(run-hooks 'tinypath-:load-path-ignore-regexp-hook)
+
+(message "TinyPath: [VAR] tinypath-:ignore-file-regexp %s"
+ (prin1-to-string tinypath-:ignore-file-regexp))
+
+(eval-and-compile ;; Needed at boot-time.
+ (defcustom tinypath-:core-emacs-load-path-list nil
+ "*List of core Emacs lisp directories.
+
+Setting this variable is mandatory if the initial `load-path'
+in Emacs startup does not contain core lisp packages.
+
+Emacs:
+
+ In Emacs, this would be directory where core lisp files
+ reside, typically /usr/share/emacs/NN.N/lisp.
+
+XEmacs:
+
+ In XEmacs, you would add the location of
+ xemacs-packages, mule-packages and site-packages or in older versions
+ /usr/lib/xemacs-NN.N/lisp/
+
+ You do not need to set this variable for XEmacs, because the automatic boot
+ up will find the core packages provided that packages have been
+ installed at the same level as the XEmacs itself:
+
+ XEmacs/xemacs-NN.N/
+ XEmacs/site-packages/
+ XEmacs/mule-packages/
+ ..."
+ :type 'directory
+ :group 'TinyPath))
+
+(message "TinyPath: [VAR] tinypath-:core-emacs-load-path-list %s"
+ (prin1-to-string tinypath-:core-emacs-load-path-list))
+
+(defcustom tinypath-:load-path-root
+ (tinypath-set-default-value-macro
+ "tinypath-:load-path-root"
+ (tinypath-default-load-path-root-dirs))
+ "*List of root directories of Emacs lisp packages.
+Put list all lisp package installation roots here, like
+
+ (setq tinypath-:load-path-root
+ (list
+ (if (not tinypath-:xemacs-p)
+ ;; This is for Emacs only
+ \"/usr/local/share/emacs/site-lisp\")
+ \"/usr/local/share/site-lisp\"
+ \"/opt/share/site-lisp\"
+ ;; or ~/lisp
+ \"~/elisp\")
+
+Non-existing directories do no harm, because every
+element that is not a string and a valid directory is ignored."
+ :type '(list directory)
+ :group 'TinyPath)
+
+(defcustom tinypath-:extra-path-root
+ (tinypath-set-default-value-macro
+ "tinypath-:extra-path-root"
+ (let ((path (tinypath-ti::win32-cygwin-p 'use-cache)))
+ (when path
+ (message
+ (concat "TinyPath: Cygwin root is %s."
+ " Consider adding all Cygwin INFO directories"
+ " to variable `Info-directory-list'.")
+ path))
+ nil))
+ "*Win32 Cygwin installation root or other search directories.
+This variable contains list of directories.
+
+In many times people working with Emacs also install http://www.cygwin.com/
+Unix environment, which contains manual pages and info files for the
+utilities.
+
+Set this variable to LIST of additional search root directories
+for manual pages and info files."
+ :type '(list directory)
+ :group 'TinyPath)
+
+(message "TinyPath: [VAR] tinypath-:extra-path-root %s"
+ (prin1-to-string tinypath-:extra-path-root))
+
+;;; ....................................................... &v-private ...
+
+(defvar tinypath-:original-load-path load-path
+ "Original load-path value before loading this package.
+It is used later in \\[tinypath-cache-regenerate]. DO NOT TOUCH.")
+
+(defvar tinypath-:original-load-path-after-load nil
+ "The `load-path' value after this package has been loaded.
+If `load-path' changes during Emacs sesssion, then
+cache is not used. This happens e.g. while value locally
+bound:
+
+ (let ((load-path ...))
+ ;; The value is no longer the global value
+ ....
+
+DO NOT TOUCH. Only function that regenerate cache are allowed
+to change this.")
+
+(defvar tinypath-:log-file
+ (tinypath-tmp-find-writable-dir "emacs-tinypath.el.log")
+ "With `tinypath-:verbose' set to 20, the message buffer
+is constantly written to disk. Prepare, everything will take oodles
+of time...")
+
+(defvar tinypath-:external-data-structure nil
+ "Whole data structure from external tool. See `tinypath-external-setup'.
+Do not touch. This is highly important for debugging purposes.")
+
+(defvar tinypath-:extra-manpath nil
+ "Additional paths found. See `tinypath-:extra-path-root'.")
+
+(defvar tinypath-:extra-ff-search-directories nil
+ "Additional C/C++ include paths found. See `tinypath-:extra-path-root'")
+
+(defvar tinypath-report-mode-map nil
+ "Keymap for buffer generated by `tinypath-cache-duplicate-report'.")
+
+(defvar tinypath-:cache nil
+ "List of all lisp files along `load-path'.
+\((\"file\" (POS . PATH)) .. ).")
+
+(defvar tinypath-:time-data nil
+ "When each package is loaded, its load time is recoded here.
+See `tinypath-time-display'. The data structure is ((package . time-sec)).")
+
+(defvar tinypath-:time-buffer "*tinypath-time-results*"
+ "Buffer to put results of `tinypath-time-display'.")
+
+(defvar tinypath-:cache-level-two nil
+ "Cache of tinypath-:cache. It keeps the files already resolved by
+consulting the cache. Its aim is to speed up the search.
+\((\"file\" . \"absolute-path\") ...).")
+
+(defvar tinypath-dumped-load-path nil
+ "Load path with Disk Drive letters. See `tinypath-load-path-dump'.")
+
+(defvar tinypath-:cache-mode nil
+ "State of `tinypath-cache-mode'. DO NOT CHANGE THIS VARIABLE DIRECTLY.
+There is more than just changing this variable's state.
+Use function `tinypath-cache-mode' which modifies everything needed.")
+
+(defvar tinypath-:report-buffer "*tinypath-report*"
+ "*Buffer where to report e.g. after `tinypath-cache-duplicate-report'.")
+
+(defvar tinypath-:timer-elt nil
+ "Timer process.")
+
+(defconst tinypath-:report-mode-font-lock-keywords
+ (list
+ ;; File size
+ (list
+ (concat
+ "[0-9][0-9]:[0-9][0-9]:[0-9][0-9][ \t]+"
+ "\\(.*\\)")
+ 1 'font-lock-reference-face)
+ ;; Filename
+ (list
+ (concat
+ "^[ \t]+[0-9]+[ \t]+"
+ "\\([0-9]+\\)")
+ 1 'font-lock-variable-name-face)
+ ;; Emacs core installation
+ (list
+ "x?emacs[-\\/][0-9]+[0-9.]+"
+ 0 'font-lock-keyword-face t)
+ (list
+ "ERROR:"
+ 0 'font-lock-constant-face)
+ ;; filename heading at the start of the line
+ (list
+ "^[^ \t\r\n]+"
+ 0 'font-lock-string-face)
+ (list ;; mark deleted files
+ "^[*].*"
+ 0 'font-lock-comment-face t))
+ "*Font lock keywords for the `tinypath-:report-buffer' buffer.")
+
+(defvar tinypath-:external-util-bin "emacs-util.pl"
+ "*External utility to help finding Emacs boot up information.
+DO NOR CHANGE THE NAME OF THE BINARY unless you rename the utility.
+See M-x tinypath-version (the manual) for more information.")
+
+;;}}}
+;;{{{ Macros
+
+;;; ----------------------------------------------------------------------
+;;; Only some values are recorded as messages to the *Messages* buffer
+;;; Showing the values possibly makes user think if he needs
+;;; to change the defaults.
+;;;
+(put 'tinypath-with-temp-buffer 'lisp-indent-function 0)
+(put 'tinypath-with-temp-buffer 'edebug-form-spec '(body))
+(defmacro tinypath-with-temp-buffer (&rest body)
+ "Clear all hooks while running `with-temp-buffer'"
+ (` (let (temp-buffer-setup-hook
+ font-lock-mode
+ lazy-lock-mode)
+ ;; This is no-op, just quiets Byte Compiler (non used variable).
+ (if temp-buffer-setup-hook
+ (setq temp-buffer-setup-hook nil))
+ (if font-lock-mode
+ (setq font-lock-mode nil))
+ (if temp-buffer-setup-hook
+ (setq temp-buffer-setup-hook nil))
+ (if lazy-lock-mode
+ (setq lazy-lock-mode nil))
+ (with-temp-buffer
+ (,@ body)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro tinypath-Info-default-directory-list ()
+ "Emacs and XEmacs compatibility."
+ ;; Latest XEmacs does not use `Info-default-directory-list'
+ (if tinypath-:xemacs-p
+ (intern "Info-directory-list")
+ (intern "Info-default-directory-list")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro tinypath-Info-default-directory-list-sym ()
+ "Emacs and XEmacs compatibility."
+ (`
+ (if tinypath-:xemacs-p
+ (intern "Info-directory-list")
+ (intern "Info-default-directory-list"))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro tinypath-message-log-max-sym ()
+ "Emacs and XEmacs compatibility."
+ (`
+ (cond
+ ((boundp 'log-message-max-size) ;; XEmacs
+ (intern "log-message-max-size"))
+ ((boundp 'message-log-max)
+ (intern "message-log-max"))
+ (t
+ (error "tinypath-message-log-max-sym")))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro tinypath-message-log-max-sym-value ()
+ "Emacs and XEmacs compatibility."
+ (`
+ (symbol-value (tinypath-message-log-max-sym))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro tinypath-message-log-max-sym-set (value)
+ "Emacs and XEmacs compatibility."
+ (`
+ (set (tinypath-message-log-max-sym) (, value))))
+
+;;; ----------------------------------------------------------------------
+;;; #copy: from tinyliba.el
+(defmacro tinypath-ti::bool-toggle (var &optional arg)
+ "Toggle VAR according to ARG like mode would do.
+Useful for for functions that use arg 0/-1 = off, 1 = on, nil = toggle.
+Minor modes behave this way.
+
+VAR is set to following values when ARG is:
+
+ arg 0/-1 VAR -> nil
+ arg nbr VAR -> t
+ arg nil VAR -> not(var) toggles variable"
+ (` (setq (, var)
+ (cond
+ ((and (integerp (, arg))
+ (< (, arg) 1)) ;Any negative value or 0
+ nil)
+ ((null (, arg))
+ (not (, var)))
+ (t
+ t)))))
+
+;;}}}
+;;{{{ Duplicated functions
+
+;;; ----------------------------------------------------------------------
+;;; #copy: tinylib.el
+(defsubst tinypath-ti::date-time-difference (a b)
+ "Calculate difference between times A and B.
+The input must be in form of '(current-time)'
+The returned value is difference in seconds.
+E.g., if you want to calculate days; you'd do
+
+\(/ (tinypath-ti::date-time-difference a b) 86400) ;; 60sec * 60min * 24h"
+ (let ((hi (- (car a) (car b)))
+ (lo (- (car (cdr a)) (car (cdr b)))))
+ (+ (lsh hi 16) lo)))
+
+;;; ----------------------------------------------------------------------
+;;; #copy: tinylib.el
+(defun tinypath-ti::dired-buffer (dir)
+ "Return dired buffer runninr DIR."
+ (setq dir (file-name-as-directory dir)) ;; Dired uses trailing slash
+ (dolist (buffer (buffer-list))
+ (with-current-buffer buffer
+ (when (and (eq major-mode 'dired-mode)
+ (string= dired-directory dir))
+ (return buffer)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-ti::window-single-p ()
+ "Check if there is only one window in current frame."
+ ;; No need to run `length' when `nth' suffices.
+ (let* ((win (selected-window))
+ (next (next-window)))
+ ;; Same window?
+ (eq win next)))
+
+;;; ----------------------------------------------------------------------
+;;; #copy: tinylibm.el
+(defmacro tinypath-ti::funcall (func-sym &rest args)
+ "Call FUNC-SYM with ARGS.
+Like funcall, but secretly call function if it exists.
+
+The full story:
+
+ Byte Compiler isn't very smart when it comes to knowing if
+ symbol exist or not. If you have following statement in your function,
+ it still complaints that the function \"is not known\"
+
+ (if (fboundp 'some-non-existing-func)
+ (some-non-existing-func arg1 arg2 ...))
+
+ instead use:
+
+ (if (fboundp 'some-non-existing-func)
+ (tinypath-ti::funcall 'some-non-existing-func arg1 arg2 ...)
+
+ to get rid of the unnecessary warning.
+
+Warning:
+
+ You _cannot_ use ti::funcall if the function is in autoload state, because
+ `symbol-function' doesn't return a function to call. Rearrange
+ code so that you do (require 'package) test."
+ (`
+ (let* ((func (, func-sym)))
+ (when (fboundp (, func-sym))
+ ;; Old
+ ;; (apply (symbol-function (, func-sym)) (,@ args) nil)
+ (apply func (,@ args) nil)))))
+
+;;; ----------------------------------------------------------------------
+;;; #copy: from tinylib.el
+(defun tinypath-days-old (file)
+ "How old FILE is in days. An approximation."
+ (let* ((a (current-time))
+ (b (nth 5 (file-attributes file)))
+ (hi (- (car a) (car b)))
+ (lo (- (car (cdr a)) (car (cdr b)))))
+ (/ (+ (lsh hi 16) lo) 86400)))
+
+;;; ----------------------------------------------------------------------
+;;; #copy from tinylibm.el
+(defun tinypath-ti::replace-match (level &optional replace string)
+ "Kill match from buffer at sub-match LEVEL or replace with REPLACE.
+Point sits after the replaced or killed area.
+
+Optionally you can give STRING. If level didn't match, do nothing.
+
+Call:
+
+ (level &optional replace string)
+
+Return:
+
+ t Action taken
+ nil If match at LEVEL doesn't exist.
+ str If string was given."
+ (if (null string)
+ (cond
+ ((match-end level)
+ (delete-region (match-beginning level) (match-end level))
+
+ ;; I think emacs has bug, because cursor does not sit at
+ ;; match-beginning if I delete that region, instead it is off +1
+ ;; --> force it to right place
+
+ (and replace
+ (goto-char (match-beginning level))
+ (insert replace))))
+ (when (match-end level) ;Handle string case
+ (concat
+ (substring string 0 (match-beginning level))
+ (if replace replace "")
+ (substring string (match-end level))))))
+
+;;; ----------------------------------------------------------------------
+;;; #copy: from tinylibb.el
+(defun tinypath-replace-regexp-in-string
+ (regexp rep string &optional fixedcase literal subexp start)
+ (let* ((i 0))
+ (or subexp
+ (setq subexp 0))
+
+ (while (string-match regexp string)
+ (if (> (incf i) 5000)
+ (error "Substituted string causes circular match. Loop never ends.")
+ (setq string (inline (tinypath-ti::replace-match subexp rep string)))))
+ string))
+
+;;; ----------------------------------------------------------------------
+;;; #copy: from tinylibm.el
+(defun tinypath-ti::pp-variable-list (list &optional buffer def-token)
+ "Print LIST of variables to BUFFER. DEF-TOKEN defaults to `defconst'."
+ (let* (val)
+ (or buffer
+ (setq buffer (current-buffer)))
+ (or def-token
+ (setq def-token "defconst"))
+ (dolist (sym list)
+ (unless (symbolp sym)
+ (error "List member is not symbol %s" sym))
+ (setq val (symbol-value sym))
+ (insert (format "\n\n(%s %s\n" def-token (symbol-name sym)))
+ (cond
+ ((numberp val)
+ (insert val))
+ ((stringp val)
+ (insert (format "\"%s\"" val)))
+ ((memq val '(t nil))
+ (insert (symbol-name val)))
+ ((and (symbolp val)
+ (fboundp val))
+ (insert "(function " (symbol-name val) ")"))
+ ((symbolp val)
+ (insert "'" (symbol-name val)))
+ ((listp
+ (insert "'" (pp val))))
+ (t
+ (error "unknown content of stream" sym val)))
+ (insert ")"))))
+
+;;; ----------------------------------------------------------------------
+;;; #copy from tinylibm.el
+(defun tinypath-ti::write-file-variable-state
+ (file desc list &optional fast-save bup)
+ "Save package state to FILE.
+
+Input:
+
+ FILE filename
+ DESC One line description string for the file.
+ LIST List of variable symbols whose content to save to FILE.
+
+ FAST-SAVE The default `pp' function used to stream out the contents
+ of the listp variables is extremely slow if your variables
+ contain lot of data. This flag instructs to use alternative,
+ much faster, but not pretty on output, method.
+
+ BUP If non-nil, allow making backup. The default is no backup."
+ (tinypath-with-temp-buffer
+ (let ((backup-inhibited (if bup nil t))
+ ;; prohibit Crypt++ from asking confirmation
+ (crypt-auto-write-buffer t))
+ (unless crypt-auto-write-buffer ;Bytecomp silencer
+ (setq crypt-auto-write-buffer nil))
+ (insert ";; " file " -- " desc "\n"
+ ";; Date: "
+ (tinypath-time-string)
+ "\n\n")
+ (if (not fast-save)
+ (tinypath-ti::pp-variable-list list)
+ (dolist (var list)
+ (insert (format "\n\n(defconst %s\n" (symbol-name var)))
+ ;; While `pp' would have nicely formatted the value, It's
+ ;; unbearable SLOW for 3000 file cache list.
+ ;; `prin1-to-string' is 10 times faster.
+ (insert "'" (prin1-to-string (symbol-value var)) ")\n")))
+ (insert (format "\n\n;; end of %s\n" file))
+ (write-region (point-min) (point-max) file))))
+
+;;; ----------------------------------------------------------------------
+;;; #copy from tinylib.el
+(defun tinypath-ti::advice-control
+ (list regexp &optional disable verb msg)
+ "Enables/disable SINGLE-OR-LIST of advised functions that match REGEXP.
+Signals no errors, even if function in LIST is not advised.
+All advice classes ['any] are ena/disabled for REGEXP.
+
+Input:
+
+ LIST list of functions.
+ REGEXP advice name regexp. Should normally have ^ anchor
+ DISABLE flag, of non-nil then disable
+ VERB enable verbose messages
+ MSG display this message + on/off indication"
+ (dolist (func list)
+ (ignore-errors
+ (if disable
+ (ad-disable-advice func 'any regexp)
+ (ad-enable-advice func 'any regexp))
+ (ad-activate func))) ;;change state
+ (if verb
+ (message
+ (concat
+ (or msg "advice(s): ")
+ (if disable
+ "off"
+ "on")))))
+
+;;; ----------------------------------------------------------------------
+;;; #copy
+(defun tinypath-ti::string-remove-whitespace (string)
+ "Squeezes empty spaces around beginning and end of STRING.
+If STRING is not stringp, then returns STRING as is."
+ (when (stringp string)
+ (if (string-match "^[ \t]+\\(.*\\)" string)
+ (setq string (match-string 1 string)))
+
+ (if (string-match "[ \t]+\\'" string)
+ (setq string
+ (substring string 0 (match-beginning 0)))))
+ string)
+
+;;; ----------------------------------------------------------------------
+;;; #copy: from tinylib.el
+(defun tinypath-ti::vc-version-lessp (a b &optional zero-treat)
+ "Return t if A is later version than B.
+This function can only check only three levels, up till: NN.NN.NN.
+
+Input
+
+ A Version string one
+ B Version string two
+ ZERO-TREAT If non-nil, consider version numbers starting with 0.NN
+ never than 2.1. In this case it is assumed
+ that zero based versions are latest development releases."
+ (flet ((version (str regexp)
+ (if (string-match regexp str)
+ (string-to-number (match-string 1 str))
+ 0)))
+ (let* ((a1 (version a "^\\([0-9]+\\)"))
+ (a2 (version a "^[0-9]+\\.\\([0-9]+\\)"))
+ (a3 (version a "^[0-9]+\\.[0-9]+\\.\\([0-9]+\\)"))
+ (b1 (version b "^\\([0-9]+\\)"))
+ (b2 (version b "^[0-9]+\\.\\([0-9]+\\)"))
+ (b3 (version b "^[0-9]+\\.[0-9]+\\.\\([0-9]+\\)")))
+ (or (and zero-treat
+ (and (= a1 0)
+ (> b1 0)))
+ (> a1 b1)
+ (and (= a1 b1)
+ (> a2 b2))
+ (and (= a1 b1)
+ (= a2 b2)
+ (> a3 b3))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-message-get-buffer ()
+ "Return *Message* buffer pointer."
+ (or (get-buffer "*Messages*")
+ (get-buffer " *Message-Log*"))) ;; XEmacs
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-log-write ()
+ "*Write log to `tinypath-:log-file'."
+ (let* ((buffer (tinypath-message-get-buffer))
+ (file tinypath-:log-file))
+ (ignore-errors
+ (with-current-buffer buffer
+ (write-region (point-min) (point-max) file)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-ti::compat-timer-elt (function)
+ "Search FUNCTION and return timer elt.
+You can use this function to check if some function is currently
+in timer list. (i.e. active)
+
+The timer lists are searched in following order:
+
+ `itimer-list'
+ `timer-list'
+ 'timer-idle-list'
+
+Return:
+
+ '(timer-elt timer-variable)"
+ (let* (pos
+ list
+ item
+ ret)
+ (flet ((get-elt (elt place)
+ (if (vectorp elt)
+ (aref elt place)
+ (nth place elt))))
+ (dolist (timer '(
+ ;; (("Mon Dec 9 10:01:47 1996-0" 10
+ ;; process nil))
+ (timer-idle-list . 5)
+ (timer-alist . 2)
+ (timer-list . 2) ;; 19.34+
+ (itimer-list . 3)))
+ (when (boundp (car timer))
+ (setq list (symbol-value (car timer))
+ pos (cdr timer))
+ ;; NOTE: this is different in Xemacs. It is not a vector
+ ;; timer-[idle-]list Emacs 19.34
+ ;; NOTE: this is different in Xemacs. It is not a vector
+
+ ;; ([nil 12971 57604 0 60 display-time-event-handler nil nil])
+ ;; [nil 13971 14627 646194 60
+ ;; (lambda (f) (run-at-time ...))
+ ;; (irchat-Command-keepalive) nil]
+ (if (and (not tinypath-:xemacs-p)
+ (vectorp (car list)))
+ (setq pos 5))
+ (dolist (elt list)
+ (setq item (get-elt elt pos))
+;;; (d!! (functionp item) (get-elt elt (1+ pos)))
+ (when (or (and (symbolp item)
+ (eq item function))
+ ;; It may be lambda expression
+ (and (functionp item)
+ (string-match (regexp-quote (symbol-name function))
+ (prin1-to-string
+ (get-elt elt (1+ pos))))))
+ (setq ret (list elt (car timer)))
+ (return))))))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-ti::compat-timer-cancel (key &optional cancel-function)
+ "Delete timer KEY entry, where KEY is full element in (i)`timer-alist'."
+ (let (var)
+ (when key
+ (when (and (null var)
+ (boundp 'timer-alist)) ;Emacs
+ (setq var 'timer-alist)
+ (tinypath-ti::funcall 'cancel-timer key)
+ (set var (delete key (symbol-value 'timer-alist))))
+ (when (and (null var)
+ (boundp 'timer-list)) ;Emacs 19.34
+ (setq var 'timer-list)
+ ;; Must use this command
+ (tinypath-ti::funcall 'cancel-timer key))
+ (when (and (null var)
+ (boundp 'timer-idle-list)) ;Emacs 19.34
+ (setq var 'timer-idle-list)
+ ;; Must use this command
+ (tinypath-ti::funcall 'cancel-timer key))
+ (when (and (null var)
+ (boundp 'itimer-list)) ;XEmacs
+ (setq var 'itimer-list)
+ (tinypath-ti::funcall 'cancel-itimer key)
+ (set var (delete key (symbol-value 'itimer-list))))
+ var)))
+
+;;; ----------------------------------------------------------------------
+;;; #copy: tinylib.el
+(defun tinypath-ti::compat-timer-cancel-function (function)
+ "Delete all timer entries for FUNCTION."
+ (let (key)
+ (while (setq key (car-safe (tinypath-ti::compat-timer-elt function)))
+ (tinypath-ti::compat-timer-cancel key))
+ key))
+
+;;; ----------------------------------------------------------------------
+;;; #copy: tinylib.el
+(defun tinypath-ti::directory-recursive-do (root function)
+ "Start at ROOT and call FUNCTION recursively from each ascended directory."
+ (let* ((list (tinypath-subdirectory-list root)))
+ (if (null list)
+ (funcall function root)
+ (dolist (path list)
+ (tinypath-ti::directory-recursive-do path function)))))
+
+;;}}}
+;;{{{ Modes
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-report-mode-default-bindings ()
+ "Define default key bindings to `tinypath-report-mode-map'."
+ (unless (keymapp tinypath-report-mode-map)
+ (setq tinypath-report-mode-map (make-sparse-keymap))
+ (cond
+ (tinypath-:xemacs-p
+ (define-key tinypath-report-mode-map [(control shift button1)]
+ 'tinypath-report-mode-delete-file))
+ (t
+ (define-key tinypath-report-mode-map [C-S-mouse-1]
+ 'tinypath-report-mode-delete-file)))
+ ;; ............................................. users with no mouse ...
+ (define-key tinypath-report-mode-map "\C-d"
+ 'tinypath-report-mode-delete-file)
+ (define-key tinypath-report-mode-map "\C-c\C-d"
+ 'tinypath-report-mode-delete-file-noconfirm)
+ (define-key tinypath-report-mode-map "\C-cd"
+ 'tinypath-report-mode-dired)
+ (define-key tinypath-report-mode-map "\C-p"
+ 'tinypath-report-mode-previous)
+ (define-key tinypath-report-mode-map [(control up)]
+ 'tinypath-report-mode-previous)
+ (define-key tinypath-report-mode-map "\C-n"
+ 'tinypath-report-mode-next)
+ (define-key tinypath-report-mode-map [(control down)]
+ 'tinypath-report-mode-next)
+ (define-key tinypath-report-mode-map "\C-cr"
+ 'tinypath-cache-duplicate-report)
+ (define-key tinypath-report-mode-map "\C-cg"
+ 'tinypath-cache-regenerate)
+ (define-key tinypath-report-mode-map [(return)]
+ 'tinypath-report-mode-find-file)
+ (define-key tinypath-report-mode-map "\C-cf"
+ 'tinypath-report-mode-find-file)))
+
+;;}}}
+;;{{{ Debug
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinypath-debug-wrapper-macro 'lisp-indent-function 0)
+(put 'tinypath-debug-wrapper-macro 'edebug-form-spec '(body))
+(defmacro tinypath-debug-wrapper-macro (&rest body)
+ "Increase `tinypath-:verbose' and `message-log-size'."
+ (`
+ (let* ((tinypath-:verbose 12))
+ ;; Value t is unlimited in Emacs, but don't know about XEmacs
+ ;; Setting a high value works always.
+ (set (tinypath-message-log-max-sym) 900000)
+ (with-current-buffer (tinypath-message-get-buffer)
+ (,@ body)
+ (pop-to-buffer (current-buffer))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-debug-test-run (&optional clear)
+ "Developer function. Test everything with full debug and CLEAR buffer."
+ (interactive "P")
+ (tinypath-debug-wrapper-macro
+ (if clear
+ (erase-buffer))
+ (tinypath-cache-regenerate)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-debug-external-helper ()
+ "Developer function. Test external helper program."
+ (interactive)
+ (tinypath-debug-wrapper-macro
+ (tinypath-external-helper-call
+ (current-buffer)
+ (tinypath-external-setup-1-main)
+ 'debug)))
+
+;;}}}
+;;{{{ Misc
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypath-load-copy-get (&optional property)
+ "Return value of `tinypath-:original-load-path-after-load'.
+Optionally from PROPERTY."
+ (if property
+ (get 'tinypath-:original-load-path-after-load property)
+ tinypath-:original-load-path-after-load load-path))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypath-load-copy-now (&optional property)
+ "Save `load-path' to `tinypath-:original-load-path-after-load'.
+Optionally save the value to PROPERTY."
+ (if property
+ (put 'tinypath-:original-load-path-after-load
+ property
+ load-path)
+ (setq tinypath-:original-load-path-after-load load-path)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypath-load-copy-equal-p ()
+ "Return non-nil if saved `load-path' copy has not changed."
+ (equal tinypath-:original-load-path-after-load load-path))
+
+;;; ----------------------------------------------------------------------
+;;; (tinypath-eval-after-load "woman" 'tinypath-insinuate-woman)
+;;;
+(defun tinypath-eval-after-load (file function)
+ "Simulate `eval-after-load'. load FILE and run FUNCTION."
+ (cond
+ ((not (fboundp 'eval-after-load)) ;; Older Emacs versions do not have this.
+ (and (load file 'noerr)
+ (funcall function)))
+ (t
+ ;; See after-load-alist
+ ;; ... If FILE is already loaded, evaluate FORM right now.
+ (eval-after-load file
+ (` (progn (funcall (quote (, function)))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-time-string (&optional time)
+ "Return TIME in ISO 8601 format YYYY-MM-DD HH:MM:SS"
+ (format-time-string "%Y-%m-%d %H:%M:%S" (or time (current-time))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-list-display (msg list &optional insert)
+ "Display MSG and LIST to *Messages* or INSERT.
+The MSG should contain %s format string to write each element."
+ (let* ((i 0)
+ (size 80000)) ;; 60k
+ ;; Without increasing the display size, all of the cached
+ ;; paths would not be seen. This could also be checked dynamically
+ ;; by computing <`length' of cache> x <approx. 120 characters display>
+ (when (and (null insert)
+ (< (tinypath-message-log-max-sym-value) size))
+ (tinypath-message-log-max-sym-set size))
+ (dolist (elt list)
+ (incf i)
+ (setq elt (if (stringp elt)
+ elt
+ (prin1-to-string elt)))
+ (setq elt (format (concat "%3d " msg) i elt))
+ (if insert
+ (insert elt "\n")
+ (message elt))))
+ (unless insert
+ (let* ((buffer (tinypath-message-get-buffer)))
+ (when buffer
+ (display-buffer buffer)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypath-suffixes (file)
+ "Return list of try suffixes for FILE. '(\".el\" \".elc\")."
+ (cond
+ ((string-match "\\.elc?$" file)
+ '(""))
+ (t
+ '(".el" ".elc"))))
+
+;;; ----------------------------------------------------------------------
+;;; We need this because we use advised `locate-library'
+;;;
+(defun tinypath-locate-library (file)
+ "Like `locate-library' FILE, but return list of paths."
+ (let (path-list
+ (suffix (tinypath-suffixes file))
+ path)
+ (dolist (dir load-path)
+ (setq dir (file-name-as-directory dir))
+ (dolist (postfix suffix)
+ (setq path (concat dir file postfix))
+ (when (file-exists-p path)
+ (pushnew path path-list :test 'string=))))
+ path-list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-byte-compile-file (file)
+ "Byte compile FILE is file name end to \".elc\"."
+ (when (and (stringp file)
+ (string-match "\\.el$" file))
+ (unless (byte-compile-file file)
+ (message "TinyPath: {ERROR] Byte compile failed for %s" file)
+ (delete-file (concat file "c")))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-cache-duplicate-report-ignore-function (file)
+ "Ignore from output in XEmacs _pkg.el and the like."
+ ;; In XEmacs there are lot of these pkg files.
+ (string-match
+ "\\(auto-autoloads\\|_pkg\\|custom-load\\|load-path\\)\\.el"
+ file))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-maybe-warn-message-log-max ()
+ "Print message if Message-Log size is too small.
+Too small value would prevent debugging tinypath.el."
+ (let* ((size 20000)
+ now)
+ (setq now
+ (symbol-value (tinypath-message-log-max-sym)))
+ (when (and (> tinypath-:verbose 9)
+ ;; Value `t' is for unlimited size.
+ (or (not (eq t now))
+ (and (integerp now)
+ (and (< now size)))))
+ (message
+ (concat "TinyPath: Possibly can't display all logs. Increase "
+ (symbol-name
+ (tinypath-message-log-max-sym))))
+ (sit-for 2))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypath-file-compressed-p (file)
+ "Check if FILE includes a comression extension."
+ (string-match "\\.\\(gz\\|[Zz]\\|bz2\\)$" file))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-use-compression ()
+ "Load jka-compr.el safely."
+ (or (featurep 'jka-compr)
+ (let ((file (or (tinypath-cache-p "jka-compr")
+ (locate-library "jka-compr")
+ (error "\
+TinyPath: [PANIC] Can't find Emacs core library jka-cmpr.el."))))
+ (if (fboundp 'ad-Orig-load)
+ (tinypath-ti::funcall 'ad-Orig-load file)
+ (load file))
+ ;; New X/Emacs releases need this
+ (cond
+ ((fboundp 'auto-compression-mode) ;; New Emacs: jka-compr.el
+ ;; symbol-function suppresses Byte compiler messages
+ (funcall (symbol-function 'auto-compression-mode) 1))
+ ((fboundp 'jka-compr-install)
+ (tinypath-ti::funcall 'jka-compr-install))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypath-use-compression-maybe (file)
+ "Use compression if FILE includes a compressed file extension."
+ (or (featurep 'jka-compr)
+ (when (tinypath-file-compressed-p file)
+ (tinypath-use-compression))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-cache-warn-if-not-exist (file)
+ "Print message if FILE does not exist."
+ (when (stringp file)
+ (tinypath-use-compression-maybe file))
+ (when (null (let (ret)
+ (dolist (ext '("" ".el" ".elc"))
+ (when (file-exists-p (concat file ext))
+ (setq ret t)
+ (return)))
+ ret))
+ (message
+ (substitute-command-keys
+ (format
+ "TinyPath: CACHE invalid. The cached file does not exist %s \
+Please run \\[tinypath-cache-regenerate]"
+ file)))
+ (sleep-for 1)
+ t))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-file-extension-compressed (&optional list)
+ "Append `tinypath-:compressed-file-extensions' to each element in LIST.
+If `tinypath-:compression-support' is nil, then do nothing and return nil."
+ (let* (ret)
+ (dolist (elt (or list '("")))
+ (when (stringp elt)
+ ;; `nreverse' is due to `push' which would change the order
+ (dolist (ext (reverse tinypath-:compressed-file-extensions))
+ (when (stringp ext)
+ (push (concat elt ext) ret)))))
+ (nreverse ret)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-file-extension-list (package)
+ "Return possible extensions to search for PACKAGE. This function is used
+only once to return the search extension list to the cache function. The
+list is reused internally and chhanging
+`tinypath-:compressed-file-extensions' afterward in running Emacs has no
+effect."
+ ;; See `tinypath-suffixes'
+ (cond
+ ((string-match "\\.elc$" package)
+ (append '(".elc")
+ (tinypath-file-extension-compressed '(".elc"))))
+ ((string-match "\\.el$" package)
+ (append '(".el")
+ (tinypath-file-extension-compressed '(".el"))))
+ ((string-match "\\(z\\|bz2\\)$" package)
+ nil)
+ (t
+ (let* (ret)
+ ;; The correct order is ELCs first then EL.
+ ;; The list is built in reverse order here.
+ (setq ret (tinypath-file-extension-compressed '(".el")))
+ (push ".el" ret)
+ (dolist (elt (tinypath-file-extension-compressed '(".elc")))
+ (push elt ret))
+ (push ".elc" ret)
+ ret))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-file-extension-list-choices ()
+ "Return list of choices to search.
+ '((el . (list)) (elc . (list)) (nil . (list)))."
+ (let* (
+ ;; As a fall back, should we search .el choices if .elc
+ ;; choices fail
+ (elc (append (tinypath-file-extension-list "package.elc")
+ (tinypath-file-extension-list "package.el")))
+ (el (tinypath-file-extension-list "package.el"))
+ (all (tinypath-file-extension-list "package")))
+ (list
+ elc
+ el
+ (cons nil all))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-file-remove-trailing-slash (path)
+ "Remove trailing slashes, unless it is a Win32 root dir f:/"
+ (unless (string-match "^[a-z]:[\\/]$" path)
+ (if (string-match "^\\(.*\\)[\\/]$" path)
+ (setq path (match-string 1 path))))
+ path)
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-emacs-lisp-file-list (&optional from-cache)
+ "Return only lisp file alist (file . path) from `tinypath-:cache'.
+With optional parameter FROM-CACHE, use the latest cached value.
+Be warned, this may not be the absolute latest."
+ (let* ((id "tinypath-emacs-lisp-file-list")
+ list
+ save)
+ (when from-cache
+ (setq list (get 'tinypath-emacs-lisp-file-list 'cache)))
+
+ (unless tinypath-:cache
+ (message "%s: [ERROR] `tinypath-:cache' is nil." id))
+
+ (unless list
+ (setq save t)
+ (dolist (elt tinypath-:cache)
+ (when (string-match "\\.el.?$" (car elt))
+ (push (cons (car elt) (cdr (nth 1 elt)))
+ list))))
+
+ (if save
+ (put 'tinypath-emacs-lisp-file-list 'cache list))
+
+ list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-emacs-lisp-file-list-cache-clear ()
+ "Clear cache kept by `tinypath-emacs-lisp-file-list'."
+ (put 'tinypath-emacs-lisp-file-list 'cache nil))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-directory-list-clean (list &optional list-name)
+ "Clean LIST for anything suspicious: non-directories, non-strings.
+If you have moved directories from one place to another or some program has
+added entries to it, it is possible that LIST is \"fragmented\".
+
+- Remove non-strings, possibly (nil t) values.
+- Expand all directories. In Win32, `downcase' every path.
+- Convert to use only forward slashes.
+- Remove trailing slashes.
+- Remove duplicate paths.
+- Remove non existing paths
+
+Input:
+
+ LIST List, List of directories
+ LIST-NAME String, The name of variable for debug."
+ (let* (new-path)
+ (or list-name
+ (setq list-name ""))
+ (dolist (path list)
+ (cond
+ ((not (stringp path))
+ (tinypath-verbose-macro 5
+ (message "TinyPath: %s cleaned, NON-STRING ENTRY %s"
+ list-name
+ (prin1-to-string path))))
+ ((not (file-directory-p path))
+ (tinypath-verbose-macro 5
+ (message "TinyPath: [WARN] %s cleaned, directory does not exist %s"
+ list-name path)))
+ (t
+ ;; This will also convert all paths to forward slashes
+ ;; and downcase them in win32
+ (setq path (tinypath-expand-file-name path))
+ ;; Remove trailing slashes, unless it is a Win32 root dir like C:/
+ (setq path (tinypath-file-remove-trailing-slash path))
+ (tinypath-verbose-macro 7
+ (message "TinyPath: %s added %s" list-name path))
+ (pushnew path new-path :test 'string=))))
+ (nreverse new-path)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-find-dir (file dir-list)
+ "Search DIR-LIST and return directory when FILE is found.
+If FILE is nil, then return first existing directory in DIR-LIST.
+
+Note: directory list passed can contain non-string entries. They are ignored."
+ (let* (ret)
+ (dolist (dir dir-list)
+ (when (stringp dir)
+ (when (string-match "[/\\]$" dir) ;Remove trailing slash
+ (setq dir (substring dir 0 (1- (length dir)) )))
+ (when (file-exists-p
+ (concat (file-name-as-directory dir)
+ (or file "")))
+ (setq ret (tinypath-expand-file-name dir))
+ (return))))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypath-path-ok-this-emacs-p (path)
+ "Check that /emacs path is for Emacs and /xemacs path is for XEmacs.
+Return t if path is ok for current Emacs."
+ (let* ((no-emacs-regexp (if (inline tinypath-:xemacs-p)
+ ".*[/\\]emacs"
+ ".*[/\\]xemacs"))
+ (this-emacs-regexp (if (inline tinypath-:xemacs-p)
+ ".*[/\\]xemacs"
+ ".*[/\\]emacs"))
+ (correct-emacs t)
+ len1
+ len2)
+ (when (string-match no-emacs-regexp path)
+ (setq len1 (length (match-string 0 path)))
+ ;; If path contains both the word Emacs and XEmacs, then it
+ ;; is hard to know if this is invalid or not
+ ;;
+ ;; /usr/local/share/bin/emacs/xemacs/xemacs-21.2
+ ;; /usr/local/share/bin/emacs/emacs/emacs-20.3
+ ;;
+ (when (string-match this-emacs-regexp path)
+ (setq len2 (length (match-string 0 path)))
+ (tinypath-verbose-macro 7
+ (message "TinyPath: PATH-NOK both emacs versions in path?? %s" path)))
+ (when (or (null len2)
+ (< len2 len1)) ;; the correct Emacs name must be LAST
+ (setq correct-emacs nil)
+ (tinypath-verbose-macro 7
+ (message "TinyPath: PATH-NOK WRONG EMACS %s" path))))
+ correct-emacs))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypath-path-ok-p (path)
+ "Check if path is accepted with `tinypath-:load-path-ignore-regexp'."
+ (when (and (stringp path)
+ (tinypath-path-ok-this-emacs-p path))
+ (cond
+ ;; .................................................... directory ...
+;;; Checked already in `tinypath-directory-list-clean'.
+;;; ((not (file-directory-p path))
+;;; (tinypath-verbose-macro 5
+;;; (message "TinyPath: PATH-NOK dir does not exist: %s"
+;;; path))
+;;; nil)
+;;; ;; ................................................ ignore regexp ...
+ ((and (stringp tinypath-:load-path-ignore-regexp)
+ (string-match "[ \t\r\n]" tinypath-:load-path-ignore-regexp)
+ (let (case-fold-search)
+ (string-match tinypath-:load-path-ignore-regexp path)))
+ (tinypath-verbose-macro 3
+ (message
+ (concat "TinyPath: PATH-NOK tinypath-:load-path-ignore-regexp "
+ "matches [%s] (ignored) %s")
+ (match-string 0 path) path))
+ nil)
+ ;; ...................................................... symlink ...
+ ((file-symlink-p path)
+ (tinypath-verbose-macro 5
+ (message "TinyPath: PATH-NOK symlink (ignored) %s" path))
+ nil)
+ ;; ................................................ non-core path ...
+ ((let (ver)
+ (and (setq ver (car-safe (tinypath-emacs-versions 'noerr 'cache)))
+ ;; It looks like core path ....
+ (tinypath-emacs-core-path-p path)
+ ;; But it's not for this emacs VERSION
+ (not (tinypath-emacs-core-path-p path ver))))
+ (tinypath-verbose-macro 5
+ (message "TinyPath: PATH-NOK non-core path (ignored) %s" path))
+ nil)
+ ;; ........................................................... ok ...
+ (t
+ t))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-directory-lisp-p (path)
+ "Check if directory has any files matching regexp `\\.elc?'."
+ (cond
+ ((not (stringp path))
+ (tinypath-verbose-macro 5
+ (message "TinyPath: [error] directory entry %s" (prin1-to-string path))))
+ ((not (file-directory-p path))
+ (tinypath-verbose-macro 5
+ (message "TinyPath: [error] directory not found %s" path)))
+ (t
+ (dolist (elt (directory-files path))
+ (when (string-match "\\.elc?" elt)
+ (return t))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-subdirectory-list (path)
+ "Return all subdirectories under PATH."
+ (let* (list)
+ (dolist (elt (directory-files path 'absolute) )
+ (when (and (not (string-match "\\.\\.?$" elt)) ;; skip . and ..
+ (file-directory-p elt)) ;; take only directories
+ (push elt list)))
+ list))
+
+;;}}}
+;;{{{ autoload and other system help functions
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-self-location-load-history ()
+ "Return `load-history' entry"
+ (let* (file)
+ (dolist (elt load-history)
+ (setq file (car elt))
+ (when (and (stringp file)
+ (setq file (tinypath-expand-file-name file))
+ (string-match "^\\(.+\\)[\\/]tinypath\\." file))
+ (return (match-string 1 file))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-self-location ()
+ "If package was loaded with absolute path, return path.
+Uses `load-history' and `load-path' information."
+ (let* ((ret (tinypath-self-location-load-history)))
+ (unless ret ;; No luck with load-history, try load-path
+ (dolist (path load-path)
+ (setq path (file-name-as-directory (expand-file-name path)))
+ (when (or (and (file-exists-p (concat path "tinypath.el"))
+ path)
+ (and (file-exists-p (concat path "tinypath.elc"))
+ path)
+ (and (file-exists-p (concat path "tinypath.el.gz"))
+ path))
+ (return (setq ret path)))))
+ (unless ret
+ (message
+ (concat
+ "TinyPath: SELF NOTE tinypath.el was not loaded"
+ "\tusing absolute path."
+ "\t(load \"~/some/absolute/path/tinypath.el\")"))
+ (message "TinyPath: SELF %s" (or ret "<no load-history>" )))
+ ;; tinypath-* function is XEmacs and Emacs compatible version
+ ;; and ensures that forward slashes are used.
+ (and ret
+ (setq ret (tinypath-expand-file-name ret)))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-autoload-file-name (function)
+ "Load package if FUNCTION is in autoload state."
+ (let* ((str (prin1-to-string (symbol-function function))))
+ (when (string-match "^(autoload[ \t]+\"\\([^\"]+\\)" str)
+ (setq str (match-string 1 str))
+ ;; there is one problem. prin1-to-string doubles every backslash
+ ;; c:\\\\dir\\\\ ... (XEmacs problem)
+ (if (string-match "/" str)
+ str
+ (let* ((final ""))
+ ;; It's easier and faster to do this in buffer, than
+ ;; parsing STRING
+ (tinypath-with-temp-buffer
+ (insert str)
+ (goto-char (point-min))
+ (while (re-search-forward "\\([^\\]+\\)" nil t)
+ (setq final (concat
+ final
+ (match-string 1)
+ "/"))))
+ ;; remove trailing "/"
+ (substring final 0 (1- (length final))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-autoload-require (function &optional noerr nomsg)
+ "Load package if FUNCTION is in autoload state.
+NOERR NOMSG are parameters to `load'."
+ (let* ((file (tinypath-autoload-file-name function)))
+ (when file
+ (load file noerr nomsg))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-admin-remove-matching (path)
+ "Remove PATH from `load-path' and add to `tinypath-:load-path-ignore-regexp'."
+ (let ((fid "tinypath-admin-remove-matching"))
+ ;; Initially the idea was that the entries were purged fom cache too, but
+ ;; looping and reconstructing it takes too much time.
+ ;;
+ ;; It's more efficient to disable packages by using regexps in
+ ;; tinypath-:load-path-ignore-regexp, although this is not as transparent.
+ ;;
+ ;; --> #todo: Add better functionality to perl code.
+
+ ;; Kill second level cache which "remembers" paths.
+ (setq tinypath-:cache-level-two nil)
+
+ (setq path (regexp-quote (tinypath-expand-file-name path)))
+ (tinypath-load-path-remove path)
+ (tinypath-load-path-remove-cache path)
+
+ (message "TinyPath: %s adding to tinypath-:load-path-ignore-regexp [%s]"
+ fid path)
+
+ (cond
+ ((not (stringp tinypath-:load-path-ignore-regexp))
+ (setq tinypath-:load-path-ignore-regexp path))
+ ((not (string-match path tinypath-:load-path-ignore-regexp))
+ (setq tinypath-:load-path-ignore-regexp
+ (concat tinypath-:load-path-ignore-regexp
+ "\\|" path))))))
+
+;;}}}
+;;{{{ External: emacs-util.pl
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-external-output-parse-1-cache ()
+ "Parse files in format `tinypath-:cache'."
+ (let* ((i 0)
+ (personal-count 0) ;; User files 0 .. 2000
+ (other-count 2000)
+ (emacs-count 5000)
+ (font-lock-mode nil)
+ (lazy-lock-mode nil)
+ (regexp (concat "^LISP-FILE[ \t]+"
+ "\\("
+ "\\([^ \t\r\n]+[\\/]\\)"
+ "\\([^ \t\r\n]+\\)"
+ "\\)"))
+ path
+ dir
+ file
+ emacs
+ other
+ personal
+ elt)
+ (goto-char (point-min))
+ (while (re-search-forward regexp nil t)
+ (setq path (match-string 1)
+ dir (match-string 2)
+ file (match-string 3))
+ ;; was: (tinypath-path-ok-p dir) , but now perl does
+ ;; the checking
+ (when t
+ ;; (set-text-properties 0 (length dir) nil dir)
+ ;; (set-text-properties 0 (length file) nil file)
+ (incf i)
+ (when (zerop (% i 10))
+ (tinypath-verbose-macro 2
+ (message "TinyPath: EXT Caching files... %d %s" i path)))
+ ;; data structure is ("file.el" (1 . "/home/foo/elisp/"))
+ ;;
+ ;; The reason why we put paths to separate lists is that
+ ;; OTHER directories must override the Core Emacs paths,
+ ;; so that newest files are found. Usually you can download
+ ;; newer versions than what Emacs has.
+ (cond
+ ((tinypath-load-path-emacs-distribution-p path)
+ (incf emacs-count)
+ (setq elt (list file (cons emacs-count dir)))
+ (push elt emacs))
+ ((tinypath-load-path-personal-p path)
+ (incf personal-count)
+ (setq elt (list file (cons personal-count dir)))
+ (push elt personal))
+ (t
+ (incf other-count)
+ (setq elt (list file (cons other-count dir)))
+ (push elt other)))))
+ (append (nreverse personal) (append other emacs))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-external-output-parse-1 (id)
+ "Parse ID from current buffer. See `tinypath-external-helper'."
+ (let* ((case-fold-search t)
+ (regexp (concat "^" id "[ \t]+\\([^ \t\r\n]+\\)"))
+ string
+ list)
+ (goto-char (point-min))
+ (while (re-search-forward regexp nil t)
+ (setq string (match-string 1))
+ ;; (set-text-properties 0 (length string) nil string)
+ (push string list))
+ (unless list
+ (tinypath-verbose-macro 1
+ (message "TinyPath: EXT PARSE FATAL (id %s)\n" id)))
+ list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-external-output-parse-main ()
+ "Parse current buffer. See'`tinypath-external-helper'."
+ (let* (list
+ data
+ name)
+ ;; Speedier processing
+ (buffer-disable-undo)
+ ;; Clear text properties so that the data structures are clean
+ ;; and possibly faster to use
+ (set-text-properties (point-min) (point-max) nil)
+ (tinypath-verbose-macro 5
+ (message "TinyPath: EXT OUTPUT \n%s\n" (buffer-string)))
+ ;; This list of symbols is same as the prefix string from
+ ;; the perl script:
+ ;;
+ ;; LISP-FILE filename-here
+ ;; LISP-DIR filename-here
+ ;; ...
+ (dolist (id '(info
+ bin
+ man
+ lisp-dir
+ c-src-dir))
+ (setq name (symbol-name id)
+ data (tinypath-external-output-parse-1 name))
+ (if (null data)
+ (tinypath-verbose-macro 3
+ (message "TinyPath: EXT PARSE ERROR [%s]" name))
+ (push (cons id data) list)))
+ ;; 'cache (lisp-files) handling is different. Do it now
+ (let ((data (tinypath-external-output-parse-1-cache)))
+ (if data
+ (push (cons 'cache data) list)))
+ list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-external-bin-location (file)
+ "Return location of BINARY. Look from the installation dir.
+Look up `exec-path' and the kit installation directory. See
+Manual \\[tinypath-version] for more."
+ (let* ((path (tinypath-executable-find file))
+ (ret path)
+ self)
+ (when (and (null path)
+ (setq self (tinypath-self-location)))
+ ;; PATH/to/.../lisp/tiny/<tinypath.el>
+ ;; |
+ ;; |
+ ;; /bin/emacs-util.pl
+ (setq self (tinypath-expand-file-name self))
+ (setq self
+ (concat
+ (file-name-as-directory self)
+ ;; PATH/to/lisp/files/<tinypath.el>
+ "../../bin/"
+ file))
+ (if (file-exists-p self)
+ (setq ret self)))
+ (tinypath-verbose-macro 3
+ (message "TinyPath: EXT bin location %s" ret))
+ (when (and ret
+ (not (file-exists-p ret)))
+ (message "TinyPath: EXT FATAL, bin location is wrong %s" ret)
+ (setq ret nil))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-external-helper-call (buffer path-list &optional debug)
+ "Use external helper Perl script if available.
+First, Environment must contain perl executable and second
+`tinypath-:external-util-bin' must be along path.
+
+Input:
+
+ BUFFER Where to output.
+ PATH-LIST list of root directories to search.
+ DEBUG Request debug.
+
+Return:
+
+ t If external utility was found and called."
+ (let* ((file tinypath-:external-util-bin)
+ (perl (tinypath-executable-find-binary "perl"))
+ (bin (tinypath-external-bin-location
+ tinypath-:external-util-bin))
+ (opt (or path-list
+ (error "TinyPath: path-list is empty.")))
+ (ignore tinypath-:load-path-ignore-regexp))
+ (tinypath-verbose-macro 3
+ (message "TinyPath: EXT perl location %s" (or perl "<not found>")))
+ (tinypath-verbose-macro 3
+ (message "TinyPath: EXT exec-path %s %s" file (or bin "<not found>")))
+ (when debug
+ (push "3" opt)
+ (push "--debug" opt))
+ (when (and tinypath-:win32-p
+ (not tinypath-:win32-cygwin-p))
+ (push "no-symlinks" opt)
+ (push "--scan-type" opt))
+ (setq ignore
+ (concat
+ (or ignore "")
+ (if (stringp ignore)
+ "\\|" "")
+ (if tinypath-:xemacs-p
+ "[/\\]emacs"
+ "[/\\]xemacs")))
+ (dolist (switch (list
+ "--Info"
+ "--Man"
+ "--Bin"
+ "--Lang-lisp-file"
+ "--Lang-lisp-dir"
+ "--Lang-c-src-dir"
+ ignore
+ "--ignore-emacs-regexp"))
+ ;; These will go to the beginning, which is ok.
+ (push switch opt))
+ (push bin opt)
+ (when debug
+ ;; If Emacs hangs, at least we know how the external command was called.
+ (find-file "~/emacs-debug-tinypath.log")
+ (erase-buffer)
+ (insert (pp opt))
+ (save-buffer))
+ (if (null (and perl bin))
+ (tinypath-verbose-macro 5
+ "TinyPath: EXT ERROR Can't call external utility")
+ (message "TinyPath: EXT Process running... [please wait] %s"
+ (mapconcat 'identity opt " "))
+ (with-current-buffer buffer
+ (apply 'call-process
+ perl
+ nil
+ (current-buffer)
+ nil
+ opt)
+ (tinypath-verbose-macro 9
+ (message
+ (concat "\nTinyPath: EXT OUTPUT END\n")))
+ (message "TinyPath: EXT done %s" bin)
+ t))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-external-helper-main (path-list)
+ "Call external helper with PATH-LIST and parse output.
+
+Return:
+
+ '((info . (path path ..))
+ (man . (path path ..))
+ (bin . (path path ..))
+ (lisp . (path path ..))
+ (cache . <FORMAT EQUALS TO TINYPATH-:CACHE>))."
+ (tinypath-with-temp-buffer
+ (when (tinypath-external-helper-call (current-buffer) path-list)
+ (tinypath-external-output-parse-main))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-external-setup-1-main ()
+ "Return paths to pass to external program."
+ (let (list)
+ (dolist (elt (list
+ ;; load-path must not be there, because it may be already
+ ;; populated from the cache file: the one that we are
+ ;; trying to build from fresh.
+ ;;
+ ;; -> do not add `load-path' to returned list
+ ;;
+ ;; But we can add the original load path which were
+ ;; saved at startup.
+ tinypath-:extra-path-root
+ tinypath-:original-load-path
+ tinypath-:load-path-root
+ (tinypath-Info-default-directory-list)))
+ (dolist (path elt)
+ (when (and (stringp path)
+ (not (string-match "^[ \t]+$" path))
+ (file-directory-p path))
+ (push (tinypath-expand-file-name path) list))))
+ list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-external-setup-cache (data)
+ "Set `tinypath-:cache from DATA '((cache (DATA) ..)."
+ (let* ((list (assq 'cache data)))
+ (when list
+ (setq list (cdr list))
+ (setq tinypath-:cache list))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypath-external-setup-1-load-path (path regexp)
+ "Add PATH to `load-path'. Use REGEXP to check validity."
+ ;; The perl program recursed ALL directories, but we only
+ ;; want to find out lisp dirs that USER requested in
+ ;; `load-path' and `tinypath-:load-path-root'
+ ;;
+ ;; lisp-roots is a lookup string "PATH\\|PATH\\|PATH .."
+ ;; which we can use to check if path is accepted
+ ;;
+ (cond
+ ((not (string-match regexp path))
+ (tinypath-verbose-macro 5
+ (message "TinyPath: PATH-NOK not candidate %s" path)))
+ ((tinypath-path-ok-p path)
+ (pushnew path load-path :test 'string=))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypath-external-setup-1-man-path (path)
+ "Add PATH to `tinypath-:extra-manpath'."
+ (when (or (not (stringp
+ tinypath-:manpath-ignore-regexp))
+ (not (string-match
+ tinypath-:manpath-ignore-regexp
+ path)))
+ (pushnew path tinypath-:extra-manpath :test 'string=)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-external-load-path-lookup-regexp ()
+ "Return candidate `load-path' lookup regexp.
+This is combination of `load-path' and `tinypath-:load-path-root'."
+ (let* ((lisp-roots (append load-path
+ tinypath-:load-path-root)))
+ ;; Make lookup regexp
+ (mapconcat
+ (function
+ (lambda (x)
+ (regexp-quote
+ (tinypath-expand-file-name x))))
+ lisp-roots
+ "\\|")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-external-setup-parse-data (data)
+ "Parse external tool's DATA structure."
+ (let* ((lisp-lookup (tinypath-external-load-path-lookup-regexp))
+ correct-emacs
+ type)
+ (when data
+ (dolist (elt data)
+ (setq type (car elt))
+ (dolist (path (cdr elt))
+ ;; 'cache element is not a string.
+ (when (stringp path)
+ (setq correct-emacs
+ (tinypath-path-ok-this-emacs-p path)))
+ (cond
+ ((equal type 'cache)
+ (return)) ;; Not handled in this loop
+ ((and (equal type 'lisp-dir)
+ correct-emacs)
+ (tinypath-external-setup-1-load-path path lisp-lookup))
+ ((equal type 'man)
+ (tinypath-external-setup-1-man-path path))
+ ((equal type 'c-src-dir)
+ (pushnew path
+ tinypath-:extra-ff-search-directories
+ :test
+ 'string=))
+ ((and (equal type 'bin)
+ correct-emacs)
+ (tinypath-exec-path-append path))
+ ((and (equal type 'info)
+ correct-emacs)
+ (tinypath-info-handler path)
+ (pushnew path
+ (tinypath-Info-default-directory-list)
+ :test
+ 'string=)))))
+ (tinypath-external-setup-cache data)) ;; When
+ (tinypath-verbose-macro 3
+ (message "TinyPath: EXT END tinypath-external-setup %s"
+ (if data
+ "[DATA OK]"
+ "[DATA NOK]")))
+ data))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-external-setup ()
+ "Use external tool to help setup emacs.
+See `tinypath-external-helper-main'."
+ (and
+ (setq tinypath-:external-data-structure
+ (tinypath-external-helper-main
+ (tinypath-external-setup-1-main)))
+ (tinypath-external-setup-parse-data
+ tinypath-:external-data-structure)))
+
+;;}}}
+;;{{{ Cache
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypath-cache-elt-fullpath (elt)
+ "Return full path t package from cache ELT."
+ ;; ("sgml-mode.el" (5359 . "d:/emacs-21.3/lisp/textmodes/")
+ (concat (cdr (nth 1 elt))
+ (car-safe elt)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypath-cache-elt-package (elt)
+ "Return package name from cache ELT."
+ (car-safe elt))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-cache-p-1-initialize ()
+ "Set internal extension cache."
+ (put 'tinypath-cache-p-1
+ 'extension-cache
+ (tinypath-file-extension-list-choices)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-cache-p-1-extensions (package)
+ "Return list of extensions for PACKAGE."
+ (unless (get 'tinypath-cache-p-1 'extension-cache)
+ (tinypath-cache-p-1-initialize))
+ (if (string-match "\\.elc?$" package)
+ (assoc (match-string 0 package)
+ (get 'tinypath-cache-p-1
+ 'extension-cache))
+ (cdr (assq nil
+ (get 'tinypath-cache-p-1
+ 'extension-cache)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-cache-p-1-new-cache-lookup
+ (package choices &optional regexp)
+ "Search PACKAGE and CHOICES from `tinypath-:cache'.
+Input:
+
+ PACKAGE vt100
+ CHOICES '(\"vt100\" \".el.gz\" \".el\" ...)
+ REGEXP If string, ignore files matching this regexp. E.g. '\.elc'."
+ (let* ((fid "tinypath-cache-p-1-new-cache-lookup")
+ (file package)
+ try
+ ret)
+ ;; Remove extension
+ (when (string-match "^\\(.*\\)\\(\\.elc?\\)$" package)
+ (setq file (match-string 1 package))
+ (tinypath-verbose-macro 10
+ (message "%s REMOVE EXTENSION %s" fid package)))
+
+ (dolist (elt choices)
+ (tinypath-verbose-macro 10
+ (message "%s trying... %s" fid (concat file elt)))
+ (setq try (concat file elt))
+ (when (and (or (null regexp)
+ (not (string-match regexp try)))
+ (setq elt (assoc try tinypath-:cache)))
+ (tinypath-verbose-macro 10
+ (message "%s ASSOC %s" fid (prin1-to-string elt)))
+ (setq ret elt)
+ (return)))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;; There used to be function `tinypath-cache-p-1-old' which
+;;; was first implementation and the new function was developed while
+;;; the "old" was trusted version.
+;;;
+(defun tinypath-cache-p-1-new-cache (package &optional no-special)
+ "Check if PACKAGE is in tinypath-:cache. Return PATH or nil.
+If package contains absolute directory part, return PACKAGE.
+
+The search order for unidentified package is:
+'(\".elc\" \".elc.bz2\" \".elc.gz\" \".el\" \".el.bz2\" \".el.gz\")
+
+Input:
+
+ PACKAGE file to find from cache.
+ NO-SPECIAL There is special handling for jka-compr which is never
+ checked for compressed file. Non-nil bypasses special
+ case handling.
+
+Return:
+
+ '(PATH CACHE-ELEMENT)"
+ (when tinypath-:cache
+ (let* ((fid "TinyPath: tinypath-cache-p-1-new-cache ")
+ (regexp1 tinypath-:ignore-file-regexp)
+ ;; These files are banned, although they were put to
+ ;; load-path or cache. Gnus version is one good example:
+ ;; The original Gnus from Emacs installation is not used
+ ;; if there is newer Gnus found.
+ (regexp2 tinypath-:load-path-ignore-regexp)
+ ;; (dir (file-name-directory package))
+ (choices (tinypath-cache-p-1-extensions package))
+ elt
+ ret)
+ (tinypath-verbose-macro 10
+ (message (concat fid
+ " CHOICES "
+ (prin1-to-string choices))))
+ (setq
+ ret
+ (catch 'done
+ (flet ( ;; First function
+ (path-name (ELT) ;; ELT = '("FILE.EL" (POS . "PATH"))
+ (when ELT
+ (concat (cdr (nth 1 ELT)) (car ELT) )))
+ ;; Second function
+ (throw-ignore
+ (ELT)
+ (cond
+ ((and ELT
+ (or (and (stringp regexp1)
+ (string-match regexp1
+ (car ELT)))
+ (and (stringp regexp2)
+ (let (case-fold-search)
+ (string-match regexp2
+ (cdr (nth 1 ELT)))))))
+ (tinypath-verbose-macro 10
+ (message "%s`ignore-file-regexp' %s"
+ fid
+ (car ELT)))
+ nil)
+ (ELT
+ (throw 'done (path-name ELT))))))
+ (tinypath-verbose-macro 10
+ (message (concat fid " ENTRY %s %s")
+ package
+ (prin1-to-string choices)))
+ (when (setq elt (assoc package tinypath-:cache))
+ (tinypath-verbose-macro 10
+ (message (concat fid "DIRECT HIT %s") package))
+ (throw-ignore elt))
+ ;; .................................................. search ...
+ (cond
+ ((and (null no-special)
+ (string-match "jka-compr" package))
+ ;; XEmacs 20.4 installs files under
+ ;; /usr/lib/xemacs-20.4/lisp and all the lisp file sources
+ ;; are in compressed format. This means, that we cannot load
+ ;; jka-compr.el.gz initially.
+ ;;
+ ;; This situation is evident if user has disabled the .elc
+ ;; loading with tinypath-:ignore-file-regexp
+ (setq regexp1 nil)
+ (tinypath-verbose-macro 10
+ (message (concat fid "SPECIAL CASE %s") package))
+ (setq elt
+ (or (and (not (string-match "\\.el$" package))
+ (assoc "jka-compr.elc" tinypath-:cache))
+ (assoc "jka-compr.el" tinypath-:cache)
+ (let ((cache
+ (tinypath-load-path-locate-library
+ "jka-compr.el")))
+ (when cache ;; Make it look like CACHE entry
+ (list "jka-compr.el"
+ (cons 1 (file-name-directory
+ cache)))))))
+ (unless elt
+ (error "TinyPath: (cache-p-1) FATAL, can't find %s"
+ package))
+ (throw 'done (path-name elt)))
+ ;; .......................................... regular files ...
+ ((not (string-match "\\.\\(g?z\\|bz2\\)$" package))
+ (throw-ignore (setq elt (tinypath-cache-p-1-new-cache-lookup
+ package choices regexp1))))))))
+ (tinypath-verbose-macro 9
+ (message "TinyPath: cache hit: %s [%s] %s"
+ package
+ (or ret "")
+ (prin1-to-string elt)))
+ (list ret elt))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-cache-p-1-new (package &optional no-special)
+ "Check if PACKAGE is in tinypath-:cache. Return PATH or nil.
+See `tinypath-cache-p-1-new-cache'.
+
+Paths with directory component are changed to plain PACKAGE
+searches. Like if searching:
+
+ term/vt100
+
+This is converted into search:
+
+ vt100"
+ ;; Do not search absolute paths
+ (let* ((fid "tinypath-cache-p-1-new "))
+ (tinypath-verbose-macro 10
+ (message "%s Searching for... %s" fid package))
+ (cond
+ ((not (stringp package))
+ (list nil nil))
+ ((string-match "^[/\\~]\\|^[A-Za-z]:" package)
+ (list package nil))
+ (t
+ (when (file-name-directory package)
+ (tinypath-verbose-macro 10
+ (message "%s %stry Searching plain PACKAGE.el" fid package))
+ (setq package (file-name-nondirectory package)))
+ (tinypath-cache-p-1-new-cache package no-special)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypath-cache-p-1 (package)
+ "Call correct cache implementation."
+ (tinypath-cache-p-1-new package))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-cache-p-2 (package)
+ "Check if PACKAGE is in `tinypath-:cache'. Return PATH or nil.
+If PACKAGE contains a path name, return PACKAGE."
+ (let (list
+ level2
+ elt
+ elt2
+ ret)
+ (cond
+ ;; Nothing to do, Linux or Win32 absolute path name
+ ((string-match "^[/\\~]\\|^[A-Za-z]:" package)
+ (setq ret package))
+ ((file-name-directory package)
+ ;; look up "package" first, because it is most
+ ;; likely known to cache, only then "dir/package"
+ (setq list
+ (list (file-name-nondirectory package)))
+ ;; 2003-15-18 disabled looking term/vt100
+ ;; because, it should be found from cache with
+ ;; simple name "vt100".
+ ;; package
+ nil)
+ (t
+ (setq list (list package))))
+ (dolist (file list)
+ (setq elt nil
+ elt2 nil
+ level2 nil)
+ (cond
+ ;; If level two cache exists, then check that the entry has not
+ ;; been resolved before.
+ ((and tinypath-:cache-level-two
+ (setq elt2 (assoc file tinypath-:cache-level-two))
+ (setq ret (cdr elt)))
+ (setq level2 t))
+ (t
+ (and (setq elt (tinypath-cache-p-1 file))
+ (setq ret (car elt)))))
+ ;; Did cache hold the information?
+ (cond
+ ((null ret))
+ ((and (stringp ret)
+ (file-exists-p ret))
+ (unless level2
+ ;; This was not in level 2, put it these
+ (push (cons package ret) tinypath-:cache-level-two))
+ (return))
+ (ret
+ ;; Invalid cache entry, file does not exist any more.
+ (tinypath-verbose-macro 3
+ (tinypath-cache-warn-if-not-exist ret))
+ ;; Remove from both caches
+ (when elt
+ (setq tinypath-:cache (delq (cadr elt) tinypath-:cache)))
+ (when elt2
+ (setq tinypath-:cache-level-two
+ (delq elt2 tinypath-:cache-level-two))))))
+ (when (null ret)
+ ;; Do full scan.
+ (setq ret (tinypath-load-path-locate-library package))
+ (when (and ret
+ (file-exists-p ret))
+ ;; Mark tesese entries with "zero" position: They have
+ ;; been found later on while Emacs is running.
+ (push (cons package ret) tinypath-:cache-level-two)
+ (push (list (file-name-nondirectory ret)
+ (cons 0 (file-name-directory ret)))
+ tinypath-:cache)))
+
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-cache-p (package)
+ "Check if PACKAGE is in tinypath-:cache. Return PATH or nil.
+If package contains absolute directory part, return PACKAGE."
+ (if (string-match "^[~/\\]" package)
+ ;; Any absolute load paths are ignored by CACHE and returned
+ ;; as is, so ignore references like ~/.emacs
+ package
+ (tinypath-cache-p-2 package)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypath-cache-p-for-advice (file)
+ "If load-path and cache are the same, return cache lookup for FILE.
+This code is used in adviced function."
+ (if (tinypath-load-copy-equal-p)
+ (tinypath-cache-p file)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-cache-match-package (regexp &optional flag)
+ "Return cache elements whose package names match REGEXP.
+If FLAG is non-nil, return package names, not cache elements."
+ (let (list
+ name)
+ (dolist (elt tinypath-:cache)
+ (setq name (tinypath-cache-elt-package elt))
+ (cond
+ ((not (stringp name))
+ (message "TinyPath: [ERROR] invalid cache entry: %s"
+ (prin1-to-string elt)))
+ ((string-match regexp name)
+ (push (if flag
+ name
+ elt)
+ list))))
+ (nreverse list)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-cache-match-fullpath (regexp &optional flag)
+ "Return cache elements whose full path match REGEXP.
+If FLAG is non-nil, return package names, not cache elements."
+ (let (list
+ name)
+ (dolist (elt tinypath-:cache)
+ (setq name (tinypath-cache-elt-fullpath elt))
+ (cond
+ ((not (stringp name))
+ (message "TinyPath: [ERROR] invalid cache entry: %s"
+ (prin1-to-string elt)))
+ ((string-match regexp name)
+ (push (if flag
+ name
+ elt)
+ list))))
+ (nreverse list)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-cache-file-hostname ()
+ "Return `system-name'."
+ (downcase
+ (or (or (getenv "HOST") ;Unix
+ (getenv "COMPUTERNAME")) ;Win32
+ "unknownhost")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-cache-file-name ()
+ "Return Emacs version specific cache file.
+
+References:
+
+ `tinypath-:cache-file-prefix'.
+ `tinypath-:cache-file-postfix'"
+ (let* (host
+ (type (if tinypath-:xemacs-p
+ "xemacs"
+ "emacs"))
+ (list (tinypath-emacs-versions))
+ (ver (or (nth 1 list)
+ (nth 0 list)))
+ (win32 (if tinypath-:win32-p
+ "win32-"
+ ""))
+ (cygwin (if tinypath-:win32-cygwin-p
+ "cygwin-"
+ ""))
+ (host-func tinypath-:cache-file-hostname-function)
+ ret)
+ (when (and host-func
+ (functionp host-func))
+ (let (ret)
+ (setq ret (funcall host-func))
+ (tinypath-verbose-macro 3
+ (message "TinyPath: CACHE file host function returned %s"
+ (or ret "nil")))
+ (if (stringp ret)
+ (setq host ret))))
+ (setq ret
+ (concat tinypath-:cache-file-prefix
+ "-"
+ win32
+ cygwin
+ (if (stringp host)
+ (concat host "-")
+ "")
+ type
+ "-"
+ ver
+ tinypath-:cache-file-postfix))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-cache-file-name-compiled-p (file)
+ "Check if FILE matches \"\\\\.elc$\". Return non-compiled FILE."
+ (when (string-match "\\(^.+\\.el\\)c$" file)
+ (match-string 1 file)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-cache-file-name-all ()
+ "Return list of cache files.
+If `tinypath-:cache-file-postfix' is `\.elc', then return both
+compiled and non-compiled files."
+ (let* ((file (tinypath-cache-file-name))
+ (el (tinypath-cache-file-name-compiled-p file)))
+ (if el
+ (list file el)
+ (list file))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-cache-file-delete ()
+ "Delete cache file(s) from disk, if they exist."
+ (dolist (file (tinypath-cache-file-name-all))
+ (when (file-exists-p file)
+ (delete-file file)
+ (tinypath-verbose-macro 5
+ (message "TinyPath: Cache deleted: %s" file)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-cache-file-old-p (file)
+ "Return non-nil if FILE exists and is too old.
+References:
+ `tinypath-:cache-expiry-days'."
+ (when (and (file-exists-p file)
+ (integerp tinypath-:cache-expiry-days))
+ (let* ((days (tinypath-days-old file)))
+ (when (> days tinypath-:cache-expiry-days)
+ (tinypath-verbose-macro 2
+ (message "TinyPath: Cache is too old: %s days" days))
+ t))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-cache-file-write (file)
+ "Write state information to FILE."
+;;; (interactive "FFile to save cache: ")
+ (let* ((bytecomp (tinypath-cache-file-name-compiled-p file))
+ (write (or bytecomp file)))
+ (tinypath-verbose-macro 2
+ (message "TinyPath: Saving cache to %s" write))
+ (tinypath-ti::write-file-variable-state
+ write
+ (concat "Emacs load-path settings.\n"
+ ";; This file is automatically generated. Do not touch.\n"
+ ";; See tinypath.el and M-x tinypath-cache-regenerate.\n")
+ (list
+ 'load-path
+ 'exec-path
+ 'tinypath-:extra-manpath
+ 'tinypath-:extra-path-root
+ 'tinypath-:extra-ff-search-directories
+ (if (boundp 'Info-directory-list) ;; XEmacs
+ 'Info-directory-list
+ 'Info-default-directory-list)
+ 'tinypath-:cache)
+ 'no-pp-print 'no-backup)
+ ;; Only if name ends to "\.elc"
+ (if bytecomp
+ (tinypath-byte-compile-file bytecomp))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-cache-file-save ()
+ "Save cache file."
+ (tinypath-cache-file-write (tinypath-cache-file-name)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-cache-file-load ()
+ "Load cache."
+ (let* (stat)
+ (dolist (file (tinypath-cache-file-name-all))
+ (setq stat (file-exists-p file))
+ (tinypath-verbose-macro 2
+ (message "TinyPath: %sLoading cache file %s"
+ (if stat
+ ""
+ "[ERROR] ")
+ file))
+ (when stat
+ (load file)
+ (return)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-cache-file-find-file ()
+ "Display cache by calling `find-file'."
+ (interactive)
+ (let* ((file (tinypath-cache-file-name)))
+ (tinypath-verbose-macro 2
+ (message "TinyPath: find-file cache %s" file))
+ (find-file file)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-cache-file-need-sync-p ()
+ "Load cache. If cache needs synchronization, return non-nil."
+ (let* (ret
+ found)
+ ;; Using a simple variable is faster than
+ ;; checking (if load-path , because load-path may be very big
+ ;;
+ (if load-path
+ (setq found t))
+ (unless found
+ (setq ret 'cache-file-content-error)
+ (message "TinyPath: [ERROR] CACHE; empty load-path"))
+ (unless tinypath-:cache
+ (setq ret 'cache-file-content-error)
+ (message "TinyPath: [ERROR] CACHE; empty tinypath-:cache in"))
+ ;; Make sure that read cache is in synch with
+ ;; the `load-path'. If not, force rescanning.
+ (when (and found
+ (tinypath-load-path-not-in-synch-p 'fast-check))
+ (setq ret 'need-sync))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-cache-display (&optional insert)
+ "Display `tinypath:-cache' and `tinypath-:cache-level-two'.
+Optionally INSERT."
+ (interactive "P")
+ (if tinypath-:cache-level-two
+ (tinypath-list-display "tinypath-:cache-level-two %s"
+ tinypath-:cache-level-two insert)
+ (message "tinypath-:cache-level-two is empty, nothing to display."))
+ (tinypath-list-display "tinypath-:cache %s"
+ tinypath-:cache insert))
+
+;;}}}
+;;{{{ Info files
+
+(defconst tinypath-:info-file-basic-contents
+ (concat
+ "This is the file .../info/dir, which contains the\n"
+ "topmost node of the Info hierarchy, called (dir)Top.\n"
+ "The first time you invoke Info you start off looking at this node.\n"
+ "\1f\n"
+ "File: dir Node: Top\tThis is the top of the INFO tree\n"
+ "\n"
+ " This (the Directory node) gives a menu of major topics.\n"
+ " Typing \"q\" exits, \"?\" lists all Info commands, \"d\" returns here,\n"
+ " \"h\" gives a primer for first-timers,\n"
+ " \"mEmacs<Return>\" visits the Emacs manual, etc.\n"
+ "\n"
+ " In Emacs, you can click mouse button 2 on a menu item or cross reference\n"
+ " to select it.\n"
+ "\n"
+ "* Menu:\n\n")
+ "*This variable includes a basic `dir' file for Emacs info.
+Do not change.")
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-info-display (&optional insert)
+ "Display info path contents. Optionally INSERT.
+This would be `Info-directory-list' in XEmacs and
+`Info-default-directory-list' in Emacs."
+ (interactive "P")
+ (tinypath-list-display
+ (concat (if tinypath-:xemacs-p
+ "Info-directory-list"
+ "Info-default-directory-list")
+ " %s")
+ (tinypath-Info-default-directory-list)
+ insert))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-Info-default-directory-list-clean ()
+ "Clean `Info-default-directory-list'.
+Remove any suspicious elements: non-directories, non-strings."
+ (set (tinypath-Info-default-directory-list-sym)
+ (tinypath-directory-list-clean
+ (tinypath-Info-default-directory-list)
+ "Info-directory-list")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-write-region (beg end file)
+ "Write region BEG END to FILE and ignore errors, but print message."
+ (condition-case err
+ (write-region (point-min) (point-max) file)
+ (error
+ (tinypath-verbose-macro 3
+ (message "TinyPath: [INFO] No permission to write %s %s"
+ (or file "<nil>") (prin1-to-string err))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-info-files-in-directory (dir)
+ "Return all info files in DIR.
+The list is composed of capitalized names of the found files:
+
+ tar.info --> Tar
+ fileutils.info --> Fileutils
+
+Returned list in the above case is '(\"Tar\" \"Fileutils\")."
+ ;; Cache this value only once and reuse as needed.
+ (unless (get 'tinypath-info-files-in-directory
+ 'compress-extensions)
+ (put 'tinypath-info-files-in-directory
+ 'compress-extensions
+ (tinypath-file-extension-compressed)))
+ (let* ((files (directory-files dir))
+ (extensions (cons "" (get 'tinypath-info-files-in-directory
+ 'compress-extensions)))
+ ret)
+ (dolist (file files)
+ (when (catch 'exit
+ (dolist (ext extensions)
+ ;; NOTE: Can't use \\| in here, because posix match engine
+ ;; tries all possibilities and we want to stop after first
+ ;; matched regexp.
+ ;;
+ ;; File Examples:
+ ;;
+ ;; cc-mode-1
+ ;; eshell.info
+ ;;
+ (dolist (re '("^\\(.*\\)\\.info-1"
+ "^\\(.*\\)\\.info"
+ "^\\(.*\\)-1"))
+ (setq re (concat re ext "$"))
+ (when (string-match re file)
+ (throw 'exit file)))))
+ (pushnew (capitalize (downcase (match-string 1 file)))
+ ret
+ :test 'string=)))
+ (sort ret 'string-lessp)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-info-directory-entry-p (entry)
+ "Search for info ENTRY."
+ (let* ((point (point)) ;; Faster than using save-excursion.
+ ret)
+ (goto-char (point-min))
+ ;; This check relies on using the same ENTRY for filename
+ ;;
+ ;; * Oview: (Overview).
+ ;;
+ ;; But what if user manually edit's the file and makes it read:
+ ;:
+ ;; * Exim Oview: (Overview).
+ ;;
+ ;; Ok, handle that too, but require thet "Oview" is still there.
+ (when (and (goto-char (point-min))
+ (re-search-forward
+ (format "^[*]\\([ \t]+[^ \t\r\n]+\\)?[ \t]+%s:[ \t]+"
+ entry)
+ nil t)
+ (setq ret (point))))
+ (goto-char point) ;; Restore point
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-info-directory-contents-update
+ (file &optional verb interactive info-files)
+ "Update the central `dir' with all new info files in directory.
+Give the absolute path to the `dir' and the directory is scanned
+for new entries which are updated to file `dir'.
+
+Input:
+
+ FILE The `dir' file location
+ VERB Allow printing verbose messages
+ INTERACTIVE Leave the buffer in Emacs for editing.
+ INFO-FILES Info files in directory, like \"Eieio\"
+
+Return:
+
+ t if any changes made."
+
+ ;; (interactive "FInfo file named `dir', location: ")
+
+ (when (file-directory-p file)
+ (error "You must give a filename"))
+ (let ((buffer (find-file-noselect file))
+ done
+ buffer-file)
+ (with-current-buffer buffer
+ ;; If we read /usr/local/info and we're not root, then
+ ;; this buffer will be read only. Make it writable. The
+ ;; save error is handled elsewhere.
+ ;;
+ (setq buffer-read-only nil)
+ (tinypath-verbose-macro 1
+ (message "TinyPath: [INFO] found %s" file))
+ (let* ((entries (or info-files
+ (tinypath-info-files-in-directory
+ (file-name-directory file)))))
+ (dolist (entry entries)
+ (unless (tinypath-info-directory-entry-p entry)
+ (goto-char (point-max))
+ (unless (looking-at "^[\n\t ]*$")
+ (insert "\n"))
+ (insert (format "* %s: (%s).\n" entry entry))
+ (tinypath-verbose-macro 2
+ (message "TinyPath: [INFO] added entry `%s' to file %s"
+ entry file))
+ (setq done t)
+ (set-buffer-modified-p nil) ;; do not ask user when killing buffer
+ (setq buffer-file (buffer-file-name))))) ;; let*
+ (if (interactive-p)
+ (when done
+ (message "TinyPath: [INFO] Edit and verify changes at %s" file))
+ (when (and done buffer-file)
+ (tinypath-write-region (point-min) (point-max) buffer-file))
+ (when (buffer-live-p buffer)
+ (kill-buffer buffer)))) ;; With-current
+ done))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-info-file-DIR (path)
+ "Make `dir' file name using PATH."
+ (concat (file-name-as-directory path) "dir"))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-info-handler-DIR (dir)
+ "Handle creating/updating central info file DIR `dir' to current directory."
+ (let* ((dir-file (tinypath-info-file-DIR dir)))
+ (unless (file-exists-p dir-file) ;No central dir, generate one...
+ (tinypath-verbose-macro 3
+ (message "TinyPath: [INFO] missing central `dir' generating %s"
+ dir-file))
+ (tinypath-with-temp-buffer
+ (insert tinypath-:info-file-basic-contents)
+ (insert " "
+ (tinypath-expand-file-name dir)
+ "\n")
+ ;; maybe we don't have permission to write to this directory?
+ (tinypath-write-region (point-min) (point-max) dir-file)
+ t))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-info-handler (dir)
+ "Check if DIR contains info files and a special `dir' file.
+This function will create `dir' file if it does not exist,
+update `Info-default-directory-list' and add any new INFO entries in
+DIR to central `dir' file in that directory.
+
+Please suggest to the lisp package maintainer that he
+should ship with default `dir' in next release so that it
+could be automatically used.
+
+Return
+
+ t if any changes made."
+ (interactive "fGive directory with info files: ")
+ ;; If user calls us, make sure new files are also noticed.
+ ;;
+ (if (interactive-p)
+ (tinypath-info-initialize))
+ (let* ((list (tinypath-info-files-in-directory dir))
+ (dir-file (concat (file-name-as-directory dir) "dir"))
+ cleanup
+ done)
+ (when (and (null list)
+ (interactive-p))
+ (message "Tinypath: No info file candidates in %s" dir))
+ (when list ;info files in this directory?
+ (setq done (tinypath-info-handler-DIR dir))
+ (tinypath-info-directory-contents-update
+ dir-file
+ (interactive-p)
+ (interactive-p)
+ list)
+ (tinypath-verbose-macro 2
+ (message "TinyPath: [INFO] PUSH maybe => %s"
+ dir))
+ (tinypath-verbose-macro 5
+ (message
+ "TinyPath: [INFO] PUSH (before) Info-default-directory-list: %s"
+ (prin1-to-string (tinypath-Info-default-directory-list))))
+ ;; Always add found directories to the list.
+ ;; Notice, that directory may contain trailing slash, that's why
+ ;; two `member' tests
+ ;;
+ ;; ../info
+ ;; ../info/
+ ;;
+ (let* ((dir1 (file-name-as-directory dir)) ;; with slash
+ (dir2 (substring dir 0 (1- (length dir1)))) ;; without
+ (list (tinypath-Info-default-directory-list)))
+ (unless (or (member dir1 list)
+ (member dir2 list))
+ (tinypath-verbose-macro 2
+ (message
+ "TinyPath: [INFO] PUSH Info-default-directory-list => %s" dir2))
+ (setq cleanup t)
+ ;; This is efectively "(push dir2 <info-list>)"
+ (set (tinypath-Info-default-directory-list-sym)
+ (cons dir2 (tinypath-Info-default-directory-list)))
+ (tinypath-verbose-macro 5
+ (message
+ "TinyPath: [INFO] PUSH (after) Info-default-directory-list: %s"
+ (prin1-to-string (tinypath-Info-default-directory-list))))))
+ ;; Kill all previous info files from Emacs, so that next info
+ ;; C-h i will force Emacs to regenerate found new entries.
+ (when (or cleanup ;Added new directory
+ (interactive-p))
+ (tinypath-info-initialize)))
+ done))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-info-kill-buffers ()
+ "Kill all *info* buffers."
+ ;; - There may be hidden buffers that Emacs uses to gather
+ ;; all 'dir' files.
+ ;; - Kill also centeal buffer *info*
+ (dolist (buffer (buffer-list))
+ (when (string-match "^ info\\|^\\*info" (buffer-name buffer))
+ (kill-buffer buffer))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-info-initialize ()
+ "Initialize info to pristine state.
+After this function, the central `dir' creates all its parts from scratch
+and not from cached directories."
+ (interactive)
+ (tinypath-Info-default-directory-list-clean)
+ ;; - This must be set to nil, because otherwise Info would not
+ ;; rescan new entries.
+ (setq Info-dir-file-attributes nil)
+ (tinypath-info-kill-buffers))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-info-scan-Info-default-directory-list (&optional list)
+ "Examine and possibly fix LIST of dirs to `Info-default-directory-list'.
+Without any arguments, checks `Info-default-directory-list'
+and `tinypath-:Info-default-directory-list'.
+
+If there were any new entries or possibly new directory without
+and root INFO file `dir', Emacs info cache cache is deleted and
+existing *info* buffer if killed. You should run \\[info] to
+regenerate all the info parts again.
+
+Return
+
+ t if any changes made."
+ (interactive)
+ (let* (seen
+ done)
+ (or list
+ (setq list (append (tinypath-Info-default-directory-list)
+ tinypath-:Info-default-directory-list)))
+ (dolist (path list)
+ (unless (member path seen)
+ (push path seen)
+ (when (file-directory-p path)
+ (when (tinypath-info-handler path)
+ (setq done t)))))
+ (when (and done
+ (interactive-p))
+ (tinypath-cache-file-save))
+ (when done
+ (tinypath-info-initialize))
+ done))
+
+;;}}}
+;;{{{ Timing support
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-time-difference (a b)
+ "Calculate difference between times A and B.
+The input must be in form of '(current-time)'
+The returned value is difference in seconds.
+E.g., if you want to calculate days; you'd do
+
+\(/ (tinypath-time-difference a b) 86400) ;; 60sec * 60min * 24h"
+ (let ((hi (- (car a) (car b)))
+ (lo (- (car (cdr a)) (car (cdr b))))
+ (mic (- (car (cddr a)) (car (cddr b)))))
+ (+
+ (+ (lsh hi 16) lo)
+ (/ mic 1000000))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-time-results (buffer)
+ "Write load time results to BUFFER. Return buffer pointer."
+ (let* (time
+ min
+ sec)
+ (with-current-buffer (get-buffer-create buffer)
+ (erase-buffer)
+ (dolist (elt tinypath-:time-data)
+ (setq time (cdr elt)
+ min (/ time 60)
+ sec (- time (* min 60)))
+ (insert
+ (format "%-20s %d %dmin %dsec\n"
+ (car elt)
+ time
+ min
+ sec)))
+ (current-buffer))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-time-display ()
+ "Display timing information of each package loaded."
+ (interactive)
+ (display-buffer (tinypath-time-results tinypath-:time-buffer)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-time-record (package start-time)
+ "Record load time of PACKAGE, when START-TIME is known."
+ (when (stringp package)
+ (let* ((stop-time (current-time))
+ (file (file-name-nondirectory package))
+ (name (if (string-match "^.*\\(.*\\)\\.elc$" file)
+ (match-string 1 file)
+ file))
+ (diff (tinypath-time-difference stop-time start-time)))
+ (if tinypath-:verbose-timing
+ (message "TinyPath: load time %s %dsec" name diff)
+ (tinypath-verbose-macro 9
+ (message "TinyPath: load time %s %dsec" name diff)))
+ (aput 'tinypath-:time-data name diff))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinypath-time-macro 'lisp-indent-function 1)
+(put 'tinypath-time-macro 'edebug-form-spec '(body))
+(defmacro tinypath-time-macro (package &rest body)
+ "Record PACKAGE timing to `tinypath-:time-data' and run BODY."
+ (`
+ (let* ((start-time (current-time)))
+ (prog1
+ (progn (,@ body))
+ (tinypath-time-record (, package) start-time)))))
+
+;;}}}
+;;{{{ exec-path
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-exec-path-from-path ()
+ "Parse environment variable PATH."
+ (let ((path (getenv "PATH"))
+ (regexp (concat "[^" path-separator "]+"))
+ list)
+ (when path
+ (tinypath-with-temp-buffer
+ (insert path)
+ (goto-char (point-min))
+ (while (re-search-forward regexp nil t)
+ (push (match-string 0) list))))
+ (nreverse list)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-exec-path-append (path)
+ "Add PATH to `exec-path'.
+Add new PATH to the end, so that user's paths take precedence.
+Ignore path if it matches `tinypath-:exec-path-ignore-regexp'."
+ ;; expand - Otherwise `member' would not do much good (duplicates)
+ (setq path (tinypath-expand-file-name path))
+ (unless (member path exec-path)
+ (if (and (stringp tinypath-:exec-path-ignore-regexp)
+ (string-match
+ tinypath-:exec-path-ignore-regexp
+ path))
+ (tinypath-verbose-macro 3
+ (message "\
+TinyPath: PATH ignored by tinypath-:exec-path-ignore-regexp %s" path))
+ (setq exec-path (append exec-path (list path))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-exec-path-check ()
+ "Check if `exec-path' lack any directory as in PATH.
+Return missing paths."
+ (let* ( ;; (tinypath-directory-list-clean exec-path "exec-path"))
+ (exec exec-path)
+ (PATH (tinypath-directory-list-clean
+ (tinypath-exec-path-from-path)
+ "PATH"))
+ missing)
+ (dolist (path PATH)
+ (unless (or (member path exec)
+ ;; With trailing slash
+ (member (file-name-as-directory path) exec))
+ (push path missing)))
+ (nreverse missing)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-exec-path-check-verbose (&optional fix)
+ "Print messages if `exec-path' lacks any directory found in PATH.
+Optionally FIX by adding missing directories to the end."
+ (interactive)
+ (let ((missing (tinypath-exec-path-check)))
+ (when missing
+ (dolist (path missing)
+ (message "TinyPath: PATH check. `exec-path' does not include %s%s"
+ path
+ (if fix
+ " [fixed]"
+ ""))
+ (when fix
+ (tinypath-exec-path-append path))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-exec-path-check-verbose-fix ()
+ "Call `tinypath-exec-path-check-verbose' with argument 'fix."
+ (tinypath-exec-path-check-verbose 'fix))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-exec-path-clean ()
+ "Clean `exec-path' for anything suspicious: non-directories, non-strings."
+ (tinypath-verbose-macro 5
+ (message "TinyPath: tinypath-exec-path-clean."))
+ (setq exec-path (tinypath-directory-list-clean exec-path "exec-path")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-exec-path-display (&optional insert)
+ "Display `exec-path' by messaging' it. Optionally INSERT."
+ (interactive "P")
+ (tinypath-list-display "exec-path %s" exec-path insert))
+
+;;}}}
+;;{{{ load-path
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-load-path-emacs-distribution-p (path)
+ "Return non-nil if PATH is from Emacs distribution."
+ (string-match
+ (concat
+ "[/\\]x?emacs[/\\][0-9]+[0-9.]+[/\\]" ;; Unix emacs/20.7/
+ "\\|[/\\]x?emacs-[0-9]+[0-9.]+[/\\]") ;; win32 emacs-20.7/
+ path))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-load-path-personal-p (path)
+ "Return non-nil if PATH is under $HOME"
+ (string-match
+ (regexp-quote (expand-file-name "~"))
+ (expand-file-name path)))
+
+;;; ----------------------------------------------------------------------
+;;; (tinypath-load-path-search "gnus.el")
+;;;
+(defun tinypath-load-path-search (package &optional all include-all)
+ "Search `load-path' for PACKAGE and optioanlly ALL occurrances.
+This is the last resort if cache fails.
+
+INCLUDE-ALL says that tinypath-:load-path-ignore-regexp'
+is not used.
+
+Return
+
+ path Absolute path location
+ '(path ..) If option ALL was set."
+ (unless (get 'tinypath-cache-p-1 'extension-cache)
+ (tinypath-cache-p-1-initialize))
+ (let* (case-fold-search ;; Case sensitive match.
+ file
+ ret)
+ (tinypath-verbose-macro 5
+ (message
+ (concat
+ "TinyPath: [WARNING] Performance problem; `%s' caused "
+ "full load-path scan.")
+ package))
+ (dolist (dir load-path)
+ (when (and (stringp dir)
+ (file-directory-p dir)
+ (or include-all
+ (null tinypath-:load-path-ignore-regexp)
+ (not (string-match
+ tinypath-:load-path-ignore-regexp
+ dir))))
+ (let* ((try (if (string-match "\\.elc?$" package)
+ (file-name-sans-extension package)
+ package))
+ (choices (tinypath-cache-p-1-extensions package))
+ (files (directory-files
+ dir
+ nil
+ (concat "^"
+ (regexp-quote try)
+ "\\("
+ (mapconcat
+ ;; "\\.el\\|\\.el\\.gz\\|..." etc.
+ (function
+ (lambda (x)
+ (regexp-quote x)))
+ choices
+ "\\|")
+ "\\)$"))))
+ (cond
+ ((eq 1 (length files))
+ (setq file (concat
+ (file-name-as-directory
+ (expand-file-name dir))
+ (car files)))
+ (if all
+ (push file ret)
+ (return (setq ret file))))
+ (t
+ ;; Multiple matches. Hm #todo.
+ nil)))))
+ ;; Retain order how files were encountered.
+ (if (listp ret)
+ (nreverse ret)
+ ret)))
+
+;;; ----------------------------------------------------------------------
+;;; (tinypath-load-path-locate-library "cperl-mode")
+;;;
+(defun tinypath-load-path-locate-library (package)
+ "Locate PACKAGE along `load-path'.
+
+References:
+
+ `tinypath-:load-path-accept-criteria'."
+ (let* ((criteria tinypath-:load-path-accept-criteria)
+ (list (tinypath-load-path-search
+ package criteria))
+
+ ;; LIST can be '(path path ...) if ALL-MATCHES is activated.
+ ;; otherwise the returned value is absolute path name.
+ (ret (if (listp list)
+ (car-safe list)
+ list)))
+ (cond
+ ((or (null ret) ;Not found. Do nothing
+ (stringp list) ;Did not search all directories
+ (eq (length ret) 1))) ;Only one match, RET already set
+ ((functionp criteria)
+ (setq ret (funcall criteria list)))
+ (criteria
+ ;; Third party package overrides Emacs installation
+ (let* ((ver (car-safe (tinypath-emacs-versions 'noerr)))
+ (home (ignore-errors (expand-file-name "~")))
+ home-list
+ emacs-list
+ other-list)
+ (dolist (path list)
+ (cond
+ ((tinypath-emacs-core-path-p path ver)
+ (push path emacs-list))
+ ((and home
+ (string-match home path))
+ (push path home-list))
+ (t
+ (push path other-list))))
+ ;; Now sort out the correct package
+ ;; 1) User comes first
+ ;; 2) non-Emacs installation
+ ;; 3) Emacs installation
+ (setq ret (or (and home-list
+ (car (nreverse home-list)))
+ (and other-list
+ (car (nreverse other-list)))
+ (and emacs-list
+ (car (nreverse emacs-list))))))))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-load-path-display (&optional insert)
+ "Display `load-path' by messaging' it. Optionally INSERT."
+ (interactive "P")
+ (tinypath-list-display "load-path %s" load-path insert))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-load-path-not-in-synch-p (&optional fast)
+ "Check that load-path directories exists.
+
+Input:
+
+ FAST If non-nil, stop at first non-existing directory.
+
+Return:
+
+ List of directories that do not exist."
+ (let (list)
+ (dolist (path load-path)
+ (when (and (stringp path)
+ (not (file-directory-p path)))
+ (push path list)
+ (if fast
+ (return))))
+ (tinypath-verbose-macro 3
+ (message "TinyPath: CACHE SYNC error status is => [%s]"
+ (prin1-to-string list)))
+ list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-load-path-clean (&optional extensive-test)
+ "Clean `load-path' for anything suspicious: non-directories, non-strings.
+
+If EXTENSIVE-TEST flag is non-nil, remove any paths that do not contain
+lisp code. With it, the check will spend much more time."
+ (tinypath-verbose-macro 3
+ (message "TinyPath: CLEAN load-path"))
+ (setq load-path (tinypath-directory-list-clean load-path "load-path"))
+ (let (list)
+ (when extensive-test
+ (dolist (path load-path)
+ (when (and (tinypath-path-ok-p path)
+ (tinypath-directory-lisp-p path)))
+ (push path list))
+ (setq load-path (nreverse list))))
+ load-path)
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-load-path-reorder ()
+ "Move Emacs paths to predefined order.
+- User paths at the beginning (HOME dir paths)
+- Next anything in any order (site-lisp)
+- Last core Emacs paths."
+ (let* (personal
+ emacs
+ other)
+ (dolist (path load-path)
+ (cond
+ ((tinypath-load-path-emacs-distribution-p path)
+ (push path emacs))
+ ((tinypath-load-path-personal-p path)
+ (push path personal))
+ (t
+ (push path other))))
+ (setq load-path
+ (append
+ (nreverse personal)
+ (append
+ (nreverse other)
+ (nreverse emacs))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-add-directory-one (path)
+ "Add one PATH to the `load-path'. Old entry is removed."
+ ;; remove previous entry
+ (if (null (tinypath-directory-lisp-p path))
+ (tinypath-verbose-macro 3
+ (message "TinyPath: Add ignored. No LISP files in %s" path))
+ (if (member path load-path)
+ (setq load-path (delete path load-path)))
+ (pushnew
+ (if tinypath-:win32-p
+ (downcase path)
+ path)
+ load-path
+ :test 'string=)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-add-directory-many (list)
+ "Add to `load-path' each directory in LIST.
+LIST can contains single elements or lists:
+ '(single single (elt elt) single (elt elt)))"
+ (dolist (elt list)
+ (when elt
+ (if (not (listp elt))
+ (setq elt (list elt)))
+ (dolist (path elt)
+ (tinypath-add-directory-one path)))))
+
+;;; ----------------------------------------------------------------------
+;;; This function is recursive
+;;;
+(defun tinypath-add-directory-many-below-root-dir (root)
+ "Add all directories below ROOT to `load-path'."
+ (if (not (stringp root))
+ (tinypath-verbose-macro 5
+ (message "TinPath: Cannot add below root. Not a string: %s"
+ (prin1-to-string root)))
+ (if (not (and (file-exists-p root)
+ (file-directory-p root)
+ (not (file-symlink-p root))))
+ (tinypath-verbose-macro 3
+ (message "TinyPath: root does NOT exist: %s" root))
+ (setq root (tinypath-expand-file-name root))
+
+ (tinypath-verbose-macro 3
+ (message "TinyPath: root %s" root))
+
+ (let* ((list (tinypath-subdirectory-list root)))
+ (when (tinypath-path-ok-p root)
+ (tinypath-verbose-macro 5
+ (message "TinyPath: adding %s" root))
+ (tinypath-info-handler root)
+ (tinypath-add-directory-one root))
+ (dolist (path list)
+ (tinypath-verbose-macro 3
+ (message "TinyPath: recursing => %s" path))
+ (tinypath-add-directory-many-below-root-dir path))) )))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-load-path-remove-old (regexp)
+ "Remove all paths matching REGEXP from `load-path'"
+ (setq load-path
+ (remove-if
+ (function
+ (lambda (x)
+ (string-match regexp x)))
+ load-path)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-load-path-remove (regexp)
+ "Remove any matching REGEXP from `load-path'.
+Return t if removed something."
+ (let* ((spare load-path)
+ list
+ status)
+ (dolist (elt load-path)
+ (if (string-match regexp elt)
+ (setq status t)
+ (push elt list)))
+ (cond
+ ((null list)
+ (setq load-path spare)
+ (tinypath-verbose-macro 3
+ (message "TinyPath: FATAL regexp %s cleaned whole load-path."
+ regexp)))
+ (t
+ (setq load-path list)))
+ status))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-load-path-remove-cache (regexp)
+ "Remove any matching REGEXP from `tinypath-:cache'.
+Return t if removed something."
+ (let* ((spare tinypath-:cache)
+ status)
+ (dolist (elt tinypath-:cache)
+ (when (string-match regexp
+ ;; ELT = '("file.el" (POS . "path"))
+ (cdr (nth 1 elt)))
+ (setq status t)
+ (setq tinypath-:cache (delete elt tinypath-:cache))))
+ (unless tinypath-:cache
+ (setq tinypath-:cache spare)
+ (tinypath-verbose-macro 3
+ (message "TinyPath: FATAL regexp %s cleaned whole tinypath-:cache."
+ regexp)))
+ status))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-load-path-setup ()
+ "This is default function to add paths to `load-path'.
+Add all paths below `tinypath-:load-path-root'. See this variable.
+
+References:
+
+ `tinypath-:load-path-function'"
+ (let ((list tinypath-:load-path-root))
+ (if (stringp list) ;; make one string into LIST
+ (setq list (list list)))
+ ;; This message is a little premature, but it cleaner here,
+ ;; than after the dolist loop
+ (message
+ "TinyPath: SETUP `tinypath-:load-path-root' was checked and cleaned.")
+ (dolist (elt list)
+ (if (not (stringp elt))
+ (message "TinyPath: `tinypath-:load-path-root' ELT `%s' \
+is not a string. `tinypath-:load-path-root': %s "
+ (prin1-to-string elt)
+ (prin1-to-string tinypath-:load-path-root)))
+ (tinypath-verbose-macro 2
+ (message "TinyPath: => load path root %s " elt))
+ (tinypath-add-directory-many-below-root-dir elt))))
+
+;;;}}}
+;;;{{{ Cache
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-load-path-directory-files (path-list)
+ "Return all files along PATH-LIST."
+ (let ((count 0)
+ list)
+ (dolist (dir path-list)
+ (when (and (stringp dir)
+ (file-directory-p dir))
+ ;; make sure directory has a slash at the end
+ (setq dir (file-name-as-directory dir))
+ ;; TRAD means "traditional Emacs Lisp way", because
+ ;; there is new method EXT for "External tool" to do similar
+ ;; caching. In fact if you see these messages, something
+ ;; went wrong with the EXT method.
+ (tinypath-verbose-macro 1
+ (message "TinyPath: TRAD Caching files... %d %s"
+ (length list)
+ dir))
+ (dolist (file (directory-files dir nil "\\.elc?$"))
+ (unless (file-directory-p (concat dir file))
+ (incf count)
+ (when (or t ) ;; (string-match "other" dir))
+ (tinypath-verbose-macro 9
+ (message "TinyPath: TRAD Cached %s"
+ (concat dir file))))
+ (push (list file (cons count
+ (tinypath-expand-file-name dir)))
+ list)))))
+ ;; Preserve find order.
+ ;; (nreverse list)
+ list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-load-path-merge (list)
+ "Merge LIST to `load-path'."
+ ;; Merge original path to loaded path
+ (dolist (path list)
+ (pushnew path load-path :test 'string=)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-cache-setup-clear ()
+ "Clear cache variables.
+You should call `tinypath-cache-setup-scan' after this function."
+ (setq tinypath-:cache nil)
+ (setq tinypath-:cache-level-two nil)
+ (tinypath-load-path-clean))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-cache-setup-scan (&optional traditional)
+ "Build the cache either by using external program or Emacs Lisp."
+ (let* ((external (not traditional))
+ ;; While loading this package Cygwin XEmacs garbage collects like mad.
+ ;; Ease it up for a while. This is 30Meg
+ (gc-cons-threshold (* 1024 1024 30)))
+ (or (and external
+ (tinypath-external-setup))
+ (progn
+ (tinypath-verbose-macro 3
+ (message
+ (concat
+ "TinyPath: "
+ "TRAD lisp method used for scanning.")))
+ (tinypath-maybe-warn-message-log-max)
+ (tinypath-info-scan-Info-default-directory-list)
+ (funcall tinypath-:load-path-function)
+ (setq tinypath-:cache (tinypath-load-path-directory-files
+ load-path))))
+ ;; many push and pushnew were called.
+ (when (fboundp 'garbage-collect)
+ (message "TinyPath: cache-setup-scan requested `garbage-collect'")
+ (garbage-collect))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-cache-status-string ()
+ "Return cache statistics."
+ (format "TinyPath: packages %d, load-path %d, exec-path %d, info %d"
+ (length tinypath-:cache)
+ (length load-path)
+ (length exec-path)
+ (length (tinypath-Info-default-directory-list))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-cache-status-message ()
+ "Print cache statistics."
+ (interactive)
+ (message (tinypath-cache-status-string)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-cache-setup-main (&optional force traditional)
+ "Set `load-path' possibly using cache.
+If `tinypath-:cache-file' is recent enough load it, otherwise
+rescan directories if cache file is older than
+`tinypath-:cache-expiry-days'. After scan save cache.
+
+Input:
+
+ FORCE Rescan and save cache.
+ TRADITIONAL Use traditional Emacs lisp cache scan."
+ (interactive "P")
+ (let* ((file (tinypath-cache-file-name))
+ (read-cache (and (null force)
+ (stringp file)
+ (file-exists-p file)
+ (null (tinypath-cache-file-old-p file))))
+ no-save)
+ ;; .............................................. compressed cache ...
+ (tinypath-use-compression-maybe file)
+ ;; .................................................... load cache ...
+ (when read-cache
+ (let ((orig load-path))
+ (tinypath-cache-file-load)
+ (setq force (tinypath-cache-file-need-sync-p))
+ (tinypath-load-path-merge orig)))
+ ;; .......................................................... scan ...
+ ;; Clean everything before scan. This has two purposes
+ ;;
+ ;; - Remove invalid entries
+ ;; - Expand all paths to use absolute names and forward slashes.
+ ;; Expand is needed because all tests are done using absolute paths:
+ ;; `member', `pushnew' etc. Emacs and XEmacs Win32 differences are
+ ;; also solved with expand.
+ (when (null read-cache)
+ (tinypath-load-path-clean)
+ ;; (tinypath-Info-default-directory-list-clean)
+ (tinypath-directory-list-clean
+ tinypath-:extra-path-root
+ "tinypath-:extra-path-root"))
+ ;; .............................................. regenerate cache ...
+ (when (or force
+ (null (file-exists-p file))
+ (null tinypath-:cache))
+ (setq force t) ;; Write cache too
+ ;; Remove invalid entries so that they are not saved
+ (tinypath-cache-setup-clear)
+ ;; READ IT
+ (tinypath-cache-setup-scan traditional)
+ ;; Clean invalid entries
+ (tinypath-directory-list-clean
+ tinypath-:extra-path-root
+ "tinypath-:extra-path-root")
+ (tinypath-directory-list-clean
+ tinypath-:extra-manpath
+ "tinypath-:extra-manpath")
+ (tinypath-load-path-clean)
+ (tinypath-Info-default-directory-list-clean))
+ (if (> (length exec-path) 100)
+ (tinypath-verbose-macro 3
+ (message
+ "TinyPath: [WARNING] exec-path length looks suspicious: %d"
+ (length exec-path))))
+ (tinypath-exec-path-clean)
+ (tinypath-exec-path-check-verbose-fix) ;; Missing items? (from PATH)
+ (unless load-path
+ (tinypath-message-bug "FATAL SCAN load-path nil")
+ ;; Try rescue as best as we can, so that User's Emacs is still usable
+ (message "TinyPath: FATAL trying to boot to restore load-path.")
+ (tinypath-load-path-initial-value)
+ (unless load-path
+ (tinypath-message-bug
+ "[FATAL] SCAN2 load-path still nil, disable tinypath.el"))
+ (setq no-save t))
+ (when (or force
+ (null read-cache))
+ ;; Cache has changed. See where is latest gnus
+ (tinypath-load-path-reorder))
+ ;; Do this always, because:
+ ;; 1. At Boot phase standard emacs-NN.N/lisp/gnus path is
+ ;; added
+ ;; 2. There may be newer Gnus, which we know only after the
+ ;; cache has been loaded.
+ ;; => Last thing to do is to check various Gnus versions along
+ ;; load-path.
+ (tinypath-insinuate-gnus)
+ ;; ................................................... write cache ...
+ (tinypath-load-copy-now) ;; Save load-path.
+ (when (and (null no-save)
+ (or force
+ (and tinypath-:cache-expiry-days ;cache allowed
+ (null read-cache)))) ;but now expired
+ (tinypath-cache-file-save))
+ (tinypath-cache-status-message)
+ ;; Make sure that this list is cleared. It must be
+ ;; regenerated as well.
+ (tinypath-emacs-lisp-file-list-cache-clear)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-cache-setup-maybe ()
+ "If `load-path' or `tinypath-:cache' is out of date, rebuild cache."
+ (when (or (tinypath-cache-non-existing-directory-list)
+ (tinypath-cache-non-existing-file-list))
+ (tinypath-verbose-macro 2
+ (message "TinyPath: Cache validate: inconsistent state, rebuilding..."))
+ (tinypath-cache-setup-main 'force)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-report-mode-font-lock (&optional buffer)
+ "Call `font-lock' with `tinypath-:report-mode-font-lock-keywords' in BUFFER."
+ (with-current-buffer (or buffer (current-buffer))
+ (font-lock-mode 1)
+ (make-local-variable 'font-lock-keywords)
+ (set 'font-lock-keywords tinypath-:report-mode-font-lock-keywords)
+ (font-lock-fontify-buffer)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-cache-duplicate-different-size-p (elt)
+ "Called by `tinypath-cache-duplicate-report'.
+Check if ELT contains different files by size."
+ (let (path
+ file
+ stat
+ size
+ size-old
+ ret)
+ (setq file (car elt)
+ elt (cdr elt))
+ (dolist (item elt)
+ (setq path (concat (cdr item) file)
+ stat (file-attributes path)
+ size (nth 7 stat))
+ (when (and size-old
+ (not (eq size-old size)))
+ (setq ret t)
+ (return))
+ (setq size-old size))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-cache-duplicate-report (&optional size-rank)
+ "Report all identical lisp files in `tinypath-:cache' and rank by SIZE.
+
+Input:
+
+ SIZE-RANK
+
+ if given, report duplicate file only if the size is
+ different. If you just have copy of the same file in the
+ `load-path' that is not critical, but if the file size differs
+ then you have different versions of the file and you should
+ remove the old one(s) from path.
+
+Output:
+
+ alist.el
+ 35 2971 1999-02-27 12:51:12 /usr/local/share/site-lisp/common/mime/apel-9.13/
+ 1166 2971 1999-11-25 00:37:18 /home/foo/elisp/tiny/lisp/other/
+ | | | |
+ | | | location
+ | | ISO 8601 modification time
+ | size
+ the order number in cache
+
+References:
+
+ `tinypath-:cache-duplicate-report-hook'
+ `tinypath-cache-problem-report'."
+ (interactive "P")
+ (let* ((ignore-functions
+ tinypath-:cache-duplicate-report-ignore-functions)
+ (report-buffer tinypath-:report-buffer)
+ accept
+ list
+ stat
+ size
+ date
+ list-tmp
+ list-dup
+ file
+ path
+ ptr
+ seen)
+ ;; .................................................... build list ...
+ ;; result: ( (FILE . (PATH PATH PATH ..)) (FILE . (PATH ..)) )
+ (dolist (elt tinypath-:cache)
+ (setq file (car elt)
+ path (nth 1 elt))
+ (when (string-match "\\.el" file)
+ (when tinypath-:win32-p
+ (setq file (downcase file)))
+ (setq accept
+ (or (and
+ ignore-functions
+ (null
+ (let (ret)
+ (dolist (func ignore-functions)
+ (when (funcall func (concat (cdr path) file))
+ (setq ret t)
+ (return)))
+ ret)))
+ (null ignore-functions)))
+ (when accept
+ (if (not (setq ptr (assoc file list)))
+ (push (cons file (list path)) list)
+ (setq list-tmp (cdr ptr))
+ (push path list-tmp)
+ (setcdr ptr list-tmp)))))
+ ;; .............................................. check duplicates ...
+ (dolist (elt list)
+ (when (> (length (cdr elt)) 1)
+ (push elt list-dup)))
+ ;; ................................................. print results ...
+ (if (null list-dup)
+ (message "TinyPath: No duplicates in `tinypath-:cache'")
+ (let ((sorted (sort
+ list-dup
+ (function
+ (lambda (a b)
+ (setq a (car a)
+ b (car b))
+ (string< a b))))))
+ (setq list-dup sorted))
+ (display-buffer (get-buffer-create report-buffer))
+ (with-current-buffer report-buffer
+ (erase-buffer)
+ (tinypath-report-mode 'verbose)
+ (dolist (elt list-dup)
+ (when (tinypath-cache-duplicate-different-size-p elt)
+ (setq file (car elt))
+ (insert file "\n")
+ (dolist (elt (nreverse (cdr elt)))
+ (setq path (concat (cdr elt) file))
+ (unless (member path seen)
+ (push path seen)
+ (if (not (file-exists-p path))
+ (insert "\t ERROR: file does not exist " path "\n" )
+ (setq stat (file-attributes path)
+ size (nth 7 stat)
+ date (nth 5 stat))
+ ;; ISO 8601 date
+ (setq date (tinypath-time-string date))
+ (insert (format "\t %5d %5d %s %s\n"
+ (car elt)
+ size
+ date
+ path))))))))) ;; dolist-dolist
+ (with-current-buffer report-buffer
+ (goto-char (point-min))
+ (run-hooks 'tinypath-:cache-duplicate-report-hook))
+ list-dup))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-report-timing-summary ()
+ "Gather timing summary from *Message* buffer if `tinypath-:verbose-timing'."
+ (interactive)
+ (let* ((buffer (tinypath-message-get-buffer))
+ string)
+ (pop-to-buffer buffer)
+ (goto-char (point-min))
+ (while (re-search-forward "^TinyPath: load time.*" nil t)
+ (setq string (concat (or string "") "=> " (match-string 0) "\n")))
+ (message "Tinypath: [TIMING SUMMARY FROM ABOVE]" string)
+ (goto-char (point-max))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypath-report-mode-map-activate ()
+ "Use local `tinypath-report-mode-map' in current buffer.
+\\{tinypath-report-mode-map}"
+ (use-local-map tinypath-report-mode-map))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-report-mode-previous ()
+ "Go to previous file."
+ (interactive)
+ (beginning-of-line)
+ (if (re-search-backward "^[ \t]+[0-9].*/\\(.\\)" nil t)
+ (goto-char (match-beginning 1))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-report-mode-next ()
+ "Go to next file."
+ (interactive)
+ (re-search-forward "^[ \t]+[0-9].*/" nil t))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-report-mode-find-file ()
+ "Load file in current line to Emacs."
+ (interactive)
+ (let* ((file (tinypath-report-mode-file-name)))
+ (cond
+ ((null file)
+ (message "TinyPath: No file in this line.")
+ nil)
+ (t
+ (display-buffer (find-file-noselect file))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-report-mode-file-name ()
+ "Read filename under point."
+ (save-excursion
+ (beginning-of-line)
+ (when (re-search-forward
+ " ..:..:..[ \t]+\\(.*\\)"
+ (save-excursion (end-of-line) (point))
+ t)
+ (tinypath-ti::string-remove-whitespace (match-string 1)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-report-mode-dired (dir)
+ "Run dired on current line (reads filename)."
+ (interactive
+ (let* ((file (tinypath-report-mode-file-name))
+ (dir (and file
+ (file-name-directory file))))
+ (list
+ (read-file-name "Dired: " dir))))
+ (unless dir
+ (error "TinyPath: DIR missing: `%s'" dir))
+ (let* ((dired (tinypath-ti::dired-buffer dir)))
+ (cond
+ (dired
+ (pop-to-buffer dired))
+ ((tinypath-ti::window-single-p)
+ (split-window)
+ (other-window 1)
+ (dired dir))
+ (t
+ (other-window 1)
+ (dired dir)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-report-mode-delete-file (&optional force)
+ "Delete file in the current line. FORCE deleting.
+See also `tinypath-report-mode-delete-file-noconfirm'."
+ (interactive "P")
+ (let* ((file (tinypath-report-mode-file-name))
+ (point (point)))
+ (cond
+ ((null file)
+ (message "TinyPath: No file in this line."))
+ ((not (file-exists-p file))
+ (message "TinyPath: file not found %s" file))
+ ((or force
+ (y-or-n-p (format "Really delete %s " file)))
+ (delete-file file)
+ (message "TinyPath: deleted %s" file)
+ (overwrite-mode 1)
+ (beginning-of-line)
+ (insert "*")
+ (overwrite-mode -1)))
+ (goto-char point)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-report-mode-delete-file-noconfirm ()
+ "Delete file in the current line without confirmation."
+ (interactive)
+ (tinypath-report-mode-delete-file 'force))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinypath-report-mode (&optional verb)
+ "Major mode to help working with `tinypath-cache-duplicate-report'.
+and `tinypath-cache-problem-report'. VERB.
+
+\\{tinypath-report-mode-map}"
+ (interactive "P")
+ (tinypath-report-mode-map-activate) ;turn on the map
+ (setq mode-name tinypath-:report-mode-name)
+ (setq major-mode 'tinypath-report-mode) ;; for C-h m
+ (when verb
+ (message
+ (substitute-command-keys
+ (concat
+ "TinyPath: delete file with \\[tinydesk-report-mode-delete-file]")))
+ (sleep-for 1))
+ (tinypath-report-mode-font-lock)
+ (run-hooks 'tinypath-:report-mode-hook))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-cache-non-existing-file-list ()
+ "Return list of non existing files in cache."
+ (let (list
+ path)
+ (dolist (elt tinypath-:cache)
+ ;; '(("file" (POS . PATH)) .. )
+ (setq path (concat (cdr (nth 1 elt))
+ (car elt) ))
+ (unless (file-exists-p path)
+ (push path list)))
+ list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-cache-non-existing-directory-list ()
+ "Return list of non existing directories in cache or `load-path'."
+ (let (list
+ path)
+ (dolist (dir tinypath-:cache)
+ ;; ( ("file" (POS . PATH)) .. )
+ (setq dir (cdr (nth 1 dir)))
+ (unless (file-exists-p dir)
+ (pushnew path list :test 'string=)))
+ (dolist (dir load-path)
+ (unless (file-exists-p dir)
+ (pushnew path list :test 'string=)))
+ list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-cache-non-exist-report ()
+ "Report non-existing files in cache."
+ (let ((list (tinypath-cache-non-existing-file-list)))
+ (if (null list)
+ (message "TinyPath: No non-existing files in `tinypath-:cache'")
+ (display-buffer (get-buffer-create tinypath-:report-buffer))
+ (with-current-buffer tinypath-:report-buffer
+ (goto-char (point-max))
+ (tinypath-report-mode-font-lock)
+ (insert "\nNon Existing files:\n")
+ (dolist (elt list)
+ (insert " %s\n" elt))))
+ list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-cache-problem-report (&optional size-rank)
+ "Generate problem report: non-existing files and duplicates.
+See SIZE-RANK in `tinypath-cache-duplicate-report'."
+ (interactive)
+ (tinypath-cache-non-exist-report)
+ (tinypath-cache-duplicate-report))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-cache-regenerate (&optional delete-cache)
+ "Regenerate cache. `tinypath-cache-setup-main' is called with arg t.
+The DELETE-CACHE removes any previous stored cache from disk.
+Use it for completely clean any previous cache conflicts."
+ (interactive "P")
+ (when delete-cache
+ (tinypath-cache-file-delete))
+ ;; If something wicked happened, at least there is a backup
+ (unless load-path
+ ;; Silence byte compiler. The function is in this file, but it
+ ;; would complain: "`tinypath-original-values' might not be defined
+ ;; at runtime."
+ (let ((func 'tinypath-original-values))
+ (funcall func 'restore)))
+ (tinypath-info-scan-Info-default-directory-list)
+ (tinypath-cache-setup-main 'regenerate))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-cache-mode (mode)
+ "Toggle fast package loading MODE by enabling or disabling advises.
+
+Input:
+
+ If MODE is positive integer, enable defadvice code to to utilize
+ package (possibly compressed) lookup from `tinypath-:cache'.
+
+ If MODE is negative integer, turn support off.
+
+Description:
+
+ If you have many directories in your `load-path', turning this mode on
+ makes packages load instantly without time consuming path lookup.
+
+Warning:
+
+ Regenerate cache with \\[tinypath-cache-regenerate] if you have installed new
+ packages or if you have added new Lisp files to your system. Keep also
+ `tinypath-:cache-expiry-days' relatively small if you update often."
+ (interactive "P")
+ (let* ((list '( ;; autoload => see below
+ locate-library
+ load
+ require)))
+ ;; In Emacs (at least on 20.7), load-library is a wrapper for load. So,
+ ;; it makes no sense advising it, because the cache is searched twice.
+ ;; #todo: check this code .. and xemacs `load-library'
+ (when t ;; tinypath-:xemacs-p
+ (push 'load-library list))
+ ;; Activate only if user requested 'all
+ (when (eq tinypath-:compression-support 'all)
+ (push 'autoload list))
+ (tinypath-ti::bool-toggle tinypath-:cache-mode mode)
+ (cond
+ (tinypath-:cache-mode
+ (tinypath-ti::advice-control list "tinypath")
+ (if (interactive-p)
+ (message "TinyPath: cache advice code ACTIVATED.")))
+ (t
+ (tinypath-ti::advice-control list "tinypath" 'disable)
+ (if (interactive-p)
+ (message "TinyPath: cache advice code DEACTIVATED."))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun turn-on-tinypath-cache-mode ()
+ "See `tinypath-cache-mode'."
+ (interactive)
+ (tinypath-cache-mode 1))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun turn-off-tinypath-cache-mode ()
+ "See `tinypath-cache-mode'."
+ (interactive)
+ (tinypath-cache-mode -1))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun turn-on-tinypath-cache-mode-maybe ()
+ "See `tinypath-cache-mode'.
+Turn mode on only if `tinypath-:cache-expiry-days' is non-nil,
+otherwise turn mode off."
+ (interactive)
+ (if (integerp tinypath-:cache-expiry-days)
+ (turn-on-tinypath-cache-mode)
+ (turn-off-tinypath-cache-mode)))
+
+;;;}}}
+;;;{{{ Advice code
+
+;; ############################ BEGIN FUNCTION -- advice instantiate
+
+(defun tinypath-advice-instantiate ()
+ "Intantiate all advices."
+ ;; These are put into function to make them delayed and
+ ;; so that they can be called at apropriate time.
+
+ (require 'advice)
+
+ ;; I don't know what EFS does, but it certainly must be loaded before we
+ ;; try to advice `require' or `load' functions. It somehow overwrites the
+ ;; the original definitions.
+ ;;
+ ;; efs.el
+ ;;
+ ;; (efs-overwrite-fn "efs" 'load)
+ ;; (efs-overwrite-fn "efs" 'require)
+ ;;
+ ;; See also efs-ovwrt.el
+
+ (when tinypath-:xemacs-p
+ (require 'efs))
+
+;;; ----------------------------------------------------------------------
+;;; (turn-on-tinypath-cache-mode)
+;;; (turn-off-tinypath-cache-mode)
+;;;
+ (defadvice autoload (around tinypath dis)
+ "Use `tinypath-:cache' for fast lookup of files."
+ (let* ((file (ad-get-arg 1))
+ (path (tinypath-cache-p-for-advice file)))
+ (when path
+ (ad-set-arg 1 path))
+ ad-do-it))
+
+;;; ----------------------------------------------------------------------
+;;; (load FILE &optional NOERROR NOMESSAGE NOSUFFIX MUST-SUFFIX)
+;;;
+ (defadvice load (around tinypath dis)
+ "Use `tinypath-:cache' for fast lookup of files."
+ (let* ((file (ad-get-arg 0))
+ (nosuffix (ad-get-arg 3))
+ (must-suffix (ad-get-arg 4)))
+ (unless (stringp file)
+ (error "Parameter FILE is not a string %s"
+ (prin1-to-string file)))
+ (when (and (null nosuffix)
+ (null must-suffix))
+ ;; #todo: this needs better handling. Now we just
+ ;; ignore cache if suffix parameters are set.
+ ;;
+ ;; If optional fourth arg NOSUFFIX is non-nil, don't try adding
+ ;; suffixes `.elc' or `.el' to the specified name FILE. If optional
+ ;; fifth arg MUST-SUFFIX is non-nil, insist on the suffix `.elc' or
+ ;; `.el'; don't accept just FILE unless it ends in one of those
+ ;; suffixes or includes a directory name.
+ (let ((path (tinypath-cache-p-for-advice file)))
+ (when path
+ (tinypath-verbose-macro 5
+ (message "TinyPath: (advice load) Cache hit %s" file))
+ (ad-set-arg 0 path))))
+ ad-do-it))
+
+;;; ----------------------------------------------------------------------
+;;;
+ (defadvice load-library (around tinypath dis)
+ "Use `tinypath-:cache' for fast lookup of files."
+ (let* ((file (ad-get-arg 0))
+ (path (tinypath-cache-p-for-advice file)))
+ (when path
+ (tinypath-verbose-macro 5
+ (message "TinyPath: (advice load-library) Cache hit %s" file))
+ (ad-set-arg 0 path))
+ ad-do-it))
+
+;;; ----------------------------------------------------------------------
+;;; In Win32 XEmacs 21.2 beta; the this function calls `locate-file' which
+;;; for some reason breaks if given a absolute file name. The XEmacs
+;;; docs also say that `locate-file' uses hash table to speed up processing.
+;;; Hm.
+;;;
+;;; There is problem with functions that use (interactive-p) test, because
+;;; advice can't pass the information to the underlying function, so any
+;;; such test inside here won't work.
+;;;
+;;; 21.3.1:
+;;; (locate-library LIBRARY &optional NOSUFFIX PATH INTERACTIVE-CALL)
+;;;
+ (defadvice locate-library (around tinypath act)
+ "Use `tinypath-:cache' for fast lookup of files."
+ (interactive
+ (let ((cache (tinypath-emacs-lisp-file-list 'from-cache)))
+ (list
+ (completing-read
+ (format "%slocate library: "
+ (if cache
+ "(TinyPath cache)"
+ ""))
+ cache
+ nil
+ nil
+ nil)))) ;;; Default word
+ (let* ((file (ad-get-arg 0))
+ (ok (tinypath-load-copy-equal-p))
+ (path (if (and ok
+ file)
+ (tinypath-cache-p file)))
+ (error (and ok
+ path
+ (tinypath-cache-warn-if-not-exist path))))
+ (unless (stringp file)
+ (error "Parameter FILE is not a string %s"
+ (prin1-to-string file)))
+ (cond
+ ((and path
+ (null error))
+ (tinypath-verbose-macro 5
+ (message "TinyPath: (advice locate-library) Cache hit %s => %s"
+ file path))
+ (setq ad-return-value path))
+ ((and ok
+ (setq path (car-safe (tinypath-locate-library file))))
+ ;; (fboundp 'locate-file) ;; Do not continue in XEmacs
+ (setq ad-return-value path))
+ (t
+ ad-do-it))
+ ;; We must simulate in the advice, this interactive behavior, because
+ ;; underlying function does not know it any more, due to advice.
+ (when (interactive-p)
+ (if path
+ (message path)
+ (message "locate-library: %s not found."
+ (or file "<no filename>"))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+ (defadvice require (around tinypath dis)
+ "Use `tinypath-:cache' for fast lookup of files.
+Property (get 'require 'tinypath-load-list) contains list
+of required packages: '((feature . path)."
+ (let* ((feature (ad-get-arg 0))
+ (opt (ad-get-arg 1)) ;the optional "file" parameter
+ (alist (get 'require 'tinypath-load-list))
+ lib
+ path)
+ (unless (symbolp feature)
+ (error "Parameter FEATURE is not a symbol %s"
+ (prin1-to-string feature)))
+ (when (and (not (featurep feature))
+ ;; Avoid recursive calls.
+ (not (assq feature alist)))
+ (setq lib (cond
+ ((stringp opt)
+ (if (string-match "/" opt)
+ (tinypath-expand-file-name opt) opt))
+ (t
+ (symbol-name feature))))
+ (when (setq path (tinypath-cache-p-for-advice lib))
+ (tinypath-verbose-macro 5
+ (message "TinyPath: (advice require) Cache hit %s" lib))
+ (tinypath-cache-warn-if-not-exist path)
+ (push (cons feature path) alist)
+ (put 'require 'tinypath-load-list alist)
+ (ad-set-arg 1 path)))
+ ad-do-it))
+
+ ) ;; ############################ END FUNCTION -- end advice instantiate
+
+;;;}}}
+;;;{{{ win32: Unix $HOME directory mounted to PC, like to H: disk
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-load-path-dump (mount-point &optional file)
+ "Dump load path directories to disk.
+
+If you have Mounted Unix disk (say H: ) which sees your Unix $HOME directory,
+then keep in mind that NT Emacs does not see symlinked directories.
+
+Call this function from _Unix_ Emacs and it converts symbolic links to
+real directory names and writes output to FILE.
+
+You can then load that file in your NT emacs and make it see all
+the same directories as your Unix Emacs does.
+
+Repeat this every time you make symbolic path links in Unix.
+
+References:
+
+ `tinypath-:load-path-dump-file'"
+ (interactive "sUnix $HOME is equivalent to: \nf")
+ (let* ((home (file-truename (tinypath-expand-file-name "~")))
+ (load-path load-path))
+ (setq tinypath-dumped-load-path nil)
+ (or file
+ (setq file tinypath-:load-path-dump-file))
+ (dolist (path load-path)
+ (if (not (string-match "[a-z]" mount-point))
+ (setq path (file-truename path))
+ (setq path (tinypath-replace-regexp-in-string
+ (regexp-quote home)
+ mount-point
+ (file-truename path))))
+ (push path tinypath-dumped-load-path))
+
+ (tinypath-ti::write-file-variable-state
+ file "Absolute path dump for NTEmacs to access Unix Home disk"
+ '(tinypath-dumped-load-path))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-load-path-setup-win32 ()
+ "Load `tinypath-:load-path-dump-file' in win32."
+ (let* ((file tinypath-:load-path-dump-file))
+ (when (and tinypath-:win32-p
+ (load file 'noerr))
+ ;; Merge these unix paths with the NT Emacs paths.
+ ;; If these paths do not exist; they are not added
+ (tinypath-verbose-macro 2
+ (message "TinyPath: load-path merge from %s" file))
+ (tinypath-add-directory-many
+ (symbol-value 'tinypath-dumped-load-path)))))
+
+;;}}}
+;;{{{ Win32 support (cygwin)
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-manpage-handler (path)
+ "If PATH has manual pages, add to `tinypath-:extra-manpath'."
+ (let* (ret)
+ (unless (member path tinypath-:extra-manpath)
+ (dolist (file (directory-files path))
+ (when (string-match "\\.[0-9]$" file)
+ (tinypath-verbose-macro 9
+ (message "TinyPath: MAN %s [found %s] " path file))
+ (pushnew path tinypath-:extra-manpath :test 'string=)
+ (setq ret path)
+ (return))))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-extra-path-handler (path)
+ "Check PATH for info files and manual pages."
+ (tinypath-info-handler path)
+ (tinypath-manpage-handler path))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-woman-setup ()
+ "Install woman.el (if available) to read manual pages in Win32."
+ (when tinypath-:win32-p
+ (when (or (featurep 'woman)
+ (fboundp 'woman)
+ (when (locate-library "woman.el")
+ (autoload 'woman "woman" "" t)
+ (autoload 'woman-find-file "woman" "" t)
+ (autoload 'woman-dired-find-file "woman" "" t)
+
+ (unless (getenv "MANPATH") ;; woman-path
+ (message
+ "TinyPath: MANPATH does not exist, set `woman-manpath'."))
+ t))
+ (defalias 'man 'woman)
+ t)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-extra-path-setup (list)
+ "Look for new info and manual pages under LIST of root directories."
+ (dolist (path list)
+ (if (or (not (stringp path))
+ (not (file-directory-p path)))
+ (tinypath-verbose-macro 5
+ (message
+ "TinyPath: invalid search ROOT %s"
+ (prin1-to-string path)))
+ (tinypath-ti::directory-recursive-do
+ path 'tinypath-extra-path-handler))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-cygwin-setup ()
+ "If Cygwin is present add it to `tinypath-:extra-path-root'."
+ (let* ((cygwin-path (tinypath-ti::win32-cygwin-p))) ;; has trailing slash
+ (if (null cygwin-path)
+ (tinypath-verbose-macro 2
+ (message "TinyPath: [Cygwin] not found from PATH."))
+ (pushnew cygwin-path
+ tinypath-:extra-path-root
+ :test 'string=)
+ ;; Be absolutely sure that the path is not added multiple
+ ;; times "f:/unix/cygwin" or "f:/unix/cygwin/" because
+ ;; this would cause reading the same directory twice
+ ;;
+ ;; (tinypath-directory-list-clean ;; No trailing slashes after this
+ ;; tinypath-:extra-path-root
+ ;; "CYGWIN tinypath-:extra-path-root")
+ ;;
+ (tinypath-verbose-macro 2
+ (message "TinyPath: [Cygwin] found from PATH: %s" cygwin-path))
+ ;; (tinypath-extra-path-setup list)
+ tinypath-:extra-path-root)))
+
+;;}}}
+;;{{{ Install functions
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-install-timer (&optional uninstall)
+ "Install or UNINSTALL timer to keep cache structure in synch with disk.
+Reference:
+ `tinypath-cache-setup-maybe' 15min, idle timer calls this periodically."
+ (interactive "P")
+ (let* (timer
+ status)
+ (when (fboundp 'run-with-idle-timer)
+ ;;
+ ;; I don't think this ever fails, but be bullet proof anyway
+ ;; We ,ust run `require' because `run-with-idle-timer'
+ ;; must not be in autoload state.
+ ;;
+ ;; timers are different in Emacs implementations. Load correct
+ ;; package.
+ ;; XEmacs keeps this in xemacs-packages/lisp/fsf-compat/timer.el
+ ;;
+ (setq status
+ (cond
+ (tinypath-:xemacs-p
+ (or (require 'itimer)
+ (require 'timer)))
+ (t
+ (require 'timer))))
+ (if (null status)
+ (tinypath-verbose-macro 1
+ (message "TinyPath: TIMER ERROR Can't install timers to emacs."))
+ (cond
+ (uninstall
+ (tinypath-ti::compat-timer-cancel-function
+ 'tinypath-cache-setup-maybe)
+ (message
+ "TinyPath: `load-path' synchronization watchdog UNINSTALLED."))
+ (t
+ (tinypath-ti::compat-timer-cancel-function
+ 'tinypath-cache-setup-maybe)
+ ;; At this point, we have wiped out the autoload definitions
+ ;; with explicit `require', because `symbol-function'
+ ;; won't work on autoloaded definitions.
+ (tinypath-autoload-require 'run-with-idle-timer)
+ (setq timer
+ (funcall
+ (symbol-function 'run-with-idle-timer)
+ (* 60 15)
+ 'repeat
+ 'tinypath-cache-setup-maybe))
+ (message
+ "TinyPath: `load-path' synchronization watchdog INSTALLED.")))))
+ (setq tinypath-:timer-elt timer)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-insinuate-woman ()
+ "Add items in `tinypath-:extra-manpath' to `woman-manpath'."
+ (when (boundp 'woman-manpath)
+ (dolist (path tinypath-:extra-manpath)
+ (when (stringp path)
+ (tinypath-verbose-macro 7
+ (message "TinyPath: Adding to `woman-manpath' %s" path))
+ (pushnew path woman-manpath :test 'string=)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-insinuate-find-file ()
+ "Add items in `tinypath-:extra-manpath' to `woman-manpath'."
+ (when (boundp 'ff-search-directories)
+ (dolist (path tinypath-:extra-ff-search-directories)
+ (when (stringp path)
+ (tinypath-verbose-macro 7
+ (message "TinyPath: Adding to `ff-search-directories' %s" path))
+ (pushnew path ff-search-directories :test 'string=)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-gnus-load-path-list ()
+ "Return Gnus locations in `load-path' by searching regexp gnus/?$"
+ (let* (list
+ found
+ previous)
+ (dolist (path load-path)
+ ;; cvs-packages/gnus/etc/gnus
+ ;;
+ ;; "../gnus/" or at the end "../gnus"
+ ;;
+ (and (not (string-match "/etc/" path))
+ (string-match "\\(.+[/\\]gnus\\)\\([/\\]\\|[/\\]?$\\)" path)
+ (setq found (match-string 1 path))
+ ;; It's faster to "remember" the previous match and test it with
+ ;; `equal' that all the time use `pushnew'. This reduces
+ ;; `pushnew' calls.
+ (not (equal previous found))
+ (setq previous found)
+ (pushnew found list :test 'string=)))
+ list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-gnus-versions (&optional path-list)
+ "Find out gnus version numbers along `load-path' or PATH-LIST.
+The PATH-LIST must conatins the root directoryies of Gnus installations.
+Return ((VER . PATH) ..)."
+ (let* (file
+ list)
+ ;; There is no way we can say which Gnus version is the latest without
+ ;; loading the gnus.el and looking inside the file
+ (tinypath-with-temp-buffer
+ (dolist (path path-list)
+ ;; XEmacs installation drop all gnus lisp files directly under:
+ ;;
+ ;; xemacs-packages/lisp/gnus/
+ ;;
+ ;; But the Gnus CVS tree contains directory structure
+ ;;
+ ;; cvs-packages/gnus/lisp/
+ ;; cvs-packages/gnus/contrib
+ ;; cvs-packages/gnus/etc
+ ;;
+ (dolist (try '("gnus.el" "lisp/gnus.el"))
+ (setq file (concat
+ (tinypath-expand-file-name
+ (file-name-as-directory path))
+ try))
+ (when (file-exists-p file)
+ (erase-buffer)
+ ;; About within 10% of the file size the defconst can be found
+ (insert-file-contents file nil 1 10000)
+ (goto-char (point-min))
+ (when (re-search-forward
+ "defconst.*gnus-version.*\"\\([0-9.]+\\)"
+ nil t)
+ (push (cons (match-string 1) file)
+ list)))))
+ (tinypath-verbose-macro 7
+ (message "TinyPath: found Gnus versions %s" (prin1-to-string list)))
+ list)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-gnus-latest-version (path-list)
+ "Return latest gnus version from PATH-LIST.
+Return structure is ordered so, that the latest version is first:
+'((VERSION-STRING . PATH) ..).
+
+Development versions starting with 0.N are condired newer that
+any N.N version."
+ (let* ((ver (tinypath-gnus-versions path-list))
+ zero
+ sorted)
+ (when ver
+ (setq sorted
+ (sort
+ ver
+ (function
+ (lambda (a b)
+ (if (or (string-match "^0" (car a))
+ (string-match "^0" (car b)))
+ (setq zero t))
+ (setq a (car a)
+ b (car b))
+ (tinypath-ti::vc-version-lessp a b)))))
+ ;; put ZERO numbers first.
+ (if zero
+ (setq sorted (reverse sorted))))
+ sorted))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-insinuate-gnus ()
+ "Examine `load-path' and leave the latest Gnus version."
+ (let* ((list (tinypath-gnus-load-path-list)))
+ (cond
+ ((null list)
+ (tinypath-verbose-macro 7
+ (message "TinyPath: No newer Gnus found along `load-path'.")))
+ ((eq 1 (length list))
+ ;; Make sure no old gnus is used.
+ (setq tinypath-:cache-level-two nil)
+ (tinypath-verbose-macro 1
+ (message "TinyPath: One Gnus found along `load-path' %s"
+ (car list)))
+ (pushnew (car list) load-path :test 'string=)
+ list)
+ (t
+ ;; Latest gnus version is first in the returned list, drop it out
+ ;; and remove all other paths.
+ ;;
+ (dolist (path (cdr (tinypath-gnus-latest-version list)))
+ (setq path
+ (tinypath-file-remove-trailing-slash
+ (file-name-directory (cdr path))))
+ ;; some/dir/gnus/lisp/ --> some/dir/gnus/
+ (tinypath-verbose-macro 1
+ (message "TinyPath: Removing older Gnus from `load-path' %s"
+ path))
+ (tinypath-admin-remove-matching path)
+ path)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-setup (&optional no-cache force)
+ "Add additional directories to `load-path'.
+If `tinypath-:cache-expiry-days' is defined, use cached `load-path'
+If cache is too old, read directories under `tinypath-:load-path-root'.
+
+Input:
+
+ NO-CACHE If non-nil, do not use cache but read directories under
+ `tinypath-:load-path-root'.
+ FORCE Regenerate cache.
+
+References:
+
+ `tinypath-:load-path-function'"
+ (interactive "P")
+ (if (or no-cache
+ (null tinypath-:cache-expiry-days)) ;Cache is not allowed
+ (funcall tinypath-:load-path-function)
+ (tinypath-cache-setup-main force)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-load-path-root-changed-p ()
+ "Check if `tinypath-:load-path-root' has changed since last run.
+The property value (get 'tinypath-:load-path-root 'tinypath-last-value)
+holds the last stored value."
+ (let ((last (get 'tinypath-:load-path-root 'tinypath-last-value)))
+ (and last
+ (not (equal last tinypath-:load-path-root)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-install ()
+ "Install package. There is no uninstall."
+ (interactive)
+ (let* ((fid "tinypath-install")
+ (time-a (current-time))
+ time-b
+ diff)
+ (message "TinyPath: %s BEGIN %s" fid (tinypath-time-string))
+ (message "TinyPath: [INFO] (defmacro) Info-default-directory-list: %s"
+ (prin1-to-string (tinypath-Info-default-directory-list)))
+ (message "TinyPath: [INFO] Info-directory-list: %s"
+ (if (boundp 'Info-directory-list)
+ (prin1-to-string Info-directory-list)
+ "<empty>"))
+ (message "TinyPath: [INFO] INFOPATH environment variable: %s"
+ (or (getenv "INFOPATH")
+ "no variable"))
+ ;; Must be before the cygwin check, where cygwin1.dll is
+ ;; searched along `exec-path'
+ ;;
+ ;; (tinypath-exec-path-clean)
+ ;; (tinypath-exec-path-check-verbose 'fix) ;; Missing items? (from PATH)
+ ;;
+ ;; This is already set in default value for `tinypath-:extra-path-root'
+ ;; (when (tinypath-win32-p) (tinypath-cygwin-setup))
+ ;; ................................................ examine system ...
+ ;;
+ ;; Make sure all are absolute: use forward slash in all path names
+ (tinypath-expand-file-name-variable-macro
+ tinypath-:load-path-root)
+ ;; Suppose user has changed the value since the last time
+ ;; and does M-x load-library RET tinypath.el RET
+ ;; => check if we should regenerate cache or read from disk
+ (if (not (tinypath-load-path-root-changed-p))
+ (tinypath-setup)
+ (message
+ "TinyPath: INSTALL tinypath-:load-path-root changed, doing reboot.")
+ ;; (tinypath-cache-regenerate)
+ nil)
+ ;; ........................................ cleanup and activation ...
+ ;;
+ ;; Delay defining advises until this point
+ ;;
+ (unless (eq tinypath-:compression-support 'none)
+ (tinypath-advice-instantiate))
+ ;;
+ ;; The autoload statements must be here, because `autoload' is
+ ;; an advised function. The `fboundp' is just an extra measure,
+ ;; so that it does not even call the advised-autoload function if
+ ;; this file is loaded multiple times
+ ;;
+ (unless (fboundp 'ti::macrof-version-bug-report)
+ (autoload 'ti::macrof-version-bug-report "tinylib" "" nil 'macro))
+ (unless (fboundp 'font-lock-mode)
+ (autoload 'font-lock-mode "font-lock" "" t))
+ (unless (eq tinypath-:compression-support 'none)
+ (turn-on-tinypath-cache-mode-maybe))
+ ;; (tinypath-install-timer) ;; Install watchdog to check load-path
+ ;; woman.el, man page viewer for Win32
+ ;; We do not load this, but define autoloads and then add the found
+ ;; paths after woman is active.
+ ;;
+ (when tinypath-:win32-p
+ (if (tinypath-woman-setup)
+ (tinypath-eval-after-load "woman" 'tinypath-insinuate-woman)
+ (when tinypath-:extra-manpath
+ (message "\
+TinyPath: ** Hm, manual pages found, but you do not have woman.el
+ Visit http://centaur.maths.qmw.ac.uk/Emacs/
+ and you will be able to use `M-x man' in Win32 system."))))
+ (tinypath-eval-after-load "find-file" 'tinypath-insinuate-find-file)
+ (setq time-b (current-time))
+ (setq diff (tinypath-ti::date-time-difference time-b time-a))
+ (put 'tinypath-:load-path-root
+ 'tinypath-last-value
+ tinypath-:load-path-root)
+ (tinypath-Info-default-directory-list-clean)
+ (tinypath-exec-path-clean)
+ (message "TinyPath: [INFO] END (defmacro) Info-default-directory-list: %s"
+ (prin1-to-string (tinypath-Info-default-directory-list)))
+ (message "TinyPath: [INFO] END Info-directory-list: %s"
+ (if (boundp 'Info-directory-list)
+ (prin1-to-string Info-directory-list)
+ "<empty>"))
+ (message "TinyPath: %s END %s" fid (tinypath-time-string))
+ (message (concat (tinypath-cache-status-string)
+ (format " time %d sec" diff)))))
+
+;;}}}
+;;{{{ Require (b)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; The require statements are unconventionally put here and not to the
+;; beginning of file, because sometimes Win32
+;; XEmacs development betas do not have correct `load-path' and
+;; require `advice' and `jka-compr' would fail.
+;;
+;; At this point the load-path has been partially fixed (that is: booted)
+;; and we can run `require' commands.
+;;
+;; The files can be in compressed format as well.
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(eval-and-compile
+ (defun tinypath-original-values (mode)
+ "MODE can be 'save 'restore original `load-path' and `exec-path'.
+The original value is saved under property `tinypath-saved-value'."
+ (let ((savesym 'tinypath-saved-value))
+ (dolist (sym '(load-path
+ exec-path))
+ (cond
+ ((eq mode 'save)
+ ;; Save can only be once.
+ (or (get sym savesym)
+ (put sym savesym (symbol-value sym))))
+ ((eq mode 'restore)
+ (set sym (get sym savesym)))))))
+
+ (tinypath-original-values 'save)
+
+ ;; We MUST run this at compile time too, because in XEmacs
+ ;; it will make loading custom.elc possible. Without it, the
+ ;; defcustomed variables give errors
+ (when tinypath-:install-flag
+ (when (and (not (tinypath-byte-compile-running-p))
+ ;;(and (tinypath-byte-compile-running-p)
+ ;; (boundp 'xemacs-logo))
+ ;;
+ ;; If there is cache and it is valid, do not run
+ ;; BOOT.
+ (let ((file (tinypath-cache-file-name)))
+ (tinypath-cache-file-old-p file)))
+ (tinypath-load-path-initial-value
+ tinypath-:core-emacs-load-path-list))))
+
+(require 'info)
+
+;;}}}
+;;{{{ Install load time
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;####autoload (autoload 'tinypath-version "tinypath" "" t)
+(defun tinypath-version (&rest args)
+ "Display version and manual. ARGS are ignored."
+ (interactive)
+ (let ((path (locate-library "tinypath.el")))
+ (cond
+ ((null path)
+ (message "TinyPath: [ERROR] cannot find tinypath.el to read."))
+ (t
+ (let* ((name "*tinypath-version*")
+ (buffer (get-buffer name)))
+ (if buffer
+ (pop-to-buffer buffer)
+ (pop-to-buffer (get-buffer-create name))
+ (insert-file-contents path)
+ (goto-char (point-min))
+ (when (re-search-forward "Change Log")
+ (forward-line 1)
+ (delete-region (point) (point-max))
+ (goto-char (point-min))
+ (while (re-search-forward "^;[;{}]+ ?" nil t)
+ (replace-match "" nil 'literal))
+ (goto-char (point-min)))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-install-reset-variables ()
+ "Restore modified values, like GC parameters."
+ ;; Restore value that was saved at the beginning of file
+ (setq gc-cons-threshold
+ (get 'gc-cons-threshold 'tinypath))
+ ;; Restore original value for rest of the Emacs session
+ (let ((val (get 'tinypath-:verbose 'debug-init)))
+ (when (integerp val)
+ (setq tinypath-:verbose val))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-install-pristine ()
+ "Try to restore package to original Emacs settings.
+This means restoring `exec-path' and `load-path' as they
+were seen at Emacs startup. The cache is cimpletely rebuilt and
+then saved to disk."
+ (interactive)
+ (let ((load (tinypath-load-copy-get 'original))
+ (exec (get 'exec-path 'tinypath)))
+ (if (not (and load exec))
+ (error "TinyPath: No original values found.")
+ (setq load-path load)
+ (setq exec-path exec)
+ (tinypath-cache-regenerate))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-install-main ()
+ "The main loader. The very first setup for the package.
+This function is called when package is loaded.
+
+Runs hooks:
+
+ `tinypath-:report-mode-define-keys-hook'
+ `tinypath-:load-hook'."
+ (run-hooks 'tinypath-:report-mode-define-keys-hook)
+ (eval-and-compile
+ (unless (tinypath-byte-compile-running-p)
+ (tinypath-install-environment)
+ (run-hooks 'tinypath-:load-hook)))
+ ;; This last message is here solely so that with log level 20
+ ;; the message is also saved the log file
+ (tinypath-verbose-macro 3
+ (tinypath-cache-status-message)))
+
+(tinypath-load-copy-now)
+(tinypath-load-copy-now 'original)
+(put 'exec-path 'tinypath exec-path) ;; Save original value
+
+(if tinypath-:install-flag
+ (tinypath-install-main))
+
+(tinypath-install-reset-variables)
+
+;;}}}
+
+;;; tinypath.el ends here
--- /dev/null
+;;; tinyperl.el --- Grab-bag of Perl related utilities. Pod documentation
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 1998-2007 Jari Aalto
+;; Keywords: extensions
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program, call M-x tinyperl-version.
+;; Look at the code with folding.el
+
+;; COPYRIGHT NOTICE
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;;; Install:
+
+;; ....................................................... &t-install ...
+;; Put this file on your Emacs-Lisp load path, add following into your
+;; ~/.emacs startup file.
+;;
+;; (require 'tinyperl)
+;;
+;; Autoload, prefer this one, your emacs starts quicker. The additional
+;; features are turned on only when `perl-mode' runs.
+;;
+;; (autoload 'turn-on-tinyperl-mode "tinyperl" "" t)
+;; (add-hook 'perl-mode-hook 'turn-on-tinyperl-mode)
+;; (add-hook 'cperl-mode-hook 'turn-on-tinyperl-mode)
+;;
+;; This package will keep the configuration information in a cache and
+;; if for some reason the cache becomes invalid, force rebuilding everything
+;; with command:
+;;
+;; C-u M-x tinyperl-install
+;;
+;; To completely uninstall package, call:
+;;
+;; C-u M-x tinyperl-install-main
+;;
+;; If you have any questions, suggestions, use this function
+;;
+;; M-x tinyperl-submit-bug-report
+
+;;}}}
+
+;;{{{ Documentation
+
+;; ..................................................... &t-commentary ...
+
+;;; Commentary:
+
+;; Preface, march 1998
+;;
+;; Perl was quite new in 1994 and perl programs imported
+;; libraries using `require' command. Some time passed and the
+;; new Perl 5 was a complete rewrite. It introduced new Object
+;; and reference technologies to language but lot of perl coders
+;; couldn't grasp the new ideas immediately. Many made the
+;; decision to move to perl 5 only after it was mature
+;; enough. The perl 5 coding was so much cleaner and simpler
+;; compared to perl 4.
+;;
+;; As a result some additional Emacs functions were needed the Perl
+;; work going and this module more or less concentrates on helping to
+;; document perl programs with POD or getting perl man pages via
+;; `perldoc' interface. The other companion that you would already
+;; know is the `cperl-mode' which is the best mode for coding the
+;; perl language.
+;;
+;; Overview of features
+;;
+;; In Windows, both Activestate Perl and native Cygwin Perl are
+;; supported. But you cannot use both. If you have accustomed to
+;; Activestate Perl, consider moving to Cygwin Perl, because
+;; it is more close to the Unix. With cygwin, you can install and upgrade
+;; CPAN archives easily: "perl -eCPAN -e shell"
+;;
+;; *Multiple* *perl* installations are _not_ _supported._ The one that
+;; comes in path first is used. Perl advances each time so much that
+;; you're much safer if you always have the latest version.
+;;
+;; `tinyperl-mode' minor mode:
+;;
+;; o Instant function help: See documentation of `shift', `pop'...
+;; o Show Perl manual pages in *pod* buffer
+;; o Load library source code into Emacs, like Devel::DProf.pm
+;; o Grep through all Perl manual pages (.pod)
+;; o Follow POD manpage references to next pod page with TinyUrl
+;; o Colored pod pages with `font-lock'
+;; o Update `$VERSION' variable with YYYY.MMDD on save.
+;;
+;; Other minor modes:
+;;
+;; o Separate `tinyperl-pod-view-mode' for reading pod2text pages
+;; o Separate `tinyperl-pod-write-mode' for writing POD documentation
+;;
+;; Package startup
+;;
+;; At package startup the perl binary's `tinyperl-:perl-bin'
+;; `@INC' content is cached. If you have modules somewhere else than
+;; the standard `@INC', then add additional `-I' switches to the
+;; `tinyperl-:inc-path-switches' so that these additional paths are
+;; cached too.
+;;
+;; In addition the Perl POD manual pages and paths are cached at startup.
+;; This is derived from *Config.pm* module $Config{privlib}.
+;;
+;; If you need to change any of the above settings in environment
+;; during the session, reload package or call `tinyperl-install' to
+;; update the changed values.
+;;
+;; Saving TinyPerl state (cache)
+;;
+;; When the package is used for the first time, the Perl `@INC'
+;; is read and all .pl and .pm files along the path are cached
+;; and written to file pointed by function
+;; `tinyperl-cache-file-name'. Next time this package is loaded,
+;; the initialization will be faster.
+;;
+;; If you upgrade Perl or add new packages along @INC, you must
+;; rebuild the cached information and have it updated. You do
+;; this by calling `tinyperl-install' with a force flag; use
+;; some prefix argument (e.g. `C-u').
+;;
+;; The cache information is expired periodically, so it should keep up
+;; with the environment changes quite well. The default cache period
+;; is 7 days, but this can be set via
+;; `tinyperl-:cache-file-days-old-max'.
+;;
+;; Perl Minor Mode description
+;;
+;; Turning on `tinyperl-mode' in any buffer gives you commands to
+;; retrieve Perl's POD (Plain Old Documentation) pages. This is
+;; most useful with the programming mode `perl-mode'. Function
+;; `turn-on-tinyperl-mode' is also added to hooks
+;; `perl-mode-hook' and `cperl-mode-hook' by default.
+;; The list of key below may be not completely up to date, so
+;; consult `C-h' `f' `tinyperl-mode'.
+;;
+;; C-c ' f tinyperl-pod-find-file
+;; C-c ' F tinyperl-pod-find-file-this-buffer
+;; C-c ' P tinyperl-pod-by-module
+;; C-c ' P tinyperl-pod-by-manpage
+;; C-c ' k tinyperl-pod-kill-buffers
+;;
+;; C-c ' m tinyperl-module-find-file
+;; C-c ' d tinyperl-perldoc
+;; C-c ' g tinyperl-pod-grep
+;;
+;; o `tinyperl-pod-find-file'
+;; run pod2text over file pointed by the function. After running this
+;; The internal POD documentation in the file is presented in man page
+;; format. You can use function `tinyperl-pod-find-file-this-buffer'
+;; to check the layout of the POD that you're writing to the current
+;; perl program.
+;; o `tinyperl-pod-by-module'
+;; View module pages by completing the installed Perl modules
+;; and running pod2text. Like reading documentation of "Getopt::Long".
+;; o `tinyperl-pod-by-manpage'
+;; View Perl manual pages, like "perlfunc.pod" and run pod2text
+;; o `tinyperl-pod-kill-buffers'
+;; Kill all *pod* buffers from Emacs
+;; o `tinyperl-module-find-file'
+;; Complete installed module in @INC and load source code into Emacs.
+;; Like if you want to see real code of "Getopt::Long"
+;; o `tinyperl-perldoc' Use perldoc -f to display documentation of
+;; a perl function at point.
+;; o `tinyperl-pod-grep'
+;; Grep regexp from all Perl POD manual pages. Answers to
+;; question "Is this mentioned in FAQ".
+;;
+;; POD view mode description: navigating in pod page and following URLs
+;;
+;; When pod is loaded to buffer, another package, *tinyurl.el*, is
+;; turned on. It can track several different kind of URLs, including
+;; perl pod manpages for references like:
+;;
+;; See perlfunc manpage
+;; ^^^^^^^^^^^^^^^^
+;;
+;; See [perltoc]
+;; ^^^^^^^^^
+;;
+;; Devel::Dprof manpage
+;; ^^^^^^^^^^^^^^^^^^^^
+;;
+;; You can use mouse-2 at the point to jump to the referenced POD
+;; page. Wait couple of seconds at the current line and any
+;; references or URLs found are marked. If you do not want to use
+;; TinyUrl package, add this setup:
+;;
+;; (add-hook tinyperl-:load-hook 'my-tinyperl-:load-hook)
+;;
+;; (defun my-tinyperl-:load-hook ()
+;; "My TinyPerl customisations."
+;; (remove-hook 'tinyperl-:pod2text-after-hook
+;; 'turn-on-tinyurl-mode-1))
+;;
+;; In *pod* buffer where the pod documentation is displayed, an
+;; additional browsing mode, `tinyperl-pod-view-mode', is turned on to
+;; help moving around topics. If you find the PgUp keys non-customary,
+;; see variable `tinyperl-:key-pageup-control'.
+;;
+;; ;; moving down/up topics
+;;
+;; Control-PgDown tinyperl-pod-view-heading-forward
+;; Control-PgDown tinyperl-pod-view-heading-backward
+;;
+;; S-PgDown tinyperl-pod-view-heading-forward2
+;; S-PgDown tinyperl-pod-view-heading-backward2
+;;
+;; ;; Moving down/up one pod page at a time
+;; ;; The pod pages are all gathered to single buffer *pod*
+;;
+;; Meta-PgDown tinyperl-pod-view-forward
+;; Meta-PgUp tinyperl-pod-view-backward
+;;
+;; ;; The normal PgUp/Down commands
+;;
+;; PgDown scroll-up
+;; PgUp scroll-down
+;;
+;; By default the POD documentation is kept in a single buffer where
+;; you can conveniently use C-s and C-r searches. If you would like to
+;; use separate POD buffers instead, a la M-x man, set variable
+;; `tinyperl-:pod-buffer-control' to 'many. The opposite is 'single.
+;;
+;; POD Write mode description
+;;
+;; There is additional minor mode to help you write POD in the current
+;; buffer The minor mode is in function `tinyperl-pod-write-mode' and
+;; you can switch to it any time you're adjusting the pod section.
+;; Don't keep on all the time, since it occupies some keys that are
+;; normally needed in programming.
+;;
+;; PgDown tinyperl-pod-write-heading-forward
+;; PgUp tinyperl-pod-write-heading-backward
+;;
+;; With shift
+;;
+;; PgDown tinyperl-pod-write-token-forward
+;; PgUp tinyperl-pod-write-token-backward
+;;
+;; Inserting default POD templates for program
+;;
+;; C-c . m tinyperl-pod-write-skeleton-script-manpage
+;; C-c . f tinyperl-pod-write-skeleton-script-function
+;; C-c . i tinyperl-pod-write-skeleton-item
+;;
+;; Inserting default POD skeletons for Modules or Classes.
+;;
+;; C-c . B tinyperl-pod-write-skeleton-module-header
+;; C-c . E tinyperl-pod-write-skeleton-module-footer
+;; C-c . F tinyperl-pod-write-skeleton-module-function
+;;
+;; POD skeleton for functions (C-c . F) is very different from the
+;; Module skeletons. This due to fact, that a Module offers documented
+;; function interface and the user callable functions should be
+;; described separately with POD in order to print the manual of the
+;; module.
+;;
+;; The POD skeletons for Modules are based on following Module
+;; layout. This is my only a suggested layout, see
+;; Lingue::EN:Squeeze.pm for complete first hand example. The
+;; places below where you see "P O D" are the places where you
+;; add pod. For each, a different pod skeleton is inserted and
+;; when the whole file is printed, it gives nice and maintainable
+;; interface description.
+;;
+;; There is another group of people that prefer writing the whole
+;; documentation after the __END__. It has drawback that then you
+;; separate the descriptions from the actual place where the code
+;; resides. The idea here has been that the documentation (function)
+;; is kept immediately above the code: if you change it (function),
+;; you can update the documentation at the same place.
+;;
+;; In the other hand, by putting documentation after __END__, the
+;; load time of module is decreased, because POD text is never
+;; read by perl interpreter. Another point to keep in mind is,
+;; that the computing power and disk speed will increase, so the
+;; __END__ solution's benefit is neglible. The maintenance is
+;; easier when the documentation is not separated from the place
+;; where it would be the most natural (nearest to the code).
+;;
+;; F I L E B A N N E R
+;;
+;; P O D H E A D E R
+;; NAME
+;; REVISION
+;; SYNOPSIS
+;; DESCRIPTION
+;; EXPORTABLE VARIABLES
+;; EXAMPLES
+;;
+;; # module interface is written next
+;;
+;; use strict;
+;;
+;; BEGIN
+;; {
+;; .. EXPORT # The export interface
+;; .. EXPORT_OK
+;; }
+;;
+;; Define exported globals
+;;
+;; Define private variables
+;;
+;; P O D I N T E R F A C E S T A R T
+;;
+;; P O D P U B L I C for public functions or method
+;; sub ...
+;;
+;; NORMAL banner of private function
+;; sub ...
+;;
+;; P O D F O O T E R
+;; KNOWN BUGS
+;; AVAILABILITY
+;; AUTHOR
+;;
+;; 1;
+;; __END__
+;;
+;; Perl SelfStubber
+;;
+;; If you're developing Perl modules, you can make it to use autoload
+;; interface. Module compiles much faster and it delays loading of
+;; functions until they are called. You can read about SelfStubber
+;; from the Module page *Devel::SelfStubber.pm* which links to
+;; *SelfLoader.pm*, which is (one file) to my opinion better
+;; autoload choice than *Autoloader.pm* (splits file to many files by
+;; function)
+;;
+;; To use SelfStubber with this package, you need to arrange your
+;; module to read like below. Notice the "BEGIN:" and "END:"
+;; comment-tokens are for function `tinyperl-selfstubber-stubs',
+;; which will fill in the section with the right stubs.
+;;
+;; If you don't have "BEGIN: Devel::SelfStubber" and "END:
+;; Devel::SelfStubber" sections in your file, calling
+;; `tinyperl-selfstubber-stubs' prints the found stubs in separate
+;; shell buffer.
+;;
+;; package MyClass;
+;;
+;; use Exporter;
+;; use SelfLoader;
+;; use vars qw( $VERSION @ISA @EXPORT @EXPORT_OK );
+;;
+;; @ISA = qw(Exporter);
+;;
+;; @EXPORT = qw( .. );
+;;
+;; $VERSION = ..
+;;
+;; # BEGIN: Devel::SelfStubber
+;;
+;; # END: Devel::SelfStubber
+;;
+;; 1;
+;; __DATA__
+;;
+;; <implementation: functions and variables>
+;;
+;; __END__
+;;
+;; Updating the VERSION variable
+;;
+;; If you plan to submit your perl module or program to the CPAN
+;; at http://cpan.perl.org/ the upload criteria is that your file
+;; must have a version number. The traditional method has long
+;; used some version control software's number (those of CVS or
+;; RCS etc.), but it really doesn't tell much to the *user*. It might
+;; tell something to the developer, but from user's point of view,
+;; he is much more interested in knowing when the file was
+;; last updated. The version number 2.77 may be two years old.
+;;
+;; Where is that variable used? The *MakeMaker* perl module (that
+;; you use when making packages ready to CPAN upload) reads the
+;; first variable named VERSION and names your release according
+;; to it.
+;;
+;; Consider to use two version numbers: one for the release and
+;; one for the kit name. In order to *MakeMaker* to pick up the
+;; version number for a kit (tar.gz release, that is, for the
+;; user), it must see a VERSION variable. You can store the
+;; (a) version control software's number at the beginning of file
+;; inside comments and the (b) release number to a perl variable.
+;;
+;; use vars qw ( $VERSION );
+;;
+;; # This is for use of Makefile.PL and ExtUtils::MakeMaker
+;; # So that it puts the tardist number in format YYYY.MMDD
+;; # The REAL version number is defined later
+;; #
+;; # The following variable is updated by Emacs setup whenever
+;; # file is saved
+;;
+;; $VERSION = '1234.1234';
+;;
+;; If the VERSION variable uses number format NNNN.NNNN, then it
+;; is assumed to contain ISO 8601 date YYYY.MMDD and this package
+;; will update the `$VERSION' variable's date every time file is
+;; saved (see `write-file-hooks' and `tinyperl-version-stamp').
+;;
+;; Submitting your perl script to CPAN
+;;
+;; In addition to archiving your Perl *libraries* to CPAN, you can also
+;; submit perl *scripts* there. In order to get your submission right
+;; refer to page:
+;;
+;; http://www.perl.com/CPAN-local//scripts/submitting.html
+;;
+;; The most important point is that your script includes pod that
+;; describes your script. It must contain at minimum the headings
+;; README, SCRIPT CATEGORIES, COREQUISITES, OSNAMES which are already
+;; included in the default pod skeleton via command
+;;
+;; `tinyperl-pod-write-skeleton-script-manpage'
+;;
+;; Here is code that that can be used in Perl programs to print out
+;; the pod documentation when --help option is requested (Use
+;; Getop::Long.pm). The code works for both Win32 and Unix Perl
+;; implementations. The variable $LIB identifies the "group" where the
+;; function belongs, in this case it is program, while it could have
+;; been a Perl library module too. You set global $LIB variable at the
+;; beginning of file with:
+;;
+;; use English
+;; use File::Basename;
+;;
+;; use vars qw( $LIB );
+;; $LIB = basename $PROGRAM_NAME;
+;;
+;; Here is the help function written with POD (perl 5.004 or higher)
+;;
+;; < Create this Help() function banner with mode key >
+;; < C-c . f or `tinyperl-pod-write-skeleton-script-function' >
+;;
+;; # ***************************************************************
+;; #
+;; # DESCRIPTION
+;; #
+;; # Print help and exit.
+;; #
+;; # INPUT PARAMETERS
+;; #
+;; # $msg [optional] Reason why function was called.-
+;; #
+;; # RETURN VALUES
+;; #
+;; # none
+;; #
+;; # ***************************************************************
+;;
+;; =pod
+;;
+;; < This part: appears after you have called >
+;; < C-c . m or `tinyperl-pod-write-skeleton-script-manpage' >
+;;
+;; =cut
+;;
+;; sub Help (;$)
+;; {
+;; my $id = "$LIB.Help";
+;; my $msg = shift; # optional arg, why are we here...
+;;
+;; pod2text $PROGRAM_NAME;
+;;
+;; print $msg if $msg;
+;;
+;; exit 1;
+;; }
+;;
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+;;{{{ setup: require
+
+(require 'tinylibm)
+
+(eval-when-compile (ti::package-use-dynamic-compilation))
+
+(eval-and-compile
+ (defvar compilation-error-regexp-alist)
+ ;; Follow pod URLs and other url links like cut(1)
+ ;; Go to grep result.
+ (autoload 'turn-on-tinyurl-mode-1 "tinyurl" "" t)
+ (autoload 'tinyurl-find-url-file "tinyurl" "" t)
+ ;; Why do we autoload this? Because function turn-on-tinyperl-mode
+ ;; is not physically here, but automagically created by a macro call,
+ ;; --> byte compiler needs this hint so that it doesn't flag
+ ;; ** The following functions are not known to be defined:
+ ;; turn-off-tinyperl-mode, turn-on-tinyperl-mode
+ ;; (autoload 'turn-on-tinyperl-mode "tinyperl" "" t)
+ ;; (autoload 'turn-off-tinyperl-mode "tinyperl" "" t)
+ (defvar font-lock-keywords))
+
+(ti::package-defgroup-tiny TinyPerl tinyperl-: extensions
+ "Additional function to perl programming.
+ Overview of features
+
+ o Instant function help: See documentation of `shift', `pop'...
+ o Show Perl manual pages in *pod* buffer
+ o Load source code into Emacs, like Devel::DProf.pm
+ o Grep through all Perl manpages (.pod)
+ o Follow POD manpage references to next pod page with TinyUrl
+ o Coloured pod pages with `font-lock'
+ o Separate `tinyperl-pod-view-mode' for jumping topics and pages
+ forward and backward in *pod* buffer.")
+
+;;}}}
+;;{{{ setup: public variables
+
+(defcustom tinyperl-:load-hook '(tinyperl-install)
+ "*Hook run when file has been loaded."
+ :type 'hook
+ :group 'TinyPerl)
+
+(defcustom tinyperl-:pod2text-before-hook nil
+ "Hook run before calling pod2text pod buffer See `tinyperl-pod2text'."
+ :type 'hook
+ :group 'TinyPerl)
+
+(defcustom tinyperl-:pod2text-after-hook nil
+ "Hook run after calling podchecker in that buffer.
+See `tinyperl-podchecker'."
+ :type 'hook
+ :group 'TinyPerl)
+
+(defcustom tinyperl-:podchecker-before-hook nil
+ "Hook run before calling pod2text pod buffer See `tinyperl-podchecker'."
+ :type 'hook
+ :group 'TinyPerl)
+
+(defcustom tinyperl-:podchecker-after-hook nil
+ "Hook run after calling pod2text in that buffer. See `tinyperl-pod2text'."
+ :type 'hook
+ :group 'TinyPerl)
+
+(defcustom tinyperl-:perldoc-hook nil
+ "Hook run after calling `tinyperl-perldoc'."
+ :type 'hook
+ :group 'TinyPerl)
+
+;;}}
+;;{{ setup: public
+
+(defcustom tinyperl-:verbose 1
+ "*If number, bigger than zero, dispaly informational messages.
+In error situations you can look old messages from *Messages* buffer."
+ :type '(integer :tag "Verbose level 0 ... 10")
+ :group 'TinyPerl)
+
+(defcustom tinyperl-:key-pageup-control 'heading
+ "*How to use PgUp and PgDown keys. 'heading or 'normal."
+ :type '(choice (const heading)
+ (const normal))
+ :group 'TinyPerl)
+
+(defcustom tinyperl-:pod-buffer-control 'one
+ "*How to display POD documentation. 'single or 'many windows."
+ :type '(choice (const one)
+ (const many))
+ :group 'TinyPerl)
+
+(defcustom tinyperl-:skeleton-script-ftp-url nil
+ "*URL where your Perl code is available. Used by skeleton."
+ :type 'string
+ :group 'TinyPerl)
+
+(defcustom tinyperl-:pause-directory nil
+ "*Directory where to copy your PAUSE uploads.
+A Perl script must have unique naming before it can be accepted
+for PAUSE upload. If you do not know what PAUSE (The Perl Authors Upload
+Server) is, learn more about becoming a Perl developer at
+http://pause.perl.org/ => about pause.
+
+This variable is used by `tinyperl-pause-copy-file' for default
+location where the pause upload candidates are copied.
+
+See also http://cpan.perl.org/authors/id/NEILB/ cpan-upload-1.9.tar.gz."
+ :type 'directory
+ :group 'TinyPerl)
+
+(defcustom tinyperl-:copyright-function 'tinyperl-copyright
+ "*Copyright notice for your Perl programs."
+ :type 'function
+ :group 'TinyPerl)
+
+;; This configuration file MUST BE in OS specific name. It is very
+;; common that Networked NT workstations access a SAMBA mounted
+;; Unix disk and then the HOME directory refer to
+;; the Unix disk.
+;;
+;; However if you log into that Unix, You will run Unix Perl
+;; If you log into win32 workstation with SAMBA mount, you run win32 Perl.
+;; See that problem now and the need for OS specific filename?
+;;
+;; The cache information for Win32 and Unix must be in different files,
+;; if your HOME points to the same location. E.g. the stored perl
+;; interpreter name and location is completely different in the cache.
+
+(defcustom tinyperl-:cache-file-prefix
+ (ti::package-config-file-prefix "tinyperl")
+ "*Prefix part of the cache filename where @INC content is recorded.
+See function `tinyperl-save-state' and `tinypath-cache-file-name'."
+ :type 'string
+ :group 'TinyPerl)
+
+(defcustom tinyperl-:cache-file-postfix ".el"
+ "*Extension for cache file. See `tinypath-:cache-file-prefix'.
+Normally \".el\" but to save space this could be set to \".el.gz\"."
+ :type 'string
+ :group 'TinyPath)
+
+(defcustom tinyperl-:cache-file-days-old-max 7
+ "Maximum days before expiring `tinyperl-:cache-file'.
+If your Perl environmnt lives a lot, new packages are installed in periodic
+intervals, then keep this value withing 7 days. If your environment is on the
+other hand very stable and packages don't change often, then you can set
+this to very large value, say, 30 days.
+
+You can always rebuild the cached Perl information with
+\\[universal-argument] \\[tinyperl-install]"
+ :type 'integer
+ :group 'TinyPerl)
+
+(defcustom tinyperl-:perl-bin
+ (or (executable-find "perl")
+ (error "TinyPerl: Can't find binary: perl"))
+ "*Perl interpreter used. Must be Perl 5.x."
+ :type 'string
+ :group 'TinyPerl)
+
+(defcustom tinyperl-:perldoc-bin
+ ;; In Win32, this is perldoc.bat and old `executable-find' command
+ ;; does not search .bat files.
+ (or (or (executable-find "perldoc")
+ (and (ti::win32-p)
+ (ti::file-get-load-path "perldoc.bat" exec-path))
+ ;; Desperate search: this shuld be equal to exec-path but
+ ;; the environment mey be messed up.
+ (and (ti::win32-p)
+ (ti::file-get-load-path "perldoc.bat"
+ (split-string (getenv "PATH") ";" )))
+ ;; Emacs executable-find cannot find pure Cygwin "perldoc".
+ ;;
+ (ti::file-get-load-path "perldoc" exec-path))
+ (error "TinyPerl: Can't find binary perldoc or perldoc.bat"))
+ "*Perldoc binary. Absolute path runs faster."
+ :type 'string
+ :group 'TinyPerl)
+
+(defcustom tinyperl-:pod2text-bin
+ (or (executable-find "pod2text")
+ (ti::file-get-load-path "pod2text" exec-path) ;; Cygwin perl file
+ (error "TinyPerl: Can't find binary: pod2text"))
+ "*Perldoc binary. Absolute path runs faster."
+ :type 'string
+ :group 'TinyPerl)
+
+(defcustom tinyperl-:inc-path-switches nil
+ "*List of swithes you want to pass to perl to add mode @INC paths.
+Example : '(\"-I\" \"/path/path\"."
+ :type 'string
+ :group 'TinyPerl)
+
+(defcustom tinyperl-:pod-font-lock-keywords ;; &fonts
+ (list
+ ;; ....................................................... pod2text ...
+ ;; Remeber that the order of the regular expressions is significant.
+ ;; First come, first served
+ ;;
+ ;; Like in File::Basename
+ ;; NAME
+ ;; fileparse - split a pathname into pieces
+ ;;
+ ;; basename - extract just the filename from a path
+ ;;
+ ;; dirname - extract just the directory from a path
+ '("^ \\([^ \t\r\n]+\\)[ \t]+-[ \t]+"
+ 1 font-lock-reference-face)
+
+ '("^ [^ \t\r\n]+[ \t]+-[ \t]+\\(.*\\)"
+ 1 font-lock-constant-face) ;; font-lock-string-face
+ ;; Headings and Sub headings
+ ;; Method description in Class
+ ;;
+ ;; $ua->from([$email_address])
+ ;; new()
+
+ '("^ ? ? ? ?\\([\"$%@A-Za-z_]+\\)[ \t]*$"
+ 1 font-lock-type-face)
+ ;; TWO WORDS after 4 spaces, level 2 heading
+ ;;
+ ;; Packaging commands
+ ;; package pkg
+ ;;
+ ;; source-package
+ '("^ \\([A-Za-z_.]+[ -]*[A-Za-z-]*\\)[ \t]*$"
+ 1 font-lock-type-face)
+ ;; Head2/over-4
+ ;; package-source.sh
+ '("^ \\([A-Za-z][A-Za-z_.-]+[ -]*[A-Za-z_.-]*\\)[ \t]*$"
+ 1 font-lock-type-face)
+ '("^\\([A-Z][a-z]+[ \t]+[A-Za-z]+.*\\)$"
+ 1 font-lock-type-face)
+ ;;
+ ;; =head2 Topic Name Here
+ ;; multipe words
+ ;; perlre.pod 5.8.0: " Version 8 Regular Expressions"
+ ;; perdoelta.pod 5.8.0 " Self-tying Problems"
+ ;;
+ '("^ \\([A-Za-z]+-?[A-Za-z]+[ \t]+[A-Za-z0-9].+[A-Za-z]\\)[ \t]*$"
+ 1 font-lock-type-face t)
+ ;; perldelta.pod 5.8.0: " 64-bit platforms and malloc"
+ '("^ \\([0-9]+-[A-Za-z]+[ \t]+[A-Za-z0-9].+[A-Za-z]\\)[ \t]*$"
+ 1 font-lock-type-face)
+ ;; perlre.pod 5.8.0: " Warning on \1 vs $1"
+ '("^ \\([A-Z][a-z]+[ \t]+[A-Za-z]+[ \t]+.*\\)[ \t]*$"
+ 1 font-lock-type-face)
+ ;; perldelta.pod 5.8.0: "IEEE-format Floating Point Default"
+ '("^ \\([A-Z]+-?[a-z]+[ \t]+[A-Za-z]+[ \t]+.*\\)[ \t]*$"
+ 1 font-lock-type-face)
+ ;; " Preliminary setup:"
+ '("^ \\([A-Z][a-z]+.*:[ \t]*\\)$"
+ 1 font-lock-type-face)
+ '("\\(perl[^ ]+\\)[ \t\n\r]+man\\(ual \\)?page"
+ 1 font-lock-type-face)
+ ;; perlre.pod 5.8.0:
+ ;; SEE ALSO
+ ;; perlrequick.
+ ;; "Regexp Quote-Like Operators" in perlop.
+ '("^[ \t]+\\(perl[^ ]+\\)\\.[ \t]*$"
+ 1 font-lock-type-face)
+ '("in[ \t]+\\(perl[^ ]+\\)\\.[ \t]*$"
+ 1 font-lock-type-face)
+ ;; --this-option
+ (list
+ (concat
+ "--[-a-zA-Z0-9]+\\>"
+ "\\| -[-a-zA-Z0-9]\\>" ;; option names
+ "\\|\\(http\\|ftp\\|news\\|wais\\)://[^ \t\r\n]+"
+ "\\|<?[^ \t\n\r]+@[^ \t\r\n]+>?" ;; <foo@bar.com>
+ "\\|`[^\"'`\n\r]+'" ;; `this'
+ "\\|\\<[^( \t\n\r]+([$@%;*]*)" ;; function($)
+ ;; File::Find Filter::Util::Call
+ ;; PerlIO::via::QuotedPrint
+ "\\|\\<[A-Z][a-zA-Z]+\\(::[A-Za-z]+\\)+\\>"
+ "\\|[^ \t\r\n]+[\\/][^ \t\r\n]+") ;; CPAN/modules/by-module
+ 0 'font-lock-reference-face)
+ ;; [Wall]
+ (list
+ (concat
+ "\\[[a-zA-Z]+\\]+"
+ "\\|\\<[-a-zA-Z0-9]+([0-9]+[A-Z]?)") ;; chmod(1)
+ 0 'font-lock-constant-face)
+ (list
+ (concat
+ ;; "abc"
+ ;; `this' US style
+ ;; 'this' European style
+ "[\"][^\"\r\n]+[\"]"
+ "\\|`[^'`\r\n]+'"
+ "\\|'[^'\r\n]+'"
+ ;; Notice that BLOCK ... LOGIN-NAME
+ "\\|\\<[%$@]*[A-Z_][-A-Z_]+\\>" ;; @VAR_HERE, BIG_LETTERS
+ ;; it's *funny* that ...
+ "\\|\\*[^ \r\n*]+\\*")
+ 0 'font-lock-keyword-face)
+;;; ;; like chdir() function ...
+;;; '("[a-z][^ \t\n\r(]+()" 0 font-lock-reference-face)
+ ;; Perl Keywords
+ (list
+ (concat
+ "^ \\( \\)*" ;; 8 x indentation allowed
+ "\\<\\("
+ "sub"
+ "\\|package"
+ "\\|use"
+ "\\|die"
+ "\\|warn"
+ "\\|local"
+ "\\|my"
+ "\\|if"
+ "\\|[ }]*else[ {]*"
+ "\\|eval"
+ "\\|print"
+ "\\|while"
+ "\\)\\>"
+ "\\|[$]_")
+ 0 'font-lock-builtin-face t)
+ ;; ...................................................... pod-write ...
+ '("^=\\(head[0-9]\\|pod\\|begin\\|end\\|cut\\|item\\)"
+ 0 font-lock-function-name-face t)
+ '("^=\\(head[0-9]\\|pod\\|begin\\|end\\|cut\\|item\\)[ \t]+\\(.*\\)"
+ 2 font-lock-reference-face t)
+ '("^=item[ \t]+\\(.*\\)"
+ 1 font-lock-keyword-face t)
+ '("^=.*"
+ 0 font-lock-type-face))
+ "*Font lock keywords."
+ :type 'sexp
+ :group 'TinyPerl)
+
+;;}}}
+;;{{{ setup: private
+
+(defvar tinyperl-:inc-path nil
+ "The content of @INC.
+The path names are not in pure rwa @INC format, but they
+have been processed to meet host Emacs's understanding of underlying
+operating systems paths.
+
+E.g Win32/Cygwin/perl returns paths in native Unix format which must
+be translated to Emacs that is running. For GNU Emacs, this means
+paths in DOS style.")
+
+(defvar tinyperl-:inc-module-list nil
+ "The content .pm files under @INC.")
+
+(defvar tinyperl-:pod-path nil
+ "Path to perl distribution POD files.")
+
+(defvar tinyperl-:pod-list nil
+ "List of pod files. '((file.pod . path) (file.pod . path) ..).")
+
+(defvar tinyperl-:pod-buffer-name "*pod*"
+ "Buffer where to print POD.")
+
+(defvar tinyperl-:faq-buffer-name "*pod FAQ-grep*"
+ "Buffer where to put context exerpts after grep search.
+See `tinyperl-pod-grep-faq-answer'")
+
+(defvar tinyperl-:perldoc-buffer "*perldoc*"
+ "Buffer where to output perldoc.")
+
+(defvar tinyperl-:podchecker-buffer "*podchecker*"
+ "Buffer where to output Pod::Checker::podchecker().")
+
+;;}}}
+;;{{{ version
+
+;;;###autoload (autoload 'tinyperl-version "tinyperl" "Display commentary." t)
+
+(eval-and-compile
+ (ti::macrof-version-bug-report
+ "tinyperl.el"
+ "tinyperl"
+ tinyperl-:version-id
+ "$Id: tinyperl.el,v 2.85 2007/08/03 20:16:25 jaalto Exp $"
+ '(tili-:version-id
+ tinyperl-:load-hook
+ tinyperl-:pod2text-before-hook
+ tinyperl-:pod2text-after-hook
+ tinyperl-:podchecker-before-hook
+ tinyperl-:podchecker-after-hook
+ tinyperl-:perldoc-hook
+ tinyperl-:key-pageup-control
+ tinyperl-:pod-buffer-control
+ tinyperl-:skeleton-script-ftp-url
+ tinyperl-:pause-directory
+ tinyperl-:copyright-function
+ tinyperl-:cache-file-prefix
+ tinyperl-:cache-file-postfix
+ tinyperl-:perl-bin
+ tinyperl-:perldoc-bin
+ tinyperl-:pod2text-bin
+ tinyperl-:inc-path-switches
+ tinyperl-:pod-font-lock-keywords
+ tinyperl-:inc-path
+ tinyperl-:inc-module-list
+ tinyperl-:pod-path
+ tinyperl-:pod-list
+ tinyperl-:pod-buffer-name
+ tinyperl-:perldoc-buffer
+ tinyperl-:podchecker-buffer)))
+
+;;;### (autoload 'tinyperl-debug-toggle "tinyperl" t t)
+
+(eval-and-compile (ti::macrof-debug-standard "tinyperl" "-:"))
+
+;;}}}
+;;{{{ Macros
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinyperl-verbose-macro 'lisp-indent-function 1)
+(defmacro tinyperl-verbose-macro (level &rest body)
+ "When LEVEL is =< `tinyperl-:verbose' run BODY."
+ (`
+ (when (and (numberp tinyperl-:verbose)
+ (or (= (, level) tinyperl-:verbose)
+ (< (, level) tinyperl-:verbose)))
+ (,@ body))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinyperl-directory-files 'lisp-indent-function 3)
+(defmacro tinyperl-directory-files (variable path &optional regexp)
+ "Store to VARIABLE .pl and .pm files in PATH. Optionally match REGEXP."
+ (` (setq (, variable)
+ (directory-files
+ (, path)
+ nil
+ (or (, regexp) "\\.pl\\|\\.pm")))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinyperl-executable-set 'lisp-indent-function 3)
+(defmacro tinyperl-executable-set (sym bin &optional regexp)
+ "Set variable SYM to executable BIN name searching REGEXP.
+This is shorthand of saying, that locate the BIN in the `exec-path'
+when it matches REGEXP and set variable SYM to that value, effectively:
+
+ (setq tinyperl-:perldoc-bin
+ (tinyperl-executable-find-path
+ \"perldoc\" tinyperl-:perldoc-bin \"perldoc\"))
+
+--> (tinyperl-executable-set 'tinyperl-:perldoc-bin \"perldoc\")"
+ (`
+ (set (, sym)
+ (tinyperl-executable-find-path
+ (, bin)
+ (symbol-value (, sym))
+ (or (, regexp)
+ (, bin))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-perl-module-exists-p (module)
+ "Return path if MODULE(.pm) is known to ´tinyperl-:inc-module-list'."
+ (unless (string-match "\\.pm$" module)
+ (setq module (concat module ".pm")))
+ (let* ((elt (assoc module tinyperl-:inc-module-list))
+ (file (if (string-match ".*::\\(.*\\)" module)
+ (match-string 1 module)
+ module)))
+ (when elt
+ (concat (file-name-as-directory (cdr elt))
+ file))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-grep-program ()
+ "Return value of `grep-program' if available."
+ ;; Hide variable `grep-program' from byte compiler
+ ;; We do not need (require 'grep) only to get this variable
+ ;; defined.
+ (let ((sym 'grep-program))
+ (if (boundp sym)
+ (symbol-value sym)
+ "grep")))
+
+;;}}}
+;;{{{ code: install, mode
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-variable-convert (&optional dos-format)
+ "Convert all path variables to Unix or DOS-FORMAT."
+ (flet ((convert (var)
+ (if dos-format
+ (ti::file-name-backward-slashes var)
+ (ti::file-name-forward-slashes var))))
+ (setq tinyperl-:pod2text-bin (convert tinyperl-:pod2text-bin))
+ (setq tinyperl-:perldoc-bin (convert tinyperl-:perldoc-bin))
+ (setq tinyperl-:perl-bin (convert tinyperl-:perl-bin))
+ (setq tinyperl-:pod-path (convert tinyperl-:pod-path))))
+
+;;; --------------------------------------------------------------------
+;;;
+(defun tinyperl-executable-find-path (program old-value regexp)
+ "Find path for PROGRAM with OLD-VALUE matching REGEXP."
+ (if (and (ti::file-name-path-p (or old-value ""))
+ (file-exists-p old-value)
+ (not (file-directory-p old-value)))
+ old-value
+ (setq program
+ (if (and tinyperl-:perl-bin
+ ;; This could return "perl5.005"
+ (string-match regexp old-value))
+ (match-string 0 old-value)
+ ;; use default then
+ program))
+ (or (executable-find program)
+ ;; Only way to find Cygwin "perldoc".
+ (ti::file-get-load-path program exec-path))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-perl-examine (perl)
+ "Check type of PERL. Return 'win32-activestate 'win32-cygwin 'perl.
+Perl is called with -v. Following properties are stored in
+
+variable `tinyperl-:perl-bin' are set to properties:
+
+ 'version-answer => The -v result string
+ 'type => 'win32-activestate
+ 'win32-cygwin
+ 'perl"
+ (let* ((info (ti::process-perl-version perl)))
+ (put 'tinyperl-:perl-bin 'version-answer (nth 3 info))
+ (put 'tinyperl-:perl-bin 'type (nth 1 info))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinyperl-perl-type ()
+ "Return Perl type. Provided `tinyperl-perl-examine' has been called."
+ (or (get 'tinyperl-:perl-bin 'type)
+ (progn (tinyperl-perl-examine tinyperl-:perl-bin)
+ (get 'tinyperl-:perl-bin 'type))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinyperl-perl-type-version-info ()
+ "Return Perl -v info. Provided `tinyperl-perl-examine' has been called."
+ (or (get 'tinyperl-:perl-bin 'version-answer)
+ (progn (tinyperl-perl-examine tinyperl-:perl-bin)
+ (get 'tinyperl-:perl-bin 'version-answer))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-install-variables-binaries (&optional force)
+ "Install or FORCE setting binary variables like `tinyperl-:perl-bin'
+Return:
+ t If some path needed fixing. This means that cache must be resaved."
+ (interactive "P")
+ (let* (ok)
+ (flet ((exec-set
+ (sym bin &optional regexp) ;; Parameters
+ (let* ((value (symbol-value sym)))
+ (when (or force
+ ;; Value is set, possibly read from the cache,
+ ;; but that binary does not exist any more.
+ ;; Perhaps user has relocated Rerl. Deternine
+ ;; new changed location.
+ (and (stringp value)
+ (not (file-exists-p value)))
+ ;; Value has not been set yet
+ (not (stringp value)))
+ (setq ok t)
+ (or (tinyperl-executable-set sym bin regexp)
+ (error "TinyPerl: No binary `%s` for variable `%s' \
+Check variable `exec-path'"
+ bin
+ (symbol-name sym)))))))
+ ;; `perl5' `perl5.004' ...
+ ;; If the name does not contain number, use "perl".
+ (exec-set 'tinyperl-:perl-bin
+ "perl" "perl[-.0-9]*\\.exe\\|perl[^\\/]*")
+ (exec-set 'tinyperl-:perldoc-bin "perldoc")
+ (exec-set 'tinyperl-:pod2text-bin "pod2text")
+ (tinyperl-perl-examine tinyperl-:perl-bin)
+ ;; Leave trace to Message buffer.
+ (tinyperl-verbose-macro 2
+ (message "TinyPerl: [Perl version] => %s"
+ (or (tinyperl-perl-type-version-info) "")))
+ ok)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-install-variables-lookup (&optional check verb)
+ "Set all global lookup variables.
+
+Input:
+
+ CHECK Check variable: Preserve previous content and set only
+ those that do not have value.
+ if value is 'force, reset variable in all cases.
+
+ VERB Allow verbose messages
+
+References:
+
+ `tinyperl-:inc-path'
+ `tinyperl-:inc-module-list'
+ `tinyperl-:pod-path'
+ `tinyperl-:pod-list'"
+ (interactive)
+ (flet ((set-maybe (symbol eval-form)
+ (when (or (eq 'force check)
+ (and check
+ (symbol-value symbol)))
+ (tinyperl-verbose-macro 1
+ (message "TinyPerl: Setting up var: %s" symbol))
+ (set symbol
+ (eval eval-form)))))
+ (when verb
+ (tinyperl-verbose-macro 1
+ (message "TinyPerl: Setting up variables...")))
+ (unless (set-maybe
+ 'tinyperl-:inc-path
+ '(tinyperl-inc-path tinyperl-:perl-bin))
+ (error "TinyPerl: Setup failure tinyperl-:inc-path,\
+tinyperl-:perl-bin Unrecognized. Need Perl 5. [%s]"
+ tinyperl-:perl-bin))
+ (unless (set-maybe
+ 'tinyperl-:inc-module-list
+ '(tinyperl-build-list-of-inc-files
+ tinyperl-:inc-path
+ verb))
+ (error "TinyPerl: Setup failure tinyperl-:inc-module-list"))
+ (unless (set-maybe
+ 'tinyperl-:pod-path
+ '(tinyperl-pod-path tinyperl-:perl-bin))
+ (error "TinyPerl: Setup failure tinyperl-:pod-path"))
+ (unless (set-maybe
+ 'tinyperl-:pod-list
+ '(tinyperl-build-pod-files))
+ (error "TinyPerl: Setup failure tinyperl-:pod-list"))
+ (when verb
+ (tinyperl-verbose-macro 1
+ (message "TinyPerl: Setting up variables...Done.")))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-install-variables-lookup-maybe (&optional force verb)
+ "Set up global variables. FORCE or only if they don't have values."
+ (tinyperl-install-variables-lookup (if force 'force 'check) verb))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-install-1 (&optional force verb)
+ "Install variables.
+You should call `tinyperl-install' or `tinyperl-install-force' instead.
+
+Input:
+
+ FORCE If non-nil, rebuild all variables and
+ save new `(tinyperl-cache-file-name)'.
+ If nil, read saved variables from `(tinyperl-cache-file-name)'.
+
+ VERB Allow verbose messaegs."
+ (let* (stat
+ ok)
+ ;; The FORCE Flag says that we should start all over, no
+ ;; matter how broken our setup is. In case the unfortunate
+ ;; accident of tinyperl-:perl-bin being in format
+ ;; e:USRLOCALBINPERLBINperl.exe we can recover the state here
+ ;; and start over (that Win32 backslash problem: \usr\local ...).
+ ;;
+ ;; If the perl exectable is not correct in the first place
+ ;; we can't continue.
+ (setq stat (tinyperl-load-state-if-recent-enough)
+ ok (tinyperl-install-variables-binaries force))
+ (if (or force
+ (null stat))
+ (tinyperl-install-variables-lookup 'force)
+ (tinyperl-install-variables-lookup-maybe))
+ ;; We must use forward slashes, because if we save the cache file,
+ ;; It would look like:
+ ;;
+ ;; (defconst tinyperl-:perl-bin
+ ;; "e:\USR\LOCAL\BIN\PERL\BIN\perl.exe")
+ ;;
+ ;; --> e:USRLOCALBINPERLBINperl.exe when read from
+ ;;
+ (tinyperl-variable-convert)
+ (when (or force
+ (null stat))
+ (tinyperl-save-state nil verb)
+ (when verb
+ (tinyperl-verbose-macro 1
+ (message "TinyPerl: Setting up variables...done"))))
+ (put 'tinyperl-mode
+ 'podchecker
+ (tinyperl-perl-module-exists-p "Pod::Checker.pm"))
+
+ ok)) ;; install end
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyperl-install (&optional uninstall force)
+ "The main installer. Set up everything: hooks and variables.
+This function is best put into `tinyperl-:load-hook'.
+
+Input:
+
+ UNINSTALL Uninstall, remove hooks etc.
+ FORCE Forced install. In case modules have installed from CPAN,
+ this variable should be set to force rescan of @INC instead
+ of using cache."
+ (interactive "P")
+ (tinyperl-install-hooks uninstall)
+ (unless uninstall
+ (tinyperl-install-1 force 'verb))
+ (turn-on-tinyperl-mode-all-buffers uninstall)
+ (ti::add-hooks '(perl-mode-hook
+ cperl-mode-hook)
+ 'turn-on-tinyperl-mode
+ uninstall))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyperl-install-force ()
+ "Rebuild all global variables. Needed after CPAN module install."
+ (interactive)
+ (tinyperl-install nil 'force))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyperl-uninstall ()
+ "Uninstall TinyPerl."
+ (interactive)
+ (tinyperl-install 'uninstall))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-cache-file-name ()
+ "Return Perl version specific cache file.
+
+Don't touch this code unless you know what you're doing.
+
+ We need Emacs specific cache files, because the @INC path
+ names returned by Activestate Perl and Cygwin Perl are different
+ under different Emacs flavors: XEmacs can be built under Cygwin and win32
+ but Emacs understands only DOS paths. .. the matrix is:
+
+ Win32 Cygwin Perl @INC is unix style => convert to dos for Emacs
+ Win32 Activestate Perl @INC is DOS style => use as is in Emacs
+
+ XEmacs .. eh, well, that hasn't been tackled yet. The @INC matrix
+ would be:
+
+ ygwin perl + Cygwin XEmacs plays well together
+ ygwin perl + Win32 XEmacs doesn't
+ ctivestate + Cygwin XEmacs doesn't
+ ctivestate + Win32 XEmacs does.
+
+References:
+
+ `tinyperl-:cache-file-prefix'.
+ `tinyperl-:cache-file-postfix'"
+ (concat (if (stringp tinyperl-:cache-file-prefix)
+ (concat tinyperl-:cache-file-prefix "-")
+ "emacs-config")
+ ;; (if (ti::win32-p) "win32-" "unix-")
+ (if (ti::emacs-p)
+ "emacs"
+ "xemacs")
+ "-"
+ (let ((sym (tinyperl-perl-type)))
+ (if sym
+ (symbol-name sym)
+ (error "TinyPerl: Perl type is not known.")))
+ (if (stringp tinyperl-:cache-file-postfix)
+ tinyperl-:cache-file-postfix
+ "")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-load-state-if-recent-enough ()
+ "Load `(tinyperl-cache-file-name)'.
+But only if less than `tinyperl-:cache-file-days-old-max'"
+ (interactive)
+ (let ((file (tinyperl-cache-file-name)))
+ (if (and (file-exists-p file)
+ (< (ti::file-days-old file)
+ tinyperl-:cache-file-days-old-max))
+ (tinyperl-save-state 'load 'message))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-save-state (&optional load &optional verb)
+ "Save or LOAD variables to `(tinyperl-cache-file-name).'
+When LOAD: If `(tinyperl-cache-file-name)' does not exist. return nil."
+ (interactive)
+ (ti::verb)
+ (let ((file (tinyperl-cache-file-name)))
+ (cond
+ (load
+ (when (file-exists-p file)
+ (load file)
+ (when verb
+ (tinyperl-verbose-macro 1
+ (message "TinyPerl: state restored [%s]" file)))
+ t))
+ (t
+ (ti::write-file-variable-state
+ file
+ "TinyPerl.el saved state"
+ '(tinyperl-:inc-path
+ tinyperl-:inc-module-list
+ tinyperl-:pod-path
+ tinyperl-:pod-list
+ tinyperl-:perl-bin
+ tinyperl-:perldoc-bin
+ tinyperl-:pod2text-bin))
+ (when verb
+ (tinyperl-verbose-macro 1
+ (message "TinyPerl: state saved [%s]" file)))
+ t))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun turn-on-tinyperl-mode-all-buffers (&optional off)
+ "Turn function `tinyperl-mode' on in every perl buffer. Optionally turn OFF."
+ (interactive "P")
+ (ti::dolist-buffer-list
+ (or
+ (string-match "perl" (downcase (symbol-name major-mode)))
+ (string-match "\\.pl$" (buffer-name))
+ (string-match "code-perl" (or (ti::id-info) "")))
+ 'tmp-buffers-too
+ nil
+ (let ((mode (symbol-value 'tinyperl-mode)))
+ ;; We use `symbol-value' because byte compiler does not see the
+ ;; 'tinyperl-mode' yet. It's defined by the minor mode wizard macro
+ (if off
+ (unless (null mode)
+ (ti::funcall 'turn-off-tinyperl-mode))
+ (unless mode
+ (ti::funcall 'turn-on-tinyperl-mode))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-install-hooks (&optional remove verb)
+ "Install default hooks or REMOVE. VERB."
+ (interactive "P")
+ (ti::verb)
+ (ti::add-hooks 'tinyperl-:perldoc-hook
+ '(tinyperl-pod-font-lock
+ turn-on-tinyurl-mode-1
+ ti::buffer-strip-control-m)
+ remove)
+ (ti::add-hooks '(tinyperl-:pod2text-after-hook
+ tinyperl-:podchecker-after-hook)
+ '(turn-on-tinyurl-mode-1
+ turn-on-tinyperl-pod-view-mode
+ ti::buffer-strip-control-m)
+ remove)
+ (ti::add-hooks 'tinyperl-:pod-view-mode-hook
+ 'tinyperl-pod-font-lock
+ remove)
+ (ti::add-hooks 'tinyperl-:pod-write-mode-hook
+ 'tinyperl-pod-font-lock
+ remove)
+ (ti::add-hooks '(perl-mode-hook
+ cperl-mode-hook)
+ 'turn-on-tinyperl-mode
+ remove)
+ (ti::add-hooks 'tinyperl-:mode-define-keys-hook
+ 'tinyperl-mode-define-keys remove)
+ (ti::add-hooks 'tinyperl-:pod-view-mode-define-keys-hook
+ 'tinyperl-pod-view-mode-define-keys
+ remove)
+ (ti::add-hooks 'tinyperl-:pod-write-mode-define-keys-hook
+ 'tinyperl-pod-write-mode-define-keys
+ remove)
+ (ti::add-hooks 'write-file-hooks
+ 'tinyperl-version-stamp
+ remove)
+ (when verb
+ (tinyperl-verbose-macro 2
+ (message "TinyPerl: Hooks installed"))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-copyright ()
+ "Insert copyright string fro Perl program."
+ (interactive)
+ (insert "Copyright (C) " (format-time-string "%Y " (current-time))
+ (or (user-full-name)
+ (read-string "You name: "))
+ ".
+This program is free software; you can redistribute and/or modify program
+under the same terms as Perl itself or in terms of Gnu General Public
+license v2 or later."))
+
+;;;###autoload (autoload 'tinyperl-mode "tinyperl" "" t)
+;;;###autoload (autoload 'turn-on-tinyperl-mode "tinyperl" "" t)
+;;;###autoload (autoload 'turn-off-tinyperl-mode "tinyperl" "" t)
+;;;###autoload (autoload 'tinyperl-commentary "tinyperl" "" t)
+
+(eval-and-compile
+
+ (ti::macrof-minor-mode-wizard
+ "tinyperl-" " pod" "\C-c'" "Tperl" 'TinyPerl "tinyperl-:" ;1-6
+
+ "Additional commands to fetch perl module and perl manpage information
+
+For complete on-line documentation, which is generated from the
+source file itself, run command `tinyperl-version`
+
+This minor mode is by default turned on when `[c]perl-mode' is turned on
+but, you can access the Perl POD page view commands directly too even if
+the minor mode is not active, Here is suggestion for global bindings that
+you can put to your $HOME/.emacs startup file:
+
+ ;; Take global prefix key C-c p for perl pod view commands
+
+ (global-set-key \"\C-cpp\" 'tinyperl-pod-by-manpage)
+ (global-set-key \"\C-cpP\" 'tinyperl-pod-by-module)
+
+You can also run `perl2text' filter on any perl file with command
+M-x `tinyperl-find-file' See also `tinyperl-pod-view-mode'
+
+The function `tinyperl-pod-write-mode' will turn on additional minor
+mode that might help you to write the POD dicumentation inside you
+perl code. this minor mode is intended to to use only at-demand
+basis, so that, when you concentrate on writing the POD page, you
+turn it on, when you have finished and continue writing perl code,
+you should in general turn it off.
+
+Mode description:
+
+\\{tinyperl-:mode-map}"
+
+ "TinyPerl"
+
+ nil
+
+ "Perl extras (pod)"
+
+ (list
+ tinyperl-:mode-easymenu-name
+
+ (list
+ "Skeleton"
+ ["Skeleton script function" tinyperl-pod-write-skeleton-script-function t]
+ ["Skeleton script manpage" tinyperl-pod-write-skeleton-script-manpage t]
+ ["Skeleton module function" tinyperl-pod-write-skeleton-module-function t]
+ ["Skeleton module header" tinyperl-pod-write-skeleton-module-header t]
+ ["Skeleton module footer" tinyperl-pod-write-skeleton-module-footer t])
+ ["Perldoc - function help" tinyperl-perldoc t]
+ "----"
+ ["Pod by module" tinyperl-pod-by-module t]
+ ["Pod by manpage" tinyperl-pod-by-manpage t]
+ ["Pod grep" tinyperl-pod-grep t]
+ ["Pod kill buffers" tinyperl-pod-kill-buffers t]
+ ["Pod syntax check"
+ tinyperl-pod-podchecker
+ (get 'tinyperl-mode 'podchecker)]
+
+ ;; ["Pod switch to buffer" tinyperl-pod-jump t]
+ ["Pod write mode" tinyperl-pod-write-mode t]
+ "----"
+ ["Pod2text on file" tinyperl-pod-find-file t]
+ ["Pod2text on current buffer" tinyperl-pod-find-file-this-buffer t]
+ "----"
+ ["Module source find-file" tinyperl-module-find-file t]
+ ["Module generate stubs" tinyperl-selfstubber-stubs t]
+ "----"
+ ["PAUSE copy file" tinyperl-pause-copy-file t]
+ ["PAUSE submit page" tinyperl-pause-url-submit-www-page t]
+ ;; ["Pause upload via FTP"] tinyperl-pause-upload-via-ftp t]
+ "----"
+ ["Package version" tinyperl-version t]
+ ["Package commentary" tinyperl-commentary t]
+ ["Mode help" tinyperl-mode-help t]
+ ["Mode off" tinyperl-mode t])
+
+ (progn
+ (define-key map "?" 'tinyperl-mode-help)
+ (define-key map "Hm" 'tinyperl-mode-help)
+ (define-key map "Hc" 'tinyperl-commentary)
+ (define-key map "Hv" 'tinyperl-version)
+ (define-key map "P" 'tinyperl-pod-by-manpage)
+ (define-key map "p" 'tinyperl-pod-by-module)
+ (define-key map "f" 'tinyperl-pod-find-file)
+ (define-key map "F" 'tinyperl-pod-find-file-this-buffer)
+ (define-key map "g" 'tinyperl-pod-grep)
+ (define-key map "G" 'tinyperl-pod-grep-faq-answer)
+ (define-key map "k" 'tinyperl-pod-kill-buffers)
+;;; (define-key map "b" 'tinyperl-pod-jump)
+ (define-key map "!" 'tinyperl-pod-podchecker)
+ (define-key map "d" 'tinyperl-perldoc)
+ (define-key map "m" 'tinyperl-module-find-file)
+ (define-key map "?" 'tinyperl-mode-help)
+ (define-key map "M" 'tinyperl-mode)
+ (define-key map "S" 'tinyperl-selfstubber-stubs)
+ ;; C = CPAN interface, other keys like P (PAUSE) are already reserved.
+ (define-key map "Cc" 'tinyperl-pause-copy-file)
+ (define-key map "Cs" 'tinyperl-pause-url-submit-www-page)
+ ;; (define-key map "Cf" 'tinyperl-pause-upload-via-ftp)
+ (define-key map "W" 'tinyperl-pod-write-mode)
+ ;; Borrow some commonly used keys from the "pod-write" mode
+ (define-key map "'f" 'tinyperl-pod-write-skeleton-script-function)
+ (define-key map "'m" 'tinyperl-pod-write-skeleton-script-manpage)
+ ;; B = Begin , E = End
+ (define-key map "'F" 'tinyperl-pod-write-skeleton-module-function)
+ (define-key map "'B" 'tinyperl-pod-write-skeleton-module-header)
+ (define-key map "'E" 'tinyperl-pod-write-skeleton-module-footer))))
+
+;;;###autoload (autoload 'tinyperl-pod-view-mode "tinyperl" "" t)
+;;;###autoload (autoload 'turn-on-tinyperl-pod-view-mode "tinyperl" "" t)
+;;;###autoload (autoload 'turn-off-tinyperl-pod-view-mode "tinyperl" "" t)
+
+(eval-and-compile
+
+ (ti::macrof-minor-mode-wizard
+ "tinyperl-pod-view-" " POD" "\C-c'" "POD" 'TinyPerl "tinyperl-:pod-view-"
+
+ "View `pod2text' formatted output.
+If you have manual pages in the current buffer, this mode makes
+navigating the headings and topics easier.
+
+This mode redefined the Page Up and Page down key to jump between
+headings. Hold also shift or meta or control key down for other
+movement controls.
+
+Mode description:
+
+\\{tinyperl-:pod-view-mode-map}"
+
+ "TinyPerl Pod View"
+
+ nil
+
+ "POD view mode."
+
+ (list
+ tinyperl-:pod-view-mode-easymenu-name
+ ["Heading forward" tinyperl-pod-view-heading-forward t]
+ ["Heading backward" tinyperl-pod-view-heading-backward t]
+ ["Sub Heading forward" tinyperl-pod-view-heading-forward2 t]
+ ["Sub Heading backward" tinyperl-pod-view-heading-backward2 t]
+ ["Section forward" tinyperl-pod-view-backward t]
+ ["Section backward" tinyperl-pod-view-backward t]
+ ["Scroll up" scroll-up t]
+ ["Scroll down" scroll-down t]
+ "----"
+ ["Pod by manpage" tinyperl-pod-by-manpage t]
+ ["Pod by module" tinyperl-pod-by-module t]
+ ["Pod grep" tinyperl-pod-grep t]
+;;; (define-key map "f" 'tinyperl-pod-find-file)
+;;; (define-key map "F" 'tinyperl-pod-find-file-this-buffer)
+;;; (define-key map "G" 'tinyperl-pod-grep-faq-answer)
+;;; (define-key map "k" 'tinyperl-pod-kill-buffers)
+ "----"
+ ["Exit and kill buffer" kill-buffer-and-window t]
+ ["Mode help" tinyperl-pod-view-mode-help t]
+ ["Mode off" tinyperl-pod-view-mode t])
+ (progn
+ ;; headings
+ (define-key map "P" 'tinyperl-pod-by-manpage)
+ (define-key map "p" 'tinyperl-pod-by-module)
+ (define-key map "f" 'tinyperl-pod-find-file)
+ (define-key map "F" 'tinyperl-pod-find-file-this-buffer)
+ (define-key map "g" 'tinyperl-pod-grep)
+ (define-key map "G" 'tinyperl-pod-grep-faq-answer)
+ (define-key map "k" 'tinyperl-pod-kill-buffers)
+;;; (define-key map "b" 'tinyperl-pod-jump)
+ (define-key map "q" 'kill-buffer-and-window)
+ (define-key root-map [(control prior)] 'tinyperl-pod-view-pageup)
+ (define-key root-map [(control next)] 'tinyperl-pod-view-pagedown)
+ ;; Sub-headings
+ (define-key root-map [(shift prior)] 'tinyperl-pod-view-heading-backward2)
+ (define-key root-map [(shift next)] 'tinyperl-pod-view-heading-forward2)
+ ;; Bigger steps with these
+ (define-key root-map [(meta prior)] 'tinyperl-pod-view-backward)
+ (define-key root-map [(meta next)] 'tinyperl-pod-view-forward))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-pod-view-backward ()
+ "Go to one topic backward."
+ (interactive)
+ ;; NAME
+ ;; Net::FTP - FTP Client class
+ (or (re-search-backward "^NAME[\n\r]" nil t) (ti::pmin)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-pod-view-pageup ()
+ "See `tinyperl-:key-pageup-control'."
+ (interactive)
+ (if (eq tinyperl-:key-pageup-control 'heading)
+ (tinyperl-pod-view-heading-backward)
+ (scroll-down)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-pod-view-pagedown ()
+ "See `tinyperl-:key-pageup-control'."
+ (interactive)
+ (if (eq tinyperl-:key-pageup-control 'heading)
+ (tinyperl-pod-view-heading-forward)
+ (scroll-up)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-pod-view-forward ()
+ "Go to one topic backward."
+ (interactive)
+ (end-of-line)
+ (or (and (re-search-forward "^NAME[\n\r]" nil t)
+ (forward-line -1))
+ (ti::pmax)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-pod-view-heading-backward (&optional regexp)
+ "Go to one heading backward. Optionally use REGEXP."
+ (interactive)
+ (let* (case-fold-search)
+ (or (and (re-search-backward (or regexp "^\\( \\)?[A-Z]") nil t)
+ (prog1 1 t
+ (beginning-of-line)
+ (skip-chars-forward " \t")))
+ (ti::pmin))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-pod-view-heading-forward (&optional regexp)
+ "Go to one heading forward. Optionally use REGEXP."
+ (interactive)
+ (end-of-line)
+ (let* (case-fold-search)
+ (or (and (re-search-forward (or regexp "^\\( \\)?[A-Z]") nil t)
+ (prog1 t
+ (beginning-of-line)
+ (skip-chars-forward " \t")))
+ (ti::pmax))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-pod-view-heading-backward2 ()
+ "Go to one sub heading backward."
+ (interactive)
+ (tinyperl-pod-view-heading-backward
+ "\\([ \t][\r\n]\\|[\r\n][\r\n]\\)\\( \\| \\)?[^ \t\n\r]"))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-pod-view-heading-forward2 ()
+ "Go to one sub heading backward."
+ (interactive)
+ (tinyperl-pod-view-heading-forward
+ "\\([ \t][\r\n]\\|[\r\n][\r\n]\\)\\( \\| \\)?[^ \t\n\r]"))
+
+;;}}}
+;;{{{ POD write mode
+
+;;;###autoload (autoload 'tinyperl-pod-write-mode "tinyperl" "" t)
+;;;###autoload (autoload 'turn-on-tinyperl-pod-write-mode "tinyperl" "" t)
+;;;###autoload (autoload 'turn-off-tinyperl-pod-write-mode "tinyperl" "" t)
+
+(eval-and-compile
+
+ (ti::macrof-minor-mode-wizard
+ "tinyperl-pod-write-" " PODw" "\C-c." "PODw" 'TinyPerl "tinyperl-:pod-write-"
+
+ "Minor mode to thelp writing POD in place.
+
+Mode description:
+
+\\{tinyperl-:pod-write-mode-map}"
+
+ "TinyPerl Pod Write"
+
+ nil
+
+ "POD Write mode."
+
+ (list
+ tinyperl-:pod-write-mode-easymenu-name
+ ["Heading forward" tinyperl-pod-write-heading-forward t]
+ ["Heading backward" tinyperl-pod-write-heading-backward t]
+ ["Token forward" tinyperl-pod-write-token-forward t]
+ ["Token backward" tinyperl-pod-write-token-backward t]
+ ["Scroll up" scroll-up t]
+ ["Scroll down" scroll-down t]
+ "----"
+ ["Skeleton script manpage" tinyperl-pod-write-skeleton-script-manpage t]
+ ["Skeleton script function" tinyperl-pod-write-skeleton-script-function t]
+ ["Skeleton module header" tinyperl-pod-write-skeleton-module-header t]
+ ["Skeleton module function" tinyperl-pod-write-skeleton-module-function t]
+ ["Skeleton module header" tinyperl-pod-write-skeleton-module-footer t]
+ ["Skeleton item" tinyperl-pod-write-skeleton-item t]
+ "----"
+ ["Mode help" tinyperl-pod-write-mode-help t]
+ ["Mode off" tinyperl-pod-write-mode t])
+ (progn
+ ;; headings
+ (define-key map [(prior)] 'tinyperl-pod-write-heading-backward)
+ (define-key map [(next)] 'tinyperl-pod-write-heading-forward)
+ ;; Sub-headings
+ (define-key map [(shift prior)] 'tinyperl-pod-write-token-backward)
+ (define-key map [(shift next)] 'tinyperl-pod-write-token-forward)
+ ;; Bigger steps with these
+ ;; (define-key map [(meta prior)] 'tinyperl-pod-write-backward)
+ ;; (define-key map [(meta next)] 'tinyperl-pod-write-forward)
+ ;; And original PgUp PgDown is saved under Control key
+ (define-key root-map [(control prior)] 'scroll-down)
+ (define-key root-map [(control next)] 'scroll-up)
+ ;; S K E L E T O N -- p for pod
+ (define-key map "m" 'tinyperl-pod-write-skeleton-script-manpage)
+ (define-key map "f" 'tinyperl-pod-write-skeleton-script-function)
+ (define-key map "i" 'tinyperl-pod-write-skeleton-item)
+ (define-key map "B" 'tinyperl-pod-write-skeleton-module-header)
+ (define-key map "E" 'tinyperl-pod-write-skeleton-module-footer)
+ (define-key map "F" 'tinyperl-pod-write-skeleton-module-function))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-pod-write-heading-backward ()
+ "Go to previous POD heading"
+ (interactive)
+ (tinyperl-pod-view-heading-backward "^=head"))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-pod-write-heading-forward ()
+ "Go to next POD heading"
+ (interactive)
+ (tinyperl-pod-view-heading-forward "^=head"))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-pod-write-token-backward ()
+ "Go to previous POD token"
+ (interactive)
+ (tinyperl-pod-view-heading-backward "^="))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-pod-write-token-forward ()
+ "Go to next POD token "
+ (interactive)
+ (tinyperl-pod-view-heading-forward "^="))
+
+;; Tell that these function are here
+
+;;;###autoload (autoload 'tinyperl-pod-write-skeleton-item "tinyperl" "" t)
+;;;###autoload (autoload 'tinyperl-pod-write-skeleton-script-manpage "tinyperl" "" t)
+;;;###autoload (autoload 'tinyperl-pod-write-skeleton-script-function "tinyperl" "" t)
+;;;###autoload (autoload 'tinyperl-pod-write-skeleton-module-header "tinyperl" "" t)
+;;;###autoload (autoload 'tinyperl-pod-write-skeleton-module-footer "tinyperl" "" t)
+;;;###autoload (autoload 'tinyperl-pod-write-skeleton-module-function "tinyperl" "" t)
+
+(defun tinyperl-skeleton-setup ()
+ "Define skeleton functions."
+ ;; It is unnecessary to load skeleton.el at package load time.
+ ;; We define here STUBS, i.e forward declaration functions, which
+ ;; will call the initialize setup, where the real function are
+ ;; defined.
+ ;;
+ ;; At that point skeleton.el is needed and loaded.
+ ;; These STUBS will at the end call the real, defined, function.
+ (let (def)
+ (mapcar
+ (function
+ (lambda (x)
+ (let ((sym (intern (format "tinyperl-pod-write-skeleton-%s"
+ (symbol-name x)))))
+ (setq def
+ (` (defun (, sym) ()
+ "Forward declaration wrapper. Will define real function."
+ (interactive)
+ (tinyperl-skeleton-initialize)
+ (funcall (quote (, sym))))))
+ (eval def))))
+ '(item
+ script-manpage
+ script-function
+ module-header
+ module-footer
+ module-function ))))
+
+(defun tinyperl-skeleton-initialize () ;; #### SKELETON-BEGIN
+ "Skeleton setup."
+
+;;; ----------------------------------------------------------------------
+;;;
+ (define-skeleton tinyperl-pod-write-skeleton-item
+ "Insert =item skeleton"
+ (read-string "Item: " "*")
+ "
+=item " str "
+
+")
+
+;;; ----------------------------------------------------------------------
+;;;
+ (define-skeleton tinyperl-pod-write-skeleton-script-manpage
+ "Script: Insert Perl Script's manpage POD."
+ (read-string "Program: " (buffer-name))
+ "=pod
+
+=head1 NAME
+
+" str " - " (read-string "One Line description: ")
+
+ "
+
+=head1 README
+
+<short overall description here. This section is ripped by CPAN>
+
+=head1 SYNOPSIS
+
+ <program call conventions>
+
+ program B<-V>...
+
+=head1 OPTIONS
+
+=head2 Gneneral options
+
+=over 4
+
+=item B<--option-name>
+
+=back
+
+=head2 Miscellaneous options
+
+=over 4
+
+=item B<--debug LEVEL>
+
+Turn on debug with positive LEVEL number. Zero means no debug.
+
+=item B<--help>
+
+Print help
+
+=item B<--test>
+
+Run in test mode, do not actually do anything.
+
+=item B<--verbose>
+
+Print informational messages.
+
+=item B<--Version>
+
+Print contact and version information
+
+=back
+
+=head1 DESCRIPTION
+
+<program description>
+
+=head1 EXAMPLES
+
+<example calls for the program in different situations>
+
+=head1 TROUBLESHOOTING
+
+<what to check in case of error or weird behavior>
+
+=head1 ENVIRONMENT
+
+<any environment variable settings>
+
+=head1 FILES
+
+<what files program generates uses>
+
+=head1 SEE ALSO
+
+<references to other programs e.g. ps(1)>
+
+=head1 STANDARDS
+
+<RFCs, ANSI/ISO, www.w3c.org that are related>
+
+=head1 BUGS
+
+<known limitations>
+
+=head1 AVAILABILITY
+
+"
+
+ (or tinyperl-:skeleton-script-ftp-url
+ (skeleton-read "Availabillity: " "<URL Where to get the program>"))
+
+ "
+
+=head1 SCRIPT CATEGORIES
+
+CPAN/Administrative
+
+=head1 PREREQUISITES
+
+<what CPAN modules are needed to run this program>
+
+=head1 COREQUISITES
+
+<what CPAN modules are needed to run this program>
+
+=head1 OSNAMES
+
+C<any>
+
+=head1 VERSION
+
+$\Id$
+
+=head1 AUTHOR
+
+"
+
+ (funcall tinyperl-:copyright-function)
+
+ "
+
+=cut
+")
+
+;;; ----------------------------------------------------------------------
+;;;
+ (define-skeleton tinyperl-pod-write-skeleton-script-function
+ "Script: Insert Function banner."
+ nil
+ "\
+# ****************************************************************************
+#
+# DESCRIPTION
+#
+#
+#
+# INPUT PARAMETERS
+#
+#
+#
+# RETURN VALUES
+#
+#
+#
+# ****************************************************************************
+")
+
+;;; ----------------------------------------------------------------------
+;;;
+ (define-skeleton tinyperl-pod-write-skeleton-module-header
+ "Module: Insert POD header; which starts the pod in module.
+See function description `tinyperl-pod-write-skeleton-module-function'."
+ nil
+ "\
+# ****************************************************************************
+#
+# POD HEADER
+#
+# ****************************************************************************
+
+=head1 NAME
+
+" (buffer-name) " - One line Module descriptions
+
+=head1 REVISION
+
+$\Id$
+
+=head1 SYNOPSIS
+
+ use " (replace-regexp-in-string "\\.pm" "" (buffer-name))
+ "; # Import EXPORT_OK
+ use "
+ (replace-regexp-in-string "\\.pm" "" (buffer-name))
+ " qw( :ALL ); # Import everything
+
+=head1 DESCRIPTION
+
+=head1 EXPORTABLE VARIABLES
+
+If there is no special marking for the variable, it is
+exported when you call `use'. The rags next to variables mean:
+
+ [ok] = variable is exported via list EXPORT_OK
+ [tag] = variable is exported via :TAG
+
+=head2 $ABC_REGEXP
+
+<description>
+
+=head2 %ABC_HASH [ok]
+
+<description>
+
+=head2 $debug [ok]
+
+Integer. If positive, activate debug with LEVEL.
+
+<description>
+
+=head1 INTERFACE FUNCTIONS
+
+=for comment After this the Puclic interface functions are introduced
+=for comment you close the blockquote by inserting POD footer
+
+=for html
+<BLOCKQUOTE>
+
+=cut
+
+")
+
+;;; ----------------------------------------------------------------------
+;;;
+ (define-skeleton tinyperl-pod-write-skeleton-module-footer
+ "Module: Insert POD footer, which starts the pod in module.
+See function description `tinyperl-pod-write-skeleton-module-function'."
+ nil
+ "\
+# ****************************************************************************
+#
+# POD FOOTER
+#
+# ****************************************************************************
+
+=pod
+
+=for html
+</BLOCKQUOTE>
+
+=head1 KNOWN BUGS
+
+<Limitations. How to debug problems>
+
+=head1 AVAILABILITY
+
+<release or where to get latest, http, ftp page>
+
+=head1 AUTHOR
+
+"
+
+ (funcall tinyperl-:copyright-function)
+
+ "
+
+=cut
+")
+
+;;; ----------------------------------------------------------------------
+;;;
+ (define-skeleton tinyperl-pod-write-skeleton-module-function
+ "Module: Insert template for Puclic interface function.
+Where you write Module.pm public interface functions, document the
+functions in place.
+
+Hee is one suggestion ofr Module.pm POD layout
+
+ P O D H E A D E R
+ NAME
+ REVISION
+ SYNOPSIS
+ DESCRIPTION
+ EXPORTABLE VARIABLES
+ EXAMPLES
+
+ # module interface is written next
+
+ use strict;
+
+ BEBGIN
+ {
+ EXPORT # The export interface
+ EXPORT_OK
+ }
+
+ Define exported globals
+
+ Define private variables
+
+ P O D I N T E R F A C E S T A R T
+
+ P O D P U B L I C for public functions or methods
+ sub ...
+
+ P O D P U B L I C for public functions or methods
+ sub ...
+
+ NORMAL banner of private function
+ sub ...
+
+ NORMAL banner of private function
+ sub ...
+
+ P O D F O O T E R
+ KNOWN BUGS
+ AVAILABILITY
+ AUTHOR
+
+ 1;
+ __END__
+
+"
+ nil
+ "
+=pod
+
+=over 4
+
+=head2 Function ()
+
+=item Description
+
+=item arg1:
+
+=item arg2:
+
+=item Return values
+
+=back
+
+=cut")
+
+ ) ;; #### SKELETON-BEGIN
+
+;;}}}
+;;{{{ Perl Path functions
+
+;;; ----------------------------------------------------------------------
+;;; (tinyperl-inc-split-win32-path "C:\\Program files\\this c:\\temp")
+;;;
+(defun tinyperl-inc-split-win32-path (string)
+ "Separate different absolute directories.
+\(tinyperl-inc-split-win32-path \"C:\\Program files\\this c:\\temp\")
+-->
+'(\"C:\\Program files\\this\" \"c:\\temp\")"
+ (let* (locations
+ beg
+ end
+ ret
+ str)
+ (with-temp-buffer
+ (insert string)
+ (ti::pmin)
+ (while (re-search-forward "\\<[a-z]:[\\//]" nil t)
+ (push (match-beginning 0) locations))
+ (push (ti::pmax) locations)
+ (setq locations (nreverse locations))
+ (while (setq beg (pop locations))
+ (when (setq end (car locations))
+ (setq str (ti::string-remove-whitespace (buffer-substring beg end)))
+ (unless (ti::nil-p str)
+ (push str ret))))
+ (nreverse ret))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-inc-split (inc)
+ "Split @INC in INC string, where entries are separated by spaces."
+ (let* ((fid "tinyperl-inc-split")
+ (perl-type (tinyperl-perl-type))
+ ;; We can't just explode RESULT with Emacs function `split'
+ ;; because in Win32 it may contain spaces
+ ;; c:\Program files\activestate\perl\lib
+ list)
+ (when inc
+ (cond
+ ((and (ti::win32-p)
+ (ti::emacs-type-win32-p)
+ (eq perl-type 'win32-activestate))
+ (setq list (tinyperl-inc-split-win32-path
+ ;; Delete current directory from the list
+ (replace-regexp-in-string " \\." "" inc))))
+ ((and (ti::win32-p)
+ (eq perl-type 'win32-cygwin)
+ (ti::emacs-type-win32-p))
+ (setq list (split-string inc))
+ ;; Native Win32 Emacs cannot use Cygwin Perl's UNIX paths.
+ ;; Convert cygwin -> Win32
+ (let (win32-list
+ cygwin-list)
+ (dolist (path list)
+ (cond
+ ((string-match "^//\\|^[a-z]:" path)
+ (push path win32-list))
+ (t
+ (push path cygwin-list))))
+ (when cygwin-list
+ (setq cygwin-list (mapcar 'w32-cygwin-path-to-dos cygwin-list)))
+ (setq list (append cygwin-list win32-list))))
+ ((and (ti::win32-p)
+ (eq perl-type 'win32-activestate)
+ (ti::emacs-type-cygwin-p))
+ (error (concat
+ "TinyPerl: [ERROR] Active Perl is first in you PATH [%s]"
+ "Arrange your PATH to find Cygwin perl first "
+ "under Cygwin Emacs/XEmacs.")
+ (if (not (string-match "[\\/]" tinyperl-:perl-bin))
+ ;; Contains path, show it as-is
+ (executable-find tinyperl-:perl-bin)
+ tinyperl-:perl-bin)))
+ (t
+ (setq list (split-string inc))))
+ (setq list (delete "." list))
+ (tinyperl-debug fid "perl" perl-type "ret" list)
+ list)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypath-path-convert-to-emacs-host (list)
+ "Convert list of paths to the format that Emacs host knows.
+If Emacs is win32 application, convert to DOS style paths."
+
+ ;; Now interesting part: If Emacs in Win32-native and user uses
+ ;; Cygwin-perl, then the situation is as follows:
+ ;;
+ ;; PERL5LIB paths refer to cygwin, like /usr/share/site-perl/CPAN
+ ;;
+ ;; But this is not a path that GNU Emacs know, because it is pure
+ ;; Windows application. The paths must be converted so that
+ ;;
+ ;; CYGWIN-ROOT/path or CYGWIN-MOUNT-POINT/path
+ ;;
+ ;; #todo: XEmacs is different game, it can be built as Cygwin native
+ ;; #todo: How to check if running Cygwin or Win32 XEmacs ?
+
+ (let* ((perl-type (tinyperl-perl-type)))
+ (cond
+ ((and (ti::emacs-p)
+ ;; #todo: if Emacs is built as native cygwin application,
+ ;; this fails.
+ (eq perl-type 'win32-cygwin))
+ (let (new-list)
+ (dolist (path list)
+ (cond
+ ((and (string-match "^/" path)
+ ;; Exclude Win32 UNC path formats: //SERVER/dir/dir
+ (not (string-match "^//" path)))
+ (push (w32-cygwin-path-to-dos path) new-list))
+ (t
+ ;; the file-directory-p is checked elswhere.
+ ;; Just return pure paths
+ (push path new-list))))
+ new-list))
+ (t
+ list))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-inc-path-external-perl (perl)
+ "Calls an external PERL process to read @INC.
+
+References:
+
+ `tinyperl-:inc-path-switches' is included in call."
+ (with-temp-buffer
+ (apply 'call-process
+ perl
+ nil
+ (current-buffer)
+ nil
+ (append tinyperl-:inc-path-switches
+ '("-e"
+ ;; "print 11"
+ "print(qq,@INC,)")))
+ (let ((ret (buffer-string)))
+ (tinyperl-debug "tinyperl-inc-path-external-perl: " ret)
+ ret)))
+
+;;; ----------------------------------------------------------------------
+;;; (tinyperl-inc-path tinyperl-:perl-bin)
+;;;
+(defun tinyperl-inc-path (&optional perl)
+ "Return @INC and and var PERL5LIB libs for PERL which defaults to `perl'.
+
+References:
+ `tinyperl-:inc-path-switches'"
+ (let* ((fid "tinyperl-inc-path")
+ (path (or perl
+ (executable-find "perl")))
+ ;; ask from perl where the paths are.
+ (result (and path
+ (tinyperl-inc-path-external-perl path)))
+ ;; We can't just explode RESULT with Emacs function `split'
+ ;; because in Win32 it may contain spaces
+ ;; c:\Program files\activestate\perl\lib
+ (list (when path
+ (tinyperl-inc-split result)))
+ ;; The LIST test is there so that if you call this with
+ ;; perl 4, then the LIST is nil and we should not check PERL5LIB,
+ ;; which is perl 5 only variable.
+ (lib (or (getenv "PERL5LIB")
+ (getenv "PERL5_LIB"))) ;; Win32 Activestate Perl
+ (path5 (and list
+ lib
+ (split-string
+ lib
+ (if (or (string-match ";" lib) ;; was (if (ti::win32-p)..
+ (string-match "[a-z]:[\\/]" lib))
+ ";"
+ ":"))))
+ ret
+ seen)
+ (tinyperl-debug fid "path" path "result" result "lib" lib "path5" path5)
+ (when (and result
+ (string-match "warning\\|error\\|fatal" result))
+ (error "TinyPerl: Reading @INC error %s" result))
+ (if path5
+ (setq list (append list path5)))
+ (setq list (delete "." list))
+ (tinyperl-debug fid "list [2]" list)
+ ;; Make sure Emacs can read the Paths -- Win32 specific support
+ (setq list (tinypath-path-convert-to-emacs-host list))
+ (dolist (x list)
+ (when (stringp x)
+ (unless (member x seen) ;; Filter out duplicates
+ (push x seen)
+ (if (file-directory-p x)
+ (push x ret)
+ ;; Record to message, so that possible errors can be
+ ;; traced.
+ (tinyperl-verbose-macro 3
+ (message "Tinyperl: invalid @INC dir %s. Ignored." x))))))
+ (tinyperl-debug fid "result [2]" result)
+ (when (and result
+ (null ret))
+ (error
+ (format
+ (concat "TinyPerl: Can't parse @INC. Please check"
+ " tinyperl-:perl-bin = %s"
+ " result: %s"
+ " path5: %s")
+ (prin1-to-string tinyperl-:perl-bin)
+ (prin1-to-string result)
+ (prin1-to-string path5))))
+ (tinyperl-debug fid "ret" ret)
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-pod-path (&optional perl-binary)
+ "Return POD path by calling PERL-BINARY or `perl'."
+ (let* ((fid "tinyperl-pod-path")
+ (perl (or perl-binary (executable-find "perl")))
+ (path
+ (with-temp-buffer
+ (call-process perl
+ nil
+ (current-buffer)
+ nil
+ "-MConfig"
+ "-e"
+ "print $Config{privlib}")
+ (buffer-string))))
+ (when (or (ti::nil-p path)
+ (and (stringp path)
+ ;; ... Can't locate Config.pm
+ ;; ... BEGIN failed--compilation aborted.
+ (string-match "Failed\\|error\\|Can't" path)))
+ (error "TinyPerl: POD failure [%s] from Config.pm using %s"
+ path perl))
+ ;; Win32 specific Cygwin support
+ (let ((path-list
+ (tinypath-path-convert-to-emacs-host (list path))))
+ (setq path (car path-list)))
+ (unless (file-directory-p path)
+ (error "TinyPerl: Can't find pod path %s [%s]" perl path))
+ (tinyperl-debug fid "perl-binary" perl-binary "path" path)
+ ;; Find out the Perl library path. The POD files are
+ ;; under subdir "pod" in Unix and Activestate Perl,
+ ;; but for some reason Cygwin Perl 5.6.1 changed the
+ ;; files under /pods.
+ (let (correct
+ try)
+ (dolist (pod '("pod/" "pods/"))
+ (setq try (concat (file-name-as-directory path) pod))
+ (when (and (file-directory-p try)
+ (directory-files
+ try
+ nil
+ "\\.pod$"))
+ (return (setq correct try))))
+ (unless correct
+ (error "TinyPerl: Can't determine POD path %s [%s]" path perl))
+ (tinyperl-debug fid "correct" correct)
+ (ti::file-name-forward-slashes correct))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-build-pod-files ()
+ "Build files under pod path."
+ (let* ((path (or tinyperl-:pod-path
+ (error "TinyPerl: No tinyperl-:pod-path")))
+ files
+ ret)
+ (setq files (ti::directory-files path "\\.pod"))
+ (dolist (file files)
+ (push (cons file (ti::file-name-forward-slashes path)) ret))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;; #todo: This should be rewritten as recursive function
+;;;
+(defun tinyperl-build-list-of-inc-files (&optional search-list verb)
+ "Build list of files under @INC. Only 3 subdir levels are scanned.
+SEARCH-LIST corresponds to `tinyperl-:inc-path'
+
+Return:
+
+ '((package.pm . path) (package::package.pm . path) ..)"
+ (let* ((INC (or search-list
+ (error "TinyPerl: No SEARCH-LIST")))
+ files
+ dirs
+ dirs2
+ dirs3
+ package
+ ret)
+ (flet ((my-add
+ (file pfx path)
+ ;; As long as the name of the .pl file is unique (not yet
+ ;; added), store without leading prefix directories.
+ ;;
+ (if (and (string-match "\\.pl" file)
+ (not (assoc file ret)))
+ (push (cons file path) ret)
+ (push (cons
+ (if pfx
+ (concat (file-name-nondirectory pfx) "::" file)
+ file)
+ path)
+ ret))))
+ (ti::verb)
+ ;; It is unusual that Perl INC path would belonger than
+ ;; 3 subdirectories, so we just check 3 levels. This is not very
+ ;; general approach to deal with the situation...
+ ;;
+ ;; Font::Metrics::Courier.pm
+ ;; HTTP::Request::Common.pm
+ (dolist (path INC)
+ (when verb
+ (tinyperl-verbose-macro 2
+ (message "TinyPerl: Reading @INC path %s" path)))
+ (tinyperl-directory-files files path)
+ (dolist (file files)
+ (push (cons file path) ret))
+ (setq dirs (ti::directory-files ;; And Level 1 directories
+ path "." 'absolute
+ '(file-directory-p arg)
+ '(string-match "\\.\\.?$" arg)))
+ (dolist (dir dirs)
+ (tinyperl-directory-files files dir)
+ (dolist (file files)
+ (setq package (file-name-nondirectory dir))
+ (my-add file package dir))
+ (setq dirs2 (ti::directory-files ;; And Level 2 directories too
+ dir "." 'absolute
+ '(file-directory-p arg)
+ '(string-match "\\.\\.?$" arg)))
+ (dolist (dir1 dirs2)
+ (setq dir1 (ti::file-name-forward-slashes dir1))
+ (tinyperl-directory-files files dir1)
+ (dolist (file files)
+ (setq package (concat (file-name-nondirectory dir) "::"
+ (file-name-nondirectory dir1)))
+ (my-add file package dir1))
+ (setq dirs3 (ti::directory-files ;; And Level 2 directories too
+ dir1 "." 'absolute
+ '(file-directory-p arg)
+ '(string-match "\\.\\.?$" arg)))
+ (dolist (dir2 dirs3)
+ (setq dir2 (ti::file-name-forward-slashes dir2))
+ (tinyperl-directory-files files dir2)
+ (dolist (file files)
+ (setq package (concat (file-name-nondirectory dir) "::"
+ (file-name-nondirectory dir1) "::"
+ (file-name-nondirectory dir2)))
+ (my-add file package dir2))))))
+ ret)))
+
+;;}}}
+;;{{{ POD lowlevel functions
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-podchecker (file &optional buffer)
+ "Run Pod::Checker/podchecker() on FILE and put output to BUFFER.
+Default value for BUFFER is `tinyperl-:perldoc-buffer'."
+ (let* ((fid "tinyperl-podchecker"))
+ (or (tinyperl-perl-module-exists-p "Pod::Checker.pm")
+ (error "\
+TinyPerl: Pod::Checker.pm is not known to this Perl version. @INC trouble?"))
+ (or buffer
+ (setq buffer (get-buffer-create tinyperl-:podchecker-buffer)))
+ (or (get-buffer buffer)
+ (setq buffer (get-buffer-create buffer)))
+ (when nil ;; disabled
+ (with-current-buffer buffer
+ (ti::pmax)
+ (run-hooks 'tinyperl-:podchecker-before-hook)
+ (call-process tinyperl-:perl-bin
+ nil
+ buffer
+ nil
+ "-MPod::Checker"
+ "-e"
+ "podchecker shift, undef, -warnings => q(on)"
+ (expand-file-name file))
+ (run-hooks 'tinyperl-:podchecker-after-hook)))
+ (when t
+ (let* (compilation-error-regexp-alist
+ ;; `shell-quote-argument' does not work here correctly.
+ ;; This tackles bash.exe and Win32 command-com
+ (quote (if (and (ti::win32-p)
+ (string-match "cmd\\|command"
+ shell-file-name))
+ "\""
+ "'"))
+ (cmd (concat
+ tinyperl-:perl-bin
+ " -MPod::Checker"
+ " -e"
+ " "
+ quote
+ "podchecker shift, undef, -warnings , q(on)"
+ quote
+ " "
+ (expand-file-name file))))
+ ;; Keep the old values and add this regexp.
+ ;; 2 = filename, 1 = line number
+ ;; *** WARNING: 2 unescaped <> in paragraph at line 1994 in file xxx
+ (push
+ '(".*[ \t]+line[ \t]+\\([0-9]+\\)[ \t]+in[ \t]+file[ \t]+\\(.*\\)"
+ 2 1)
+ compilation-error-regexp-alist)
+ (tinyperl-debug fid "cmd" cmd)
+ (compile-internal cmd
+ "No more lines." ;; error-message
+ nil ;; name-of-mode
+ nil ;; parser
+ nil))) ;; error-regexp-alist
+ (tinyperl-debug fid "buffer" buffer)
+ buffer))
+
+;;; ----------------------------------------------------------------------
+;;; (tinyperl-pod2text (tinyperl-pod-manpage-to-file "perlfunc.pod"))
+;;;
+(defun tinyperl-pod2text (file &optional buffer)
+ "Run pod on FILE and put output to BUFFER."
+ (let ((fid "tinyperl-pod2text"))
+ (or buffer
+ (setq buffer (tinyperl-pod-buffer-name
+ (file-name-nondirectory file))))
+ (or (get-buffer buffer)
+ (setq buffer (get-buffer-create buffer)))
+ ;; Append text to the end of buffer.
+ (with-current-buffer buffer
+ (setq buffer-read-only nil)
+ (run-hooks 'tinyperl-:pod2text-before-hook)
+ (ti::pmax)
+ ;; Move point to the end of visible window
+ ;; #todo: was I thinking of something here ?...
+ (when nil ;disabled
+ (let* ((win (get-buffer-window (current-buffer) t)))
+ (when win
+ (set-window-point win (point-max)))))
+ (let ((point (point))
+ (file (expand-file-name file))
+ ;; Native Win32 Emacs + Cygwin
+ (nt-cygwin (and (ti::emacs-type-win32-p)
+ (ti::win32-cygwin-p))))
+ (tinyperl-debug fid "file" file)
+ ;; perl -MPod::Text -e "pod2text shift" -n groff /cygdrive/p/unix/cygwin/lib/perl5/5.8.0/pods/perlfunc.pod
+ (call-process tinyperl-:perl-bin
+ nil
+ buffer
+ nil
+ "-MPod::Text"
+ "-e"
+ "pod2text shift"
+ ;; Cygwin's groff(1) was changed to bash
+ ;; shell script which cannot be used
+ ;; from NTEmacs
+;;;#todo
+;;; (if nt-cygwin
+;;; "-n")
+;;; (if nt-cygwin
+;;; "groff")
+ file)
+ (when (eq (point) point)
+ (message
+ (concat "TinyPerl: pod2text was empty. "
+ "Please check Perl environment."
+ "It may be broken: try running `perldoc perl'."))))
+ (ti::pmin)
+ (tinyperl-debug fid "tinyperl-:pod2text-after-hook" tinyperl-:pod2text-after-hook)
+ (run-hooks 'tinyperl-:pod2text-after-hook)
+ (setq buffer-read-only t)
+ buffer)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-pod-manpage-to-file (pod)
+ "Convert POD `perldoc.pod' or `perldoc' into absolute filename."
+ (let* ((elt (assoc (ti::string-verify-ends pod ".pod")
+ (or tinyperl-:pod-list
+ (error "TinyPerl: No tinyperl-:pod-list")))))
+ (when elt
+ (concat (cdr elt) (car elt)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-read-word-module ()
+ "Read word at point suitable for Perl module. Add .pm."
+ (let ((word (ti::buffer-read-word "a-zA-Z:"))
+ case-fold-search)
+ (when (and (stringp word)
+ (or (string-match
+ ;; English.pm
+ ;; use English;
+ (concat
+ "^[A-Z]\\([a-z]+\\|[A-Z]+\\)$"
+ ;; use Getopt::Long;
+ ;; use HTTP::Request;
+ ;; LWP::UserAgent;
+ "\\|^[A-Z]\\([a-z]+\\|[A-Z]+\\)"
+ "\\(::[A-Z]\\([a-z]+[A-Za-z]+\\|[A-Z]+\\)\\)+$")
+ word)))
+ (setq word (match-string 0 word))
+ (when (not (string-match "\\.pm$" word))
+ (setq word (concat word ".pm")))
+ word)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-ask-module (&optional msg)
+ "Ask with MSG a module."
+ (let ((word (tinyperl-read-word-module)))
+ (completing-read
+ (or msg "Module: ")
+ (or tinyperl-:inc-module-list
+ (error "TinyPerl: No tinyperl-:inc-module-list"))
+ nil
+ (not 'require-match)
+ (if word
+ ;; Put point to the beginning so that user can hit C-k to kill
+ ;; possibly unwanted word.
+ (cons word 0)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-locate-library (module &optional no-guess)
+ "Check where is MODULE. A .pl and .pm suffixes is added if needed.
+Input:
+
+ MODULE String, name of perl module that should be along
+ `tinyperl-:inc-module-list'
+ NO-GUESS Flag, if non-nil don't try searching suffixes .pm and .pl. Trus
+ MODULE to be exact name.
+
+Return:
+
+ '(module . path)"
+ (if no-guess
+ (assoc module tinyperl-:inc-module-list)
+ (or (assoc module tinyperl-:inc-module-list)
+ (assoc (concat module ".pm") tinyperl-:inc-module-list)
+ (assoc (concat module ".pl") tinyperl-:inc-module-list))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-library-find-file (elt)
+ "Load library pointer by ELT into emacs.
+The ELT is return value from `tinyperl-locate-library'.
+
+Return:
+ buffer pointer"
+
+ (find-file-noselect
+ (format "%s/%s"
+ (cdr elt)
+ ;; Getopt::Long.pm --> Long.pm
+ (replace-regexp-in-string "^.*:" "" (car elt)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-manpage-at-point ()
+ "Read word under cursor, if it looks like a perl manual page.
+The word must be in lowercase and start with 'perl'."
+ (let ((word (thing-at-point 'word))
+ case-fold-search)
+ (when (and word
+ (string-match "^perl." word))
+ word)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-pod-ask-manpage ()
+ "Ask pod page and return absolute path of POD manpage."
+ (tinyperl-pod-manpage-to-file
+ (completing-read
+ "View pod manpage: "
+ tinyperl-:pod-list
+ (not 'predicate)
+ 'match-it
+ (let ((word (tinyperl-manpage-at-point)))
+ (when word
+ (concat word ".pod"))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-pod-font-lock ()
+ "Turn on `font-lock-mode' and set `tinyperl-:pod-font-lock-keywords'.
+The `font-lock-mode' is turned on only if `ti::colors-supported-p'
+returns non-nil."
+ (interactive)
+ (when (ti::colors-supported-p)
+ (ti::string-syntax-kill-double-quote)
+ ;; Somehow the keywords must be setq after font-lock is turned on
+ ;; to take in effect.
+ ;;
+ (turn-on-font-lock-mode)
+ (setq font-lock-keywords tinyperl-:pod-font-lock-keywords)
+ (font-lock-fontify-buffer)
+ nil))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-pod-buffer-name (module)
+ "Make POD buffer name for perl module like ´English'.
+
+Rerefences:
+
+ `tinyperl-:pod-buffer-name' Always is single POD buffer in effect
+ `tinyperl-:pod-buffer-control'."
+ (if (memq tinyperl-:pod-buffer-control '(nil one single))
+ tinyperl-:pod-buffer-name
+ (let* ((name module)) ;; (replace-regexp-in-string "\.pm$" "" module)))
+ (concat "*pod: " name "*"))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-pod-re-search (regexp &optional buffer)
+ "Check BUFFER for REGEXP and return (buffer . point) or nil."
+ (or buffer
+ (setq buffer (current-buffer)))
+ (when (buffer-live-p buffer)
+ (with-current-buffer buffer
+ (save-excursion
+ (ti::pmin)
+ (if (re-search-forward regexp nil t)
+ (cons (current-buffer) (point)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-pod-pop-to-buffer (regexp &optional buffer)
+ "Pop to POD buffer if REGEXP matches. Return non-nil if ok."
+ (let* ((elt (tinyperl-pod-re-search regexp buffer)))
+ (when elt
+ (pop-to-buffer (car elt))
+ (goto-char (cdr elt)))))
+
+;;}}}
+;;{{{ POD interactive
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyperl-pod-kill-buffers ()
+ "Kill all temporary POD buffers."
+ (interactive
+ (progn
+ (unless (y-or-n-p "Kill All temporary pod buffers ")
+ (error "TinyPerl: Abort."))))
+ (dolist (buffer (buffer-list))
+ ;; For each buffer that has string "*pod" and which doesn't have
+ ;; attached filename
+ (when (string-match "\\*pod" (buffer-name buffer))
+ (unless (with-current-buffer buffer (buffer-file-name))
+ (kill-buffer buffer)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-external-command-format (bin)
+ "Determine how to call external BIN. Prepend Perl interpreter as needed.
+If BIN name contain .bat .cmd etc, return BIN as it.
+Otherwise prepend \"perl\" at from and return '(\"perl\" . BIN)."
+ (if (string-match "\\....?$" bin) ;; .ex or .ext
+ bin
+ (cons tinyperl-:perl-bin bin)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-perldoc-1 (buffer arg-list)
+ "Call ´tinyperl-:perldoc-bin'. Insert results to BUFFER.
+Call arguments are in ARG-LIST."
+ ;; Win32 call-process fails if the binary c:\prgram files\..
+ ;; name contains spaces. This is special problems for perldoc.bat
+ ;; Because it is in fact full of perl code and called again. See
+ ;; The source of perldoc.bat
+ (cond
+ ((not (ti::win32-p))
+ (apply 'call-process
+ tinyperl-:perldoc-bin
+ nil
+ buffer
+ nil
+ arg-list))
+ (t
+ (with-current-buffer buffer
+ (let* ((perl-type (tinyperl-perl-type))
+ (cmd (if (ti::win32-shell-p)
+ ;; Must not contain path name
+ ;; I don't know if the exact problem was due to
+ ;; SPACES in the path name.
+ "perldoc"
+ tinyperl-:perldoc-bin))
+ (call-type (tinyperl-external-command-format cmd))
+ (args (ti::list-to-string arg-list)))
+ ;; Add "perl" to the front of command if it is "perldoc".
+ ;; This will work under Windows/Cygwin and Unix
+ (if (listp call-type)
+ (setq cmd (format "%s %s %s"
+ (car call-type)
+ (cdr call-type)
+ args))
+ (setq cmd (format "%s %s" cmd args)))
+ (ti::process-perl-process-environment-macro
+ perl-type
+ ;; At least shell command works, this a bit more expensive
+ (let ((out (shell-command-to-string cmd)))
+ (if (stringp out)
+ (insert out))))))))
+ buffer)
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyperl-perldoc (string &optional force verb)
+ "Run perldoc with STRING. First try with -f then without it.
+Show content in `tinyperl-:perldoc-buffer'. If buffer is visible in
+some other frame, the cursor is not moved there. Only contents is updated.
+
+The last used STRING is cached and if called next time with same
+string, the shell command is not called unless FORCE is non-nil.
+
+Input:
+
+ STRING Seach string
+ FORCE Force calling shell although answer cached
+ VERB flag, Allow verbose messages
+
+References:
+
+ `tinyperl-:perldoc-hook'"
+ (interactive
+ (list
+ (read-string "Perldoc -f: " (ti::buffer-read-word))
+ current-prefix-arg))
+ (let* ((buffer (get-buffer-create tinyperl-:perldoc-buffer))
+ (last (get 'tinyperl-perldoc 'string))
+ (cmd (format
+ "%s -f %s"
+ (if (ti::win32-shell-p)
+ ;; Must not contain path name
+ ;; I don't know if the exact problem was due to
+ ;; SPACES in the path name.
+ "perldoc"
+ tinyperl-:perldoc-bin)
+ string
+ ""))
+ run
+ win)
+ (ti::verb)
+ (when (or force
+ (and buffer
+ (with-current-buffer buffer
+ (ti::buffer-empty-p)))
+ (not (stringp last)) ;Show previous result
+ (not (string= last string)))
+ (setq run t)
+ (get-buffer-create buffer)
+ (with-current-buffer buffer
+ (setq buffer-read-only nil)
+ (erase-buffer))
+ (when verb
+ (tinyperl-verbose-macro 2
+ (message "TinyPerl: Running %s" cmd)))
+ ;; Win32 call-process fails if the binary c:\prgram files\..
+ ;; name contains spaces. This is special problems for perldoc.bat
+ ;; Because it is in fact full of perl code and called again. See
+ ;; The source of perldoc.bat
+ (tinyperl-perldoc-1 buffer (list "-f" string))
+ ;; What if we had no luck? Try without "-f" then.
+ (with-current-buffer buffer
+ (ti::pmin)
+ (when (or (looking-at "^No documentation.*for.*function\\|Can't open")
+ (ti::buffer-empty-p))
+ (erase-buffer)
+ (when verb
+ (tinyperl-verbose-macro 2
+ (message "TinyPerl: No matches. Trying without -f ...")))
+ (tinyperl-perldoc-1 buffer (list string))
+ (setq cmd (format "%s %s"
+ tinyperl-:perldoc-bin
+ string))
+ (when verb
+ (tinyperl-verbose-macro 2
+ (message "TinyPerl: No matches. Trying without -f ...Done.")))))
+ (when verb
+ (tinyperl-verbose-macro 2
+ (message "TinyPerl: Running %s. Done." cmd))))
+ (cond
+ ((setq win (or (get-buffer-window buffer t) ;In another frame
+ (get-buffer-window buffer)))
+ (shrink-window-if-larger-than-buffer win)
+ (raise-frame (window-frame win)))
+ (t
+ (display-buffer buffer)))
+ (when run
+ (with-current-buffer buffer
+ (setq buffer-read-only nil)
+ (run-hooks 'tinyperl-:perldoc-hook)
+ (setq buffer-read-only t)))
+ ;; save the last query string.
+ (if string
+ (put 'tinyperl-perldoc 'string string))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyperl-module-find-file (module)
+ "Load Perl MODULE source."
+ (interactive (list (tinyperl-ask-module "Perl module find file: ")))
+ (tinyperl-pod-by-module module 'load))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-pod-search-regexp-by-module (module)
+ "Generate a search regexp for `tinyperl-:pod-buffer-name' for MODULE."
+ (if (string-match "^\\(.+\\)\\.pm" module)
+ (setq module (match-string 1 module)))
+ (let ((name (regexp-quote module)))
+ (concat
+ ;;NAME
+ ;; Tie::Hash, Tie::StdHash, Tie::ExtraHash - base class definitions for
+ "^NAME[ \t]*\\(\r\n\\|\n\\)"
+ "[ \t]+.*"
+ name
+ "\\|"
+ ;; use Tie::Hash;
+ ;; require Tie::Hash;
+ "^[ \t]+\\(use +\\|require +\\) *"
+ name
+ " *;")))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyperl-pod-by-module (module &optional mode)
+ "Show pod manual page for MODULE or load MODULE.
+
+Input:
+
+ MODULE The Perl module as it appears in `use' statement,
+ like Getopt::Long the '.pm' is automatically added.
+ MODE If non-nil, load source file, not pod."
+ (interactive
+ (list (tinyperl-ask-module "View module's pod: ")
+ current-prefix-arg))
+ (let* ((name (replace-regexp-in-string "\.pm$" "" module))
+ (pod-buffer-name (tinyperl-pod-buffer-name module))
+ (pod-buffer (get-buffer pod-buffer-name))
+ (regexp (tinyperl-pod-search-regexp-by-module name))
+ file)
+ (cond
+ ;; ................................................. existing POD ...
+ ((and (null mode)
+ pod-buffer
+ (tinyperl-pod-pop-to-buffer regexp pod-buffer))
+ nil) ;POD is already available
+ ;; ................................... new documentation or load ...
+ (t
+ (if (not (string-match ".p[lm]$" module))
+ (setq module (concat module ".pm")))
+ (unless (setq module (tinyperl-locate-library module))
+ (error
+ (substitute-command-keys
+ (concat
+ "TinyPerl: Can't find module from `tinyperl-:inc-module-list'. "
+ "If new perl modules have been installed from CPAN, use "
+ "\\[tinyperl-install-force] to rebuild cache."))))
+ ;; In FEW cases the *.pm file does not contain the documentation,
+ ;; but there is separate *.pod file, E.g POSIX.pm => POSIX.pod
+ (multiple-value-bind (name pathname)
+ (list (car module) (cdr module))
+ (dolist (elt (list
+ (replace-regexp-in-string
+ ".pm" ".pod" name)
+ name))
+ (setq path
+ (ti::file-make-path
+ pathname
+ ;; Delete prefix, because (cdr path) will cnotain the
+ ;; full directory
+ ;;
+ ;; Getopt::Long.pm --> Long.pm
+ (replace-regexp-in-string
+ ".*:" ""
+ elt)))
+ (when (file-exists-p path)
+ (setq file path)
+ (return))))
+
+ (when (or (not file)
+ (not (file-exists-p file)))
+ (error "TinyPerl: Cache error, %s does not exist" (car module)))
+ (cond
+ (mode
+ (find-file file)
+ (ti::pmin))
+ (t
+ (ti::pop-to-buffer-or-window
+ (tinyperl-pod2text
+ file
+ (get-buffer-create pod-buffer-name)))
+ (ti::pmin)
+ (re-search-forward regexp nil t)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-pod-podchecker (file)
+ "Run podchecker on current file."
+ (interactive
+ (list
+ (read-file-name
+ "TinyPerl podcheck: "
+ (file-name-directory (or (buffer-file-name)
+ default-directory))
+ nil
+ t
+ (if (buffer-file-name)
+ (file-name-nondirectory (buffer-file-name))
+ ""))))
+ (let* ((buffer (tinyperl-podchecker file)))
+ (display-buffer buffer)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyperl-pod-find-file (file)
+ "Run pod2text on FILE and create new buffer: '*pod' + FILE + '*'.
+If file contains pod documentation section, it will be formatted nicely."
+ (interactive "fFile to pod: ")
+ (let* ((name (file-name-nondirectory file))
+ (buffer (get-buffer-create (concat "*pod " name "*"))))
+ (with-current-buffer buffer
+ (setq buffer-read-only nil)
+ (erase-buffer))
+ (ti::pop-to-buffer-or-window (tinyperl-pod2text file buffer))
+ (ti::pmin)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-pod-find-file-this-buffer ()
+ "Call `tinyperl-pod-find-file' with `buffer-file-name'"
+ (interactive)
+ (if (buffer-file-name)
+ (tinyperl-pod-find-file (buffer-file-name))
+ (error "TinyPerl: This buffer is not associated with file.")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-pod-jump (module)
+ "Jump to Perl MODULE POD if it exists or do nothing."
+ (interactive)
+ (let* ((buffer (get-buffer (tinyperl-pod-buffer-name module))))
+ (when buffer
+ (ti::pop-to-buffer-or-window buffer))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyperl-pod-by-manpage (file)
+ "Display pod for FILE."
+ (interactive (list (tinyperl-pod-ask-manpage)))
+ (when (ti::nil-p file)
+ (error "TinyPerl: Need POD FILE, like `perldoc.pod', was `%s'" file))
+ (let* ((fid "tinyperl-pod-by-manpage")
+ (buffer (get-buffer-create (tinyperl-pod-buffer-name
+ (file-name-nondirectory file))))
+ (beg (with-current-buffer buffer
+ (point-max)))
+ ;; perldsc - Perl Data Structures Cookbook
+ ;; ^^^^^^^
+ (regexp (concat "NAME[\n\r \t]+"
+ (regexp-quote
+ (replace-regexp-in-string
+ "\.pod" ""
+ (file-name-nondirectory file)))
+ " +-+ ")))
+ (tinyperl-debug fid "file" file "buffer" buffer)
+ (or (tinyperl-pod-pop-to-buffer regexp buffer)
+ (progn
+ (ti::pop-to-buffer-or-window (tinyperl-pod2text file buffer))
+ (goto-char beg)))))
+
+;;}}}
+;;{{{ POD grep
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyperl-pod-grep (regexp &optional pod-path)
+ "Grep REGEXP from perl pod files.
+This is your way to find what pages contain references to the items you're
+looking for. However if you select the file from compile buffer, it is
+in the unconverted format (.pod). A better would be to memorize the
+pod file name, like
+
+ perlre.pod:165: \\Z Match at only e
+
+And call immediately \\[tinyperl-pod-by-manpage] and view `perlre' in
+more pleasant manner. Few C-s searches or \\[occur] will take you
+to the correct position."
+ (interactive "sPod grep regexp: ")
+ (or pod-path
+ (setq pod-path (or tinyperl-:pod-path
+ (error "TinyPerl: No tinyperl-:pod-path"))))
+ (unless (file-directory-p pod-path)
+ (error "POD directory not found [%s]" pod-path))
+ (let* ((grep (tinyperl-grep-program))
+
+ ;; Have to set this variable, because we can't
+ ;; allow to pass full path to the grep. in Win32 Emacs would
+ ;; send path in DOS style, but Cygwin does not accept those;
+ ;; only unix style paths.
+ ;:
+ ;; So, it's enough to Emacs to do an "cd" to directory.
+ ;;
+ (default-directory (file-name-directory pod-path)))
+ (setq pod-path "")
+ (if (fboundp 'igrep)
+ (ti::funcall 'igrep nil regexp "*.pod" pod-path)
+ (grep (format "%s -n '%s' %s*pod" grep regexp pod-path)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyperl-process-wait (buffer)
+ "Wait until process in BUFFER has finished."
+ (let (process)
+ (while (or (null (get-buffer buffer))
+ (and (setq process (get-buffer-process buffer))
+ (memq (process-status process) '(run))
+ (prog1 t
+ (sit-for 0.5)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-pod-grep-faq-data-context-1 (&optional line)
+ "Read FAQ context around LINE in current buffer.
+Enough context is a) FAQ entry b) or paragraph if there
+is no direct faq entry.
+
+Return:
+
+ '(TOPIC-HEADING TEXT-DATA)
+
+TOPIC-HEADING does not end to cr/lf
+TEXT-DATA ends to cr/lf"
+ (flet ((context-min (point lines)
+ (goto-char point)
+ (backward-line lines)
+ (point))
+ (context-max (point lines)
+ (goto-char point)
+ (forward-line lines)
+ (point))
+ (enough-chars-found-point-p
+ (point1 point2)
+ ;; Require at least 5 lines
+ (> (abs (- point1 point2)) (* 80 5))))
+ (let (point
+ min
+ max
+ search-min
+ string
+ topic)
+ ;; about 15 lines supposing 80 chars per line.
+ ;; These values are rough guesses.
+ (save-excursion
+ (when line
+ (goto-line line))
+ (setq point (point))
+ (setq min (context-min point 7))
+ (setq max (context-max point 5))
+ (setq search-min (context-min point 20)))
+ (cond
+ ((re-search-backward
+ ;; FAQ topic line: perlfaq6.pod
+ "^\\(=head[0-9]?.*\\)"
+ search-min 'noerr)
+ (setq min (point))
+ (setq topic (match-string 1))
+ ;; See if we can find next TOPIC nearby. Perhaps
+ ;; this is short quote from faq.
+ (forward-line 1)
+ (if (re-search-forward "^=head[0-9]?\\(.*\\)"
+ max 'noerr)
+ (setq max (line-beginning-position))))
+ (t
+ (goto-char point) ;; Previous search-min changed point
+ (save-excursion
+ (when (re-search-backward "^=head[0-9]?" nil 'noerr)
+ (setq topic (ti::buffer-read-line))))
+ ;; Excerpt enough content arount the point.
+ (let (try-min
+ try-max)
+ (re-search-backward "^[ \t]*$" nil t)
+ (setq try-min (point))
+ (goto-char point)
+ (re-search-forward "^[ \t]*$" nil t)
+ (setq try-max (point))
+ ;; Do not accept too small paragraph for an answer
+ (if (enough-chars-found-point-p try-min point)
+ (setq min try-min))
+ (if (enough-chars-found-point-p try-max point)
+ (setq max try-max)))))
+ ;; Read complete lines. Using just MIN and MAX would
+ ;; give ragged text.
+ (setq string (ti::remove-properties (buffer-substring min max)))
+ (goto-char point) ;; restore
+ (list (ti::remove-properties topic)
+ string))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-pod-grep-faq-data-context
+ (&optional buffer grep-data line)
+ "Read FAQ context around point in BUFFER.
+GREP-DATA is the actual grep content.
+
+Return:
+
+'(absolute-file-name GREP-DATA LINE (topic context-excerpt))"
+ (with-current-buffer (or buffer (current-buffer))
+ (list (ti::remove-properties (buffer-file-name))
+ line
+ (and grep-data
+ (ti::remove-properties grep-data))
+ (tinyperl-pod-grep-faq-data-context-1 line))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-pod-grep-faq-data-context-all-files
+ (&optional buffer verb)
+ "Read every grep in BUFFER and retun text excerpts from files.
+VERB allows verbose messages.
+
+Return:
+
+'((absolute-file-name grep-data (topic text-data)
+ (absolute-file-name grep-data (topic text-data)
+ ...)"
+ (let (list
+ data)
+ (ti::grep-output-parse-macro (or buffer (current-buffer))
+ ;; Load file and goto correct line
+ (let ((file (concat grep-dir grep-file)))
+ (when verb
+ (tinyperl-verbose-macro 2
+ (message "TinyPerl: reading faq context %s" file)))
+ (setq buffer (find-file-noselect file)))
+ (with-current-buffer buffer
+ (goto-line grep-line))
+
+ ;; read enough context
+ (when (setq data
+ (tinyperl-pod-grep-faq-data-context
+ buffer grep-data grep-line))
+ (push data list)))
+ (nreverse list)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-pod-grep-faq-data-insert (data &optional verb)
+ "Insert faq text DATA into current buffer. VERB.
+
+References:
+ `tinyperl-pod-grep-faq-data-context-all-files'"
+ (let ((colors-p (ti::colors-supported-p))
+ point)
+ ;; Has to disable font lock in this buffer of the
+ ;; Highlighting isn't shown.
+ (when colors-p
+ (turn-on-font-lock-mode))
+ (dolist (elt data)
+ (multiple-value-bind (file line grep-data context-data) elt
+ (multiple-value-bind (topic text) context-data
+ (when verb
+ (tinyperl-verbose-macro 2
+ (message "TinyPerl: processing data %s"
+ (file-name-nondirectory file))))
+ (insert
+ (format "FILE: [%s]" (file-name-nondirectory file))
+ (if line
+ (format " LINE: %d\n" line)
+ "\n")
+ (make-string 70 ?-)
+ "\n"
+ (if topic
+ (format "%s\n[...cut...]\n" topic)
+ ""))
+ (setq point (point))
+ (insert text "\n")
+ (when colors-p)
+ (goto-char point)
+ ;; Mark line that matched.
+ (ti::text-re-search-forward (regexp-quote grep-data))
+ (ti::pmax))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyperl-pod-grep-faq-answer (regexp &optional verb)
+ "Grep REGEXP from perl pod files. VERB.
+
+This function also gathers all =head topics that match the REGEXP.
+You can use generated page as an answer to 'Has this this question
+been answered in FAQ'"
+ (interactive "sPod FAQ search regexp: ")
+ (let* ((path (or tinyperl-:pod-path
+ (error "TinyPerl: No tinyperl-:pod-path")))
+ (default-directory (file-name-directory path))
+ (buffer "*grep*")
+ (out-buffer tinyperl-:faq-buffer-name)
+ (grep (tinyperl-grep-program))
+ data)
+ (ti::verb)
+ (setq path "")
+ ;; Grep all strings in pod files
+ (grep (format "%s -n '%s' %s*pod" grep regexp path))
+ ;; Grep is asyncronousd, need sleep, and then
+ ;; wait until process finishes. Only after that we gather hits.
+ (tinyperl-verbose-macro 1
+ (message "TinyPerl: waiting *grep* process finish..."))
+ (tinyperl-process-wait buffer)
+ (tinyperl-verbose-macro 1
+ (message "TinyPerl: waiting *grep* process finish...done"))
+ ;; See if we got any faq Subject hits?
+ ;; --> put them into list '((faq-name (topic data)) ..)
+ (setq data (tinyperl-pod-grep-faq-data-context-all-files buffer verb))
+ (when data
+ (display-buffer (get-buffer-create out-buffer))
+ (with-current-buffer out-buffer
+ (erase-buffer)
+ (tinyperl-pod-grep-faq-data-insert data)
+ (ti::pmin)))
+ (if data
+ (tinyperl-verbose-macro 1
+ (message "TinyPerl: FAQ done."))
+ (tinyperl-verbose-macro 1
+ (message "TinyPerl: FAQ context processing failed [no data].")))))
+
+;;}}}
+;;{{{ Misc
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinyperl-version-macro 'edebug-form-spec '(body))
+(put 'tinyperl-version-macro 'lisp-indent-function 0)
+(defmacro tinyperl-version-macro (&rest body)
+ "Do BODY when version variable is found. Uses `save-excursion'."
+ (`
+ (save-excursion
+ (ti::pmin)
+ ;; (ti::buffer-outline-widen)
+ (when (tinyperl-version-stamp-re-search-forward)
+ (,@ body)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-version-stamp-re-search-forward ()
+ "Search perl $VERSION variable. Match 2 will contain the version."
+ (let (case-fold-search)
+ (re-search-forward
+ (concat
+ "^[ \t]*\\(my\\|local\\|our\\)?[ \t]*\\$VERSION[ \t]*=[ \t]*[\"']"
+ "\\([0-9][0-9][0-9][0-9]\\.[0-9][0-9][0-9][0-9]\\)[\"'][ \t]*;")
+ nil
+ t)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-version-stamp ()
+ "Find $VERSION = '1234.1234'; variable and update ISO 8601 date."
+ (let* ((date (format-time-string "%Y.%m%d" (current-time))))
+ (tinyperl-version-macro
+ ;; Replace only if it is not current date
+ (unless (save-match-data
+ (string-match (regexp-quote date) (match-string 2)))
+ (replace-match date nil nil nil 2)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-pause-file-name (&optional filename use-date)
+ "Generate PAUSE FILENAME: file-version.pl.
+Input:
+
+ FILENAME like `buffer-file-name'
+ USE-DATE if non-nil, use file-yyyy.mmdd.pl, otherwise
+ try to guess verison number from a Perl variable in script.
+ See function `tinyperl-version-stamp-re-search-forward'."
+ (let* (kill
+ buffer
+ ret)
+ (setq buffer (or (and filename
+ (find-buffer-visiting filename))
+ (prog1
+ (find-file-noselect filename)
+ (setq kill t))))
+ (with-current-buffer buffer
+ (tinyperl-version-macro
+ (let* ((ver (or (match-string 2)
+ (and use-date
+ (format-time-string
+ "%Y.%m%d"
+ (current-time)))))
+ (name1 (file-name-nondirectory
+ (or filename
+ (buffer-file-name)
+ (error "TinyPerl: No `buffer-file-name'"))))
+ (name (file-name-sans-extension name1))
+ (ext (file-name-extension name1)))
+ (when (and (stringp ver)
+ (string-match "^[0-9]+" ver))
+ (setq ret (format "%s-%s.%s" name ver ext))))))
+ (if kill ;We loaded this from disk
+ (kill-buffer buffer))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-pause-copy-file (&optional directory)
+ "Copy perl script to separate directory to wait for PAUSE submission.
+
+In order to submit code to PAUSE, it must contain version number.
+The file is copied under name FILE-VERSION.pl to DIRECTORY in
+this order:
+
+ 1. DIRECTORY (available only as a lisp call)
+ 2. `tinyperl-:pause-directory' (user's default setting)
+ 3. or to current directory
+
+References:
+
+ `tinyperl-:pause-directory'."
+ (interactive
+ (let ((path tinyperl-:pause-directory))
+ (list
+ (read-file-name "TinyPerl: [PAUSE dir]: "
+ (and path (file-name-directory path))
+ nil ;; users null string
+ (not 'must-match)
+ (and path
+ (file-name-nondirectory path))))))
+ (let* ((from (buffer-file-name))
+ (file (tinyperl-pause-file-name from))
+ to)
+ (unless (file-directory-p directory)
+ (error "TinyPerl: Directory not found %s" directory))
+ (unless file
+ (message "TinyPerl: Not ready for PAUSE. No $VERSION = 'value';"))
+ (setq to (concat (file-name-as-directory directory) file))
+ (copy-file from to 'ok-if-already-exists)
+ (tinyperl-verbose-macro 1
+ (message "Tinyperl: PAUSE, Copied to %s" to))
+ to))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-pause-upload-via-ftp (file)
+ "Upload file to PAUSE server for submission.
+The filename must contain version number: FILE-VERSION.pl"
+ (interactive (list (buffer-file-name)))
+ (let* ((ver (tinyperl-pause-file-name file))
+ (temp (file-name-as-directory
+ (ti::temp-directory)))
+ (upload (concat temp ver)))
+ ;; Use safety net, not just about anything shuld be uploaded.
+ (unless (string-match "\\.\\(pl\\|pm\\)$" file)
+ (error "TinyPerl: Only .pm or .pl files can be uploaded."))
+;;;#todo: background upload not working.
+
+;;; (ti::file-ange-file-handle
+;;; 'put
+;;; "anonymous"
+;;; "pause.perl.org"
+;;; "/incoming"
+;;; temp
+;;; (list ver)
+;;; nil ;; Run on background
+;;; (format "TinyPerl: ange-ftp PAUSE upload completed %s" ver))
+ (copy-file file upload 'ok-if-already-exists)
+ (with-temp-buffer
+ (insert-file upload)
+ (write-file
+ (concat
+ "/anonymous@pause.perl.org:/incoming/"
+ ver)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-pause-url-submit-www-page ()
+ "Visit PAUSE WWW page where you can submit your files.
+PAUSE means \"The Perl Authors Upload Server\""
+ (interactive)
+ (tinyurl-agent-funcall
+ 'url
+ ;; You need to be logged, in order to use this:
+ ;; https://pause.perl.org/authenquery?ACTION=add_uri
+ "http://pause.perl.org"))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyperl-selfstubber-stubs (file &optional force)
+ "Generate stubs, ie. function predeclarations from FILE.
+Run SelfStubber on current module, whichexpects to find functions
+after __DATA__ token.
+
+If there is entry in current buffer to read
+
+ # BEGIN: Devel::SelfStubber
+ # END: Devel::SelfStubber
+
+Then the generated subs are inserted into that section. Any previous
+stubs are removed.
+
+Input:
+
+ FORCE Flag, if nono-nil, copy the file under temp directory
+ and __DATA__ token to the beginning of file do that
+ all functions are shown. You can use this flag to generate
+ prototypes of all functions."
+ (interactive
+ (list
+ (read-file-name "Perl stubs from file: "
+ nil nil 'match
+ (file-name-nondirectory buffer-file-name))
+ current-prefix-arg))
+ (let* ((name (file-name-nondirectory file))
+ tmp
+ buffer
+ cmd-1
+ beg
+ end)
+ (setq file (expand-file-name file))
+ (unwind-protect
+ (progn
+ ;; ........................................... forced insert ...
+ (when force
+ (unless (string-match "\\.pm$" name)
+ ;; SelfStubber expects Modules (.pm) files only
+ (tinyperl-verbose-macro 2
+ (message "TinyPerl: %s must end to .pm, fixing..." file))
+ (setq name (concat name ".pm")))
+
+ (setq tmp (ti::temp-file name 'tmp-dir))
+ (copy-file file tmp)
+ (setq file tmp)
+
+ (with-current-buffer (setq buffer (find-file-noselect file))
+ (delete-matching-lines "__DATA__")
+ (ti::pmin)
+ (insert "use SelfLoader;\n__DATA__\n")
+ (save-buffer nil)))
+ ;; ............................................ perl-command ...
+ (setq cmd-1
+ (format
+ "Devel::SelfStubber->stub( qq{%s}, qq{%s} )"
+ (replace-regexp-in-string "\\.pm$" ""
+ (file-name-nondirectory file))
+ (replace-regexp-in-string "[\\/]$" ""
+ (file-name-directory file))))
+
+ (tinyperl-verbose-macro 2
+ (message ;Record it to *Messages* buffer
+ (format
+ "%s -MDevel::SelfStubber -e %s"
+ tinyperl-:perl-bin
+ cmd-1)))
+ ;; ........................................... find-position ...
+
+ (and (setq beg (ti::re-search-check
+ "BEGIN:[ \t]+Devel::SelfStubber"))
+ (setq end (ti::re-search-check
+ "\n#[ \t]+END:[ \t]+Devel::SelfStubber")))
+ (cond
+ ((and beg end)
+ (save-excursion
+ (goto-char beg)
+ (forward-line 1)
+ (delete-region (point) end)
+ (insert "\n")
+ (call-process tinyperl-:perl-bin
+ nil
+ (current-buffer)
+ nil
+ "-MDevel::SelfStubber "
+ "-e"
+ cmd-1)
+
+ (tinyperl-verbose-macro 1
+ (message "TinyPerl: stubs updated in buffer"))))
+ (t ;No previoous STUBS
+ (call-process tinyperl-:perl-bin
+ nil
+ (current-buffer)
+ nil
+ "-MDevel::SelfStubber "
+ "-e"
+ cmd-1)))) ;; progn
+ (when buffer
+ (kill-buffer buffer)))))
+
+;;}}}
+
+(tinyperl-skeleton-setup)
+
+(provide 'tinyperl)
+(run-hooks 'tinyperl-:load-hook)
+
+;;; tinyperl.el ends here
--- /dev/null
+;;; tinypgp.el --- PGP minor mode, remailing, keyring management
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 1996-2007 Jari Aalto
+;; Keywords: extensions
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program, call M-x tinypgp-version.
+;; Look at the code with folding.el
+
+;; COPYRIGHT NOTICE
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;; This file is not part of Emacs
+
+;;}}}
+;;{{{ Install
+
+;;; Install:
+
+;; ....................................................... &t-install ...
+;;
+;; THIS FILE IS UNMAINTAINED - AND NOT WORKING IN ANY WAY
+;;
+;; Put this file on your Emacs-Lisp load path, add following into your
+;; ~/.emacs startup file.
+;;
+;; (require 'tinypgp)
+;;
+;; or use this; your ~/.emacs loads quicker
+;;
+;; (autoload 'tinypgp-mode "tinypgp" "" t)
+;; (autoload 'turn-on-tinypgp-mode "tinypgp" "" t)
+;; (autoload 'turn-off-tinypgp-mode "tinypgp" "" t)
+;; (autoload 'tinypgp-install "tinypgp" "" t)
+;;
+;; (add-hook 'message-mode-hook 'turn-on-tinypgp-mode)
+;; (add-hook 'mail-mode-hook 'turn-on-tinypgp-mode)
+;; (add-hook 'rmail-mode-hook 'turn-on-tinypgp-mode)
+;; (add-hook 'vm-mode-hook 'turn-on-tinypgp-mode)
+;; (add-hook 'gnus-startup-hook 'tinypgp-install)
+;; (add-hook 'gnus-article-edit-mode 'turn-on-tinypgp-mode)
+;;
+;; Put your customizations to separate file and add this.
+;;
+;; (setq tinypgp-:load-hook
+;; '(lambda () (require 'rc-tinypgp "~/elisp/rc/emacs-rc-tinypgp")))
+;;
+;; to automatically sign all your outgoing mail, add this to your .emacs
+;; For more personal signing, see manual
+;;
+;; (add-hook 'mail-send-hook 'tinypgp-sign-mail-auto-mode-on)
+;; (add-hook 'message-send-hook 'tinypgp-sign-mail-auto-mode-on)
+;;
+;; Suggested mode binding, "m" prefix for all minor mode toggles.
+;; If these are occupied, then choose some other bindings.
+;;
+;; ;; note, Mailcrypt's prefix key is C-c / which is also
+;; ;; this package's prefix key unless you use the setq below.
+;; ;;
+;; ;; Personally I like the "-" because it's easier to reach than "/"
+;; ;; in my keyboard.
+;; ;;
+;; (setq tinypgp-:mode-prefix-key "\C-c-")
+;; (global-set-key "\C-cm-" 'tinypgp-mode)
+;; (global-set-key "\C-cm'" 'tinypgp-key-mode)
+;;
+;; See the end of file for additional examples.
+;; If you want to contact maintainer, always use this function
+;;
+;; M-x tinypgp-submit-bug-report -- send feedback or bug report
+
+;;}}}
+;;{{{ Documentation
+
+;; ..................................................... &t-commentary ...
+;;; Commentary:
+
+;;}}}
+
+;;; History:
+
+;;; Code:
+
+;;{{{ setup: require
+
+;;; ......................................................... &require ...
+
+(require 'tinylib)
+(require 'tinylibmail)
+(require 'mail-utils)
+
+(eval-when-compile
+ (ti::package-use-dynamic-compilation)
+ (require 'advice))
+
+(eval-and-compile
+
+ (message "\
+ ** tinypgp.el: Notice dated 2000-02-10
+ THIS FILE IS NOT CURRENTLY MAINTAINED. You can expect that the pgp
+ interface is non-functional and compiling this file gives errors.")
+
+ (when (and (ti::win32-p)
+ (ti::nil-p (getenv "PGPPATH")))
+ (error "TinyPgp: environment variable PGPPATH not set for secring.*"))
+
+ (ti::package-package-require-timer)
+
+ (autoload 'rmail-edit-current-message "rmailedit" t t)
+ (autoload 'rmail-cease-edit "rmailedit" t t)
+ (autoload 'rmail-add-label "rmailkwd")
+ (autoload 'rmail-kill-label "rmailkwd")
+
+ (defvar vm-frame-per-edit t) ;See vm-vars.el
+ (autoload 'vm-edit-message "vm-edit" t t)
+ (autoload 'vm-edit-message-end "vm-edit" t t)
+ (autoload 'vm-delete-message-labels "vm-undo" t t)
+ (autoload 'vm-add-message-labels "vm-undo" t t)
+ (autoload 'vm-update-summary-and-mode-line "vm" t t)
+
+ (defvar mail-send-hook nil)
+ (defvar mail-mode-hook nil)
+
+ (defvar message-mode-hook nil)
+ (autoload 'message-send-and-exit "message")
+
+ (autoload 'mail-send-and-exit "sendmail")
+ (autoload 'mail-setup "sendmail")
+ (autoload 'mail-do-fcc "sendmail")
+
+ (autoload 'adelete "assoc")
+
+ ;; TM mime available at
+ ;; ftp://ftp.jaist.ac.jp:/pub/GNU/elisp/mime/
+
+ (defvar mime/editor-mode-flag nil)
+ (autoload 'mime-editor/exit "tm-edit")
+ (autoload 'mime-editor/enclose-signed-region "tm-edit")
+ (autoload 'mime-editor/enclose-encrypted-region "tm-edit")
+ (autoload 'mime-viewer/quit "tm-view")
+
+ (autoload 'timi-mail "tinymail")
+
+ (autoload 'bbdb-search-simple "bbdb")
+ (autoload 'bbdb-record-getprop "bbdb")
+
+ (autoload 'gnus-inews-do-gcc "gnus-msg")
+ (autoload 'gnus-summary-edit-article "gnus-sum" t t)
+ (autoload 'gnus-article-edit-done "gnus-art" t t)
+
+ ;; The expect code is needed only in Pgp 5.x
+ ;; Only if that backend is used the expect.el is loaded.
+
+ (autoload 'expect-make-info "expect" nil nil)
+ (autoload 'expect-info-process "expect" nil nil 'macro)
+ (autoload 'expect-info-message "expect" nil nil 'macro)
+ (autoload 'expect-info-point "expect" nil nil 'macro)
+ (autoload 'expect-info-set-point "expect" nil nil 'macro)
+ (autoload 'expect-info-sentinels "expect" nil nil 'macro)
+ (autoload 'expect-info-set-sentinels "expect" nil nil 'macro)
+ (autoload 'expect-info-timer "expect" nil nil 'macro)
+ (autoload 'expect-info-set-timer "expect" nil nil 'macro)
+ (autoload 'expect-info-queries "expect" nil nil 'macro)
+ (autoload 'expect-info-set-queries "expect" nil nil 'macro)
+ (autoload 'expect-find-info "expect" nil nil 'macro)
+ (autoload 'with-expect "expect" nil nil 'macro)
+ (autoload 'expect-start-process "expect" nil nil)
+ (autoload 'with-expect-asynchronous "expect" nil nil 'macro)
+ (autoload 'expect "expect" nil nil 'macro)
+ (autoload 'expect-cond "expect" nil nil 'macro)
+ (autoload 'expect-exit "expect" nil nil 'macro)
+ (autoload 'expect-send "expect" nil nil 'macro)
+ (autoload 'expect-setup "expect" nil nil)
+ (autoload 'expect-shutdown "expect" nil nil)
+ (autoload 'expect-kill "expect" nil nil)
+ (autoload 'expect-wait "expect" nil nil)
+ (autoload 'expect-1 "expect" nil nil)
+ (autoload 'expect-exit-1 "expect" nil nil)
+ (autoload 'expect-filter "expect" nil nil)
+ (autoload 'expect-sentinel "expect" nil nil)
+ (autoload 'expect-find-event "expect" nil nil)
+ (autoload 'expect-setup-timer "expect" nil nil)
+ (autoload 'expect-cancel-timer "expect" nil nil)
+
+ ;; When file is byte compiled, the expand-file-name might eventually
+ ;; call this function, so let emacs know where it is.
+
+ (autoload 'ange-ftp-real-expand-file-name "ange-ftp" t t))
+
+;;; ......................................................... &v-group ...
+
+(defgroup TinyPgp nil
+ "Emacs PGP and Remailer interface.
+
+ TinyPgp is intended to be a 2nd generation Emacs PGP interface
+ and it supports all major pgp commands from inside
+ emacs. Remailing and anonymous account handling in different
+ servers is included."
+
+ :link '(url-link
+ :tag "Keyserver home"
+ "http://geronimo.uit.no/cc/tjenester/PGP/servruit.eng.html")
+
+ :link '(url-link
+ :tag "Pgp mailing list"
+ "http://pgp.rivertown.net/")
+
+ :link '(url-link
+ :tag "Norway's keyserver"
+ "http://www.ifi.uio.no/pgp/")
+
+ :link '(url-link
+ :tag "Remailer Faq (Galactus)"
+ "http://www.stack.urc.tue.nl/~galactus/remailers/")
+
+ :link '(url-link
+ :tag "PGP faq alt.security.pgp"
+ "ftp://ftp.prairienet.org/pub/providers/pgp/pgpfaq.txt")
+
+ :link '(url-link
+ :tag "X-Pgp header specififacion"
+ "ftp://cs.uta.fi/pub/ssjaaa/pgp-xhd.html")
+
+ :link '(url-link
+ :tag "TinyPgp Manu page"
+ "ftp://cs.uta.fi/pub/ssjaaa/tinypgp.html")
+
+ :prefix "tinypgp-:"
+ :group 'extensions)
+
+;;; .................................................... &v-group-mode ...
+
+(defgroup tinypgp-mode-definitions nil
+ "Mode names, menu names and prefix key settings."
+ :prefix "tinypgp-:"
+ :group 'TinyPgp)
+
+(defgroup tinypgp-mode nil
+ "Options that directly address basic PGP commands in minor modes."
+ :prefix "tinypgp-:"
+ :group 'TinyPgp)
+
+(defgroup tinypgp-header nil
+ "Options that deal with Email message headers."
+ :prefix "tinypgp-:"
+ :group 'TinyPgp)
+
+(defgroup tinypgp-file nil
+ "Files used when communicating with PGP. You shouldn't rename these.
+Do not add any extension to files, because PGP itself may append extension
+.asc or .pgp or .bak. change only directory location.
+
+When you load the package first time the directory name is initialized
+from `tinypgp-:file-directory' or if it is nil a wild guess will be taken
+See function documentation `tinypgp-path' for details.
+"
+ :prefix "tinypgp-:"
+ :group 'TinyPgp)
+
+(defgroup tinypgp-hook nil
+ "Variables where you can put your own functions."
+ :prefix "tinypgp-:"
+ :group 'TinyPgp)
+
+(defgroup tinypgp-function nil
+ "Variables where you can put your own functions."
+ :prefix "tinypgp-:"
+ :group 'TinyPgp)
+
+(defgroup tinypgp-pgp nil
+ "Options that relate to PGP executable and shell envinronment."
+ :prefix "tinypgp-:"
+ :group 'TinyPgp)
+
+;;; .................................................... &v-group-misc ...
+
+(defgroup tinypgp-interface nil
+ "Variables to configure connections to outside world (ftp, http, email)"
+ :prefix "tinypgp-:"
+ :group 'TinyPgp)
+
+(defgroup tinypgp-remail nil
+ "Remailer interface settings."
+ :prefix "tinypgp-:r"
+ :group 'TinyPgp)
+
+(defgroup tinypgp-remail-hook nil
+ "Remailer interface hooks."
+ :prefix "tinypgp-:r"
+ :group 'tinypgp-remail)
+
+(defgroup tinypgp-nymserver nil
+ "Anonymous service (paid) anon.nymserver.com settings.
+Similar to anon.penet.fi, which has been closed permanently."
+
+ :link '(url-link
+ :tag "Nymserver main page"
+ "http://www.nymserver.com")
+
+ :link '(url-link
+ :tag "Nymserver html doc (a bit old)"
+ "ftp://cs.uta.fi/pub/ssjaaa/nymserv.html")
+
+ :prefix "tinypgp-:r"
+ :group 'TinyPgp)
+
+(defgroup tinypgp-newnym nil
+ "Anonymous PGP service newnym type remailers."
+
+ :link '(url-link
+ :tag "Nym help page"
+ "http://www.stack.nl/~galactus/remailers/nym.html")
+
+ :prefix "tinypgp-:r"
+ :group 'TinyPgp)
+
+;;}}}
+;;{{{ setup: predefined functions
+
+(defcustom tinypgp-:file-directory nil
+ "*Directory where to store temporary files. Must not be public; like /tmp/.
+You should store files under your private directory. If this variable
+is nil; then `tinypgp-path' guesses the right location for you. See function
+documentations for more."
+ :type 'directory
+ :group 'tinypgp-file)
+
+;;; ----------------------------------------------------------------------
+;;; Define this function becore it is used in variables.
+;;;
+
+(eval-and-compile
+
+ (defun tinypgp-expand-file-name (file &optional type)
+ "Expand file under correct OS. TYPE overrides: 'unix 'win32."
+ (cond
+ ((and (ti::win32-p)
+ (eq type 'unix))
+ (save-match-data
+ (ti::file-name-forward-slashes-cygwin (expand-file-name file))))
+ ((or (ti::win32-p)
+ (eq type 'win32))
+ (save-match-data
+ (ti::file-name-backward-slashes (expand-file-name file))))
+ (t
+ (expand-file-name file))))
+
+ (defun tinypgp-path (file &optional try-paths)
+ "Add path to FILE with TRY-PATHS. See also `tinypgp-:file-directory'.
+Search list is:
+
+ `tinypgp-:file-directory'
+ PGPPATH
+ ~/.pgp/
+ ~/
+
+If FILE already includes path, do nothing."
+ (let* (path)
+ (or (stringp file)
+ (error "FILE is missing."))
+
+ (if (string-match "[~/]" (substring file 0 1))
+ (tinypgp-expand-file-name file) ;Already had path
+ (dolist (try (or try-paths
+ (list tinypgp-:file-directory
+ (getenv "PGPPATH")
+ "~/.pgp/"
+ "~/")))
+ (when try
+ (setq try (ti::string-verify-ends try "/"))
+ (when (file-directory-p try)
+ (setq path try)
+ (return))))
+ (if (not (file-exists-p path))
+ (error "Can't find path %s" path))
+ (tinypgp-expand-file-name (concat path file))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+
+(eval-and-compile
+
+ (defun tinypgp-binary-get-version (&optional ret-type call-shell)
+ "Return version number of current pgp.
+
+Input:
+
+ RET-TYPE How the information is returned.
+ If this is nil then return STRING.
+ If this is non-nil then return 'us (2.6.2) or
+ 'international (2.6.3i)
+
+ CALL-SHELL if nil, then look variable `tinypgp-:pgp-binary'.
+ If there is no variable or it is not string, then
+ call shell to find out pgp exe's version number
+
+Return:
+
+ string See RET-TYPE
+ symbol"
+ (let (ret)
+ (if (and (null call-shell)
+ (boundp 'tinypgp-:pgp-binary)
+ (setq ret (get 'tinypgp-:pgp-binary 'version)))
+ nil ;ret already set
+ (setq ret (ti::mail-pgp-exe-version-string)))
+
+ (if (and ret-type (stringp ret))
+ (if (string-match "i" ret)
+ (setq ret 'international)
+ (setq ret 'us)))
+ ret)))
+
+;;}}}
+;;{{{ setup: version
+
+;;; ...................................................... &vp-version ...
+;;; the version information is needed in the variable definitions later.
+
+(eval-and-compile
+ (defconst tinypgp-:version-id
+ "$Id: tinypgp.el,v 2.57 2007/05/07 10:50:10 jaalto Exp $"
+ "Latest modification time and version number.")
+ (defun tinypgp-version-number ()
+ "Return version number as string."
+ (ti::string-match "\\([0-9]+\\.[0-9]+\\)" 1 tinypgp-:version-id)))
+
+;;; ----------------------------------------------------------------------
+;;;
+
+(defun tinypgp-version (&optional arg)
+ "Show version information. ARG instruct to print message in echo area only."
+ (interactive "P")
+ (ti::package-version-info "tinypgp.el" arg))
+
+;;; ----------------------------------------------------------------------
+;;;
+
+(defun tinypgp-version-message ()
+ "Display version."
+ (interactive)
+ (message tinypgp-:version-id))
+
+;;}}}
+;;{{{ setup: hooks
+
+;; ......................................................... &v-hooks ...
+
+(defcustom tinypgp-:load-hook nil
+ "*Hook that is run when package is loaded."
+ :type 'hook
+ :group 'tinypgp-hook)
+
+(defcustom tinypgp-:mode-hook nil
+ "*Hook run when minor mode is turned on."
+ :type 'hook
+ :group 'tinypgp-hook)
+
+(defcustom tinypgp-:key-mode-hook nil
+ "*Hook run when minor mode is turned on."
+ :type 'hook
+ :group 'tinypgp-hook)
+
+(defcustom tinypgp-:summary-mode-hook nil
+ "*Hook run when minor mode is turned on."
+ :type 'hook
+ :group 'tinypgp-hook)
+
+(defcustom tinypgp-:mail-send-hook-list
+ '(mail-send-hook
+ message-send-hook
+ mh-before-send-letter-hook)
+ "*List of hooks that are called by Mail agents before sending mail."
+ :type 'hook
+ :group 'tinypgp-hook)
+
+(defcustom tinypgp-:turn-on-hook-list
+ '(mail-mode-hook
+ rmail-mode-hook
+ vm-mode-hook
+ message-mode-hook
+ gnus-article-mode-hook ; When selecting the article.
+ gnus-article-edit-mode-hook
+ news-reply-mode-hook ; 'f' key reply, GNUS 4 only
+ mh-letter-mode-hook
+ mh-show-mode-hook)
+ "*List of hooks where to install pgp mode.
+Call `add-hook' only inside `tinypgp-:load-hook', because the defvar
+installs many default hooks."
+ :type 'hook
+ :group 'tinypgp-hook)
+
+(defcustom tinypgp-:sig-from-header-hook nil
+ "*Hook run at the end of `tinypgp-pgp-move-sig-from-header' function.
+If there is no PGP header, hook is not called."
+ :type 'hook
+ :group 'tinypgp-hook)
+
+(defcustom tinypgp-:sig-to-header-hook nil
+ "*Hook run at the end of `tinypgp-signature-move-to-header function' function.
+If there is no PGP header, hook is not called."
+ :type 'hook
+ :group 'tinypgp-hook)
+
+(defcustom tinypgp-:sign-loose-info-hook nil
+ "*Hook run when the `tinypgp-sign-loose-info' function has completed."
+ :type 'hook
+ :group 'tinypgp-hook)
+
+(defcustom tinypgp-:define-keys-hook nil
+ "*List of functions to define all keys and menus."
+ :type 'hook
+ :group 'tinypgp-hook)
+
+(defcustom tinypgp-:key-mode-define-keys-hook nil
+ "*List of functions to define all keys and menus."
+ :type 'hook
+ :group 'tinypgp-hook)
+
+(defcustom tinypgp-:summary-mode-define-keys-hook nil
+ "*List of functions to define all keys and menus."
+ :type 'hook
+ :group 'tinypgp-hook)
+
+(defcustom tinypgp-:newnym-mode-define-keys-hook nil
+ "*List of functions to define all keys and menus."
+ :type 'hook
+ :group 'tinypgp-hook)
+
+(defvar tinypgp-:do-command-region-before-hook nil
+ "Hook run in tmp buffer where containing data for pgp.
+The PGP shell command is at this point stored into variable
+`tinypgp-:last-pgp-exe-command'.
+
+Note:
+
+ If function in this hook returns non-nil, the rest of the functions are
+ not called.
+
+Call arguments:
+
+ cmd msg res-str")
+
+(defvar tinypgp-:do-command-region-after-hook nil
+ "Hook run in tmp buffer after the PGP shell command has completed.
+
+Note:
+
+ If function in this hook returns non-nil, the rest of the functions are
+ not called.
+
+Call arguments:
+ cmd msg res-str")
+
+(defvar tinypgp-:cmd-macro-before-hook nil
+ "Hook which run before the pgp sequence initiates in current buffer.
+See function `tinypgp-cmd-macro' for arguments.
+
+Note:
+
+ First function that returns non-nil terminates running the
+ rest of the functions. User functions must be at the end of hook
+ (use add-hook's 3rd parameter)
+
+Call arguments:
+
+ cmd user msg string")
+
+(defvar tinypgp-:cmd-macro-after-hook nil
+ "Hook which run after the pgp sequence has been completed.
+See function `tinypgp-cmd-macro' for arguments.
+
+Note:
+
+ First function that returns non-nil terminates running the
+ rest of the functions. User functions must be at the end of hook
+ (use add-hook's 3rd 'append parameter)
+
+Call arguments:
+
+ cmd user msg string
+
+Call Note:
+
+ if the CMD is 'cancel, then the function in this hook must not
+ do any modification, but only restore any state that may have
+ been opened in the *before* hook. (Eg. closing rmail-edit-mode).
+ The 'cancel indicates that `error' command is about to be called soon.")
+
+(defcustom tinypgp-:verify-before-hook nil
+ "*Hook run before verify function is called.
+Every function in the hook is called with 2 args: region-beg region-end
+The function should return non-nil if it doesn't want to allow other
+functions in the hook to continue."
+ :type 'hook
+ :group 'tinypgp-hook)
+
+(defcustom tinypgp-:verify-after-hook nil
+ "*Hook run when verify function is done.
+
+Note:
+
+ First function that returns non-nil terminates running the
+ rest of the functions.
+
+Call arguments:
+
+ region-beg region-end verify-string-ret-val."
+ :type 'hook
+ :group 'tinypgp-hook)
+
+(defcustom tinypgp-:read-email-after-hook '(tinypgp-email-substitution-default)
+ "*This hook is called after email address list has been read.
+The list is used e.g. for decrypting the message to multiple
+users.
+
+It may be desiradble to change some email address to something else;
+supposes that you're sending encrypted message to foo2@site.com, but
+you have key from him only that refers to email foo1@site.com. If you
+try to encrypt according to \"To: foo2@site.com\" you get PGP error,
+because there is no such key in the active keyring. That's why
+you modify list and change the foo2@site.com to foo1@site.com.
+
+Call arguments:
+
+ email-list or string
+
+Function should return:
+
+ list ,original list if no changes.
+ modified list"
+ :type 'hook
+ :group 'tinypgp-hook)
+
+(defcustom tinypgp-:insert-file-sign-base64-hook
+ 'ti::process-tar-zip-view-maybe-command
+ "*Hook to run before the file is inserted to current point.
+There is default function to this hook for tar/zip files, which inserts
+the file listing into the buffer.
+
+Note:
+
+ If some function return non-nil the rest of the functions are not run.
+ The buffer is temporary buffer for inserted data where hook is run,
+ point sits at `point-min' and buffer holds the base64 signed file.
+
+Call arguments:
+
+ string : filename"
+ :type 'hook
+ :group 'tinypgp-hook)
+
+(defcustom tinypgp-:auto-action-before-hook nil
+ "*Hook run before `tinypgp-auto-action' processes anything."
+ :type 'hook
+ :group 'tinypgp-hook)
+
+(defcustom tinypgp-:auto-action-defeat-hook '(tinypgp-auto-action-defeat-p)
+ "*If any the functions return non-nil, the auto action is defeated.
+Called from `tinypgp-auto-action'. The default function
+`tinypgp-auto-action-defeat-p' inhibits processing MIME messages."
+ :type 'hook
+ :group 'tinypgp-hook)
+
+;;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. others . .
+
+(defcustom tinypgp-:finger-discard-email-hook
+ '(tinypgp-finger-discard-by-regexp)
+ "*This hook is called before finger spawned to fetch public key.
+You should discard any email addresses that refer to your account.
+
+Default function:
+ `tinypgp-finger-discard-by-regexp'
+ --> uses variable `tinypgp-:finger-discard-by-regexp'
+
+Function call arguments:
+
+ string or list of strings '(email email ..)
+
+Function should return:
+
+ modified list or string
+ nil ,do not finger anything.
+
+Example code, which is also the idea of default function:
+
+ (add-hook 'tinypgp-:finger-discard-email-hook
+ 'my-tinypgp-finger-discard-email)
+
+ (setq my-:tinypgp-me \"me.surname@\\|myOtherAccount@foo\\|3rd@bix.com\")
+
+ (defun my-tinypgp-finger-discard-email (string-or-list)
+ ;; Discard addresses that point to me
+ (require 'tinylibm)
+ (let (ret)
+ (mapcar
+ (function
+ (lambda (x)
+ (if (not (string-match my-:tinypgp-me x))
+ (push x ret))))
+ ;; convert string to list if needed.
+ (ti::list-make string-or-list))
+ ret))"
+ :type 'hook
+ :group 'tinypgp-hook)
+
+(defcustom tinypgp-:find-by-guess-hook nil
+ "*Functions called to find public key and keyring.
+
+Notes:
+
+ First function that return non-nil terminates calling other
+ function in the hook
+
+ PLEASE THINK CAREFULLY WHICH IS THE FIND ORDER, if you
+ use your own function; use add-hook's 3rd parameter to
+ add your methods last in the hook.
+
+Function call arguments:
+
+ string usually email address(key id)
+
+Function should return:
+
+ string (filename) keyring where the key is available
+ nil"
+ :type 'hook
+ :group 'tinypgp-hook)
+
+(defcustom tinypgp-:auto-action-encrypt-ok-hook nil
+ "*Hook to determine if sending auto encrypted mail is ok.
+This hook is called only if some recipent matches
+`tinypgp-:auto-action-encrypt-regexp'
+
+Function call arguments:
+
+ flag
+ list list of To and Cc recipients.
+
+Function should return:
+
+ boolean non-nil says that encrypting is ok"
+ :type 'hook
+ :group 'tinypgp-hook)
+
+;;; ...................................................... &v-function ...
+;;; These are not in defcustom. Experts user know what to look
+;;; for from source code if they need to change these.
+
+(defcustom tinypgp-:encrypt-after-function 'tinypgp-encrypt-add-remailer-tag
+ "Function run after the buffer is encrypted.
+The default function `tinypgp-encrypt-add-remailer-tag' adds the
+'Encrypted: PGP' tag to the beginning of encryopted block. It is needed
+when the message is sent to remailer.
+
+If you put your function inside this, be sure that you supply that tag
+if you're writing message to remailer.
+
+ ::
+ Encrypted: PGP
+
+ -----BEGIN PGP MESSAGE-----
+ ...
+
+Function call arguments:
+ none
+
+Function should return:
+
+ none
+
+Function call point
+
+ at the beginnning of message"
+ :type 'function
+ :group 'tinypgp-pgp)
+
+(defcustom tinypgp-:filter-email-function 'tinypgp-mail-abbrevs-filter
+ "*Function to filter out unwanted mailabbrevs.
+When making the completion list of email address out of the
+mail-abbrev table, the obarray may contain some _old_, unwanted, or
+invalid email addresses. Perhaps you just don't want to have all
+email addresses for PGP encryption: that's what this filter
+function is for.
+
+Call arguments:
+
+ list list of email addresses.
+
+Return value:
+
+ list list of valid email addresses.")
+ :type 'function
+ :group 'tinypgp-pgp
+
+(defcustom tinypgp-:verify-message-function nil
+ "*Function called to print the verify status.
+This function is called with one argument: STRING, when verify status
+is displayed. For example; sometimes PGP could display
+
+ Good signature from user \"0f00bc000\".
+
+Which isn't quite enlightling. By supplying your own function you
+can check cases like this and convert the message into something
+more meaningful.
+
+Example:
+
+ (setq tinypgp-:verify-message-function 'my-tinypgp-verify-message)
+
+ (defun my-tinypgp-verify-message (str)
+ \"Display more meaningful message\"
+ (let* ((pfx \"Good signature from: \"))
+ (cond
+ ((string-match \"0f00bc095\" str)
+ (setq str (concat pfx \"Foo Bar\"))))
+ (message str)))"
+ :type 'function
+ :group 'tinypgp-pgp)
+
+(defcustom tinypgp-:pgp-encrypted-p-function 'tinypgp-pgp-encrypted-p-default
+ "*Function to return PGP data type for message.
+When you call `tinypgp-decrypt-mail' interactively, the
+PGP type is asked. However, you can automate the type checking if you
+know the type of PGP data.
+
+The default function `tinypgp-pgp-encrypted-p-default' check the CTB bits
+and return correct type.
+
+Function arguments:
+
+ none
+
+Function should return:
+
+ string 'pgp', 'base64', 'conventional' or nil"
+ :type 'function
+ :group 'tinypgp-pgp)
+
+(defcustom tinypgp-:pgp-decrypt-arg-function
+ 'tinypgp-decrypt-arg-function
+ "*How to Honour variable `tinypgp-:decrypt-arg-interpretation'.
+The default function `tinypgp-decrypt-arg-function' treats writable and read
+only buffers differently."
+ :type 'function
+ :group 'tinypgp-pgp)
+
+(defcustom tinypgp-:pgp-command-compose-function nil
+ "*Hook to run after pgp executable command has been composed.
+If this hook doesn't modify the command, it should return CMD untouched.
+
+function args:
+
+ cmd string
+
+Should return:
+
+ cmd string"
+ :type 'function
+ :group 'tinypgp-pgp)
+
+(defcustom tinypgp-:secring-crypt-function 'tinypgp-crypt-do-with-pgp
+ "*Function to crypt the secring.
+
+Default values available:
+
+ 'tinypgp-crypt-do-with-pgp
+ 'tinypgp-crypt-do-with-crypt ;; not recommended
+
+Function args:
+
+ from source file
+ to destination file
+ password TO crypted by using this
+
+Notes
+
+ Function should detect by looking FROM file if it is already
+ in encrypted format and convert it to back to regular file.
+ Kinda flip-flop. It should also signal error and terminate if
+ wrong password were used for opening the file (that is, if it
+ is possible to determine that condition)"
+ :type 'function
+ :group 'tinypgp-pgp)
+
+(defcustom tinypgp-:encrypt-with-function nil
+ "*When message is encrypted, this function return additional keyIds.
+
+For example if you want to encrypt all messages to yourself but only
+when they are not sent to remailers, then you could use this setup.
+All messages would be then readable by you also.
+
+ (setq tinypgp-:encrypt-with-function 'my-tinypgp-encrypt-with)
+
+ (defun my-tinypgp-encrypt-with ()
+ (unless (ti::re-search-check \"remail\")
+ ;; Or your explicit PGP keyID if the name is not unique enough
+ (list tinypgp-:user-primary)))
+
+Function args:
+
+ none
+
+Should return:
+
+ list of additional keyIds (strings) used in encryption or nil."
+ :type 'function
+ :group 'tinypgp-pgp)
+
+;;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. remailer . .
+
+(defcustom tinypgp-:r-post-before-hook nil
+ "*Hook run before post is converted into Anon format."
+ :type 'hook
+ :group 'tinypgp-remail-hook)
+
+(defcustom tinypgp-:r-post-after-hook nil
+ "*Hook run after post is converted into Anon format."
+ :type 'hook
+ :group 'tinypgp-remail-hook)
+
+(defcustom tinypgp-:nymserver-post-hook nil
+ "*Hook run after `tinypgp-nymserver-post' function finishes."
+ :type 'hook
+ :group 'tinypgp-nymserver)
+
+(defcustom tinypgp-:r-init-hook nil
+ "*Hook run after the remailer support has been initialised.
+See `tinypgp-r-init'."
+ :type 'hook
+ :group 'tinypgp-remail-hook)
+
+(defcustom tinypgp-:r-get-list-hook nil
+ "*Hook run after the Levien list file is inserted into temporary buffer.
+This is your chance to check and modify the Remailer Levien list.
+See `tinypgp-r-get-list'."
+ :type 'hook
+ :group 'tinypgp-remail-hook)
+
+;;}}}
+;;{{{ setup: mode variables
+
+;;; .......................................................... &v-mode ...
+
+(defvar tinypgp-mode nil
+ "Minor mode variable.")
+
+(make-variable-buffer-local 'tinypgp-mode)
+
+(defvar tinypgp-:mode-name nil
+ "Minor mode name.
+This is not a user variable because the string is modified dynamically.")
+(make-variable-buffer-local 'tinypgp-:mode-name)
+
+(defcustom tinypgp-:mode-menu-name "TPgp"
+ "*Menu name for pgp mode."
+ :type 'string
+ :group 'tinypgp-mode-definitions)
+
+(defvar tinypgp-:mode-map nil
+ "Minor mode map.")
+
+(defvar tinypgp-:mode-menu nil
+ "Menu for mode.")
+
+(defcustom tinypgp-:mode-prefix-key "\C-c/"
+ "*Key map prefix."
+ :type '(string :tag "Key sequence")
+ :group 'tinypgp-mode-definitions)
+
+;;; ................................................ &v-key-management ...
+
+(defvar tinypgp-key-mode nil
+ "Minor mode variable.")
+(make-variable-buffer-local 'tinypgp-key-mode)
+
+(defconst tinypgp-:key-mode-name nil
+ "Minor mode name.
+This is not a user variable because the string is modified dynamically.")
+(make-variable-buffer-local 'tinypgp-:key-mode-name)
+
+(defvar tinypgp-:key-mode-map nil
+ "Minor mode map.")
+
+(defvar tinypgp-:key-mode-menu nil
+ "Menu for mode.")
+
+(defcustom tinypgp-:key-mode-menu-name "TPk"
+ "*Menu name for pgp key mode."
+ :type 'string
+ :group 'tinypgp-mode-definitions)
+
+(defcustom tinypgp-:key-mode-prefix-key "\C-c'"
+ "*Key map prefix."
+ :type 'string
+ :group 'tinypgp-mode-definitions)
+
+;;; .................................................. &v-summary-mode ...
+
+(defvar tinypgp-summary-mode nil
+ "Minor mode variable.")
+(make-variable-buffer-local 'tinypgp-summary-mode)
+
+(defconst tinypgp-:summary-mode-name nil
+ "Minor mode name. Changed dynamically.")
+(make-variable-buffer-local 'tinypgp-:summary-mode-name)
+
+(defvar tinypgp-:summary-mode-map nil
+ "Minor mode map. \\[tinypgp-:summary-mode-map].")
+
+(defvar tinypgp-:summary-mode-menu nil
+ "Menu for mode.")
+
+(defcustom tinypgp-:summary-mode-menu-name "TPsum"
+ "*Menu name for mode."
+ :type 'string
+ :group 'tinypgp-mode-definitions)
+
+(defcustom tinypgp-:summary-mode-prefix-key tinypgp-:mode-prefix-key
+ "*Key map prefix."
+ :type 'string
+ :group 'tinypgp-mode-definitions)
+
+;;; ................................................... &v-newnym-mode ...
+
+(defvar tinypgp-newnym-mode nil
+ "Minor mode variable.")
+(make-variable-buffer-local 'tinypgp-newnym-mode)
+
+(defvar tinypgp-:newnym-mode-name " Nym"
+ "Minor mode name.")
+(make-variable-buffer-local 'tinypgp-:newnym-mode-name)
+
+(defvar tinypgp-:newnym-mode-map nil
+ "Minor mode map. \\[tinypgp-:newnym-mode-map].")
+
+(defvar tinypgp-:newnym-mode-menu nil
+ "Menu for mode.")
+
+(defcustom tinypgp-:newnym-mode-menu-name "TPnym"
+ "*Menu name for mode."
+ :type 'string
+ :group 'tinypgp-mode-definitions)
+
+;; escreen.el uses same prefix; so change this if you use that package.
+;; Also the (enable-flow-control) takes over C-\ key.
+;;
+(defcustom tinypgp-:newnym-mode-prefix-key "\C-\\"
+ "*Key map prefix."
+ :type 'string
+ :group 'tinypgp-mode-definitions)
+
+;;; ................................................. &v-mode-remailer ...
+
+;; In HP the keys "/." are next to each other on the lower right
+;; near RET key
+;;
+(defcustom tinypgp-:mode-prefix-key-remailer "\C-c/.r"
+ "*Key map prefix for remailer commands."
+ :type 'string
+ :group 'tinypgp-mode-definitions)
+
+(defcustom tinypgp-:mode-prefix-key-newnym "\C-c/.n"
+ "*Keymap prefix for newnym type anon server commands.
+The default prefix key is C - c / . n; where p refers to (n)ewnym
+account; similar to famous nym.alias.net"
+ :type 'string
+ :group 'tinypgp-mode-definitions)
+
+(defcustom tinypgp-:mode-prefix-key-nymserver "\C-c/.y"
+ "*Keymap prefix for nymserver type anon server commands.
+The default prefix key is C - c / . y; where p refers to n(y)mserver
+account; similar to ex-anon.penet.fi.
+
+As of writing this, the only active remailer that resembles 'penet' is
+anon.nymserver.com"
+ :type 'string
+ :group 'tinypgp-mode-definitions)
+
+;;}}}
+;;{{{ setup: user config
+
+;;; ........................................................ &v-config ...
+;;; PGP executable settings
+
+(defvar tinypgp-:pgp-binary-interactive-option
+ (if (ti::win32-p)
+ nil
+ '(format "+comment=\"Processed by Emacs TinyPgp %s\""
+ (tinypgp-version-number)))
+ "*Extra encrypt option passed to PGP; use only \"+comment=\\\"\\\"\".
+This variable is EVALUATED; so it can contain lisp FORM.
+Must be nil in PCP platform.")
+
+;; See tinypgp-binary-header-field-fix
+
+(put 'tinypgp-:pgp-binary-interactive-option
+ 'comment
+ (format "Processed by %sEmacs TinyPgp %s"
+ (if (ti::win32-p) "WinNT " "")
+ (tinypgp-version-number)))
+
+(put 'tinypgp-:pgp-binary-interactive-option 'original
+ tinypgp-:pgp-binary-interactive-option)
+
+;;; ....................................................... &v-pgp-exe ...
+
+;; This variable also has property
+;; 'crypt The absolute path for 'crypt'.
+;;
+;; In variable tinypgp-:hash you find following properties
+;; Note: this is not in the hash table itself, but in symbol's plist,
+;; because hash table is resetted in regular intervals.
+;;
+;; 'secring-passwd
+;; 'secring The whole secring.pgp
+;;
+(defvar tinypgp-:pgp-binary nil
+ "Property list of PGP executables.
+The value of variable is always nil (not used). Property list values are:
+
+ 'version string, PGP version number
+
+ 'ppg2 symbol 'ok if found
+ 'ppg2-type symbol 'unix or 'win32
+
+ 'pgp5 symbol 'ok if found
+ 'ppg5-type symbol 'unix or 'win32
+
+ 'gpg
+ 'gpg-type symbol 'unix or 'win32
+
+ 'pgp string, pgp 2.6.x executable path
+
+ 'pgp{koves} string, pgp 5 executable paths
+
+ 'pgp-now symbol 'pgp2, 'pgp5, `gpg;
+ What pgp version is used currently
+ 'pgp-now-type 'unix 'win32
+ What kind of pgp version is in use: Unix/Cygwin or Win32")
+
+(defconst tinypgp-:pgp-binary-support-table
+ '( ;; will generate a file with the specified filename, containing <nnn>
+ ;; random bytes, to allow other programs to benefit from PGP's
+ ;; strong random-number generator.
+
+ (random "+makerandom=")
+
+ ;; This prints trust parameters
+
+ (trust "-km"))
+ "Support table of undocumented commands for your PGP binary.
+These commands are usually available in 2.6.3, but they just aren't
+include in PGP documentation.")
+
+(defcustom tinypgp-:pgp-binary-charset "noconv"
+ "*See PGP documentation.
+If you change this value, you have to reload tinypgp.el.
+
+Possible choices according to Pgp 2.6.3ia manual:
+
+ noconv No conversion [prefer this]
+ latin1 ISO 8859-1
+ koi8 Eastern countries e.g. Russia
+ cp850 ms-dos users in Europe"
+
+ :type '(choice
+ (const "noconv")
+ (const "latin1")
+ (const "koi8")
+ (const "cp850"))
+ :group 'tinypgp-pgp)
+
+(defvar tinypgp-:pgp-sh-exe
+ (let (path-win32
+ path-unix)
+ (when (ti::win32-p)
+ (or (setq path-win32 (executable-find "cmdproxy.exe"))
+ (error "\
+TinyPgp: `tinypgp-:pgp-sh-exe' - cmdproxy.exe not in exec-path?")))
+
+ (when (and (null (setq path-unix (executable-find "sh")))
+ (not (ti::win32-p)))
+ (error "\
+TinyPgp: `tinypgp-:pgp-sh-exe' - /bin/sh not in exec-path?"))
+ (list
+ (list 'unix (or path-unix "/bin/sh")
+ (list 'win32 (or path-win32 "cmdproxy.exe")))))
+
+ "*Shell executables. Use absolute path names for greater speed.
+
+'((win32 \"cmdproxy.exe\")
+ (unix \"/bin/sh\"))")
+
+;;; ......................................................... &v-files ...
+
+;;; Please do not add exension to these files!
+;;; --> PGP itself adds extension if it needs to create any additional files.
+;;;
+(defcustom tinypgp-:file-source
+ (if (ti::win32-p)
+ "c:/pgp-src"
+ (tinypgp-path "pgp-src"))
+ "*Source file fed to PGP. Region is written to this file.
+Must reside in C:/ root directory in PC platform due to total command
+length restrictions."
+ :type 'file
+ :group 'tinypgp-file)
+
+(defcustom tinypgp-:file-output
+ (if (ti::win32-p)
+ "c:/pgp-out"
+ (tinypgp-path "pgp-out"))
+ "*Output file produced by PGP when it gets `tinypgp-:file-source'.
+Must reside in C:/ root directory in PC platform."
+ :type 'file
+ :group 'tinypgp-file)
+
+(defcustom tinypgp-:file-password
+ (if (ti::win32-p)
+ "c:/pgp-pwd"
+ (tinypgp-path "pgp-pwd"))
+ "*File where to save the password only during calling PGP.
+The file is immediately deleted after PGP has finished.
+Must reside in C:/ root directory in PC platform due to total command
+length restrictions."
+ :type 'file
+ :group 'tinypgp-file)
+
+(defcustom tinypgp-:file-user-list
+ (if (ti::win32-p)
+ "c:/pgp-lst"
+ (tinypgp-path "pgp-lst"))
+ "*File where to store user list. (e.g. when encrypting).
+Must reside in C:/ root directory in PC platform due to total command
+length restrictions."
+ :type 'file
+ :group 'tinypgp-file)
+
+(defcustom tinypgp-:file-key-cache (tinypgp-path "tinypgp-cache")
+ "*File where to store key cache."
+ :type 'file
+ :group 'tinypgp-file)
+
+(defcustom tinypgp-:file-secring
+ (list
+ (cons 'pgp2 (tinypgp-path "secring.pgp"))
+ (cons 'pgp5 (tinypgp-path "secring.skr"))
+ (cons 'gpg (tinypgp-path "secring.gpg"
+ (list
+ (getenv "GNUPGHOME")
+ "~/.gnupg"))))
+ "*Secring path. If you change this you must reload TinyPgp.
+Format:
+ '((pgp2 . \"/absolute/path/secring.pgp\")
+ (pgp5 . \"/absolute/path/secring.skr\"))"
+ :type 'file
+ :group 'tinypgp-file)
+
+(defcustom tinypgp-:file-secring-encrypted (tinypgp-path "secring.enc")
+ "*Where to store the encrypted secring."
+ :type 'file
+ :group 'tinypgp-file)
+
+;;; .......................................................... &v-user ...
+
+(defcustom tinypgp-:user-primary
+ (or (car-safe (ti::mail-email-from-string user-mail-address))
+ (error
+ "\
+TinyPgp: tinypgp-:user-primary, Set user-mail-address to foo@site.com: '%s'"
+ user-mail-address))
+ "*Variable is used when you decrypt mail in buffer.
+
+o whatever your logical user id may
+ be currently, it is changed to this
+
+After decrypt has finished, the previous user identity is restored.
+This should provide smooth processing of incoming encrypted messages,
+while you may be doing something else."
+ :type 'string
+ :group 'tinypgp-mode)
+
+(defcustom tinypgp-:user-identity-table nil
+ "*When decrypting, this table is consulted for right active pgp user.
+
+Format:
+
+ '((\"key-hex-id\" \"key-id\")
+ ...)
+
+The encrypted PGP ascii armor is examined and if the found
+hex key-id match, then switch to key-i (usually mode descriptive
+email string) as a current PGP user.
+
+Example:
+
+ (setq tinypgp-:user-identity-table
+ '(
+ ;; My known public keyid firtsname.surname@site.com
+ (\"12345670\" \"firsname.surname\")
+
+ ;; If I receive pgp message from nymserver, then use my
+ ;; nymserver user id
+
+ (\"12345678\" \"an12345@anon.nymserver\")))"
+ :type '(repeat
+ (list
+ (string :tag "Key-id (8 hex)"
+ (string :tag "Clear text User id"))))
+ :group 'tinypgp-mode)
+
+;;; .......................................................... &v-misc ...
+
+(defcustom tinypgp-:register ?/
+ "*Register used to store the contents of PGP output."
+ :type 'character
+ :group 'tinypgp-mode)
+
+(defcustom tinypgp-:password-protection
+ (if (ti::win32-p)
+ nil
+ t)
+ "*If this variable is non-nil, use extra caution to protect the password.
+Set this to t only if you're in UNIX system where
+the processes commands can be seen by running 'ps'. This variable
+prohibits using PGP's -z flag and forces using file descriptors
+which cannot be snooped so easily.
+
+Set the variable to t only if your PGP understands env variable PGPPASSFD
+and that it can use many file descriptors.
+
+In default WinNT this variable must be nil."
+ :type 'boolean
+ :group 'tinypgp-pgp)
+
+(defcustom tinypgp-:password-keep-time (* 15 60) ;; 15 minutes default
+ "*How many seconds to keep password in memory before forgetting it.
+Set to nil, if you want to be asked password every time when you sign
+a message."
+ :type 'integer
+ :group 'tinypgp-mode)
+
+(defcustom tinypgp-:decrypt-arg-interpretation nil
+ "*How to interpret prefix argument to `tinypgp-decrypt-mail' (interacive only).
+This variable is used _only_ if function is called interactively.
+
+If non-nil
+ then meaning of the prefix arg passed to function
+ `tinypgp-decrypt-mail' is reversed.
+
+If 'preview
+ As in non-nil but also the the content of the decrypted message is
+ displayed in a separate buffer"
+ :type 'boolean
+ :group 'tinypgp-mode)
+
+(defcustom tinypgp-:finger-discard-by-regexp (user-login-name)
+ "*When fingering email addresses, discard those that match regexp.
+Please look at variable `tinypgp-:finger-discard-email-hook' for more."
+ :type 'regexp
+ :group 'tinypgp-mode)
+
+;;; ........................................................ &v-labels ...
+
+(defcustom tinypgp-:label-table
+ '((v ("v+" "v-"))
+ (s "s")
+ (d "d")
+ (e "e")
+ (pgp "pgp"))
+ "*Labels to attach to messages.
+There are two ways to use labels in your mail agent. Here is one style,
+where a general label is attached first and then the short flags. The advantage
+of this is that you can summarise a) all 'pgp' labels b) summarise
+'pgp' labels _and_ decrypted messages 'd'. See TinyRmail.el That adds
+new command to RMAIL to do this kind of label _and_ operation.
+
+ pgp,v+ PGP message, verified
+ pgp,v+,d PGP message, verified and decrypted
+ pgp,v-,d PGP message, verify failed and decrypted
+
+Or you could leave out the general label out and mark each pgp actions with
+
+ pgp+v
+ pgp+v, pgp-d
+ pgp-v, pgp-d
+
+Choose your style, but remember that shortest labels are the best.
+
+Format:
+ '((v (OK-VERIFY-LABEL NOK-VERIFY-LABEL)
+ (s SIGN-LABEL)
+ (d DECRYPT-LABEL
+ (e ENCRYPT-LABEL)
+ (pgp PGP-GENERAL-LABEL) << can be empty string or nil
+ ))"
+ :type '(list
+ (list (const v :tag "verify") (list string string))
+ (list (const s :tag "sign") string)
+ (list (const d :tag "decrypt") string)
+ (list (const e :tag "encrypt") string)
+ (list (const pgp :tag "pgp") string))
+ :group 'TinyPgp)
+
+;;; ................................................... &v-tables-misc ...
+
+(defcustom tinypgp-:pubring-table
+ (let* ((file2 (tinypgp-path "pubring.pgp"))
+ (file5 (tinypgp-path "pubring.pkr"))
+ (gpg (tinypgp-path "pubring.gpg"
+ (list
+ (getenv "GNUPGHOME")
+ "~/.gnupg"))))
+ (if (and (not (file-exists-p file2))
+ (not (file-exists-p file5))
+ (not (file-exists-p gpg)))
+ (error "\
+TinyPgp: tinypgp-:pubring-table, Please configure, cannot auto-install.
+File pubring.pgp or pubring.pkr couldn't be found. Check PGPPATH."))
+
+ (list
+ (list 'pgp2 (if file2
+ (list (list "default" file2 "-"))))
+ (list 'pgp5 (if file5
+ (list (list "default" file5 "-"))))
+ (list 'gpg (if gpg
+ (list (list "default" gpg "-"))))))
+ "*Pubrings, alias names and mode line indicators.
+
+Description:
+
+ Possible pubrings user can select. Make sure your primary
+ pubring is first in the list and that the others come
+ in order of importance. The last one is least unimportant
+ keyring. When searching for key, this is the search order.
+
+To remember:
+
+ Your primary pubring must be first.
+
+ Your merged keyring must be last. When you're encrypting to
+ multiple people, pgp needs one big pubring which contains
+ all keys for those people that your encrypting the message. When
+ program sees that you have multiple CC, BCC or To recipients,
+ it automatically sets the active pubring to the last one in this
+ list.
+
+Tip:
+
+ Please use some common convention when creating new pubring, e.g.
+ use name \"pr-\" to denote pubring and add the descriptor after it.
+ pr-elisp.pgp ;; my pgp keys for my elisp mates
+ pr-news.pgp ;; occasional users from newsgroups
+ pr-pgpnews.pgp ;; the pgp newsgroup people pubring
+ ...
+ pr-temp.pgp ;; temporary storage that I may discard any time
+ pr-all.pgp ;; Merged, pubring for all. maybe keyserver ring.
+
+Format:
+
+ '((BACKEND
+ (COMPLETION-STRING PUBRING-FILE MODE-STRING) (COMP PUB-F MODE-S)
+ ..)
+ (BACKEND
+ (COMPLETION-STRING PUBRING-FILE MODE-STRING) (COMP PUB-F MODE-S)
+ ..))
+
+ BACKEND is either 'pgp2 or 'pgp5
+
+ COMPLETION-STRING is 'nice name' for the pubring.
+
+ PUBRING-FILE is the absolute filename where pubring resides.
+
+ MODE-STRING is displayed in the mode line to show which pubring
+ you have active. Please choose some non-word character to give
+ you enough visible hint which pubring you use currently. Eg.
+
+ - default
+ = secondary
+ * special, whole keyserver pubring."
+
+ :type '(repeat
+ (list
+ (string :tag "Pubring completion name")
+ (file :tag "Pubring filename")
+ (string :tag "String, One character modeline indicator")))
+ :group 'tinypgp-mode)
+
+(defcustom tinypgp-:header-sign-table
+ ;; Always use these fields
+ '(("@" ("subject" "reply-to" )))
+ "*List of headers that should be signed along with the message.
+
+Format:
+
+ '((REGEXP '(HEADER-NAME-STRING HEADER-NAME-STRING ..) [NO-XPGP-MODE])
+ ...)
+
+Example:
+
+Definition of fields:
+
+REGEXP If matches To-field or Newsgroup-field, the HEADER-LIST is used.
+ You should not sign reply-to field if the destination
+ address changes the field contents. Many times mailing
+ list do this.
+HEADER-LIST If it is empty, no headers are included in signing.
+NO-XPGP-MODE This field is optional. If it is non-nil, then when you
+ do signing, this flag is consulted. If the to-field matches
+ the no X-Pgp signing is done, no matter what the
+ `tinypgp-:xpgp-signing-mode' says currently. In some cases
+ you can't send X-pgp signed messages to the destination
+ address.
+
+References:
+
+ `tinypgp-:xpgp-signing-mode'"
+ :type '(repeat
+ (list
+ (regexp :tag "Regexp matching To/Newsgroups")
+ (repeat (string :tag "Header field to be signed"))))
+ :group 'tinypgp-header)
+
+(defcustom tinypgp-:keyserver-mail-table
+ '(
+ ;; official
+ ("pgp" "pgp-public-keys@keys.pgp.net")
+
+ ;; 1998-03 http://www.prairienet.org/~jalicqui/pgpfaq.txt
+ ("uk" "pgp-public-keys@keys.uk.pgp.net")
+ ("de" "pgp-public-keys@keys.de.pgp.net")
+ ("no" "pgp-public-keys@keys.no.pgp.net")
+ ("us" "pgp-public-keys@keys.us.pgp.net")
+ ("nl" "pgp-public-keys@keys.nl.pgp.net")
+ ("fi" "pgp-public-keys@keys.fi.pgp.net")
+ ("es" "pgp-public-keys@keys.es.pgp.net")
+ ("hr" "pgp-public-keys@keys.hr.pgp.net")
+ ("tw" "pgp-public-keys@keys.tw.pgp.net")
+ ("pl" "pgp-public-keys@keys.pl.pgp.net")
+ ("au" "pgp-public-keys@keys.au.pgp.net"))
+ "*List of available Email keyservers.
+See PGP faq \"8.2. What public key servers...\" for updated list.
+http://www.pgp.net/mail-help/email-help-en.html
+
+Format:
+ '((COMPLETION-NAME EMAIL-ADDRESS))
+ (COMP-N EMAIL-A)
+ ..)"
+ :link '(url-link :tag "PGP keyservers"
+ "http://www.pgp.net/mail-help/email-help-en.html")
+ :type '(repeat (list string string))
+ :group 'tinypgp-interface)
+
+;; http://geronimo.uit.no/pgp/servruit.eng.html
+;; http://www-swiss.ai.mit.edu/~bal/bal-home.html
+;;
+(defcustom tinypgp-:keyserver-http-table
+ '(
+
+ ;; Maintainer: <grobi@uni-paderborn.de>
+ ;; http://math-www.uni-paderborn.de/pgp/
+
+ ("wwwkeys.pgp.net:11371"
+ "/pks/lookup?op=get&search=%s")
+
+ ;; Hm, this is nowadays PGP 5 keyserver
+
+ ("pgp.ai.mit.edu"
+ "/htbin/pks-extract-key.pl?op=get&search=%s")
+
+ ("goliat.upc.es:1137" ;; <marc@mit.edu>
+ "/pks/lookup?op=index&search=%s"))
+ "*List of available http keyservers.
+Be sure that you put your nearest/fastest keyserver first in the list.
+It is offered as default connection.
+
+Format:
+
+ '((KEYSERVER COMMAND)
+ (KEYSERVER COMMAND)
+ ...)"
+ :type '(repeat (list string string))
+ :group 'tinypgp-interface)
+
+;;; ................................................... &v-auto-action ...
+
+(defcustom tinypgp-:sign-mail-p-function nil
+ "*Function to decide if message should be signed.
+Auto signing mode is active when function is called.
+See `tinypgp-sign-mail-auto-mode'.
+
+Function return values:
+
+ t Yes, sign this mail
+ nil Ignore signing for this message
+
+Example:
+
+ ;; Do not sign messages that are sent to my fellow
+ ;; workers at domain 'foo'. Ie. sign messages to the outside
+ ;; world.
+
+ (setq tinypgp-:sign-mail-p-function
+ '(lambda ()
+ (not (string-match \"foo\" (or (mail-fetch-field \"to\") \"\")))))"
+ :type 'sexp
+ :group 'tinypgp-mode)
+
+(defcustom tinypgp-:auto-action-encrypt-regexp nil
+ "*Bulk encryption regexp to match all members in To, CC, BCC.
+This is special auto action variable and it is used only if
+there is more than _one_ address where you're sending a message.
+Typical situation: You want to send encrypted mail to Cc'd
+members who also have pgp.
+
+The regexp s matched individually against each member in To, Cc and Bcc
+fields. If regexp didn't match for each member, then the auto encryption
+is not engaged.
+
+You must know for sure who have pgp and those people's keys must
+be stored in big pubring 'all'. (see `tinypgp-:pubring-table')"
+ :type 'regexp
+ :group 'tinypgp-mode)
+
+(defcustom tinypgp-:auto-action-table nil
+ "*Automatic encrypt and sign control table.
+When there is only _one_ email destination (no CC, BCC and one entry in To)
+
+Alternative way, see also:
+ `tinypgp-:bbdb-field'
+ Note: `tinypgp-:auto-action-table' overrides BBDB
+
+Format:
+
+ '((EVAL-OR-REGEXP [SIGN-KEY-ID] [ENCRYPT] [MIME] [XPGP] [KEYRING])
+ ..)
+
+Example:
+
+ ;; To automatically send PGP/MIME encrypted messages to
+ ;; foo and bar, signed by you:
+
+ '((\"foo@bar.com\" 'my-pgp-key-id@site.com 'encrypt 'mime)
+ (\"bar@bar.com\" 'my-pgp-key-id@site.com 'encrypt 'mime))
+
+Definition of fields:
+
+ EVAL-OR-REGEXP: string or lisp list
+ Regexp means matching on To field contents.
+ *Note* To field must have address including @ character otherwise no
+ comparison is done.
+
+ If you use EVAL, then you can refer to variable 'to-field' in the
+ form that builds up eval. You can also search the buffer for specific
+ strings before determining if the actions defined should be
+ engaged.
+
+ SIGN-KEY-ID: string or symbol
+ If this contains string key-id, that is used to sign the message. If
+ value is SYMBOL instead of string _and_ the ENCRYPT is non-nil, then the
+ result is 'one pass' encrypt and sign and not a separate encrypt + sign.
+
+ ENCRYPT: boolean
+ If non-nil, the message is encrypted according to TO field content.
+ See also `tinypgp-:email-substitution-table' if you want to encrypt
+ using some other key.
+
+ MIME: symbol
+ nil use Regular pgp
+ 'mime use PGP/MIME interface with TM or SEMI if mime interface is present.
+
+ XPGP: boolean
+ If non-nil means signing by using X-Pgp headers;
+ if this is nil, then use regular signing. This overrides any existing mode.
+
+ KEYRING: string; absolute filename
+ tells which file to use as pubring when doing the encryption/signing.
+ It defaults to current keyring in use.
+
+ The following example demonstrates EVAL-use of this variable, there are
+ three entries in this list.
+
+ o If newsgroup field is found from the message and
+ it matches to pgp groups, then sign every mail.
+ o if to-field matches person foo@site.com, then the mail
+ is encrypted and signed. (in this order)
+ o If message is sent somewhere else than my current domain,
+ sign it.
+
+ (setq tinypgp-:auto-action-table
+ '(
+ ;; elt 1
+ ((let ((grp (mail-fetch-field \"Newsgroups\")))
+ ((string-match \"pgp\" (or grp \"\"))))
+ \"me@foo\")
+
+ ;; elt 2
+ (\"foo@site.com\" \"me@foo\" 'enc)
+
+ ;; elt 3
+ ((not (string-match \"@mysite.com\" to-field))
+ \"me@foo\")))
+
+Note 1:
+
+ If message _already_ contains some Pgp data (signed; encrypted)
+ this variable is not used, because it's supposed that the user is
+ controlling the layout of PGP message.
+
+Note 2:
+
+ This variable is used only if you send message to _one_
+ destination. If any CC or BCC is found from the message or if To:
+ field contains comma, then this variable is not used.
+
+Note 3:
+
+ All mode settings are overridden. Toggling modes on/off do not
+ affect auto-action command.
+
+Note 4:
+
+ The order of regexp elements is important: first one matched is used
+ and the rest of the list is forgotten."
+
+ :type '(repeat
+ (list
+ (sexp :tag "To field regexp")
+ (boolean :tag "Sign flag")
+ (boolean :tag "X-pgp flag")
+ (file :tag "Keyring file used:")))
+ :group 'tinypgp-mode)
+
+;;}}}
+;;{{{ setup: header
+
+;;; ........................................................ &v-header ...
+
+(defcustom tinypgp-:xpgp-signing-mode nil
+ "*Non-nil if X-Pgp signing is used.
+
+References:
+ `tinypgp-:header-sign-table' ,this overrides `tinypgp-:xpgp-signing-mode'
+
+See \\[tinypgp-xpgp-header-mode-toggle]"
+ :type 'boolean
+ :group 'tinypgp-header)
+
+(defcustom tinypgp-:xpgp-user-info
+ '(format "Comment= \"Processed by Emacs TinyPgp.el %s\""
+ (tinypgp-version-number))
+ "*Additional information added to X-Pgp header.
+Set this variable to STRING-OR-EVAL-FORM that you wish to include
+in X-Pgp. The correct keywords are defined in X-Pgp standard.
+ftp://cs.uta.fi/pub/ssjaaa/pgp-xhd.html#additional_keywords:_telling_how_to
+
+Notes:
+
+ DO NOT put newline code at the end of string.
+ Put 2 spaces before each statement line (except first line).
+ Every keyword must end to semicolon!
+ Enclose strings in double quotes.
+
+Full Example:
+
+ (setq tinypgp-:xpgp-user-info
+ '(concat
+ \" Fingerprint=\\\"12 92 9C E4 60 DF 62 CD FC AD 18 47 9A 74 E7 D1\\\";\\n\"
+ \" Length=1024; Id=0x17D57681;\"
+ \" Access-type=Finger; Address=foo@site.com;\\n\"
+ (format \" Comment=\\\"Processed by Emacs TinyPgp.el %s\\\";\"
+ (tinypgp-version-number))))
+
+Recommended Example (only essential keywords):
+
+ (setq tinypgp-:xpgp-user-info
+ '(concat
+ \" Id=0x17D57681; Access-type=Finger; Address=foo@site.com;\\n\"
+ (format \" Comment=\\\"Processed by Emacs TinyPgp.el %s\\\";\"
+ (tinypgp-version-number))))"
+ :type '(sexp :tag "String of Form")
+ :group 'tinypgp-header)
+
+;;}}}
+;;{{{ setup: remail private
+
+;;; ....................................................... &vp-remail ...
+;;; Private
+
+(defvar tinypgp-:r-levien-table nil
+ "Updated by program. List of remailers and their properties.")
+
+(defvar tinypgp-:r-host-table nil
+ "Updated by program. List of accepted remailers and their properties.")
+
+(defvar tinypgp-:r-history nil
+ "History.")
+
+;; Raph's list is not always right. This variable is for experts only
+;; and you should not touch it if you don't what you're doing.
+;;
+(defconst tinypgp-:r-control-list nil
+;;; '(("replay" ("ek")) ;does no support this
+;;; ("dustbin" nil ("post")) ;supports this
+;;; ("haystack" nil ("post")) ;supports this
+;;; )
+ "List of remailers and additional property control.
+
+Format:
+
+ '((REMAILER (REMOVE-PLIST) (ADD-PLIST))
+ (REMAILER ..))
+
+ For each remailer a property is either removed or added.
+
+Example:
+
+ (setq tinypgp-:r-control-list
+ ;; dustbin supported one day the property post.
+ '((\"dustbin\" nil (\"post\"))))")
+
+(defvar tinypgp-:r-mode-indication-flag nil
+ "Non-nil means that current message should be treated with caution.
+Eg. if you encrypt the message, there will be no extra
+PGP 'Comment' keywords included that may reveal your identity.")
+
+(make-variable-buffer-local 'tinypgp-:r-mode-indication-flag)
+(put 'tinypgp-:r-mode-indication-flag 'permanent-local t)
+
+;;}}}
+;;{{{ setup: remail user config
+
+;;; ................................................... &v-remail-hook ...
+
+(defcustom tinypgp-:r-post-before-hook '(tinypgp-r-post-before-default)
+ "*Things to do before converting message to anonymous format.
+Turn off/exit all minor modes that may interfere the process."
+ :type 'hook
+ :group 'tinypgp-remail)
+
+(defcustom tinypgp-:r-reply-block-basic-hook nil
+ "*Hook that is run after reply block is added."
+ :type 'hook
+ :group 'tinypgp-remail-hook)
+
+;;; ........................................................ &v-remail ...
+;;; User config
+
+(defcustom tinypgp-:r-list-file
+ (let ((file "~/.remailer.lst"))
+
+ ;; Suppose we have low quota account; use .gz file if it exists.
+ ;; the regular file is not checked here: it is checked when
+ ;; user uses the remail functions.
+
+ (if (file-exists-p (concat file ".gz"))
+ (concat file ".gz")
+ file))
+
+ "*Remailer list file. See `tinypgp-r-update-remailer-list'."
+ :type 'file
+ :group 'tinypgp-remail)
+
+(defcustom tinypgp-:r-user-mail-address user-mail-address
+ "*Email address of your reply block.
+This account may be different from your regular email address."
+ :type 'string
+ :group 'tinypgp-remail)
+
+;; 1998-01 #finger also rlist@anon.lcs.mit.edu
+(defcustom tinypgp-:r-list-finger "remailer-list@kiwi.cs.berkeley.edu"
+ "*Finger address where to get updated remailer list."
+ :type 'string
+ :group 'tinypgp-remail)
+
+(defcustom tinypgp-:r-mail2news-remailer "replay"
+ "*Remailer alias through which you want to send you Usenet posts.
+Variable is not a email address, but the remailer alias name according
+to Levien remailer list. This variable can contain lisp FORM.
+
+Must support properties: POST PGP HASH CUTMARKS."
+ :type 'string
+ :group 'tinypgp-remail)
+
+(defcustom tinypgp-:r-chain nil
+ "*Remailer chain table. List of remailer.
+Only remailers that at least have properties PGP HASH EK are allowed.
+
+Format:
+
+ '((COMPLETION-NAME
+ [vector or (lisp-form-to-evaluate; must return vector)
+ (REMAILER
+ latent-time this is optional
+ encrypt-key) this is optional
+ (REMAILER
+ ...)
+ ])
+ ...)
+
+Examples:
+
+ (defconst tinypgp-:r-chain
+ '((\"1-way\" [(\"replay\" \"+0:05r\" \"ZepHyR1x\")])
+ ;; Select random path
+ (\"hide\" (progn (shuffle-vector [(\"replay\") (\"dustbin\")])))
+ ;; Use some reliable remailer, but hide identity better
+ (\"milkyway\" [\"replay\" \"replay\" \"replay\"])))"
+ :type 'sexp
+ :group 'tinypgp-remail)
+
+(defcustom tinypgp-:r-subject-table
+ '(" dummy"
+ " This is a test"
+ " ignore this message"
+ " Regarding your previous message"
+ " As for the www and html..."
+ " Re: about the last subject..."
+ " Re: Programming langueges.. ")
+ "*List of dummy Subject sentences that are used in your Remailer message.
+The subject should be such that it doesn't draw your sysadm's attention."
+ :type '(repeat (list string))
+ :group 'tinypgp-remail)
+
+(defcustom tinypgp-:r-reply-block-table nil
+ "*Correct reply block for each remailer.
+Suggested filename could be ~/.r-dustbin for dustbin remailer.
+You can place anything after the last -----END PGP MESSAGE-----
+because the reply block is only read from `point-min' to this
+tag line and rest of the file is ignored.
+
+File format:
+
+ ::
+ Request-Remailing-To: remailer@replay.com
+ Latent-Time: +0:00
+
+ ::
+ Encrypted: PGP
+
+ -----BEGIN PGP MESSAGE-----
+ Version: 2.6.3ia
+
+ hIkDPRWysueuweUBA+jLifdDpkCxcUYA
+ ...
+ -----END PGP MESSAGE-----
+
+ #
+ # this is comment
+ # this is another comment
+ # end of file
+
+Variable format:
+
+'((REMAILER-ALIAS FILE)
+ (R F)
+ ..
+ )"
+ :type '(repeat
+ (list
+ (string :tag "Remailer alias")
+ (file :tag "Reply block File")))
+ :group 'tinypgp-remail)
+
+(defcustom tinypgp-:r-header-keep-list '("Gcc" "Fcc")
+ "*In addition to strict RFC headers; keep these headers too.
+When you compose anon post, all the unnecessary headers will be
+killed so that your identity is not revealed by accident.
+This is list f headers that are preserved in addition to RFC headers.
+Please do not include colon or spaces.
+
+Format:
+ '(\"hdr1\" \"hdr2\" ..)"
+ :type '(repeat string)
+ :group 'tinypgp-remail)
+
+;;; ........................................................ &v-newnym ...
+
+(defcustom tinypgp-:r-newnym-stamp-file-prefix
+ (tinypgp-path "~/.emacs.tinypgp-stamp.")
+ "*Newnym type accounts expire in 120 days.
+This file is touched every time user sends a newnym account
+request or remail. It is compared to current sate and a warning
+is issued after 100 days if user hasn't used the account.
+
+The filenames are manfgled to protect reading the Newnym server and
+account information from them.
+
+User must send `request' message to the account to keep it alive."
+ :type 'file
+ :group 'tinypgp-newnym)
+
+(defcustom tinypgp-:r-newnym-default-account-table nil
+ "*List of newnym servers and accounts you have.
+The active default server and login information are stored
+into properties 'default-server and 'default-account. If these properties
+are nil, then no default values are set.
+
+Format:
+ '((COMPLETION-NAME NYM-SERVER NYM-ACCOUNT MODELINE-CHAR)
+ (.. .. ..))
+ Important: NYM-ACCOUNT must not have @site.suffix.com; only the account name
+
+Example:
+ '((\"weasel\" \"weasel\" \"my-weasel-login-name\" \"W\")
+ (\"nym\" \"nym\" \"my-nym-login-name\" \"N\")
+ (\"nym2\" \"nym\" \"my-nym-login-name2\" \"N2\")
+ (\"efga\" \"efga\" \"my-efga-login-name\" \"E\"))"
+ :type '(repeat (list string string string))
+ :group 'tinypgp-newnym)
+
+(defcustom tinypgp-:r-newnym-mail2news-address
+ "mail2news_nospam@anon.lcs.mit.edu"
+ "*Email address through which the newsgroup posts are sent.
+This variable is evaled to get the email address.
+
+Aug 13 1997 there was a list of gateways available at
+http://students.cs.byu.edu/~don/mail2news.html and the list below
+is copied from there.
+
+Note:
+
+ The default value is mail2news_nospam@anon.lcs.mit.edu which creates
+ headers like this:
+
+ From: Bogus Name <Use-Author-Address-Header@[127.1]>
+ Author-Address: Name <AT> nym <DOT> alias <DOT> net
+
+ If you would use regular mail2news_nospam@anon.lcs.mit.edu; then your
+ headers were as they would. But expect to get UCE mail through your newnym
+ account as soon as you post to usenet.
+
+ From: Sam Bogus <name@nym.alias.net> ????
+
+Sites that scan headers:
+
+ mail2news@anon.lcs.mit.edu CONFIRMED Jun97
+ mail2news@news.wsnet.com NOT FUNCTIONAL
+
+Sites that parse the email address:
+
+ group.name.usenet@alpha.jpunix.com DO NOT USE
+ m2n-YYYYMMDD-group.name+group.name@alpha.jpunix.com CONFIRMED Aug97
+ post-group.name@newspost.zippo.com CONFIRMED Mar97
+ group.name@news.cs.dal.ca PROBABLY NOT FUNCTIONAL
+ no.group.name@news.uninett.no
+ (uninett only reported to carry norwegian news) CONFIRMED Jul96
+ group.name@news.uni-stuttgart.de CONFIRMED Mar97
+ mail2news-YYYYMMDD-group.name+group.name@anon.lcs.mit.edu CONFIRMED Jul97
+ group.name@myriad.alias.net CONFIRMED Jun97"
+ :type 'string
+ :group 'tinypgp-newnym)
+
+(defcustom tinypgp-:r-newnym-help-file nil
+ "*Remailer 'newnym' help file."
+ :type 'file
+ :group 'tinypgp-newnym)
+
+(defconst tinypgp-:newnym-cmd-table
+ '(("acksend"
+ "per-message: automatic acknowledgment of successfully remailed message."
+ "Default: -acksend")
+ ("signsend"
+ "per-message: automatic PGP signing of any outgoing mail."
+ "Default: -signsend")
+ ("cryptrecv"
+ "automatic encryption with your nym's public key."
+ "Default: +cryptrecv")
+ ("fixedsize"
+ "all messages padded to exactly the same size (roughly 10K)"
+ "Default: -fixedsize")
+ ("disable"
+ "4 Megabytes per day disables account, notified if this happens."
+ "Default: -disable. Re-enable account with -disable.")
+ ("fingerkey"
+ "Allow people to finger <yournym@weasel.owl.de> for you PGP key."
+ "Default: -fingerkey")
+ ("name"
+ "\
+Describe text of nym >> From: YOUR-NAME-DESC-HERE <yournym@weasel.owl.de>"
+ "Default: name=\"\". Example: name=\"Your Alias Name\"")
+ ("create"
+ "\
+Create fails if a nym exists. Use Create? for updating nym. (sign message)."
+ "Example: create/create?")
+ ("delete"
+ "Deletes your alias and wipes your reply block. Acknowledged."
+ "<no other options>")
+ ("nobcc"
+ "\
+Counce bcc, only To, Cc, Resent-To, or Resent-Cc accepted. (SPAM protect)"
+ "Default: -nobcc"))
+ "Newnym command table.
+Format:
+ '((COMMAND DESC cmd-example-or-default-value)
+ (COMMAND DESC cmd-example-or-default-value)
+ ..)")
+
+;;; ....................................................... &vp-remail ...
+;;; Private variables.
+
+(defvar tinypgp-:r-reply-block-cache nil
+ "Reply block cache.
+
+Format:
+ '((BUFFER PGP-BEG PGP-END)
+ (B P-B P-E)
+ )")
+
+;;}}}
+;;{{{ setup: Nymserver
+
+;;; ....................................................... &nymserver ...
+
+(defcustom tinypgp-:nymserver-request-encrypt nil
+ "*To send every command to 'nymserver' account in encrypted format.
+NOTE: You must have inserted the Server's PGP key into the keyring."
+ :type 'boolean
+ :group 'tinypgp-nymserver)
+
+;;; Currently this is not user variable
+;;; There is only one nymserver type remailer currently active.
+;;;
+(defconst tinypgp-:nymserver-table
+ '(("nymserver"
+ tinypgp-nymserver-create-1 "request@anon.nymserver.com"
+ "anon@anon.nymserver.com"
+ 3))
+ "Table of 'nymserver' type services.
+Format:
+
+ '((SERVER-ALIAS-STRING
+ ACCOUNT-CREATE-FUNCTION
+ ACCOUNT-CREATE-EMAIL-ADDRESS
+ SERVER-EMAIL-POST-TO
+ NEWSGROUP-POST-COUNT-LIMIT)
+ (S A A S N )
+ ..)")
+
+;;; When you receive account creation confirmation; update
+;;; this variable immediately.
+;;;
+(defcustom tinypgp-:nymserver-account-table nil
+ "*Your nymserver account information table.
+
+'((SERVER-ALIAS-STRING
+ ACCOUNT-EMAIL
+ ACCOUNT-PASSWORD
+ [ACCOUNT-NICKNAME-STRING | nil ]
+ [FROM-ADDRESS | nil ]
+ [HELP-FILE | nil ]))
+
+You get the slots ACCOUNT-EMAIL, ACCOUNT-PASSWORD when you order an
+account from the server. The ACCOUNT-NICKNAME-STRING can be nil,
+because nymserver also controls your Nickname. This overrides
+the server's value.
+
+FROM-ADDRESS
+
+ is important. When you ordered account from nymserver, it
+ allocates only your current address and handles only messages sent from
+ that address.
+
+ aa@a.com --> you ordered anon account here.
+ bb@b.com you have another normal account here
+ cc@c.com you have yet another normal account here
+
+ Suppose you want to post from account bb@b.com as anon. Can't
+ do that because nymserver expects you to be only in aa@a.com, in the
+ site where you initially ordered the anon account.
+
+ Now, if you set FROM-ADDRESS to aa@a.com, then the From-field is inserted
+ into the message pretending that the mail is coming from aa@a.com and
+ now you can use your Anon account from different sites.
+
+HELP-FILE
+
+ If the E-mail message that contained the server manual which explains
+ all its features. Store the mail to this file;
+
+Example:
+
+ (defconst tinypgp-:nymserver-account-table
+ '((\"nymserver\"
+ \"an1111@anon.nymserver.com\"
+ \"qF8asdd\"
+ \"\"
+ \"my.name@address.com\"
+ \"~/txt/nymserver.hlp\"
+ )))"
+ :type '(list
+ (const "nymserver" :tag "Server")
+ (string :tag "Account email")
+ (string :tag "Account ppassword")
+
+ ;; optional
+ ;;
+ (string :tag "nickname")
+ (string :tag "From address")
+ (file :tag "Help file"))
+ :group 'tinypgp-nymserver)
+
+;;}}}
+
+;;{{{ setup: private
+
+;;; ...................................................... &vp-private ...
+
+(defvar tinypgp-:timer-elt nil
+ "Timer process that e.g. expires passwords.")
+
+(defvar tinypgp-:key-cache nil
+ "Cache: '((key-id, pubring, public-key) (...)).")
+
+(defvar tinypgp-:key-cache-last nil
+ "Last accessed 'get element in cache. See function `tinypgp-key-cache'.
+ (ORIGINAL-EMAIL (CACHE-KEY PUBRING ..))")
+
+(defvar tinypgp-:return-value nil
+ "Common return value between functions.
+This variable is used as a signal to TinyPgp when it has called
+some user function or hook. The usage is explained in
+the functions that use it. It will contain properties too.")
+
+(defvar tinypgp-:buffer-tmp-shell "*tinypgp-shell-tmp*"
+ "Temporary buffer.")
+
+(defvar tinypgp-:buffer-tmp-finger " *tinypgp-finger-tmp*"
+ "Temporary buffer.")
+
+(defvar tinypgp-:buffer-tmp-copy " *tinypgp-copy-tmp*"
+ "Temporary buffer.")
+
+(defvar tinypgp-:buffer-tmp-article " *tinypgp-article*"
+ "Temporary buffer.
+If user doesn't want to replace the contents of the
+buffer in mail-like modes, then the content is copied to
+this buffers first, so that any text properties or overlays can beremoved
+without invoking edit mode.")
+
+(defvar tinypgp-:buffer-tmp-http " *tinypgp-http-tmp*"
+ "Temporary buffer.")
+
+(defvar tinypgp-:buffer-tmp-kring " *tinypgp-kring-tmp*"
+ "Temporary buffer.")
+
+(defvar tinypgp-:buffer-tmp-show " *tinypgp-show-tmp*"
+ "Temporary buffer.")
+
+(defvar tinypgp-:buffer-tmp-mail " *tinypgp-mail-tmp*"
+ "Temporary mail buffer.")
+
+(defvar tinypgp-:buffer-tmp " *tinypgp-tmp*"
+ "Temporary buffer.")
+
+(defvar tinypgp-:buffer-newnym "*mail-newnym*"
+ "Newnym remailer mail buffer.")
+
+(defvar tinypgp-:buffer-comint "tinypgp-comint"
+ "Interactive comint buffer to talk with PGP.
+This buffer name will automatically have stars over the name.")
+
+(defvar tinypgp-:buffer-view "*tinypgp-view*"
+ "Interactive comint buffer to talk with PGP.
+This buffer name will automatically have stars over the name.")
+
+(defvar tinypgp-:original-buffer nil
+ "Original buffer storage. Set in macro `tinypgp-run-in-tmp-buffer'.")
+
+(defvar tinypgp-:pgp-email-list nil
+ "List of email addresses in ~/.emailrc.")
+
+(defvar tinypgp-:pgp-email-abbrev-list nil
+ "List of abbrevs and their expansions: '((\"abb\" . \"expa\") ..).")
+
+(defvar tinypgp-:pgp-email-list-completions nil
+ "Email assoc menu for completion. '((\"a@b.com\" . 1) ..)
+This variable is initialised to the contents of your
+~/.mailrc file.")
+
+(defvar tinypgp-:sign-data nil
+ "Stored sign information for current message.
+Used for checking message tampering afterwards.
+
+Format:
+ number ,message body length in characters.")
+(make-variable-buffer-local 'tinypgp-:sign-data)
+(put 'tinypgp-:sign-data 'permanent-local t)
+
+;;; ....................................................... &vp-colors ...
+
+(defvar tinypgp-:face-mark 'highlight
+ "The face for text marking.")
+
+(defvar tinypgp-:face-error 'bold
+ "The face for pointing out errors.")
+
+;;; ...................................................... &vp-history ...
+
+(defvar tinypgp-:history-key-info nil
+ "History of used key info strings.")
+
+(defvar tinypgp-:history-email nil
+ "User email history.")
+
+(defvar tinypgp-:history-newnym-account nil
+ "Nym account name history.")
+
+(defvar tinypgp-:history-r-chain nil
+ "Remailer chain selection history.")
+
+(defvar tinypgp-:history-r-chain nil
+ "Remailer chain selection history.")
+
+(defvar tinypgp-:history-http-keyserver nil
+ "History of used key servers.")
+
+(defvar tinypgp-:history-http-keyserver-string nil
+ "History of used key server search strings.")
+
+;;; ..................................................... &vp-commands ...
+
+(defconst tinypgp-:pgp-command-options
+ (let* ((charset (ti::string-remove-whitespace
+ (if (ti::nil-p tinypgp-:pgp-binary-charset)
+ "noconv"
+ tinypgp-:pgp-binary-charset)))
+ (secring (cdr (assq 'pgp2 tinypgp-:file-secring))))
+ (concat
+
+ ;; These options are best to left out from the commands in WinNT.
+ ;; The maximum command line parameter length is 255 or was it 180 ?
+ ;;
+ ;; The PGP compress ratio is like 1,6M text --> 600k
+
+ (if (ti::win32-p)
+ ""
+ (concat
+ (if secring
+ (concat " +secring=" secring)
+ "")
+ " "
+ " +nomanual"
+ " +showpass=off" ;There is no cmd line arg
+ " +encrypttoself=off"
+
+ " +verbose=1"
+ " +language=en" ;don't use language modules
+ " +armorlines=0" ;No separate UU chunks
+ " +charset=" charset
+ " "))
+ ""))
+ "Default 2.6.x options for every pgp command.
+Notice that in PC platform there may be restrictions.")
+
+;; #todo: tinypgp-:pgp-command-options5 for Unix?
+
+(defconst tinypgp-:pgp-command-options5
+ (let* ((charset (ti::string-remove-whitespace
+ (if (ti::nil-p tinypgp-:pgp-binary-charset)
+ "noconv"
+ tinypgp-:pgp-binary-charset))))
+;;; (secring (cdr (assq 'pgp5 tinypgp-:file-secring)))
+
+ (if (ti::win32-p)
+ ""
+ (concat
+ " +headers"
+ " +encrypttoself=off "
+ " +compress=on "
+ " +language=en " ;don't use language modules
+ " +armorlines=0 " ;No separate UU chunks
+
+ ;; " WarnOnMixRSADiffieHellman=on "
+ ;; " WarnOnRSARecipAndNonRSASigner=on "
+
+ ;; batchmode; You must not add this to the switches, because
+ ;; then PGP 5.x won't ask for pass phrase, but expects to get
+ ;; it from PGPPASSFD. We don't use PGPASSFD in Unix, but the expect.el
+ ;; will feed the pass phrase to the prompt.
+ ;;
+ ;; " +batchmode=1"
+ ;;
+ ;; " -v " ;; Verbose mode
+
+ " +charset=" charset
+ " ")))
+ "Default 5.x options for every pgp command.
+Notice that in PC platform there may be restrictions.")
+
+(defconst tinypgp-:gpg-command-table
+ (let* ((common2 tinypgp-:pgp-command-options) ;Without batch mode
+ (common
+ (concat
+ common2
+ " --batch "
+ " "))
+ (passwd-scheme
+ (concat
+ " echo #password #bin "
+ common
+ " --passphrase-fd 0 ")))
+
+ (list
+ ;; Encrypt and output ascii #todo
+ (list
+ 'encrypt-info
+ (concat common " -f -u xx_test -z xx_test #SOURCE-FILE"))
+
+ (list
+ 'encrypt
+ ;; Multiple users
+ (concat passwd-scheme
+ " #OUT-FILE -e -a #MUSER #SOURCE-FILE "))
+
+ (list
+ 'encrypt-sign
+ (concat common
+ " --textmode --sign -e -a #MUSER #PGP-USER #password"))
+
+ (list
+ 'decrypt
+ (concat passwd-scheme " #OUT-FILE --decrypt #USER #SOURCE-FILE "))
+
+ (list
+ 'decrypt-base64
+ (concat (concat common " -f ")))
+
+ (list
+ 'crypt
+ (concat common2 " -a -c "))
+
+ (list
+ 'sign
+ (concat
+ passwd-scheme
+ " #OUT-FILE --textmode --clearsign -a #USER #SOURCE-FILE "))
+
+ (list
+ 'sign-detach
+ (concat common " -bsatf #USER #password "))
+
+ (list
+ 'verify
+ (concat common " --verify "))
+
+ (list
+ 'key-get
+ (concat common " -kaf "))
+
+ (list
+ 'key-info
+ (concat common " -kvc "))
+
+ (list
+ 'key-add
+ (concat common " -fka "))
+
+ (list
+ 'key-extract
+ (concat common " -fkxa "))
+
+ (list
+ 'key-generate
+ (concat common2 " -kg "))
+
+ (list
+ 'key-delete
+ (concat common " +force -kr "))
+
+ (list
+ 'key-remove
+ (concat common " +force -kr "))
+
+ (list
+ 'key-sign-a
+ (concat common " +force #USER -ks "))
+
+ (list
+ 'key-sign-b
+ (concat common " +force #USER -krs "))))
+ "GPG 1.0.4 command table.")
+
+(defconst tinypgp-:pgp-command-table
+ (let* ((common2 tinypgp-:pgp-command-options) ;Without batch mode
+ (common
+ (concat
+ common2
+ " +batchmode "
+ " ")))
+
+ ;; To use a Unix-style filter mode, reading from standard
+ ;; input and writing to standard output, use -f option
+
+ ;; converted to recipient's local text
+ ;; line conventions, add the -t (text)
+
+ (list
+ ;; Encrypt and output ascii ascii
+ (list
+ 'encrypt-info
+ (concat common " #PUBRING -f -u xx_test -z xx_test #SOURCE-FILE"))
+
+ (list
+ 'encrypt
+ ;; Multiple users
+ (concat common " #PUBRING -eatf #SOURCE-FILE #MUSER "))
+
+ (list
+ 'encrypt-sign
+ (concat common " #PUBRING -eatfs #MUSER #PGP-USER #password"))
+
+ (list
+ 'decrypt
+ (concat common " #PUBRING -f #password "))
+
+ (list
+ 'decrypt-base64
+ (concat common " -f "))
+
+ (list
+ 'crypt
+ (concat common2 " -a -c "))
+
+ (list
+ 'sign
+ (concat common " #PUBRING -satf #USER #password "))
+
+ (list
+ 'sign-detach
+ (concat common " #PUBRING -bsatf #USER #password "))
+
+ (list
+ 'verify
+ (concat common " #PUBRING -f "))
+
+ (list
+ 'key-get
+ (concat common " #PUBRING -kaf "))
+
+ (list
+ 'key-info
+ (concat common " #PUBRING -kvc "))
+
+ (list
+ 'key-add
+ (concat common " #PUBRING -fka "))
+
+ (list
+ 'key-extract
+ (concat common " #PUBRING -fkxa "))
+
+ (list
+ 'key-generate
+ (concat common2 " #PUBRING -kg "))
+
+ (list
+ 'key-delete
+ (concat common " +force #PUBRING -kr "))
+
+ (list
+ 'key-remove
+ (concat common " +force #PUBRING -kr "))
+
+ (list
+ 'key-sign-a
+ (concat common " +force #PUBRING #USER -ks "))
+
+ (list
+ 'key-sign-b
+ (concat common " +force #PUBRING #USER -krs "))))
+ "PGP 2.6.x command table.")
+
+;; #todo: #PUBRING is not in the switches.
+;; #todo: I have no idea if these work in Unix
+
+(defconst tinypgp-:pgp-command-table5
+ (let* ((common tinypgp-:pgp-command-options5))
+ (list
+ ;; Encrypt and output ascii ascii
+ (list
+ 'encrypt-info
+ (concat common " -f -u xx_test -z xx_test #SOURCE-FILE"))
+
+ (list
+ 'encrypt
+ (concat common " -atf #OUT-FILE #MUSER #SOURCE-FILE"))
+
+ (list
+ 'encrypt-sign
+ (concat
+ common
+ " -atf -s #OUT-FILE #USER #MUSER #password #SOURCE-FILE "))
+
+ (list
+ 'decrypt
+ (concat common " -f #OUT-FILE #password #SOURCE-FILE"))
+
+ (list
+ 'decrypt-base64
+ (concat common " -f #OUT-FILE #SOURCE-FILE"))
+
+ (list
+ 'crypt
+ (concat common " -a -c #SOURCE-FILE"))
+
+ (list
+ 'sign
+ (concat
+ common
+ " -atv #USER #password #OUT-FILE #SOURCE-FILE "))
+
+ (list
+ 'sign-detach
+ (concat
+ common
+ " -b -atv #USER #password #OUT-FILE #SOURCE-FILE "))
+
+ (list
+ 'verify
+ ;; option -z requires pass phrase argument.
+ ;;
+ (concat common " #OUT-FILE #SOURCE-FILE "))
+
+ (list
+ 'key-get
+ (concat common " -kaf "))
+
+ (list
+ 'key-info
+ (concat common " -ll "))
+
+ (list
+ 'key-add
+ (concat common " -a "))
+
+ (list
+ 'key-extract
+ (concat common " -xa "))
+
+ (list
+ 'key-generate
+ (concat common " -g "))
+
+ (list
+ 'key-delete
+ (concat common " -r "))
+
+ (list
+ 'key-remove
+ (concat common " -kr "))
+
+ (list
+ 'key-sign-a
+ (concat common " #USER -ks "))
+
+ (list
+ 'key-sign-b
+ (concat common "#USER -krs "))))
+ "PGP 5.0.x command table.")
+
+(defconst tinypgp-:pgp-binary-exit-code-table
+ '((pgp2 .
+ (
+ ;; Possible error exit codes - not all of these are used. Note that
+ ;; we don't use the ANSI EXIT_SUCCESS and EXIT_FAILURE. To make
+ ;; things easier for compilers which don't support enum we use
+ ;; #defines
+
+ (0 'EXIT_OK "JumBoJumboMamboBaile")
+ (1 'INVALID_FILE_ERROR)
+ (2 'FILE_NOT_FOUND_ERROR)
+ (3 'UNKNOWN_FILE_ERROR)
+ (4 'NO_BATCH)
+ (5 'BAD_ARG_ERROR)
+ (6 'INTERRUPT)
+ (7 'OUT_OF_MEM)
+ ;; /* Keyring errors: Base value = 10 */
+ (10 'KEYGEN_ERROR )
+ (11 'NONEXIST_KEY_ERROR)
+ (12 'KEYRING_ADD_ERROR)
+ (13 'KEYRING_EXTRACT_ERROR)
+ (14 'KEYRING_EDIT_ERROR)
+ (15 'KEYRING_VIEW_ERROR)
+ (16 'KEYRING_REMOVE_ERROR)
+ (17 'KEYRING_CHECK_ERROR)
+ (18 'KEY_SIGNATURE_ERROR)
+ (19 'KEYSIG_REMOVE_ERROR)
+ ;; /* Encode errors: Base value = 20 */
+ (20 'SIGNATURE_ERROR)
+ (21 'RSA_ENCR_ERROR)
+ (22 'ENCR_ERROR)
+ (23 'COMPRESS_ERROR)
+ ;; /* Decode errors: Base value = 30
+ (30 'SIGNATURE_CHECK_ERROR)
+ (31 'RSA_DECR_ERROR)
+ (32 'DECR_ERROR)
+ (33 'DECOMPRESS_ERROR))))
+ "Error codes of PGP versions.
+Format:
+ '((PGP-VERSION-REGEXP .((EXIT-CODE ERROR-SYMBOL [ERROR-REGEXP] ..)))
+ (P-V-R . ((EX ES ER) (EX ES ER) ..))))
+
+If ERROR-REGEXP is not specified, then ERROR-SYMBO should be used to
+show the error to user.")
+
+(defconst tinypgp-:pgp-binary-error-regexp
+ (concat
+ "Bad pass phrase"
+ "\\|user ID is required"
+ "\\|Unable to get terminal"
+ "\\|Transport armor stripping failed"
+ "\\|Encryption error"
+ "\\|No such file or directory"
+ "\\|Cannot find the public key"
+ "\\|Output file.*already exists"
+ "\\|You do not have the secret key needed to decrypt this file\\."
+ "\\|We need to generate.*bits" ;; Can I handle this in the prg?
+
+ ;; If you encrypt with multiple keys, then missing key is flagged
+
+ "\\|This user will not be able to decrypt this message"
+
+ "\\|Key matching userid.*not found in file"
+ "\\|Key matching.*not found in file"
+
+;;; Signature validation....
+;;; "\\|Key matching expected Key ID.*not found in file"
+
+ "\\|Keyring extract error\\."
+
+ ;; When removing keys...
+
+ "\\|Do you also want to remove it from.*[?]"
+
+ ;; When you try to verify detached sig file and say that some file
+ ;; XXX holds sig (when it doesn't)
+
+ "\\|Error:.*is not a ciphertext, signature, or key file."
+
+ ;; Eg. From conventional crypt error
+
+ "\\|You need a pass phrase to decrypt this file"
+
+ ;; PGP 5.x Error! Unable to load string PRIVATE_KEY_MISSING.
+
+ "\\|Error!.*Unable to load string.")
+ "All error messages from PGP executable.
+These are case sensitive sentences.")
+
+(defconst tinypgp-:pgp-binary-error-regexp-quiet
+ (concat
+ "Bad pass phrase"
+ "\\|Cannot find the public key"
+ "\\|Key matching userid.*not found in file"
+ "\\|Key matching.*not found in file")
+ "List of errors that does not bring up the Shell Error buffer.
+The buffer contain the last PGP executable call.
+Consider these errors so familiar that you don't have to
+examine the shell error message better.")
+
+(defvar tinypgp-:error nil
+ "Last error message.")
+
+(defvar tinypgp-:last-pgp-exe-command nil
+ "Last command sent to PGP exe.")
+
+;;; .................................................... &vp-pass-hash ...
+
+(defvar tinypgp-:hash-password (make-vector 127 0)
+ "Stored passwords, expired periodically.")
+
+;; Some variables must be stored locally, but some variables must
+;; be globally visible; becfause on error conditions the
+;; current buffer may have changed and in order to restore
+;; situation, we must do lookup from GLOBAL array, because we don't
+;; know any more what was the starting buffer.
+;;
+(defvar tinypgp-:hash nil
+ "General _local_ hash storage.")
+(make-variable-buffer-local 'tinypgp-:hash)
+
+(defvar tinypgp-:hash-global nil
+ "General _global_ hash storage.")
+
+(defvar tinypgp-:secring-crypt-mode nil
+ "If Non-nil, use encrypted secring.
+This is NOT A USER VARIABLE. Use \\[tinypgp-secring-crypt-mode-toggle]
+Variable's value should not be trusted at all; but instead set it
+by calling function `tinypgp-secring-crypt-mode-detect' and only
+then trusting the value.")
+
+;;; ......................................................... &vp-misc ...
+
+(defvar tinypgp-:header-sign-smf-info nil
+ "The header SMF data that was constructed is stored here.")
+
+(defvar tinypgp-:pubring-now nil
+ "Current pubring in use.
+This will be initialised in `tinypgp-backend-select'")
+
+(defvar tinypgp-:user-now
+ (let* ((em user-mail-address))
+ (cond
+ ((not (stringp em))
+ (error "\
+TinyPgp: tinypgp-:user-now, user-mail-address is not str like foo@site.com"))
+
+ ;; If you have <> in user-mail-address that messes up From
+ ;; field.
+
+ ((string-match "<.*@.*>" em)
+ (error "\
+TinyPgp: tinypgp-:user-now, please remove <> from user-mail-address")))
+ (car (ti::mail-email-from-string em)))
+ "Current user.")
+
+(defvar tinypgp-:last-network-error nil
+ "Last finger call error text.")
+
+;;}}}
+
+;;; ########################################################### &Funcs ###
+
+;;{{{ Bug report
+
+;;; ........................................................... &debug ...
+
+(defvar tinypgp-:debug-buffer-size 100000
+ "The buffer size after which the debug buffer is emptied.
+If you don't see all the information, increase size.")
+
+(defvar tinypgp-:debug t
+ "*Debug flag.")
+
+(defvar tinypgp-:debug-buffer "*tinypgp-debug*"
+ "*Debug buffer.")
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro tinypgpd (&rest args)
+ "Generate debug if debug is on and output ARGS."
+ (`
+ (when tinypgp-:debug
+ (let* ( ;; write to package's private buffer.
+ (ti:m-debug-buffer tinypgp-:debug-buffer))
+ (save-match-data
+ (ti::d!! (,@ args) "\n")
+ ;; don't let it grow without limit....
+ (with-current-buffer ti:m-debug-buffer
+ (if (and (integerp tinypgp-:debug-buffer-size)
+ (> (buffer-size) tinypgp-:debug-buffer-size))
+ (erase-buffer))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-debug-buffer-clear ()
+ "Clear the debug buffer."
+ (interactive)
+ (ti::temp-buffer tinypgp-:debug-buffer 'clear)
+ (if (interactive-p)
+ (message "TinyPgp: Debug buffer cleared.")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-password-wipe-buffer (&optional force)
+ "Wipe password strings from buffer. This may not succeed if cache is empty.
+if passwords are not in cache any more this function is no-op.
+
+If FORCE is non-nil ask interactively.
+If force is nil, then get the passwords from cache and
+
+Normally getting passwords from cache is performed in `mail-send-hook'"
+ (interactive (list (interactive-p)))
+ (let ((fid "tinypgp-password-wipe-buffer:")
+ passwd
+ serv-passwd)
+
+ (cond
+ (force
+ (setq passwd (tinypgp-password-set "\
+I need pass phrase to wipe out all references to it: "))
+
+ (setq
+ serv-passwd (tinypgp-nymserver-password
+ (tinypgp-nymserver-ask
+ "Nymserver server you have used: "))))
+ (t
+ ;; is it there?
+ (if (ti::vector-table-get tinypgp-:hash-password tinypgp-:user-now)
+ (setq passwd (ti::vector-table-property
+ tinypgp-:hash-password tinypgp-:user-now 'password)))
+ ;;
+ ;; Actually there may be multiple passwords if user has several PGP
+ ;; keys (common, if you use remailers)
+ ;;
+ ;; #todo: We don't know nymserver password, because it is not in hash
+
+ (mapatoms
+ (function
+ (lambda (x)
+ (when x)))
+ ;; (ti::d! x)
+ tinypgp-:hash-password)))
+
+ ;; finally, scramble any pass pharases, so that they are not sent
+ ;; to Maintainer!
+
+ (ti::save-line-column-macro nil nil
+ (when (stringp passwd)
+ (ti::mail-hmax 'move)
+ (replace-string passwd "#PASSWD-WAS-HERE"))
+
+ (when (stringp serv-passwd)
+ (ti::mail-hmax 'move)
+ (replace-string serv-passwd "#PASSWD-WAS-HERE-ANON")))
+ (tinypgpd fid "out:" (current-buffer))
+ ;; Clean return value
+ nil))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-submit-bug-report ()
+ "Submit bug report or feedback.
+When you call this function it automatically includes all needed
+buffers. Please leave the *Backtrace* buffer before you call this function
+and it will be copied too.
+
+If this is feedback call, then do not include any extra buffers.
+\[Answer 'n' when to insert questions]"
+ (interactive)
+ (ti::package-submit-bug-report
+ "tinypgp.el"
+ tinypgp-:version-id
+ '(tinypgp-:version-id
+
+ message-send-hook
+ mail-send-hook
+ message-send-hook
+
+ mail-mode-hook
+ rmail-mode-hook
+ vm-mode-hook
+ vm-version
+ message-mode-hook
+ gnus-article-mode-hook
+ gnus-version
+ news-reply-mode-hook
+ mh-show-mode-hook
+ mh-letter-mode-hook
+ mh-before-send-letter-hook
+ mh-show-hook
+ mh-e-version
+
+ tinypgp-:load-hook
+ tinypgp-:mode-hook
+ tinypgp-:turn-on-hook-list
+ tinypgp-:sig-from-header-hook
+ tinypgp-:sig-to-header-hook
+ tinypgp-:sign-loose-info-hook
+ tinypgp-:key-mode-define-keys-hook
+ tinypgp-:do-command-region-before-hook
+ tinypgp-:do-command-region-after-hook
+ tinypgp-:cmd-macro-before-hook
+ tinypgp-:cmd-macro-after-hook
+ tinypgp-:verify-before-hook
+ tinypgp-:verify-after-hook
+ tinypgp-:read-email-after-hook
+ tinypgp-:find-by-guess-hook
+ tinypgp-:finger-discard-email-hook
+ tinypgp-:r-post-before-hook
+ tinypgp-:r-post-after-hook
+ tinypgp-:nymserver-post-hook
+ tinypgp-:r-post-before-hook
+ tinypgp-:r-reply-block-basic-hook
+ tinypgp-:define-keys-hook
+
+ tinypgp-:pgp-encrypted-p-function
+ tinypgp-:decrypt-arg-interpretation
+ tinypgp-:pgp-decrypt-arg-function
+ tinypgp-:pgp-command-compose-function
+ tinypgp-mode
+ tinypgp-:mode-name
+;;; tinypgp-:mode-menu-name
+;;; tinypgp-:mode-map
+ tinypgp-:mode-prefix-key
+ tinypgp-:mode-prefix-key-remailer
+ tinypgp-:mode-prefix-key-nymserver
+ tinypgp-key-mode
+;;; tinypgp-:key-mode-map
+;;; tinypgp-:key-mode-menu
+ tinypgp-:key-mode-menu-name
+ tinypgp-:key-mode-prefix-key
+ tinypgp-:xpgp-user-info
+ tinypgp-:pgp-binary-charset
+ tinypgp-:pgp-sh-exe
+ tinypgp-:pgp-binary
+ tinypgp-:file-source
+ tinypgp-:file-output
+ tinypgp-:file-password
+ tinypgp-:file-user-list
+ tinypgp-:file-key-cache
+ tinypgp-:file-secring-encrypted
+ tinypgp-:face-mark
+ tinypgp-:face-error
+ tinypgp-:register
+ tinypgp-:finger-discard-by-regexp
+ tinypgp-:password-protection
+ tinypgp-:password-keep-time
+ tinypgp-:user-primary
+ tinypgp-:filter-email-function
+ tinypgp-:sign-mail-p-function
+
+;;; Do not send this to maintainer!
+;;; tinypgp-:user-identity-table
+ tinypgp-:header-sign-table
+;;; tinypgp-:keyserver-mail-table
+ tinypgp-:auto-action-table
+ tinypgp-:pubring-table
+ tinypgp-:r-levien-table
+ tinypgp-:r-host-table
+ tinypgp-:r-history
+ tinypgp-:r-mode-indication-flag
+ tinypgp-:r-list-file
+ tinypgp-:r-user-mail-address
+ tinypgp-:r-list-finger
+ tinypgp-:r-newnym-help-file
+ tinypgp-:r-mail2news-remailer
+ tinypgp-:r-chain
+ tinypgp-:r-reply-block-table
+ tinypgp-:r-reply-block-cache
+ tinypgp-:nymserver-request-encrypt
+ tinypgp-:nymserver-account-table
+ tinypgp-:debug
+ tinypgp-:debug-buffer-size
+;;; tinypgp-:key-cache
+ tinypgp-:key-cache-last
+ tinypgp-:return-value
+ tinypgp-:buffer-tmp-shell
+ tinypgp-:buffer-tmp-finger
+ tinypgp-:buffer-tmp-copy
+ tinypgp-:buffer-tmp-http
+ tinypgp-:buffer-tmp-kring
+ tinypgp-:buffer-tmp-show
+ tinypgp-:buffer-tmp-mail
+ tinypgp-:buffer-tmp
+ tinypgp-:buffer-comint
+ tinypgp-:buffer-view
+ tinypgp-:original-buffer
+ tinypgp-:xpgp-signing-mode
+ tinypgp-:history-email
+;;; tinypgp-:pgp-email-list
+;;; tinypgp-:pgp-email-abbrev-list
+;;; tinypgp-:pgp-email-list-completions
+ tinypgp-:sign-data
+ tinypgp-:history-key-info
+ tinypgp-:error
+ tinypgp-:last-pgp-exe-command
+;;; tinypgp-:hash-password
+;;; tinypgp-:hash
+ tinypgp-:header-sign-smf-info
+ tinypgp-:pubring-now
+ tinypgp-:user-now
+ tinypgp-:last-network-error
+ tinypgp-:nymserver-echo-menu-use-p
+
+ tinypgp-:key-mode-name
+ tinypgp-:pgp-binary-interactive-option
+ tinypgp-:pgp-binary-support-table
+;;; tinypgp-:keyserver-http-table
+ tinypgp-:r-control-list
+;;; tinypgp-:r-subject-table
+ tinypgp-:nymserver-table))
+;;; tinypgp-:pgp-command-table
+;;; tinypgp-:pgp-binary-error-regexp
+;;; tinypgp-:nymserver-echo-menu
+
+ (save-excursion
+
+ (ti::pmax)
+
+ (when (get-buffer "*Backtrace*")
+ (insert "\n\n#BACKTRACE BEGIN-------------\n")
+ (insert-buffer (get-buffer "*Backtrace*")) (ti::pmax)
+ (insert "\n\n#BACKTRACE END-------------\n"))
+
+ (when (and (get-buffer tinypgp-:buffer-tmp-shell)
+ (y-or-n-p "Insert PGP shell buffer contents? "))
+ (insert "\n\n#SHELL BEGIN-------------\n")
+ (insert-buffer (get-buffer tinypgp-:buffer-tmp-shell)) (ti::pmax)
+ (insert "\n\#SHELL END-------------\n"))
+
+ (cond
+ ((or
+ (and
+ (null (get-buffer tinypgp-:debug-buffer))
+ (y-or-n-p
+ "No debug buffer: Are you sure maintainer doesn't need it? "))
+ (y-or-n-p "Insert the debug buffer contents too? "))
+ (insert "\n\n#DEBUG BEGIN-------------\n")
+ (insert-buffer tinypgp-:debug-buffer) (ti::pmax)
+ (insert "\n\#DEBUG END-------------\n")))
+
+ (tinypgp-password-wipe-buffer 'force))
+ (ti::read-char-safe-until
+ "[press]Please check that your pass phrase wasn't included..."))
+
+;;}}}
+;;{{{ macros: test-p
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypgp-backend-now ()
+ "Return 'gpg 'pgp2 or 'pgp5"
+ (get 'tinypgp-:pgp-binary 'pgp-now))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypgp-backend-type (&optional backend)
+ "Return BACKEND type: 'unix or 'win32."
+ (let* ((prop (intern (concat (symbol-name
+ (or backend
+ (tinypgp-backend-now)))
+ "-type"))))
+ (get 'tinypgp-:pgp-binary prop)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-backend-file (file)
+ (concat file "." (symbol-name (tinypgp-backend-now))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypgp-backend-pgp2-p ()
+ "Return non-nil is if pgp 2.6.x is in use."
+ (eq (tinypgp-backend-now) 'pgp2))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypgp-backend-gpg-p ()
+ "Return non-nil is if gpg is in use."
+ (eq (tinypgp-backend-now) 'gpg))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypgp-backend-list ()
+ "Return available backends: 'pgp2 'pgp5"
+ (get 'tinypgp-:pgp-binary 'pgp-backends))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypgp-backend-exist-pgp2 ()
+ "Return non-nil if pgp2 is available"
+ (memq 'pgp2 (tinypgp-backend-list)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypgp-backend-exist-pgp5 ()
+ "Return non-nil if pgp5 is aailable"
+ (memq 'pgp5 (tinypgp-backend-list)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypgp-sign-data-same-p ()
+ "Compare previous signing info against current buffer content.
+If this function returns non-nil, the buffer has been changed and
+it should be resigned."
+ (eq (ti::mail-message-length) tinypgp-:sign-data))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypgp-sign-data-set ()
+ "Store sign information."
+ (if (ti::mail-mail-p)
+ (setq tinypgp-:sign-data (ti::mail-message-length))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypgp-sign-mail-auto-mode-on-p ()
+ "Check if auto sign is active."
+ (memq 'tinypgp-sign-mail-func mail-send-hook))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypgp-mail-buffer-p (&optional msg-flag)
+ "Check if buffer look like mail message.
+Non-nil MSG-FLAG displays message if test is nil."
+ ;; Gnus uses message-mode
+ ;;
+ (if (ti::mail-mail-p)
+ t
+ (tinypgpd "tinypgp-mail-buffer-p")
+ (when msg-flag
+ (message "This PGP action is available only in mail, news")
+ (sit-for 1))
+ nil))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypgp-hidden-p ()
+ "Check if the PGP BLOCK is hidden.
+Return:
+ nil
+ (point . invisible-property-value)"
+ (let* ((point (point-min)) ;Before widen
+ (pmax (+ (point-max) (* 80 6))) ;lookahead about 6 full lines
+ pos
+ prop)
+ ;; first find our property. Then see if it's invisible
+ ;;
+ (when (and
+ ;; In RMAIL buffer this widens a lot!
+ (ti::widen-safe
+ (setq pos (text-property-any
+ point
+ ;; Select lookahead or point-max.
+ ;; In RMAIL the pmax is selected.
+ ;;
+ (min pmax (point-max))
+ 'owner 'tinypgp)))
+ (setq prop (get-text-property pos 'invisible)))
+ (cons pos prop))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypgp-user-list (&optional list)
+ "Add to LIST users from `tinypgp-:encrypt-with-function'."
+ (let* ((add (if tinypgp-:encrypt-with-function
+ (funcall tinypgp-:encrypt-with-function))))
+ (if add
+ (ti::list-merge-elements list add)
+ list)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-user-find-current ()
+ "Find current user.
+
+If buffer is read-only (supposing RMAIL, VM):
+
+ look at the PGP stream in buffer and consult `tinypgp-:user-identity-table'.
+
+If buffer is writable:
+
+ Do nothing special."
+ (let ((fid "tinypgp-user-find-current:")
+ (type (tinypgp-hash 'action 'get 'now nil 'global))
+ key-id
+ elt)
+
+ (tinypgpd fid "TYPE" type "READ-ONLY" buffer-read-only (buffer-name)
+ "remail" tinypgp-:r-mode-indication-flag)
+
+ (cond
+ ((or (and (not (member (buffer-name) '("RMAIL" "INBOX")))
+ (not buffer-read-only))
+ tinypgp-:r-mode-indication-flag)
+ nil)
+ (t
+ (setq type (save-excursion
+ (ti::pmin)
+ (ti::mail-pgp-stream-forward-and-study)))
+ (tinypgpd fid type)
+ (when (and (eq (car type) 'enc)
+ (setq key-id (nth 3 type))
+ (inline
+ (setq elt
+ (ti::list-find
+ tinypgp-:user-identity-table key-id))))
+ (nth 1 elt))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinypgp-interactive-enable 'lisp-indent-function 2)
+(defmacro tinypgp-interactive-enable (type)
+ "Check TYPE condition and display MSG if function usage is prohibited."
+ (`
+ (cond
+ ((eq (, type) 'remail)
+ (unless (tinypgp-install-menu-bar-remail)
+ (message "You haven't configured TinyPgp to use remailers yet.")
+ (sit-for 1)
+ (error "See TinyPgp Manual and 'tinypgp-:r-levien-table'")))
+
+ ((eq (, type) 'newnym)
+ (unless (tinypgp-install-menu-bar-newnym)
+ (message "\
+You haven't ordered newnym account or configured TinyPgp to use it.")
+ (sit-for 1)
+ (error "See TinyPgp Manual and 'tinypgp-:r-levien-table'")))
+
+ ((eq (, type) 'nymserver)
+ (unless (tinypgp-install-menu-bar-nymserver)
+ (message "\
+You haven't ordered nymserver account or configured TinyPgp to use it.")
+ (sit-for 1)
+ (error "See TinyPgp Manual and `tinypgp-:nymserver-account-table'")))
+ (t
+ (error "Not know type. %s" (, type))))))
+
+(defsubst tinypgp-r-i-enable ()
+ "Interactive check."
+ (tinypgp-interactive-enable 'remail))
+
+(defsubst tinypgp-newnym-i-enable ()
+ "Interactive check."
+ (tinypgp-interactive-enable 'newnym))
+
+(defsubst tinypgp-nymserver-i-enable ()
+ "Interactive check."
+ (tinypgp-interactive-enable 'nymserver))
+
+;;}}}
+;;{{{ macros: misc and inline defsubst
+
+;;; .......................................................... ¯os ...
+;;; Macros must be defined before used --> keep them at the top of file
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypgp-email-or-string (string)
+ "Return email address from STRING or STRING itself."
+ (or (ti::string-match "[^< \t]+@[^ >\t]+" 0 string)
+ string))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypgp-comint-buffer ()
+ "Return comint buffer name."
+ (concat "*" tinypgp-:buffer-comint "*"))
+
+;;; ----------------------------------------------------------------------
+;;; - This "stringifies" a regexp :-)
+;;;
+(defsubst tinypgp-cnv (string)
+ "Remove possible anchor tag or other RE tags from STRING."
+ (replace-regexp-in-string "[\n\r?$^]+" "" string))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypgp-pubring-table ()
+ "Return backend's pubring table."
+ (or (nth 1 (assq (tinypgp-backend-now) tinypgp-:pubring-table))
+ (error "tinypgp-:pubring-table is corrupt. No backend %s: %s"
+ (tinypgp-backend-now)
+ tinypgp-:pubring-table)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypgp-pubring-set-big ()
+ "Set `tinypgp-:pubring-now' to point to big pubring."
+ (setq tinypgp-:pubring-now
+ (nth 1 (car (reverse (tinypgp-pubring-table))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro tinypgp-do-shell-env (&rest body)
+ "Execute BODY in specific shell environment."
+ (`
+ (let* ((pgp-type (tinypgp-backend-type))
+ (shell (nth 1 (assq pgp-type tinypgp-:pgp-sh-exe)))
+ (explicit-shell-file-name (or shell
+ explicit-shell-file-name
+ shell-file-name))
+ (shell-file-name (or shell shell-file-name)))
+ (if (null explicit-shell-file-name) ;; nop-op Quiet XE ByteCompiler
+ (setq explicit-shell-file-name nil))
+ (,@ body))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinypgp-save-state-macro 'lisp-indent-function 0)
+(defmacro tinypgp-save-state-macro (&rest body)
+ "Save key values of program and execute BODY."
+ (`
+ (let ((TINYPGP-user tinypgp-:user-now) ;Mixed case: Prevent variable suicide
+ (TINYPGP-userp tinypgp-:user-primary)
+ (TINYPGP-pring tinypgp-:pubring-now)
+ (TINYPGP-h-s-t tinypgp-:header-sign-table)
+ (TINYPGP-x-s-m tinypgp-:xpgp-signing-mode))
+ (prog1 (progn (,@ body))
+ (setq tinypgp-:user-now TINYPGP-user
+ tinypgp-:user-primary TINYPGP-userp
+ tinypgp-:pubring-now TINYPGP-pring
+ tinypgp-:header-sign-table TINYPGP-h-s-t
+ tinypgp-:xpgp-signing-mode TINYPGP-x-s-m)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypgp-clone-buffer ()
+ "Copy content of current buffer to `tinypgp-:buffer-tmp-article'."
+ (tinypgp-copy-to-buffer (tinypgp-ti::temp-buffer 'article)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-copy-to-buffer (buffer)
+ "Copy content of current buffer to BUFFER and remove all properties."
+ (let ((data-buffer (current-buffer)))
+ (tinypgpd "tinypgp-copy-to-buffer" buffer)
+ (with-current-buffer (get-buffer-create buffer)
+ (erase-buffer)
+ (insert-buffer data-buffer)
+
+ ;; SIG may be hidden; Gnus hides headers with properties
+
+ (ti::buffer-text-properties-wipe (point-min) (point-max))
+ (ti::overlay-remove-region (point-min) (point-max))
+ buffer)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinypgp-run-in-tmp-buffer 'lisp-indent-function 1)
+(defmacro tinypgp-run-in-tmp-buffer (buffer &rest body)
+ "Use BUFFER, which is copy of current buffer, and do BODY.
+All text properties in the copy are removed. If BUFFER is nil,
+then use internal temporary buffer.
+
+Note:
+ The `set-buffer' command leaves pointer to copy buffer.
+
+References:
+ `tinypgp-:original-buffer' is set to buffer from where the text was copied."
+ (`
+ (let ((Data-buffeR (current-buffer))
+ BuffeR)
+ (setq BuffeR (or (, buffer) (tinypgp-ti::temp-buffer 'copy)))
+ (tinypgpd "tinypgp-run-in-tmp-buffer" BuffeR)
+
+ (setq tinypgp-:original-buffer Data-buffeR) ;save position
+ (tinypgp-copy-to-buffer BuffeR)
+
+ (with-current-buffer BuffeR
+ (,@ body)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinypgp-set-pgp-env-macro 'lisp-indent-function 2)
+(defmacro tinypgp-set-pgp-env-macro (user-list &optional verb &rest body)
+ "Set environment. Find correct keyring and switch to it temporarily.
+But only if USER-LIST length is 1; if list is longer, use big pubring
+that holds all keys. The VERB parameter must also be set. Do BODY.
+
+Error is signalled if we can't find keyring."
+ (`
+ (tinypgp-save-state-macro
+ ;; Let's be a little user friendly and try finding the key
+ ;;
+ (let ((user (cond
+ ((stringp (, user-list))
+ (, user-list))
+
+ ((and (ti::listp (, user-list))
+ (eq 1 (length (, user-list))))
+ (car (, user-list)))))
+ kring)
+
+ (when (, verb)
+
+ (cond
+ (user
+ (if (not (setq kring (tinypgp-key-find-by-guess user)))
+ (error "Sorry, can't set keyring '%s'. Fetch key first." user)
+ (tinypgpd "tinypgp-set-pgp-env-macro" (, user-list) kring )
+ (setq tinypgp-:pubring-now kring)))
+
+ ((ti::listp (, user-list))
+ ;; Multiple users, set pubring to point to BIG RING
+ ;;
+ (tinypgpd "tinypgp-set-pgp-env-macro: LAST KRING")
+ (tinypgp-pubring-set-big))))
+ (tinypgpd "tinypgp-set-pgp-env-macro: BODY " verb (, user-list)
+ tinypgp-:pubring-now)
+
+ (,@ body)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinypgp-user-change-macro 'lisp-indent-function 0)
+(defmacro tinypgp-user-change-macro (&rest body)
+ "Change pgp user if From field address match `tinypgp-:user-identity-table'.
+If there is no From field or match this macro does nothing to BODY."
+ (`
+ (let (UseR)
+ (if (setq UseR (tinypgp-user-find-current))
+ (setq tinypgp-:user-now UseR))
+ (tinypgpd "tinypgp-user-change-macro: " tinypgp-:user-now)
+ (,@ body))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypgp-name2alias (str table)
+ "Return Nth 0 when NTH 1 STR is given from TABLE."
+ (let* (ret)
+ (dolist (elt table)
+ (when (string= str (nth 1 elt))
+ (setq ret elt)
+ (return)))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypgp-alias2name (str table)
+ "Return Nth 1 when NTH 0 STR is given from TABLE."
+ (nth 1 (assoc str table)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypgp-x-headers-deinstall ()
+ "Move X-pgp signature to normal format (if X-pgp exist)."
+ (tinypgpd "tinypgp-x-headers-deinstall")
+ (if (ti::mail-pgp-headers-p)
+ ;; Move X-pgp headers to their normal places
+ ;;
+ (tinypgp-signature-from-header)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypgp-pubring-complete (&optional prompt init)
+ "Read the pubring name with PROMPT and INIT. Return nil or selected string."
+ (let ((ans
+ (completing-read
+ (or prompt "Select pubring: ")
+ (ti::list-to-assoc-menu (mapcar 'car (tinypgp-pubring-table)))
+ nil
+ 'require-match
+ init)))
+ (if (ti::nil-p ans)
+ nil
+ ans)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypgp-pubring-alias2file (name)
+ "Find real pubring behind completion NAME."
+ (if name
+ (tinypgp-expand-file-name
+ (nth 1 (assoc name (tinypgp-pubring-table))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-pubring-file2alias (name)
+ "Find alias for real pubring NAME. Return nil if no match."
+ (let* (ret)
+ (setq name (tinypgp-expand-file-name name))
+ (dolist (elt (tinypgp-pubring-table))
+ (when (string= name (tinypgp-expand-file-name (nth 1 elt)))
+ (setq ret (car elt))
+ (return)))
+ (or ret
+ (error "Can't find alias for: %s"))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypgp-pubring-list ()
+ "Return all pubrings known to program."
+ (let (list)
+ (dolist (elt (tinypgp-pubring-table))
+ (push (tinypgp-expand-file-name (nth 1 elt)) list))
+ list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypgp-pubring-many-p ()
+ "Return non nil if there are many pubrings."
+ (> (length (tinypgp-pubring-table)) 1))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypgp-pubring-default ()
+ "Return first pubring< which is supposed to be default."
+ (nth 1 (car (tinypgp-pubring-table))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypgp-pubring-change-to-current ()
+ "Change to pubring relative to current user.
+Calling function should possibly save the `tinypgp-:pubring-now'."
+ (setq tinypgp-:pubring-now
+ (or (tinypgp-key-find-by-cache tinypgp-:user-now)
+ tinypgp-:pubring-now)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypgp-user-change-to-primary ()
+ "Change current variable settings to reflect primary user.
+The calling function should copy the key values of TinyPgp
+before calling this function.
+
+This also changes the pubring.
+
+Reference:
+ `tinypgp-save-state-macro'"
+ (tinypgpd "tinypgp-user-change-to-primary" tinypgp-:user-primary )
+ (setq tinypgp-:user-now tinypgp-:user-primary)
+ (setq tinypgp-:pubring-now
+ (tinypgp-expand-file-name
+ (if (tinypgp-key-find-by-cache
+ tinypgp-:user-now)
+ (nth 1 (car (tinypgp-pubring-table)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypgp-randseed-file ()
+ "Return randseed filename."
+ (or (getenv "RANDSEED")
+ (format "%s/%s"
+ (tinypgp-expand-file-name (or (getenv "PGPPATH") "~/.pgp"))
+ "randseed.bin")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypgp-finger-email-filter (list)
+ "Filter out unwanted entries from email LIST."
+ (when list
+ (setq list (tinypgp-email-discard-default list))
+ (when tinypgp-:finger-discard-email-hook
+ (setq list (run-hook-with-args-until-success
+ 'tinypgp-:finger-discard-email-hook list)))
+ list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-email-find-region (beg end)
+ "Read all email addressed from BEG END and filter out unwanted ones.
+See. `tinypgp-:finger-discard-email-hook'."
+ (tinypgp-finger-email-filter
+ (ti::mail-email-find-region beg end 'no-dupes)))
+
+;;}}}
+
+;;{{{ misc: messages, error; hash; whatever...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-error (message)
+ "Generate error using MESSAGE and show buffer `tinypgp-:buffer-tmp-shell'.
+If the error is in list `tinypgp-:pgp-binary-error-regexp-quiet' then the
+shell buffer is not shown."
+
+ (tinypgpd "tinypgp-error" message tinypgp-:cmd-macro-after-hook)
+
+ (if (not (string-match tinypgp-:pgp-binary-error-regexp-quiet message))
+ (ti::pop-to-buffer-or-window tinypgp-:buffer-tmp-shell))
+
+ ;; We must close the EDIT-RMAIL etc. before calling error.
+
+ (run-hook-with-args-until-success 'tinypgp-:cmd-macro-after-hook 'cancel)
+ (tinypgp-password-expire-now 'keep-tmp-files)
+
+ (when (eq '1pass (tinypgp-hash 'action 'get 'detail 'global))
+ (setq
+ message
+ (concat
+ message
+ "[possible cause: you don't have all the keys in this keyring.]")))
+ (error "[PGP executable signalled error] %s" message))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-unfinished-function ()
+ "Signal error."
+ (if (not (string= (getenv "USER") "jaalto"))
+ (error "\
+Function you tried to call is not yet ready; it's on todo list.")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-initial-message ()
+ "
+Release note
+
+ 1999-12-10 Development of this package has been stalled and there is no
+ guarrantees that it will continue to work in new Emacs versions. The last
+ update was more than year ago and since then I've been busy elswhere.
+ I do appreciate bug reports, even if I can't adress any of the defects
+ raised by the reports --The Maintainer.
+
+ Emacs debug and TinyPgp debug is now ON."
+ (interactive)
+ (let* ((win (selected-window)))
+ (tinypgp-version)
+ (ti::pmin)
+ (insert (documentation 'tinypgp-initial-message) "\n\n")
+ (ti::pmin)
+ (select-window win)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-hash (var-sym mode &optional property value global)
+ "Set or get data from obarray.
+This function is used for internal data handling for current buffer.
+
+Input:
+
+ VAR-SYM variable name as symbol
+ MODE 'put or 'get and 'def checks if defined
+ PROPERTY property name
+ VALUE value for property
+ GLOBAL Instead of using buffer local hash, use global hash table
+
+References:
+ `tinypgp-:hash'
+ `tinypgp-:hash-global'"
+
+ ;; Make sure these two are initialized.
+ (unless (vectorp tinypgp-:hash)
+ (ti::vector-table-init tinypgp-:hash))
+;;; (tinypgpd "HASH INIT" tinypgp-:hash)
+
+;;; (tinypgpd "HASH" var-sym mode property tinypgp-:hash)
+
+ (or (vectorp tinypgp-:hash-global)
+ (ti::vector-table-init tinypgp-:hash-global))
+
+ (let* ((hash (if global
+ tinypgp-:hash-global
+ tinypgp-:hash)))
+
+ (if (symbolp var-sym)
+ (setq var-sym (symbol-name var-sym))
+ (error "TinyPgp: Must give a symbol '%s' " var-sym))
+
+ (cond
+ ((eq mode 'def)
+ (let* ((sym (ti::vector-table-get hash var-sym)))
+ (if (null property) ;Check only if variable exist.
+ (ti::vector-table-get hash var-sym)
+ (when sym ;Check property list
+ (memq property (symbol-plist sym))))))
+
+ ((eq mode 'get)
+ (if (ti::vector-table-get hash var-sym) ;Exist ?
+ (ti::vector-table-property hash var-sym property)))
+
+ ((eq mode 'put)
+ (ti::vector-table-get hash var-sym 'allocate)
+ (ti::vector-table-property hash var-sym property value 'set))
+ (t
+ (error "TinyPgp: No such mode '%s' ." mode)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-update-modeline ()
+ "Set correct mode name."
+ (let* ((fid "tinypgp-update-modeline:")
+ (str (cond
+ ((tinypgp-backend-pgp2-p)
+ " pgp")
+ ((tinypgp-backend-gpg-p)
+ " gpg")
+ (t
+ " pgp5")))
+ elt
+ D) ;_Extra_ debug
+
+ (if elt
+ (setq elt nil)) ;No-op, byteComp silencer
+
+ ;; This makes sense only if mode is on.
+
+ (when tinypgp-mode
+ (tinypgpd fid "BEGIN" (point))
+
+ ;; ................................................ update hooks ...
+ ;; Keep the hooks in proper order, Call function only
+ ;; periodically every 20th time. (it's too heavy operation to
+ ;; run all the time)
+
+ (inline (tinypgp-install-menu-bar))
+
+ (unless (setq elt (tinypgp-hash 'vital-hook 'get 'counter nil 'global))
+ (setq elt 1)
+ (tinypgp-hash 'vital-hook 'put 'counter 0 'global))
+
+ (when (zerop (% (incf elt) 20))
+ (tinypgp-install-hooks-vital)
+ (setq elt 1))
+
+ (tinypgp-hash 'vital-hook 'put 'counter elt 'global)
+
+ (if D (tinypgpd fid "1" (point)))
+
+ ;; ............................................... install check ...
+ ;; Confirm proper installation. If we see any new packages since last
+ ;; modeline update, these trigger auto installation.
+
+ (if (and (featurep 'gnus) (null (get 'tinypgp-:hash 'gnus-check)))
+ (tinypgp-install-gnus))
+
+ (inline (tinypgp-install-mime-pgp))
+
+ (if (and (featurep 'vm) (null (get 'tinypgp-:hash 'vm-check)))
+ (tinypgp-install-vm))
+
+ ;; .............................................. update pubring ...
+ (setq elt (tinypgp-pubring-elt))
+
+ (setq str (concat ;Set pubring indicator
+ str
+ (or (nth 2 elt)
+ (error "\
+Internal error tinypgp-:pubring-table tinypgp-:pubring-now conflict"))))
+
+ (if D (tinypgpd fid "2" (point)))
+
+ ;; ..................................................... secring ...
+
+ (inline (tinypgp-secring-crypt-mode-detect))
+
+ (when tinypgp-:secring-crypt-mode
+ (setq str (concat str "c")))
+
+ ;; ...................................................... remail ...
+
+ (if tinypgp-:r-mode-indication-flag
+ (setq str (concat str "r")))
+
+ (when tinypgp-:read-email-after-hook
+ (if (tinypgp-key-id-conversion-check)
+ (setq str (concat str "E"))
+ (setq str (concat str "e"))))
+
+ ;; Hmm, Should I call (tinypgp-header-sign-active-list)
+ ;; Which tells if this message will have headers?
+ ;;
+ ;; Right now I just show the mode.
+
+ (if tinypgp-:header-sign-table
+ (setq str (concat str "h")))
+
+ (if tinypgp-:xpgp-signing-mode
+ (setq str (concat str "x")))
+
+ (when (tinypgp-sign-mail-auto-mode-on-p)
+ (if (inline (tinypgp-sign-mail-auto-p))
+ (setq str (concat str "A"))
+ (setq str (concat str "a"))))
+
+ (if D (tinypgpd fid "3" (point)))
+
+;;; (if (tinypgp-nymserver-mail-p)
+;;; (setq str (concat str "n")))
+
+ (when (setq elt (get 'tinypgp-:r-newnym-default-account-table
+ 'default-completion))
+ (setq str
+ (concat
+ str
+ (or (nth 3 (assoc elt tinypgp-:r-newnym-default-account-table))
+ "N")))
+
+ (if D (tinypgpd fid "3.5" (point)))
+
+ (cond
+ ((progn
+ (if D (tinypgpd fid "3.510" (point)))
+ (tinypgp-auto-action-multiple-addresses-p))
+ (if D (tinypgpd fid "3.511" (point)))
+ (setq str (concat str "$"))
+ (unless (tinypgp-hash 'auto-action 'get 'user-mode)
+ (setq str (concat str "-"))))
+
+ ((progn
+ (if D (tinypgpd fid "3.520" (point)))
+ (tinypgp-auto-action-on-p))
+ (if D (tinypgpd fid "3.521" (point)))
+ (setq str (concat str "!"))
+ (unless (tinypgp-hash 'auto-action 'get 'user-mode)
+ (setq str (concat str "-")))))
+
+ (if D (tinypgpd fid "4" (point)))
+
+) ;; check if we know this person: is the
+ ;; public key pubring info in cache?
+
+ (when (and (null buffer-read-only) ;skip RMAIL
+ (inline (ti::mail-mail-p))
+ (setq elt (car-safe (ti::mail-email-from-string
+ (mail-fetch-field "to"))))
+
+ ;; Call the conversion if it is activated,
+ ;; save possibly one function call
+
+ (or (and tinypgp-:read-email-after-hook
+ (setq elt (car-safe (tinypgp-key-id-conversion elt))))
+ t)
+ (inline (tinypgp-key-find-by-cache elt "modeline")))
+ ;; Yes, key is known
+ (setq str (concat str "k")))
+ (setq tinypgp-:mode-name str)
+ (tinypgpd fid "END" (point))
+ (ti::compat-modeline-update))
+
+ ;; These modes may have dynamic mode name later
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. key mode . .
+
+ (when tinypgp-key-mode
+ (setq tinypgp-:key-mode-name " pgpK")
+ (ti::compat-modeline-update))
+
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. summary mode . .
+
+ (when tinypgp-summary-mode
+ (setq tinypgp-:summary-mode-name " pgp-sum")
+ (ti::compat-modeline-update))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-highlight
+ (regexp &optional level point face ov-type arg1 arg2 arg3)
+ "Mark text forward.
+If Emacs does not support highlight, this function does nothing.
+
+Input:
+
+ REGEXP string to search
+ This can also be symbol with special meaning.
+ Additional arguments are passed in other variables.
+ 'delet-all remove all _tinypgp_ overlays
+ 'wipe-all delete ALL overlays and faces
+ 'match mark matched text
+
+ LEVEL which level in string to match, defaults to 0
+ POINT from which point forward, defaults to `point-min'
+ FACE defaults to `tinypgp-:face-mark'
+ OV-TYPE overlay type information. Defaults to 'mark
+ ARG1 additional arguments to 'match
+ ARG2
+ ARG3"
+ (when (ti::colors-supported-p)
+
+ (let* ((fid "tinypgp-highlight: ")
+ plist)
+
+ (setq face (or face tinypgp-:face-mark)
+ level (or level 0)
+ ov-type (or ov-type 'mark)) ;used to be overlay type
+
+ (setq plist ;property list
+ (list 'owner 'tinypgp
+ 'type ov-type
+ 'face face))
+
+ (tinypgpd fid "r" regexp "l" level "point" point face ov-type
+ (current-buffer))
+
+ (save-excursion
+ (cond
+ ((stringp regexp)
+ (goto-char (or point (point-min)))
+ (ti::text-re-search regexp nil level nil plist))
+
+ ((eq regexp 'match)
+ (tinypgpd fid "level" level arg1 arg2)
+ (ti::text-match-level level plist arg1 arg2))
+
+ ((eq regexp 'delete-all)
+ (ti::text-clear-region-properties
+ (point) (point-max) '(owner tinypgp) ))
+
+ ((eq regexp 'wipe-all)
+ (set-text-properties (point) (point-max) nil))
+
+ (t
+ (error "TinyPgp: No such action as '%s'" regexp)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-set-session-parameters (action)
+ "Set program flags according to ACTION.
+In some cases the program's parameters must be in certain state
+before ACTION 'sign 'encrypt 'decrypt 'verify is carried out.
+
+Here is one reason to do so:
+
+ When you sign create command to 'newnym' account: the X-Pgp
+ signing must not be used, No headers must be signed.
+
+This function should be inside wrapper macro that saves the previous
+state of session. Use `tinypgp-save-state-macro'.
+
+Return:
+ t if state changed
+ nil nothing done"
+ (when (ti::mail-mail-p)
+ (let* ((to (or (mail-fetch-field "to") ""))
+ ret)
+ (cond
+ ((string-match
+ "@weasel\\|@squirrel\\|efga\\|nym.alias" to) ;Newnym remailers
+ (setq tinypgp-:header-sign-table nil
+ tinypgp-:xpgp-signing-mode nil
+ ret t)))
+ ret)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-add-signature-if-signing ()
+ "Insert `mail-signature-file' in mail. Do nothing in `message-mode'."
+ (when (and (boundp 'mail-signature-file)
+ (memq major-mode
+ '(mail-mode
+ news-reply-mode)))
+ ;; message-mode , Gnus
+
+ (let* ((file (symbol-value 'mail-signature-file))
+ (sig (and file
+
+ ;; Gnus composes messages in message-mode,
+ ;; we don't touch
+ ;; that buffer because Gnus 5 can add signature when
+ ;; you compose the mail.
+
+ (file-exists-p file)
+ (null (ti::mail-signature-p))
+
+ ;; If we're signing whole mail buffer, then ask if
+ ;; signature should be added before signing.
+
+ (y-or-n-p
+ "Tinypgp: Add .signature before sign? "))))
+ (when sig
+ (save-excursion
+ (ti::pmax)
+ (insert-file-contents file)
+ ;; According to RFC there must be "-- \n" before signature.
+ (ti::mail-signature-insert-break))
+ nil))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-after-pgp-command (&optional cmd &rest args)
+ "Example function: run after you have executed and some PGP command.
+If buffer contains diff (after decrypting) and you have tinydiff.el
+loaded, call function `tinydiff-patch' to apply that diff.
+
+Input:
+ CMD ,'encrypt 'sign 'verify ...
+ ARGS ,ignored"
+ (if (and (fboundp 'tinydiff-patch)
+ ;; We suppose that we're in incoming RMAIL or VM buffer
+
+ (memq major-mode '(rmail-mode vm-mode))
+ (memq cmd '(verify decrypt))
+ (ti::buffer-diff-type-p)) ;Is there diff
+ (call-interactively 'tinydiff-patch))
+ nil)
+
+;;}}}
+;;{{{ misc: file control; abbrevs
+
+;;; ........................................................ &pgp-misc ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-show-last-finger-error ()
+ "Show last finger error message in echo area."
+ (interactive)
+ (if (stringp tinypgp-:last-network-error)
+ (message tinypgp-:last-network-error)
+ (message "No Finger error information.")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-view-register (&optional noerr)
+ "View content of register.
+Do not signal error if the register `tinypgp-:register' is empty and
+NOERR is non nil. NOERR is automatically t if function is called
+interactively."
+ (interactive)
+ (let* ((reg tinypgp-:register)
+ (msg (format "TinyPgp: register '%c' doesn't contain data yet."
+ tinypgp-:register))
+ win)
+ (if (not (stringp (get-register reg)))
+ (unless noerr
+ (if (interactive-p)
+ (message msg)
+ (error msg)))
+ (setq win (get-buffer-window tinypgp-:buffer-view t))
+
+ (if (null win)
+ (pop-to-buffer (ti::temp-buffer tinypgp-:buffer-view 'clear))
+ (raise-frame (window-frame win))
+ (select-window win)
+ (erase-buffer))
+
+ (insert-register tinypgp-:register)
+ (ti::pmin)
+ (when (interactive-p)
+ (message "Content of register '%c'" tinypgp-:register)
+ (sleep-for 1)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-file-control (mode &optional arg)
+ "Do file operation according to MODE and ARG.
+
+Input:
+ MODE 'all-kill
+ 'password-write
+ 'password-kill
+ 'password-kill
+ 'source-kill
+ 'source-write
+ 'users-write
+ ARG"
+ (let* (buffer)
+ (tinypgpd "file-control in:" mode arg)
+
+ (cond
+ ((eq 'all-kill mode)
+ (dolist (file
+ (list
+ tinypgp-:file-source
+ tinypgp-:file-output
+ tinypgp-:file-password
+ tinypgp-:file-user-list))
+ (if (file-exists-p file)
+ (delete-file file))))
+
+ ((eq 'password-write mode)
+ (ti::file-delete-safe tinypgp-:file-password)
+
+ (with-current-buffer (tinypgp-ti::temp-buffer)
+ (buffer-disable-undo (current-buffer))
+
+ (insert
+ (or arg
+ (ti::vector-table-property
+ tinypgp-:hash-password tinypgp-:user-now 'password)))
+
+ (set-buffer-modified-p nil)
+ (write-region (point-min) (point-max) tinypgp-:file-password)
+
+ ;; Don't leave password traces in the buffer
+
+ (if (fboundp 'passwd-erase-buffer)
+ (ti::funcall 'passwd-erase-buffer) ;passwd.el
+ (let ((s (* (buffer-size) 3))) ;Code copied from passwd.el
+ (erase-buffer)
+ (while (> s 0)
+ (insert ?\000)
+ (setq s (1- s)))
+ (erase-buffer)))
+
+ (ti::file-mode-protect tinypgp-:file-password)))
+
+ ((eq 'password-kill mode)
+ (if (file-exists-p tinypgp-:file-password)
+ (delete-file tinypgp-:file-password)))
+
+ ((eq 'source-kill mode)
+ (if (file-exists-p tinypgp-:file-source)
+ (delete-file tinypgp-:file-source)))
+
+ ((eq 'source-write mode)
+ ;; When wring the file out, it must be exactly
+ ;; as it appears in buffer
+
+ (let* ((require-final-newline nil))
+ (ti::file-delete-safe
+ (list tinypgp-:file-source
+ (concat tinypgp-:file-source ".asc")))
+
+ ;; I don't think this is good for Multibyte Chars
+
+;;; (if (fboundp 'as-binary-process)
+;;; (as-binary-process
+;;; (write-region (point) (point-max) tinypgp-:file-source))
+
+ (write-region (point) (point-max) tinypgp-:file-source)
+
+ (ti::file-mode-protect tinypgp-:file-source)))
+
+ ((eq 'users-write mode)
+ (ti::file-delete-safe tinypgp-:file-user-list)
+ (setq buffer (tinypgp-ti::temp-buffer))
+ (unless arg
+ (error "No USER LIST"))
+
+ (with-current-buffer buffer
+
+ (dolist (elt (ti::list-make arg))
+ (unless (stringp elt)
+ (error "Users corrupt. Check tinypgp-:encrypt-with-function"))
+ (insert (ti::string-remove-whitespace elt) "\n"))
+
+ (ti::file-delete-safe tinypgp-:file-user-list)
+ (write-region (point-min) (point-max) tinypgp-:file-user-list)
+ (ti::file-mode-protect tinypgp-:file-user-list)))
+
+ (t
+ (error "Unknown mode")))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-mail-abbrevs-filter (email-list)
+ "Filter invalid entries out form EMAIL-LIST.
+Every entry must have .xx or .xxx extension, which refers to country
+name or organisation form."
+ (let* (ret)
+ (dolist (elt email-list)
+ (if (string-match "\\....?$" (car (ti::mail-email-from-string elt)))
+ (push elt ret)))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-update-mail-abbrevs ()
+ "Update mail abbrevs.
+You need to do this is you have modified ~/.mailrc.
+Call mail abbrev.el first to read the file."
+ (interactive)
+ (let* ((sym 'timi-:mail-aliases-alist)
+ list)
+ (tinypgpd "update-mail-abbrevs 1:")
+
+ ;; since the tinymail.el and tinypgp.el use the same
+ ;; abbrevs list, it isn't worth to build 2 separate lists,
+ ;; because creating alist is slow!
+ ;;
+ ;; Now we share the same list and the abbrevs are built by
+ ;; tinymail, which we copy here.
+
+ (if (and (featurep 'tinymail)
+ (boundp 'timi-:mail-aliases-alist))
+ (setq tinypgp-:pgp-email-abbrev-list (symbol-value sym))
+ (setq tinypgp-:pgp-email-abbrev-list (ti::mail-abbrev-get-alist)))
+
+ (tinypgpd "update-mail-abbrevs 2:")
+ (setq tinypgp-:pgp-email-list
+ (ti::mail-mail-abbrevs-email-list tinypgp-:pgp-email-abbrev-list))
+
+ (tinypgpd "update-mail-abbrevs 3:")
+
+ ;; maybe not all are valid in the obarray...
+
+ (setq list (funcall tinypgp-:filter-email-function
+ tinypgp-:pgp-email-list))
+
+ (tinypgpd "update-mail-abbrevs 4:")
+ (setq tinypgp-:pgp-email-list-completions
+ (ti::list-to-assoc-menu list))
+
+ nil))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-update-mail-abbrevs-hook ()
+ "Reparse the ~/.mailrc file when it is saved.
+This function is installed into `write-file-hooks'."
+ (when (string-match "\\.mailrc" (or buffer-file-name "#noName"))
+ (message "Updating mail abbrevs for TinyPgp...")
+ (tinypgpd "update-mail-abbrevs-hook in:")
+ (tinypgp-update-mail-abbrevs)
+ (message "Updating mail abbrevs for TinyPgp...done")
+ nil)) ;Hook return value
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-invisible-region (beg end &optional show)
+ "Make BEG END invisible. Optionally SHOW it."
+ ;; We also say that these properties belong to "tinypgp"
+ (let* (buffer-read-only) ;allow writing
+ (with-buffer-modified
+ (if (null show)
+ (set-text-properties beg end '(invisible t owner tinypgp))
+ (set-text-properties beg end '(invisible nil owner tinypgp))))))
+
+;;}}}
+;;{{{ misc: test-p, or or primitives
+
+;;; ........................................................... &tests ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-pgp-encrypted-p-default ()
+ (let (stat)
+ ;; this function returns symbol, convert it to string
+ (save-excursion
+ (ti::pmin)
+ (if (setq stat (ti::mail-pgp-data-type))
+ (symbol-name stat)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-password-time-valid-p ()
+ "Return non-nil, if it's not yet time to forget password.
+The returned value is number of seconds left."
+ (let* (secs-was
+ secs-now
+ diff
+ val)
+ (cond
+ ((not (integerp tinypgp-:password-keep-time))
+ nil)
+ (t
+ (if (null (tinypgp-hash 'password-time 'get 'tick nil 'global))
+ (tinypgp-hash 'password-time 'put 'tick (current-time) 'global))
+
+ (setq val (tinypgp-hash 'password-time 'get 'tick nil 'global)
+ secs-was (nth 1 val)
+ secs-now (nth 1 (current-time))
+ diff (- secs-now secs-was)
+ diff (- tinypgp-:password-keep-time diff))
+
+;;; (ti::d! diff)
+
+ (if (> diff 0)
+ ;; How much is left, counts down...
+ diff)))))
+
+;;}}}
+;;{{{ misc: email and substitutions
+
+;;; ........................................................... &email ...
+
+(defvar tinypgp-:email-substitution-table nil
+ "Where this variable is used:
+
+ Change email addresses if needed to get right public key.
+
+ Say, the PGP key-id shows <foo@site.com> as email, but the person also
+ has mailing address <foo@x-site.com>. If we receive mail from
+ foo@x-site.com, PGP wouldn't find it from the database if we used
+ that. Instead we must immediately tell 'hey, this person is known as
+ <foo@site.com>' which is listed in his key-id field.
+
+How this variable is used:
+
+ List of email substitution. When REGEXP is matches then SUBST is used.
+ SUBST is should match unique key entry in your keyrings. Best if
+ SUBST is 0xFFFF key id, but many times it more descriptive to use
+ alternative email address.
+
+Where this variable is used
+
+ In function `tinypgp-email-substitution-default' which is installed
+ to `tinypgp-:read-email-after-hook'
+
+Example:
+
+ WE CHANGE THIS VARIABLE WITH FUNCTION `tinypgp-email-substitution-add'
+
+ ;; List of email addresses that are not in the person's pgp-key id
+ ;; Use the right Hand key when left hand matches.
+
+ (defconst my-:tinypgp-email-substitution-table
+ (list
+ (cons \"xxx@.*lycaeum\" \"yyy@lycaeum.org\")
+ (cons \"xxx.*jena.de\" \"zzz.foo@Jena.Thur.De\")
+
+ ;; This one has multiple keys and we want to use one particular.
+ ;; The 0xFFFF is unique way to tell which key to use
+
+ (cons \"valkyr\" \"0xA73B5E6D\"))
+ \"*My email substitutions that will be added to
+ `tinypgp-:email-substitution-table'\")
+
+ ;; Now add my substitutions
+
+ (tinypgp-email-substitution-add my-:tinypgp-email-substitution-table)
+
+Format:
+ '((REGEXP SUBST) (R S) ..)")
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-email-make-choices (email)
+ "Make new choices from EMAIL.
+If you try to encrypt with EMAIL and it fails; it may be
+the case that the email address is not added to user's PGP key-id field.
+
+This function examines EMAIL and constructs some suitable
+choices that may match better when doing new lookup.
+
+Return:
+ nil
+ (\"string\"
+ ..)"
+ (let* (list
+ str
+ s1
+ s2)
+
+ ;; firstname.surname@site.com --> "Firstname Surname"
+
+ (when (string-match "^\\(.*\\)\\.\\(.*\\)@" email)
+ (setq s1 (capitalize (match-string 1 email))
+ s2 (capitalize (match-string 2 email)))
+
+ ;; Because the firsh name may be shortened
+ ;; "Rich" is actually "Richard", we want to add the surname
+ ;; by it self to the list too
+
+ (push (concat s1 " " s2) list)
+ (push s2 list))
+
+ ;; many times the 'server' is local and is not
+ ;; included in the key id
+ ;;
+ ;; @server.domain.here.com --> "domain.here.com"
+
+ (if (setq str (ti::string-match "@[^.]+\\.\\(.*\\..*\\)" 1 email))
+ (push str list))
+
+ list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-email-discard-default (list)
+ "Toss away addresses from LIST that are not finger sites.
+
+In-Reply-To: <199611101605.LAA18736@site.com> from Foo Bar at..
+X-Face: >>@YIrj6h"
+ (let (ret)
+ (tinypgpd "tinypgp-email-discard-default in: " list )
+
+ (when list
+ (dolist (elt (ti::list-make list))
+ (when (and (not (string-match
+ (concat
+ "\\(19[89][0-9]\\|200[0-9]\\)[0-9][0-9]"
+ "\\|^foo\\|^ba[zr]@\\|@site.com"
+ "\\|[^-_0-9a-zA-Z+]@")
+ elt))
+ ;; leave only real email addresses
+ (string-match "@" elt))
+ (push elt ret))))
+ (tinypgpd "tinypgp-email-discard-default out: " ret )
+ (if ret
+ (nreverse ret))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-email-substitution-add-1 (cons-cell &optional remove)
+ "Add new CONS-CELL (RE . SUBST) to `tinypgp-:email-substitution-table'.
+IF REMOVE is non-nil, search for SUBST and delete the entry
+from the table.
+
+Return:
+ killed entry
+ added entry
+ nil ;already exist(add) or not exist(remove)"
+ (let* (elt
+ ret)
+ (setq elt (rassoc (cdr cons-cell) tinypgp-:email-substitution-table))
+ (cond
+ (remove
+ (when elt
+ (setq tinypgp-:email-substitution-table
+ (delete elt tinypgp-:email-substitution-table))
+ (setq ret elt)))
+
+ ((null elt) ;Add new element if not there.
+ (setq ret cons-cell)
+ (push cons-cell tinypgp-:email-substitution-table)))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-email-substitution-add (cons-list &optional remove)
+ "Add CONS-LIST or REMOVE it from list of email substitutions.
+The CONS-LIST must be in format:
+
+'((RE . SUBST) (R . S) ..)"
+
+ (mapcar
+ (function
+ (lambda (x)
+ (tinypgp-email-substitution-add-1 x remove)))
+ cons-list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-email-substitution-default (list)
+ "Check LIST of email addresses and subtitute them with suitable pgp-ids.
+`tinypgp-:email-substitution-table' takes precedence over BBDB record `pgp-id'.
+
+References:
+ `tinypgp-:email-substitution-table'
+ `tinypgp-:read-email-after-hook'."
+ (let* (re
+ subst
+ bbdb-pgp-id
+ ret)
+ (dolist (email (ti::list-make list))
+
+ (dolist (elt tinypgp-:email-substitution-table)
+ (setq re (car elt) subst (cdr elt))
+ (cond
+ ((string-match re email)
+ (setq email subst) ;; substitute and stop loop
+ (return))
+ ((setq bbdb-pgp-id (tinypgp-bbdb-id email))
+ (setq email bbdb-pgp-id)
+ (return))))
+
+ (push email ret))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-email-substitution-toggle (&optional mode)
+ "Toggle email substitution.
+It is possible that you have coded an email substitution function
+and installed it into `tinypgp-:read-email-after-hook'.
+
+If there is such a function; it probably converts some email addresses
+to some relevant PGP key ids. However sometimes you may want to turn
+off this feature completely to be sure that when reading the
+email address eg from TO: field, it will also be used when calling
+for encryption.
+
+This functions toggles email substitution functions on/off by
+clearing/restoring the `tinypgp-:read-email-after-hook'
+
+MODE can be
+ nil toggle
+ 0 -1 off
+ other on"
+ (interactive)
+ (let* ((sym 'tinypgp-:read-email-after-hook))
+
+ ;; Not recorded; record original value
+
+ (if (null (get sym 'original))
+ (put sym 'original (symbol-value sym)))
+
+ (cond
+ ((or (memq mode '(0 -1))
+ (symbol-value sym))
+ (set sym nil)
+ (message "Email substitution off."))
+ (t
+ (set sym (get sym 'original))
+ (message "Email substitution restored to original.")))
+
+ (tinypgp-update-modeline)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-key-id-conversion (single-or-list)
+ "Modify SINGLE-OR-LIST and return possibly modified list.
+Function is used to convert any email address in the list to a suitable pgp
+key-id that can be used in place of the 'email' string.
+
+This function stores the list to hash table and reads the
+conversion from there if it exist in symbol 'key-id property
+'conversion.
+
+References:
+
+ `tinypgp-:read-email-after-hook'"
+ (let* ((fid "tinypgp-key-id-conversion: ")
+ ;; Make hash access key property
+ (prop (when single-or-list
+ (make-symbol
+ (mapconcat
+ 'concat
+ (ti::list-make single-or-list)
+ ""))))
+ val)
+
+ ;; Because you use the key-id conversion in the program all the
+ ;; time (called multiple times) and the conversion will
+ ;; always be same, we save the converted list into hash table
+ ;; for later use.
+ ;;
+ ;; 1. the hash-key is all list strings concatenated
+ ;; together "me@foo.siteyou@bar.site"
+ ;;
+ ;; 2. If that hash entry is not found, then we call conversion
+ ;; function and store the result to hash
+ ;;
+ ;; 3. Next time the conversion is already available for us
+ ;; from quick cache.
+ ;;
+ ;; This should result faster response, becuse calling hook
+ ;; functions is real slow.
+
+ (tinypgpd fid 'KEY prop 'LIST single-or-list)
+
+ (when single-or-list
+ (cond
+ ((tinypgp-hash 'key-id-conversion 'def prop)
+ (when (setq val (tinypgp-hash 'key-id-conversion 'get prop))
+ (setq single-or-list val))
+ (tinypgpd fid 'HASH single-or-list))
+ (t
+ (tinypgpd fid 'HOOK tinypgp-:read-email-after-hook)
+ (dolist (func (ti::list-make tinypgp-:read-email-after-hook))
+ (setq single-or-list (funcall func single-or-list)))
+
+ (tinypgp-hash 'key-id-conversion 'put prop single-or-list)
+ (tinypgpd fid 'OUT single-or-list))))
+
+ (when single-or-list
+ (ti::list-make single-or-list))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-key-id-conversion-check ()
+ "Return non-nil if the the conversion happens on TO field.
+To field must contain only one address."
+ (let* (elt)
+ (when (ti::mail-mail-p)
+ ;; Will conversion happen?
+ ;; - To field must have something
+ ;; - there must be only one email
+ ;; - the conversion has changed email.
+ (cond
+ ((and (not (ti::nil-p (setq elt (mail-fetch-field "To"))))
+ (not (string-match "," elt))
+ (not (string= elt (or (car-safe (tinypgp-key-id-conversion elt))
+ ""))))
+ (or (car-safe (tinypgp-key-id-conversion elt))
+ ""))
+ (t
+ nil)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-key-id-conversion-check-verbose ()
+ "Check if email address conversion is about to happen in To field."
+ (interactive)
+ (let* (stat)
+ (cond
+ ((null (ti::mail-mail-p))
+ (message "Email conversion: not a mail buffer, can't read To field."))
+ (t
+ (setq stat (tinypgp-key-id-conversion-check))
+ (cond
+ ((null tinypgp-:read-email-after-hook)
+ (message "You have turned off Email conversion mode. %s"
+ (if stat (format "[cnv: %s" stat))))
+ (t
+ (if stat
+ (message "Conversion to: %s" stat)
+ (message "No Email conversion trigges"))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-key-id-find ()
+ "Try to find 'Id' 0x12345678 from current buffer. X-Pgp is searched first."
+ (let* ((list (tinypgp-xpgp-get-info))
+ elt
+ ret)
+ (cond
+ ((and list ; Id=0xF72ED579;
+ (setq elt (assoc "id" list)))
+ (setq ret (nth 1 elt)))
+ (t ;No other methods yet.
+ nil))
+ ret))
+
+;;}}}
+
+;;{{{ buffer: generate, show
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-ti::temp-buffer (&optional choice arg1 arg2 arg3)
+ "Create tmp buffer for TinyPgp.el. CHOICE ARG1 ARG2 ARG3 are internal."
+ (let ((fid "tinypgp-ti::temp-buffer:")
+ mail-setup-hook ;No hooks now (slow) !
+ mail-mode-hook
+ message-mode-hook
+ buffer)
+ (tinypgpd fid choice arg1 arg2 arg3)
+
+ ;; ByteComp silencer, this is no-op
+ (if mail-setup-hook (setq mail-setup-hook nil))
+ (if mail-mode-hook (setq mail-setup-hook nil))
+
+ (setq
+ buffer
+ (cond
+ ((eq choice 'shell)
+ (ti::temp-buffer tinypgp-:buffer-tmp-shell 'clear))
+
+ ((eq choice 'copy)
+ (ti::temp-buffer tinypgp-:buffer-tmp-copy 'clear))
+
+ ((eq choice 'article)
+ (ti::temp-buffer tinypgp-:buffer-tmp-article 'clear))
+
+ ((eq choice 'finger)
+ (ti::temp-buffer tinypgp-:buffer-tmp-finger 'clear))
+
+ ((eq choice 'http)
+ (ti::temp-buffer tinypgp-:buffer-tmp-http 'clear))
+
+ ((eq choice 'kring)
+ (ti::temp-buffer tinypgp-:buffer-tmp-kring 'clear))
+
+ ((eq choice 'show)
+ (ti::temp-buffer tinypgp-:buffer-tmp-show 'clear))
+
+ ((eq choice 'mail)
+ (ti::kill-buffer-safe tinypgp-:buffer-tmp-mail)
+ (setq buffer (ti::temp-buffer tinypgp-:buffer-tmp-mail 'clear))
+ (with-current-buffer buffer
+ (setq tinypgp-:hash nil) ;Clear hash array
+ (mail-mode)
+ ;; to subject in-reply-to cc replybuffer actions
+ ;;
+ (mail-setup arg1 arg2 nil arg3 nil nil))
+ (tinypgpd fid "MAIL OUT")
+ buffer)
+
+ ((null choice)
+ (ti::temp-buffer tinypgp-:buffer-tmp 'clear))
+ (t
+ (error "TinyPgp: No such mode '%s'" choice))))
+
+ (with-current-buffer buffer
+ (defconst font-lock-mode nil)
+ (defconst lazy-lock-mode nil)
+ ;; one time scratch buffer
+ (buffer-disable-undo (current-buffer)))
+
+ buffer))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-show-buffer-general (type)
+ "Pop to buffer TYPE."
+ (let ((buffer
+ (cond
+ ((eq type 'comint) (tinypgp-comint-buffer))
+ ((eq type 'debug) tinypgp-:debug-buffer)
+ ((eq type 'finger) tinypgp-:buffer-tmp-finger)
+ ((eq type 'http) tinypgp-:buffer-tmp-http)
+ ((eq type 'shell) tinypgp-:buffer-tmp-shell)
+ ((eq type 'tmp) tinypgp-:buffer-tmp))))
+ (cond
+ ((null buffer)
+ (error "TinyPgp: Wrong type '%s' " type))
+ ((get-buffer buffer)
+ (pop-to-buffer buffer))
+ (t
+ (message "Buffer does not exist: '%s'" buffer)))))
+
+(defun tinypgp-show-buffer-comint ()
+ "Show buffer."
+ (interactive) (tinypgp-show-buffer-general 'comint))
+
+(defun tinypgp-show-buffer-debug ()
+ "Show buffer."
+ (interactive) (tinypgp-show-buffer-general 'debug))
+
+(defun tinypgp-show-buffer-finger ()
+ "Show buffer."
+ (interactive) (tinypgp-show-buffer-general 'finger))
+
+(defun tinypgp-show-buffer-http ()
+ "Show buffer."
+ (interactive) (tinypgp-show-buffer-general 'http))
+
+(defun tinypgp-show-buffer-shell ()
+ "Show buffer."
+ (interactive) (tinypgp-show-buffer-general 'shell))
+
+(defun tinypgp-show-buffer-tmp ()
+ "Show buffer."
+ (interactive) (tinypgp-show-buffer-general 'tmp))
+
+;;}}}
+;;{{{ pubring: misc
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-pubring-elt ()
+ "Return active pubring ELT."
+ (let* ((ring (tinypgp-expand-file-name tinypgp-:pubring-now))
+ kring
+ ret)
+ (dolist (elt (tinypgp-pubring-table))
+ (setq kring (nth 1 elt))
+ (cond
+ ((stringp kring)
+ ;; Second element must be filename string
+ (when (string= ring (tinypgp-expand-file-name kring))
+ (setq ret elt)
+ (return)))
+ (t
+ (error "Invalid format: tinypgp-:pubring-table, please check."))))
+
+ (unless ret
+ (error "tinypgp-:pubring-table, can't find tinypgp-:pubring-now?"))
+
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-pubring-ask (&optional msg)
+ "Ask pubring with MSG and offer 'alias' completion.
+
+Return:
+ nil
+ pubring file"
+ (let (ret)
+ (setq ret
+ (tinypgp-pubring-complete
+ (if msg
+ msg
+ (format
+ "Ok to use pubring '%s' [ret=yes]? "
+ (or (tinypgp-pubring-file2alias tinypgp-:pubring-now)
+ "<unknown>")))))
+
+ (if (not (ti::nil-p ret))
+ (setq ret (tinypgp-pubring-alias2file ret))
+ (setq ret nil))
+
+ (tinypgpd "tinypgp-pubring-ask out: " ret )
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-pubring-in-use-confirm ()
+ "Change pubring if it is not the first entry in `tinypgp-pubring-table'.
+Ask confirmation for the change. The calling
+function should bound variable `tinypgp-pubring-table' locally,
+because it may be changed here.
+
+References:
+ `tinypgp-save-state-macro'"
+ (let ((first (tinypgp-expand-file-name
+ (nth 1 (car (tinypgp-pubring-table)))))
+ (now (tinypgp-expand-file-name tinypgp-:pubring-now)))
+ (when (not (string= first now))
+ (setq now (tinypgp-pubring-ask))
+ (when now
+ (setq tinypgp-:pubring-now now)
+ (tinypgpd "tinypgp-pubring-in-use-confirm out: "
+ tinypgp-:pubring-now)))))
+
+;;}}}
+;;{{{ pubring: interactive
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-pubring-display ()
+ "Show current pubring in use."
+ (interactive)
+ (message "Current pubring: %s" tinypgp-:pubring-now)
+ (sit-for 1)) ;; If drawn from menu, the mouse move wipes it away..
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-pubring-set-current (alias)
+ "Set active pubring using ALIAS and update mode line."
+ (interactive (list (tinypgp-pubring-complete "Set active pubring to: ")))
+ (when alias
+ (setq tinypgp-:pubring-now
+ (tinypgp-expand-file-name (nth 1 (assoc alias
+ (tinypgp-pubring-table)))))
+
+ (if (not (file-exists-p tinypgp-:pubring-now))
+ (error "No pubring file %s" tinypgp-:pubring-now))
+
+ (tinypgpd "tinypgp-pubring-set-current out: " alias tinypgp-:pubring-now)
+
+ (tinypgp-update-modeline)
+ (if (interactive-p)
+ (tinypgp-pubring-display))))
+
+;;}}}
+;;{{{ user: general, interactive
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-user-in-use-confirm (&optional msg)
+ "Change user if Primary user is not active ask confirmation with MSG."
+ (let (ans)
+ (setq msg
+ (or
+ msg
+ "Not primary, change user id to [empty = no change]: "))
+ (if (and (not (string-match
+ (regexp-quote tinypgp-:user-primary) tinypgp-:user-now))
+ (not
+ (ti::nil-p
+ (setq ans (read-from-minibuffer msg tinypgp-:user-now)))))
+ (setq tinypgp-:user-now ans))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-user-display ()
+ "Show active user."
+ (interactive)
+ (ti::read-char-safe-until (concat "Current user: " tinypgp-:user-now)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-user-set-current (user)
+ "Set active USER."
+ (interactive
+ (list
+ (completing-read
+ (format "[%s] Set pgp user to: " tinypgp-:user-now)
+ tinypgp-:pgp-email-list-completions
+ nil nil nil
+ 'tinypgp-:history-email)))
+
+ (if (ti::nil-p user)
+ (error "Invalid input."))
+
+ (setq tinypgp-:user-now user)
+ (if (interactive-p)
+ (tinypgp-user-display)))
+
+;;}}}
+;;{{{ key: handling
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-key-cache (mode &optional data1 data2 data3)
+ "Function to control caching of key-id and.
+The cache hook tells if the entry should be cached when MODE is 'put
+
+When inserting new keys into cache, every 3rd key triggers saving
+the cache to disk.
+
+References:
+
+ `tinypgp-:key-cache'
+ `tinypgp-:key-cache-last'
+
+Input MODE:
+
+ 'get look for data1 from cache and return cache entry or nil
+ 'put cache entries data1, data2, data3
+ 'del remove named entry from cache. Do nothing if no such entry.
+
+Data arguments:
+
+ DATA1 DATA2 DATA3
+
+Return:
+
+ nil
+ cache entry"
+ (let ((last tinypgp-:key-cache-last)
+ (data1-orig data1) ;Email may be changed
+ (debug nil) ;developer's manual debug flag
+ (fid "tinypgp-key-cache: ")
+ ret)
+
+ ;; The cache is used only if user has multiple pubrings
+ (when (tinypgp-pubring-many-p)
+
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. fast case . .
+ ;; Remember that modeline calls us many times
+
+ (cond ;Is the entry in QUICK cache?
+ ((and last ;bypass everything if we find it
+ (eq mode 'get) ;many time we call 'get successively
+ (string= (car last) data1))
+ (setq ret (nth 1 (nth 1 last)))
+
+ (if debug
+ (tinypgpd fid "fast get" data1 ret )))
+
+ (t
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. . normal case ..
+
+;;; (ti::d! "C in: " mode data1 data2)
+
+ (setq data1 (ti::remove-properties data1))
+
+ (if data2
+ (setq data2 (ti::remove-properties data2)))
+
+ (if debug
+ (tinypgpd fid "in:" 'MODE mode 'DATA1 data1 'DATA2 data2))
+
+;;; (ti::d! "Cache name>>" data1 data2)
+
+ ;; Note: I used elp.el to check if the obarray method
+ ;; would be faster, but it seems that at least for single entry
+ ;; the list implementation is faster? I was suprised..
+
+ (if (not (listp tinypgp-:key-cache)) ;make sure this is a list
+ (setq tinypgp-:key-cache nil))
+
+ (cond
+
+ ((eq mode 'get)
+ (when (setq ret (assoc data1 tinypgp-:key-cache))
+ (setq tinypgp-:key-cache-last (list data1-orig ret))
+ (setq ret (nth 1 ret))))
+
+ ((eq mode 'del)
+ (if (setq ret (assoc data1 tinypgp-:key-cache))
+ (adelete 'tinypgp-:key-cache (car ret))))
+
+ (t
+ (if (and (null (assoc data1 tinypgp-:key-cache)) ;; Already there ?
+ (< (length tinypgp-:key-cache) 300)) ;Hard limit
+ (push (list data1 data2 data3) tinypgp-:key-cache ))
+
+ ;; Save every 3rd new entry.
+
+ (if (eq (% (length tinypgp-:key-cache) 3) 0)
+ (tinypgp-key-cache-save)))))))
+
+ (if debug
+ (tinypgpd fid "out: RET" ret))
+
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-key-cache-save (&optional load)
+ "Save or LOAD the key cache file.
+If the underlying cache file has recent copy; the SAVE is not
+performed, but the newer copy reloaded and evaluated.
+
+Signal no erro if LOAD cannot find cache file."
+ (let* ((fid "tinypgp-key-cache-save:")
+ (file (or (tinypgp-backend-file tinypgp-:file-key-cache)
+ (error "TinyPgp: Internal cache error")))
+ (list tinypgp-:key-cache)
+ (len (length list))
+ (olen (tinypgp-hash 'cache 'get 'len nil 'global))
+ buffer
+ done)
+ (tinypgpd fid "in: FILE" file 'LEN len 'OLEN olen 'LOAD-FLAG load)
+
+ (cond
+ (load
+ (when (file-exists-p file)
+ (with-current-buffer (find-file-noselect file)
+ (if (fboundp 'eval-buffer) ;XE 19.14
+ (ti::funcall 'eval-buffer)
+ (ti::funcall 'eval-current-buffer))
+ (setq done t))))
+
+ ;; ......................................................... save ...
+ (t
+ ;; There may be several emacsen running, and they may have saved the
+ ;; cache too. Reload the file if it is newer that the buffer
+ ;; in this emacs (it has been saved by some other emacs)
+
+ (when (and (buffer-live-p (setq buffer (find-buffer-visiting file)))
+ (with-current-buffer buffer (ti::file-changed-on-disk-p)))
+ (with-current-buffer buffer
+ (revert-buffer t t) ;No confirmations
+ (if (fboundp 'eval-buffer) ;XE 19.14
+ (ti::funcall 'eval-buffer)
+ (ti::funcall 'eval-current-buffer)
+ (setq done t))))
+
+ (when (and (null done)
+ ;; Something to save? Has Length changed
+ (or (not (eq len olen))
+ ;; Not yet saved?
+ (not (file-exists-p file))))
+ (tinypgp-hash 'cache 'put 'len len 'global)
+ (with-current-buffer (find-file-noselect file)
+ (erase-buffer)
+ (insert ";;\n;;\tEmacs TinyPgp.el: key cache file\n;;\n\n")
+ (insert "(defconst tinypgp-:key-cache\n '(\n")
+ (dolist (elt list) (insert " " (prin1-to-string elt) "\n"))
+ (insert " ))\n\n;; End of file\n")
+ (save-buffer)))))
+ done))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-key-cache-display (&optional verb)
+ "Print contents of cache. VERB."
+ (interactive)
+ (tinypgp-key-cache-save) ;; Save latest first
+ (let* ((fid "tinypgp-key-cache-display:")
+ (file (tinypgp-backend-file tinypgp-:file-key-cache))
+ (buffer (or (find-buffer-visiting file)
+ (and (file-exists-p file)
+ (find-file-noselect file)))))
+ (tinypgpd fid file buffer)
+ (if (null buffer)
+ (error "Can't display %s" file)
+ (display-buffer buffer))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-key-cache-remove-entry-last ()
+ "Clear last fast cache entry."
+ (interactive)
+ (setq tinypgp-:key-cache-last nil)
+ (if (interactive-p)
+ (message "Cleared last cache entry.")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-key-cache-remove-entry (string &optional raw-entry)
+ "Read email addresses from string and remove it from cache.
+
+Input:
+ STRING String ==> email address is picked from it
+ RAW-ENTRY if nono-nil, then bypass call to
+ `tinypgp-:read-email-after-hook' which may change the string"
+ (let* ((fid "tinypgp-key-cache-remove-entry: ")
+ list)
+ (tinypgpd fid "in:" raw-entry string )
+
+ (when (tinypgp-pubring-many-p)
+
+ (cond
+ (raw-entry
+ (tinypgp-key-cache 'del string))
+
+ (t
+ (or (setq list (ti::mail-email-from-string string))
+ (setq list (list string)))
+ (dolist (elt list)
+ (when elt ;; Should we change the keyId that is read from field?
+ (setq elt (car (tinypgp-key-id-conversion elt))))
+ (tinypgp-key-cache 'del elt))))
+ ;; Clear fast cache
+ (tinypgp-key-cache-remove-entry-last))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-key-generate
+ (key-bit-choice user-id pass-phrase &optional verb)
+ "Generate new key. Only default key sizes are supported.
+
+Input:
+ KEY-BIT-CHOICE 1,2 or 3
+ USER-ID
+ PASS-PHRASE
+ VERB"
+ (interactive
+ (let* ((key-list
+ '(("512" 1)
+ ("768" 2)
+ ("1024" 3)))
+ key
+ user
+ pass
+ ans)
+
+ (setq key (completing-read "Key size: " key-list nil 'match-it "768"))
+ (if (null (setq key (tinypgp-alias2name key key-list)))
+ (error "No key choice found."))
+
+ (setq user (read-from-minibuffer "User id for your public key: "))
+ (if (ti::nil-p user)
+ (error "Empty user id."))
+
+ (setq pass (ti::compat-read-password "Pass phrase: "))
+ (if (ti::nil-p pass)
+ (error "Empty pass phrase"))
+
+ (list key user pass)))
+
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... ... ... body . .
+
+ (if (not (and (memq key-bit-choice '(1 2 3))
+ (stringp user-id)
+ (stringp pass-phrase)))
+ (error "Arg error."))
+
+ (let* ( ;; (BCMD (tinypgp-binary-get-cmd 'key-generate))
+ ;; (cmd (tinypgp-cmd-compose BCMD user-id pass-phrase))
+ ret)
+ (ti::verb)
+ (tinypgp-unfinished-function)
+
+ (tinypgp-save-state-macro
+ (if verb (tinypgp-pubring-in-use-confirm)))
+
+ (if verb
+ (message "Generating new user-id...done."))
+
+ ret))
+
+;;}}}
+
+;;{{{ misc: auto-action
+
+;;; ..................................................... &auto-action ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-auto-action-on-modeline-p ()
+ "Check if mode line string say that auto action in 'on'."
+ (and (stringp tinypgp-:mode-name)
+ (string-match "!$\\|!k" tinypgp-:mode-name)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-auto-action-on-p ()
+ "Check is user has allowed action and if action exists."
+ ;; There is no auto action for read only buffer like RMAIL
+ (tinypgpd "tinypgp-auto-action-on-p: "
+ tinypgp-mode
+ (tinypgp-hash 'auto-action 'def 'user-mode)
+ (tinypgp-hash 'auto-action 'get 'user-mode))
+
+ (when (and (null buffer-read-only)
+ tinypgp-mode)
+ (unless (tinypgp-hash 'auto-action 'def 'user-mode)
+ ;; Not defined, initialize
+ (tinypgpd "tinypgp-auto-action-on-p: SET DEFAULT")
+ (tinypgp-hash 'auto-action 'put 'user-mode t))
+ (tinypgp-auto-action-p 'read-hash)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-auto-action-defeat-p ()
+ "Check if auto action should be cancelled."
+ ;; Forget mime multiparts/PGP signed.
+ (ti::mail-mime-maybe-p))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-auto-action-verbose ()
+ "Show auto-action entry to user.
+If auto action is found it is also available from `tinypgp-:register'."
+ (interactive)
+ (let* (elt)
+ (tinypgpd "tinypgp-auto-action-verbose in:")
+
+ (cond
+ ((ti::mail-mime-maybe-p)
+ (message "TinyPgp; Looks like MIME message, no auto action allowed"))
+
+ ((tinypgp-auto-action-multiple-addresses-p 'force)
+ (message "TinyPgp; encryption to multiple recipients pending."))
+
+ ((setq elt (tinypgp-auto-action-p))
+ (message "TinyPgp; Auto-action triggers: %s" (prin1-to-string elt))
+ (set-register tinypgp-:register (prin1-to-string elt)))
+
+ (t
+ (message "TinyPgp; There is no auto action that would activate.")))
+ (tinypgp-update-modeline)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-auto-action-update-modeline ()
+ "Do auto action check and update mode line."
+ (tinypgp-auto-action-p)
+ (tinypgp-update-modeline))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-auto-action-p (&optional read-hash)
+ "Check if auto-action entry is defined for current (email) buffer.
+If buffer is read only, this does nothing.
+Any MIME message in buffer suppresses auto-action.
+
+Note:
+
+ Multiple recipients are not checked, Only To address.
+ See `tinypgp-auto-action-multiple-addresses-p' for that.
+
+References:
+
+ `tinypgp-:auto-action-table'
+
+Input:
+
+ READ-HASH non-nil instructs to read the value
+ from storage, if the TO: address hasn't changed.
+ This is faster than evaluating the list every time.
+
+Return:
+
+ elt entry from action table"
+ (let ( ;; (EVAL-OR-STRING SIGN-FLAG [ENCRYPT-FLAG] [KEYRING])
+ (fid "tinypgp-auto-action-p: ")
+ (tbl tinypgp-:auto-action-table)
+
+ ;; We don't enable this because timer calls us
+ ;; Only when we debug the function
+
+ (debug t)
+
+ ;; These tags must be broken in this file so that TM won't get upset
+ ;; seeing them
+ ;;
+ ;; -- } - <<signed>>
+ ;; -- } - <<encrypted>>
+
+ (mime-p (ti::re-search-check "--[}]-<<"))
+
+ user-mode
+ to-field
+ val
+ ret)
+
+ ;; This function is called from a timer process to update the
+ ;; modeline, that's why we can't afford to rescan the auto-action
+ ;; list all the time: it takes too much time.
+ ;;
+ ;; Instead, we store the found ACTION to hash table and read the
+ ;; hash entry. The drawback is that if user goes and changes
+ ;; the auto action table, we can't tell about it in the modeline.
+ ;;
+ ;; Used local hash properties on variable 'auto-action
+ ;; 'user-mode bool t = ok, nil = defeated by user
+ ;; 'to-field string to field contents
+ ;; 'elt lisp stored auto action.
+
+ ;; If not yet defined, set the auto action to 't'
+ ;; User may defeat the action manually.
+
+ (if (tinypgp-hash 'auto-action 'def 'user-mode)
+ (setq user-mode (tinypgp-hash 'auto-action 'get 'user-mode))
+ (tinypgp-hash 'auto-action 'put 'user-mode t)
+ (setq user-mode t))
+
+ ;; Should always be a string otherwise lot of code breaks.
+
+ (unless (stringp tinypgp-:user-now)
+ (message "\
+Tinypgp: Warning, tinypgp-:user-now is not a string. Fixing...")
+ (sit-for 1)
+ (setq tinypgp-:user-now (user-login-name)))
+
+ ;; TO FIELD: see what we have in the hash table
+
+ (setq val (tinypgp-hash 'auto-action 'get 'to-field))
+
+ (when debug
+ (tinypgpd fid
+ "read-only" buffer-read-only
+ "USER-MODE" user-mode
+ "mail" (ti::mail-mail-p)
+ "pgp" (ti::mail-pgp-p)
+ "MIME" (ti::mail-mime-maybe-p) mime-p
+ "remail" tinypgp-:r-mode-indication-flag
+ "READ HASH" read-hash
+ "to-field hash" val
+ "to-field" (mail-fetch-field "to")))
+
+ (when (and (ti::mail-mail-p)
+ (null buffer-read-only)
+ (cond
+ ((or (ti::mail-mime-maybe-p) mime-p)
+ ;; MIME found, defeat auto action immediately.
+ ;;
+ (tinypgp-hash 'auto-action 'put 'elt nil)
+ nil)
+ (t t))
+ ;;
+ ;; only if there is no previous PGP,
+ ;; If there is PGP, let go through is there is
+ ;; remailer message Eg. newnym account create where
+ ;; you send you PGP key in buffer.
+ ;;
+ (if (ti::mail-pgp-p)
+ (if tinypgp-:r-mode-indication-flag
+ t nil)
+ t)
+
+ (not (ti::nil-p (setq to-field (mail-fetch-field "to"))))
+ (not (string-match "," to-field)) ;skip multiple addresses
+ (ti::nil-p (mail-fetch-field "cc")))
+
+ ;; .................................................. hash check ...
+
+ (cond
+ ((and read-hash
+ val ;previous TO field in HASH ?
+ (string= to-field val)) ;compare previous with current TO
+ (setq val (tinypgp-hash 'auto-action 'get 'elt))
+ (when debug (tinypgpd fid "hash ret"))
+ (setq ret val))
+
+ ;; .................................................. raw check ...
+
+ (t
+
+ ;; Empty field with spaces does not come here
+ ;; To field has changed, we must calculate new entry
+ ;; OR the hash-get wasn't set.
+
+ (tinypgp-hash 'auto-action 'put 'to-field to-field)
+ (tinypgp-hash 'auto-action 'put 'elt nil)
+ (when debug (tinypgpd fid "evaluate"))
+
+ ;; First check BBDB entry
+
+ (setq ret (tinypgp-bbdb-entry))
+ (when debug (tinypgpd fid to-field "BBDB" ret))
+
+ ;; And this table overrrides bbdb
+
+ (dolist (elt tbl)
+ (setq val (nth 0 elt))
+ (when debug (tinypgpd fid "action tbl" val))
+ (when (or ;Try to match
+ (and (stringp val)
+ (string-match val to-field))
+ (and (symbolp val) (not (ti::bool-p val))
+ (eval val)))
+ (setq ret elt)
+ (return)))
+
+ (if ret
+ (tinypgp-hash 'auto-action 'put 'elt ret))))) ;Save it!
+
+ (if debug
+ (tinypgpd fid "RET" ret))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-auto-action ()
+ "Determine right auto action for mail message.
+If auto-action has been disabled or if `tinypgp-mode' is off, do nothing.
+
+References:
+
+ `tinypgp-:header-sign-table'
+ `tinypgp-:auto-action-table'
+ `tinypgp-:auto-action-defeat-hook'"
+ (tinypgpd "tinypgp-auto-action: function entry")
+ (let ((fid "tinypgp-auto-action: ")
+ (umode (tinypgp-hash 'auto-action 'get 'user-mode))
+ (multi-flag (tinypgp-auto-action-multiple-addresses-p 'force))
+ (pgp-p (ti::mail-pgp-p))
+ to-field
+ sign enc mime-mua xpgp keyr
+ email
+ len
+ elt)
+
+ (tinypgpd fid 'user-mode umode 'multi-flag multi-flag 'pgp-p pgp-p)
+
+ (when tinypgp-mode
+ (run-hooks 'tinypgp-:auto-action-before-hook)
+
+ (cond
+ ;; ............................................ user defeat ...
+
+ ((or pgp-p
+ (run-hook-with-args-until-success
+ 'tinypgp-:auto-action-defeat-hook))
+ (tinypgpd fid "defeated")
+ nil)
+
+ ;; ........................................... nymserver-cc ...
+
+ ((and (tinypgp-nymserver-mail-p)
+ (tinypgp-nymserver-send)) ;Maybe no multi-CC ?
+ (tinypgpd fid "Nymserver"))
+
+ ;; ............................................... defeated ...
+
+ ((not umode) ;User has defeated the action
+ (tinypgpd fid "Umode")
+ nil)
+
+ ;; ............................................ encrypt-to-many ...
+
+ (multi-flag
+ (tinypgpd fid "Multi")
+ (tinypgp-auto-action-multiple-addresses))
+
+ ;; ............................................ auto-action ...
+
+ ((and (not (ti::nil-p (setq to-field (mail-fetch-field "to"))))
+
+ ;; The Addresses must be expanded so that they have @
+
+ (string-match "@" to-field)
+
+ ;; Force reading real action. If user has made changes
+ ;; in his rc file; this guarrantees that we see them.
+
+ (setq elt (tinypgp-auto-action-p))
+
+ ;; returns a list of email strings
+
+ (setq email (ti::mail-email-from-string to-field)))
+
+ (tinypgpd fid "--Action--" 'TO to-field 'EMAIL email 'ELT elt)
+
+ (setq len (length elt)
+ sign (nth 1 elt)
+ keyr tinypgp-:pubring-now)
+
+ ;; Should we change the key-id that is read from field?
+
+ (setq email (car-safe (tinypgp-key-id-conversion email)))
+
+ ;; optional fields
+
+ (setq enc (if (> len 2) (nth 2 elt))
+ mime-mua (if (> len 3) (nth 3 elt))
+ xpgp (if (> len 4) (nth 4 elt))
+ keyr (tinypgp-expand-file-name
+ (cond
+ ((> len 5)
+ (nth 5 elt))
+ ((tinypgp-key-find-by-keyrings email))
+ (t
+ tinypgp-:pubring-now))))
+
+ ;; XE byteCompiler 19.14 has bug here, it reports that
+ ;; variable 'xpgp bound but not referenced, allthoug
+ ;; it is used in 'let' stement underneath! The following
+ ;; silences byteCompiler.
+
+ (if (null xpgp) (setq xpgp nil))
+
+ (tinypgpd fid "addr" email "ENC" enc "SIGN" sign "XP" xpgp
+ "KEY" keyr "MUA" mime-mua elt)
+
+ (when (and mime-mua
+ (null (ti::mail-mime-tm-featurep-p))
+ (null (ti::mail-mime-semi-featurep-p)))
+ (setq mime-mua nil)
+ (message "\
+Auto-action: PGP/MIME requested but no TM/SEMI mime support present.")
+ (sit-for 2))
+
+ (cond
+ (mime-mua
+
+ ;; These only add the TAGS into the buffer. SEMI/TM
+ ;; hook handles the actual work of turning then to PGP/MIME
+ ;; --> It calls TinyPgp to do it.
+
+ (if sign (ti::mail-mime-sign-region))
+ (if enc (ti::mail-mime-encrypt-region)))
+ (t
+ (tinypgp-save-state-macro
+ (if sign (setq tinypgp-:user-now
+ (if (and (not (ti::bool-p sign))
+ (symbolp sign)) ;One pass encrypt/sign
+ (symbol-name sign)
+ sign)))
+ (if keyr (setq tinypgp-:pubring-now keyr))
+ (setq tinypgp-:xpgp-signing-mode xpgp)
+
+ (tinypgpd fid "SIGN" sign "KEY" keyr tinypgp-:user-now "KRING" keyr)
+
+ ;; ............................................ do encrypt ...
+
+ (when enc
+ (when (and (not (ti::bool-p sign)) (symbolp sign))
+ (tinypgp-password-set
+ (format "[%s] Auto-action sign password: "
+ tinypgp-:user-now)))
+ (tinypgp-encrypt-mail
+ email
+ (not 'register-insert)
+ (if (and (not (ti::bool-p sign)) (symbolp sign))
+ '1pass)
+ nil
+ 'verb))
+
+ ;; ......................................... possibly sign ...
+
+ (when (and sign (stringp sign))
+ (tinypgp-password-set
+ (format "Auto-action, Sign pass phrase %s: " tinypgp-:user-now))
+
+ ;; The previous function call may have changed the user,
+ ;; keep the pubring also in sync
+
+ (tinypgp-pubring-change-to-current)
+ (call-interactively 'tinypgp-sign-mail))))))
+
+ ;; ........................................... auto-encrypt ...
+ ;; If there is no auto action, we check if we have previously
+ ;; encrypted to that person.
+
+ ((and (null (ti::mail-pgp-p)) ;No previsou pgp
+ (not (ti::nil-p (setq to-field (mail-fetch-field "to"))))
+ (setq elt
+ (tinypgp-key-find-by-cache
+ (car-safe (ti::mail-email-from-string to-field)))))
+ (tinypgpd fid "encrypt guess" to-field elt)))
+
+ ;; We actually do nothing here...but the code is ready
+ ;; (tinypgp-encrypt-mail email)
+
+ (tinypgpd fid "out:" (current-buffer))
+
+ ;; ..................................................... restore ...
+
+ ;; If this was nym create request, restore pgp user
+ ;; - If there are these buffer local variables and PGP msg found
+ ;; - If saver "now" is "now"; ie. user hasn't changed active user
+ ;; after the create request was started.
+ ;; - THEN restore the original pgp user
+
+ (when (and (boundp 'tinypgp-pgp-user-original)
+ (boundp 'tinypgp-pgp-user-now)
+ (ti::mail-pgp-p))
+ (let* ((orig (symbol-value 'tinypgp-pgp-user-original))
+ (now (symbol-value 'tinypgp-pgp-user-now)))
+ (if (string= now tinypgp-:user-now)
+ (setq tinypgp-:user-now orig))))
+
+;;; (ti::d! "AUTO-ACT done" email)
+ elt)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-auto-action-multiple-addresses-p (&optional force)
+ "Check multiple address auto-action. Optionally FORCE raw check."
+ (and (null (tinypgp-nymserver-mail-p))
+ (tinypgp-auto-action-multiple-addresses 'check force)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-auto-action-multiple-addresses (&optional mode force)
+ "Determine if multiple address encryption will be done.
+Function does nothing if buffer is read only
+
+Input:
+
+ MODE If 'check, then return nil or t if auto-action
+ is in progress. Any other value starts auto-encryption
+ if the conditions are met.
+
+ FORCE Force re-evaluating the buffer check (normally read result
+ from stored value in hash table)
+
+Return:
+
+ non-nil auto action in progress. All recipientsents have PGP
+ LIST '(email email ..) There were many recipients
+ but not all members members have PGP. This is list of email
+ addresses that had PGP.
+ nil
+
+References:
+
+ `tinypgp-:auto-action-encrypt-regexp'
+ `tinypgp-:auto-action-encrypt-ok-hook'"
+ (let* ((re tinypgp-:auto-action-encrypt-regexp)
+ (fid "tinypgp-auto-action-multiple-addresses: ")
+ (debug nil) ;func is Called by timer...
+ hsize-prev
+ hsize
+ list
+ len
+ ret
+ pgp-ok-list
+ pgp-nok-list)
+
+ ;; Because this function is called from timer process, the
+ ;; 'check must be very quick in order not to decrease
+ ;; emacs performance
+ ;;
+ ;; 'many-addr-hsize
+ ;; We count the length of the header area and put that value
+ ;; into property. If the size has changed, we reread
+ ;; the To,CC,BCC headers again and do the checking
+ ;;
+ ;; If the headers have not changed, then we don't do time
+ ;; consuming parse, but assume thet 'many-addr-hsize value
+ ;; is valid (No changes compared to last parse)
+ ;;
+ ;; 'many-addr-stat
+ ;; Holds value t or nil if auto action should be engaged.
+
+ (if debug (tinypgpd fid
+ "in: mode" mode
+ 'force force
+ 'mail (ti::mail-mail-p)
+ 'point (point) ))
+
+ (when (and (ti::mail-mail-p) ;Only do in mail buffers
+ (null buffer-read-only))
+ (setq hsize (ti::mail-header-area-size)
+ hsize-prev (tinypgp-hash 'auto-action 'get 'many-addr-hsize))
+
+ (when debug
+ (tinypgpd fid
+ 'hsize hsize
+ 'prev hsize-prev
+ (ti::mail-get-all-email-addresses
+ nil tinypgp-:pgp-email-abbrev-list)
+ "point"
+ (point)))
+
+ (if force (setq hsize nil hsize-prev 1)) ;Re-evaluate.
+
+ (cond
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .
+ ((and (eq hsize hsize-prev)
+ mode)
+ ;; return the precalculated status
+ ;;
+ (setq ret (tinypgp-hash 'auto-action 'get 'many-addr-stat))
+ (if debug (tinypgpd fid 'cond1-hash ret (point))))
+
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .
+
+ ((eq hsize hsize-prev) ;Not check mode, do action
+ (if debug (tinypgpd fid 'cond2-enc ret (point)))
+ (if (and (tinypgp-hash 'auto-action 'get 'many-addr-stat)
+ (not (ti::mail-pgp-p))) ;No previous pgp
+ (tinypgp-encrypt-mail-verbose)))
+
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. recalculate . .
+ ;; *) The size has changed, so update it immediately.
+ ;; *) put initial value into the property, because we may not enter
+ ;; the case at all if list is empty
+ ;;
+ ;; The rest of the 'and' are real tests
+
+ ((and (prog1 t
+ (tinypgp-hash 'auto-action 'put 'many-addr-hsize hsize)
+ (tinypgp-hash 'auto-action 'put 'many-addr-stat nil))
+ (setq list (ti::mail-get-all-email-addresses
+ nil tinypgp-:pgp-email-abbrev-list))
+ (> (setq len (length list)) 1))
+ (if debug (tinypgpd fid 'cond3 len list (point)))
+;;; (ti::d! "HZ" hsize (tinypgp-hash 'auto-action 'get 'many-addr-hsize))
+
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. do checking ..
+ ;; Is there regexp defined in the table ?
+
+ (when (stringp re)
+ ;; See if there is hit for all recipinets,
+ ;; then we want t'1o encrypt this mail.
+ ;;
+ ;; Other times; this may be just regular CC mail
+
+ (dolist (elt list)
+
+ (when debug
+ (tinypgpd fid 'dolist-match
+ (string-match re elt)
+ (if (string-match re elt)
+ (match-string 0 elt))
+ elt))
+
+ (if (string-match re elt)
+ (push elt pgp-ok-list)
+ (push elt pgp-nok-list)))
+
+ (if debug (tinypgpd fid (ti::mail-pgp-p)))
+
+ (tinypgp-hash 'auto-action 'put 'many-addr-ok-list pgp-ok-list)
+ (tinypgp-hash 'auto-action 'put 'many-addr-nok-list pgp-nok-list)
+
+ ;; There must not be no PGP already in the buffer!
+
+ (if (ti::mail-pgp-p)
+ (tinypgp-hash 'auto-action 'put 'many-addr-stat nil)
+ (tinypgp-hash 'auto-action 'put 'many-addr-stat pgp-ok-list)))
+
+ (setq ret (tinypgp-hash 'auto-action 'get 'many-addr-stat))
+
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. return action ..
+ (when (and ret (null mode))
+ (setq pgp-ok-list (tinypgp-hash 'auto-action 'get 'many-addr-ok-list)
+ pgp-nok-list (tinypgp-hash 'auto-action 'get 'many-addr-nok-list))
+ (if (null pgp-nok-list)
+ (tinypgp-encrypt-mail-verbose)
+
+ ;; #todo: send each message separately: those who have PGP
+ ;; #todo: and those that don't? Hmm.. this function
+ ;; is run from `mail-send-hook' so we have to send non-pgp first.
+
+ (message "TinyPgp: auto-action info, not all recipients have pgp")
+ (sleep-for 2)
+
+ (if (y-or-n-p "\
+Would you like to send separate PGP and plain mail messages?")
+ (let* ((orig (current-buffer))
+ (buffer (tinypgp-ti::temp-buffer 'mail "" "")))
+ (with-current-buffer buffer
+ (erase-buffer)
+ (insert-buffer orig)
+ (ti::mail-set-recipients pgp-nok-list pgp-ok-list 'cc-all)
+;;; (pop-to-buffer buffer)
+ (mail-send-and-exit nil))
+ ;; Now it's time to encrypt this message for recipients that
+ ;; do have pgp.
+
+ (ti::mail-set-recipients pgp-ok-list pgp-nok-list)
+ (tinypgp-encrypt-mail (tinypgp-key-id-conversion pgp-ok-list)))))))
+ )) ;; if-let
+
+ (if debug (tinypgpd fid 'RET ret 'pgp-p (ti::mail-pgp-p) 'point (point) "\n"))
+
+ ;; If we decided it was okay to send multiple encrypted message,
+ ;; let user say final word
+
+ (if (and ret tinypgp-:auto-action-encrypt-ok-hook)
+ (setq ret (run-hook-with-args
+ tinypgp-:auto-action-encrypt-ok-hook
+ list)))
+
+ (if debug (tinypgpd fid 'after-user-hook ret))
+
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-auto-action-toggle (&optional mode verb)
+ "If the auto action is detected for this buffer, toggle MODE on/off.
+Otherwise if no auto action is present, do nothing. VERB."
+ (interactive)
+ (let* ((act (tinypgp-auto-action-p))
+ val)
+ (ti::verb)
+ (if (null act)
+ (if verb (message "TinyPgp: no action entry found for this buffer."))
+ (setq val (tinypgp-hash 'auto-action 'get 'user-mode))
+
+ (ti::bool-toggle val mode)
+ (tinypgp-hash 'auto-action 'put 'user-mode val)
+ (tinypgp-update-modeline)
+
+ (if verb
+ (message (format "TinyPgp auto action: %s"
+ (if (not val) "pending" "defeated")))))))
+
+;;}}}
+;;{{{ misc: functions
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypgp-require-final-newline ()
+ "Make sure there is empty line at the end."
+ (save-excursion
+ (ti::pmax)
+ (if (not (looking-at "^[ \t]*$"))
+ (insert "\n"))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-xpgp-get-info ()
+ "Return X-pgp info '((MIME-KEY DATA) (MIME-K DATA) ..) or nil.
+This function caches the read X-Pgp information so that the parsing
+doesn't take effect in every call. The cache will be expired if the buffer
+size has changed and the new data parsing will be done."
+ (let* ((fid "tinypgp-xpgp-get-info:")
+ (size (- (point-max) (point-min)))
+ field
+ list)
+ (cond
+ ((and (eq size (tinypgp-hash 'xpgp-info 'get 'size))
+ (setq list (tinypgp-hash 'xpgp-info 'get 'data)))
+ (tinypgpd fid "cache"))
+ ((setq field (mail-fetch-field "X-Pgp-signed"))
+ (setq list (ti::mail-mime-parse-header field 'downcase))
+ (tinypgp-hash 'xpgp-info 'put 'size size)
+ (tinypgp-hash 'xpgp-info 'put 'data list)))
+ (tinypgpd fid (current-buffer) list)
+ list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-xpgp-key-address (type &optional message)
+ "Return TYPE (Finger or http) URL if can be found from X-Pgp header.
+Print optional MESSAGE if there is no such information.
+
+TYPE can be
+ 'finger
+ 'http
+
+Return:
+ string
+ nil"
+ (let* ((elt (tinypgp-xpgp-get-info))
+ ret)
+ (when elt
+ (cond
+ ((and (eq type 'finger)
+ (setq elt (assoc "address" elt)))
+ (setq ret (nth 1 elt)))
+ ((and (eq type 'http)
+ (setq elt (assoc "url" elt)))
+ (setq ret (nth 1 elt)))))
+ (if message
+ (message message))
+
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-header-sign-mode-toggle (&optional mode)
+ "Toggle signing of selected headers `tinypgp-:header-sign-table' with MODE.
+When the mode if OFF, the `tinypgp-:header-sign-table' is ignored."
+ (interactive)
+ (let* ((sym 'tinypgp-:header-sign-table))
+ ;; Not recorded; record original value
+ ;;
+ (if (null (get sym 'original))
+ (put sym 'original (symbol-value sym)))
+
+ (cond
+ ((or (memq mode '(0 -1))
+ (symbol-value sym))
+ (set sym nil)
+ (message "Headers are not signed: tinypgp-:header-sign-table is ignored."))
+ (t
+ (set sym (get sym 'original))
+ (message "Header list tinypgp-:header-sign-table is used.")))
+ (tinypgp-update-modeline)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-header-list-show ()
+ "See what headers will be signed for this message."
+ (interactive)
+ (tinypgp-header-sign-active-list 'display))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-header-sign-active-list (&optional display)
+ "See what headers we should sign. Optionally DISPLAY to user.
+Subject is the only safe field to sign when you for example
+send a message to some mailing list that may alter all other fields.
+
+References:
+ `tinypgp-:header-sign-table'"
+ (let* ((list tinypgp-:header-sign-table)
+ to
+ elt)
+ (and list
+ (setq to (or (mail-fetch-field "To")
+ (mail-fetch-field "Newsgroups")))
+ (not (ti::nil-p to))
+ (setq elt (ti::list-find list to)))
+ (when display
+ (cond
+ ((ti::nil-p to)
+ (message "Header sign info: Can't find field To or Newsgroups."))
+ ((null elt)
+ (message "Header sign info: To or Newsgroup header does not trigger."))
+ (t
+ (message "Header sign info: %s" (ti::list-to-string (nth 1 elt))))))
+
+ elt))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-header-move-to-body (&optional opt1 opt2)
+ "Move headers into body and anonymize them. See source for OPT1 and OPT2"
+ (interactive)
+ (ti::mail-pgpr-anonymize-headers
+ (or opt1 'move-to-body-maybe) opt2 "message" "dummy"))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-header-kill (&optional add-list)
+ "Kill all but the most crucial headers.
+ADD-LIST is additional headers to keep."
+ (let* ((hlist (ti::list-merge-elements
+ (mapcar
+ (function
+ (lambda (x)
+ (make-symbol
+ (downcase x))))
+ tinypgp-:r-header-keep-list)
+ (ti::mail-required-headers))))
+ (ti::mail-kill-non-rfc-fields hlist)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-header-sign-make-smf (&optional read-xpgp &optional header-list)
+ "Construct header SMF (a stripped message format).
+Read header field names and their contents from the message. If some
+header does not exist or is empty in message, then that header is ignored.
+
+References:
+
+ `tinypgp-:header-sign-table' Read from
+ `tinypgp-:header-sign-smf-info' Written to
+
+Input:
+
+ READ-XPGP ,The headers that were signed are told in X-Pgp.
+ If cannot read all headers, signal error.
+ HEADER-LIST ,list of headers names
+
+Return:
+ (string (hdr hdr ..)) ,SMF'd header-string and headers included
+ nil"
+ (interactive)
+ (let* ((fid "tinypgp-header-sign-make-smf:")
+ elt
+ (list (or header-list
+ (if (setq elt (tinypgp-header-sign-active-list))
+ (nth 1 elt))))
+ hdr-name
+ flag
+ fld
+ hlist
+ str
+ buffer
+ ret)
+
+ (tinypgpd fid "in" read-xpgp header-list "list" elt)
+ ;; Clear this global
+ ;;
+ (setq tinypgp-:header-sign-smf-info nil)
+
+ (when read-xpgp
+ (setq fld (mail-fetch-field "X-Pgp-signed"))
+ (when (setq fld (ti::string-match "SignedHeaders=\\([^;]+\\);" 1 fld))
+ ;; Remove newlines, because the field may continue
+ ;;
+ (setq fld (subst-char-with-string fld ?\n " "))
+ (setq list (split-string fld "[ ,]+"))))
+
+ (when (ti::listp list)
+ (setq buffer (tinypgp-ti::temp-buffer))
+ ;; Get the fields
+ ;;
+ (save-restriction
+ (dolist (elt list)
+
+ (when (setq str (ti::mail-get-field elt nil 'pure))
+
+ ;; this code is inside loop, because outside loop
+ ;; we don't know if we got any headers
+ ;;
+ (unless flag ;Do only once
+ (setq flag t) ;Remailer type header hash ##
+ (ti::append-to-buffer buffer "##\n"))
+
+ ;; We want to store the real header name, not the "list"
+ ;; names that can be "reply-to", where real header name is like
+ ;;
+ ;; REPLY-to: .....
+ ;;
+ (setq hdr-name (ti::string-match "^\\([^:]+\\):" 1 str))
+ (tinypgpd fid "READ" elt "NAME" hdr-name str)
+ (ti::nconc hlist hdr-name)
+
+ (ti::append-to-buffer
+ buffer
+ (format "%s\n" (ti::string-remove-whitespace str) )))))
+
+ (when hlist
+ ;; Add final newline after the headers.
+ ;;
+ (ti::append-to-buffer buffer "\n")
+ (with-current-buffer buffer
+ (setq ret (buffer-substring (point-min) (point-max))))))
+
+ (tinypgpd fid "ret" ret hlist)
+
+ (when ret
+ (setq tinypgp-:header-sign-smf-info (list ret hlist)))))
+
+;;}}}
+;;{{{ timer control
+
+;;; .......................................................... &timers ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-timer-process ()
+ "PGP timer process. Expires stored password and update mode line."
+ ;; Run only if some visible windows has tinypgp-mode on.
+ ;;
+ (let (do-it)
+ (dolist (win (ti::window-list))
+ (with-current-buffer (window-buffer win)
+ (when tinypgp-mode (setq do-it t wlist nil))))
+
+ (if do-it (tinypgp-update-modeline))
+ (if (not (tinypgp-password-time-valid-p))
+ (tinypgp-password-expire-now))
+ do-it))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-timer-control (&optional remove verb)
+ "Keep the password expiration timer alive. Optionally REMOVE it. VERB."
+ (interactive "P")
+ (let* ((fid "tinypgp-timer-control: ")
+ (timer tinypgp-:timer-elt))
+ (ti::verb)
+
+ (tinypgpd fid "in:" timer)
+
+ (ti::compat-timer-cancel-function 'tinypgp-timer-process)
+
+ (unless remove
+ (setq tinypgp-:timer-elt (run-at-time "10 sec" 10 'tinypgp-timer-process)))
+
+ (when verb
+ (if remove
+ (message "TinyPgp timer process installed")
+ (message "TinyPgp timer process removed.")))))
+
+;;}}}
+;;{{{ password control
+
+;;; ........................................................ &password ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-password-expire-now (&optional no-file-kill verb)
+ "Expire all PGP passwords including used files.
+Input:
+
+ NO-FILE-KILL if non-nil, then temporary files are not removed.
+ VERB Display verbose message."
+ (interactive "P")
+ (ti::verb)
+ (tinypgpd "tinypgp-password-expire-now" no-file-kill verb)
+
+ ;; Do not leave traces to memory (gc)
+ ;;
+ (let* ((gc-cons-threshold (* 1024 1024)))
+ (ti::vector-table-clear tinypgp-:hash-password))
+
+ ;; Create new
+ ;;
+ (ti::vector-table-init tinypgp-:hash-password)
+
+ ;; This command also may contains the password, wipe it
+ ;;
+ (setq tinypgp-:last-pgp-exe-command nil)
+ (tinypgp-hash 'password-time 'put 'tick nil 'global)
+
+ (if (null no-file-kill)
+ (tinypgp-file-control 'all-kill))
+
+ (when (or verb (interactive-p))
+ ;; If user called us; expire also secring password
+ ;;
+ (tinypgp-secring-crypt-expire-password)
+ (message "TinyPgp: all pass phrases and files expired.")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-password-get ()
+ "Get password."
+ (let* ((sym tinypgp-:user-now)
+ (type (tinypgp-hash 'action 'get 'now nil 'global))
+ ret)
+ (tinypgpd "tinypgp-password-get:" sym type)
+
+ ;; This may be "pgp" decrypt or "conventional". pick right
+ ;; password from hash.
+
+ (when (string= "conventional" type)
+ (setq sym "conventional"))
+
+ (tinypgp-password-set
+ "Password: "
+ (if (string= "conventional" type)
+ 'conventional))
+
+ (unless (setq ret
+ (ti::vector-table-property
+ tinypgp-:hash-password sym 'password))
+ (error "Internal error. Password hash corrupt."))
+
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-password-set (&optional prompt type)
+ "Set pass phrase for `tinypgp-:user-now' or ask again with PROMPT (expired).
+Eg. if last PGP command terminated to error, that had expired all
+pass phrases.
+
+Input:
+
+ prompt string, Prompt to user
+ TYPE symbol, if 'conventional, set conventional password.
+ If 'e-s, set one pass encrypt&sign password
+
+Return:
+ t if password available"
+ (let* ((fid "tinypgp-password-set:")
+ (sym (if (and (not (ti::bool-p type))
+ (symbolp type))
+ (symbol-name type)
+ tinypgp-:user-now))
+ ret
+ pass)
+ (or prompt
+ (setq
+ prompt
+ (cond
+ ((equal type 'conventional)
+ "Conventional decrypt password: ")
+ ((equal type 'e-s)
+ (format "[%s] One pass encrypt&Sign password: " tinypgp-:user-now))
+ (t (format "[%s] Pass phrase: " tinypgp-:user-now)))))
+
+ (tinypgpd fid "in:" tinypgp-:user-now prompt type sym)
+
+ (if (and (ti::vector-table-get tinypgp-:hash-password sym)
+ (ti::vector-table-property tinypgp-:hash-password sym 'password)
+ (tinypgp-password-time-valid-p)
+ (null tinypgp-:error))
+ (setq ret t) ;Ok, was in hash
+
+ ;; unwind: Makes sure 'pass' is wiped away
+
+ (unwind-protect
+ (progn
+ (setq pass (ti::compat-read-password prompt))
+ (when tinypgp-:password-keep-time
+
+ ;; Create new user to hash table
+
+ (intern sym tinypgp-:hash-password)
+
+ ;; Set user's password in the hash
+
+ (ti::vector-table-property tinypgp-:hash-password sym 'password pass 'force)
+ (tinypgp-hash 'password-time 'put 'tick nil 'global)
+ (setq tinypgp-:error nil)
+ (setq ret t)))))
+;;; Hmm; this also wipes the password from hash; why?
+;;; (if pass (fillarray pass 0))
+
+ (tinypgpd fid "out:" tinypgp-:user-now prompt type ret)
+
+ ret))
+
+;;}}}
+
+;;{{{ installation funcs
+
+;;; ----------------------------------------------------------------------
+;;; We can't initialize the substitution table in defvar, because
+;;; it may be possible that some user sats (setq ...) and then these
+;;; definitions aren't there any more.
+;;;
+(defun tinypgp-install-default-substitutions (&optional remove)
+ "Add default email substitutions or REMOVE."
+ (let* ((nymserver-re
+ (concat
+ "\\("
+ (mapconcat
+ 'concat
+ '("anon" "finger" "ping" "remove" "help"
+ "nick"
+ "newpassword" "newalias" "newpgp" "newaddress"
+ "vacation" "noarchive" "setnon" "paranoid"
+ "pgpencrypt" "pgpsign" "sendmix"
+ "abuse")
+ "\\|")
+ "\\)@anon.nymserver.com"))
+
+ (weasel-re "@weasel.owl.de\\|@squirrel.owl.de"))
+
+ (tinypgp-email-substitution-add
+ (list
+ ;; the 2nd entry is found from PGP key id.
+ (cons nymserver-re "Nymserver at anon.nymserver.com")
+
+ ;; You can get the Weasel 'newnym' PGP key from
+ ;; <info@weasel.owl.de>
+ ;; Johannes Kroeger <jkroeger@squirrel.owl.de>
+ ;;
+ ;; Squirrel.owl.de and weasel.owl.de offer the following mail services:
+ ;; 1. The Squirrel Remailer, a Mixmaster/Ghio remailer combination:
+ ;;
+ ;; The capabilities of the Ghio remailer are: $remailer{"squirrel"} =
+ ;; "<mix@squirrel.owl.de> cpunk mix pgp pgponly hash latent cut ek" The
+ ;; abbrevs are explained in http://www.publius.net/rlist.html
+ ;;
+ ;; It accepts only PGP messages encrypted
+
+ (cons weasel-re "config@weasel.owl.de"))
+ remove)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-install-send-mail-hook (&optional remove)
+ "Install right hook order to `' or REMOVE hooks."
+ (let* (hook
+ func)
+
+ ;; Hook chain is this:
+ ;;
+ ;; tinypgp-password-wipe-buffer
+ ;; tinypgp-sign-modify-check
+ ;; tinypgp-auto-action
+ ;; --> rest of the user hooks.
+ ;;
+ ;; The REST user hooks that do something TO BUFFER before sending
+ ;; message, should be in tinypgp-cmd-
+ ;; or to `tinypgp-:auto-action-before-hook'.
+ ;;
+
+ (setq hook tinypgp-:mail-send-hook-list
+ func '(tinypgp-auto-action
+ tinypgp-sign-modify-check
+ tinypgp-password-wipe-buffer))
+
+ ;; First remove then add --> puts hooks to the beginning.
+ ;; IMPORTANT:
+ ;;
+ ;; tinypgp-auto-action --> add SEMI tags
+ ;; mime-edit-maybe-translate --> translate tags and make PGP/MIME
+ ;;
+ ;; So, TM/SEMI hook must be after TinyPgp hooks.
+
+ (ti::add-hooks hook func 'remove)
+
+ ;; Add the hooks in right order
+
+ (unless remove
+ (ti::add-hooks hook func))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-install-hooks-vital (&optional remove)
+ "Install and keep vital functions in right order. Optionally REMOVE."
+ (interactive "P")
+ (let* (func
+ list)
+
+ ;; .............................................. kring find hooks ...
+
+ (setq list
+ '(tinypgp-key-find-by-cache
+ tinypgp-key-find-by-keyrings-verbose
+ tinypgp-key-find-by-finger-verbose
+ tinypgp-key-find-by-http-url-verbose
+ tinypgp-key-find-by-http-keyserver-verbose))
+
+ (ti::add-hooks 'tinypgp-:find-by-guess-hook list 'remove)
+ (unless remove (ti::add-hooks 'tinypgp-:find-by-guess-hook (nreverse list)))
+
+ ;; ................................................. control hooks ...
+
+ (remove-hook 'tinypgp-:cmd-macro-after-hook
+ 'tinypgp-mode-specific-control-after)
+ (unless remove
+ (add-hook 'tinypgp-:cmd-macro-after-hook
+ 'tinypgp-mode-specific-control-after 'append))
+
+ ;; .......................................................... mail ...
+
+ (tinypgp-install-send-mail-hook remove)
+
+ ;; ...................................................... external ...
+ ;; It is essential that mime translate hooks is after TinyPgp
+ ;; or otherwise eg when you send patch:
+ ;;
+ ;; o content is made quoted printble (=3D ...)
+ ;; o auto action triggers encrypting
+ ;; --> receiving end doesn't get clean patch
+
+ (setq func 'mime-editor/maybe-translate ;TM.el
+ list '(mail-send-hook
+ message-send-hook))
+
+ (dolist (hook list)
+ (when (and (boundp hook)
+ (memq func (symbol-value hook)))
+ (remove-hook hook func)
+ ;; Make sure it is last
+ (add-hook hook func 'append)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-install-hooks (&optional remove)
+ "Install package hooks. Optionally REMOVE installation.
+Can't restore changes to key maps."
+ (interactive "P")
+
+ (ti::add-hooks 'find-file-hooks 'turn-on-tinypgp-mode-maybe remove)
+
+ (ti::add-hooks tinypgp-:turn-on-hook-list 'turn-on-tinypgp-mode remove)
+
+ (ti::add-hooks 'tinypgp-:define-keys-hook ;; just to make sure they are there.
+ '(tinypgp-mode-define-menu
+ tinypgp-mode-define-keys))
+
+ (ti::add-hooks 'tinypgp-:key-mode-define-keys-hook
+ '(tinypgp-key-mode-define-menu
+ tinypgp-key-mode-define-keys))
+
+ (ti::add-hooks 'tinypgp-:summary-mode-define-keys-hook
+ '(tinypgp-summary-mode-define-menu
+ tinypgp-summary-mode-define-keys))
+
+ (ti::add-hooks 'tinypgp-:newnym-mode-define-keys-hook
+ '(tinypgp-newnym-mode-define-menu
+ tinypgp-newnym-mode-define-keys))
+
+ (ti::add-hooks '(rmail-show-message-hook
+ vm-display-buffer-hook
+ mh-show-hook)
+ 'tinypgp-hide
+ remove)
+
+ (ti::add-hooks '( ;; RMAIL summary is handled elswhere
+ vm-summary-mode-hook
+ gnus-summary-mode-hook
+ mh-show-mode-hook)
+ 'turn-on-tinypgp-summary-mode
+ remove)
+
+ (ti::add-hooks 'gnus-select-article-hook 'tinypgp-hide-gnus remove) ;Gnus 4
+
+ (tinypgp-install-hooks-vital remove)
+
+ ;; This must be after the mode specific hook has finished.
+
+ (unless remove
+ (add-hook 'tinypgp-:cmd-macro-after-hook
+ 'tinypgp-after-pgp-command 'append))
+
+ (ti::add-hooks 'tinypgp-:verify-before-hook
+ 'tinypgp-mode-specific-control-before
+ remove)
+
+ (ti::add-hooks 'tinypgp-:verify-after-hook
+ 'tinypgp-mode-specific-control-after
+ remove)
+
+ (ti::add-hooks 'write-file-hooks ; ~/.mailrc parsing
+ 'tinypgp-update-mail-abbrevs-hook
+ remove)
+
+ (ti::add-hooks 'tinypgp-:r-reply-block-basic-hook
+ 'tinypgp-r-mail-mode-init
+ remove))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-install-menu-bar-remail ()
+ "Disable or enable items from menubar."
+ (if (tinypgp-hash 'remail 'get 'init nil 'global) ;If initialised
+ (put 'tinypgp-:mode-menu 'remail t)
+ (put 'tinypgp-:mode-menu 'remail nil)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-install-menu-bar-newnym ()
+ "Disable or enable items from menubar."
+ ;; Hmm. Let me think of some test here later; Now it is enabled always.
+ ;;
+ (if (tinypgp-hash 'remail 'get 'init nil 'global)
+ (put 'tinypgp-:mode-menu 'newnym t)
+ (put 'tinypgp-:mode-menu 'newnym nil)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-install-menu-bar-nymserver ()
+ "Disable or enable items from menubar."
+ ;; Enable only if user has ordered Nymserver account
+ (if (ti::listp tinypgp-:nymserver-account-table)
+ (put 'tinypgp-:mode-menu 'nymserver t)
+ (put 'tinypgp-:mode-menu 'nymserver nil)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-install-menu-bar ()
+ "Disable or enable items from menubar."
+ (tinypgp-install-menu-bar-remail)
+ (tinypgp-install-menu-bar-newnym)
+ (tinypgp-install-menu-bar-nymserver))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-install-check-environment ()
+ "Check basic environment variabler or die on error.
+PGP uses TMP for temporary files, make sure directory is accessible."
+ (let* ((dir (getenv "TMP"))
+ file)
+
+ ;; PGP 2.6.x uses TMP env variable. See pgp.doc
+
+ (unless dir
+ (message "TinyPgp: WARNING, environment variable TMP is not set.")
+ (sleep-for 2)
+ (dolist (directory '("/tmp" "/temp"))
+ (when (file-directory-p directory)
+ (setenv "TMP" directory)
+ (setq dir directory)
+ (message "TinyPgp: Setenv TMP ==> %s" directory)
+ (return))))
+
+ (when (file-directory-p dir)
+ (setq file (ti::file-make-path dir "tinypgp.tmp")))
+
+ (cond
+ ((null dir)
+ (error "TinyPgp: environment variable TMP is not set."))
+
+ ((not (file-directory-p dir))
+ (error "TinyPgp: environment variable TMP is not pointing to directory"))
+
+ ((not (file-writable-p file))
+ (error "TinyPgp: Can't write to TMP dir: %s" dir))
+
+ ;; Actually try to write, one day I got weir error from my TMP
+ ;; file system. This neede fcsk run because disk had inode broken.
+ ;;
+ ;; echo test > test.txt
+ ;; test.txt: No such device or address.
+
+ ((with-temp-buffer
+ (insert "test\n")
+ (write-region (point-min) (point-max) file) ;Breaks if not ok
+ ;; Breaks if not ok
+ (delete-file file))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-install (&optional remove)
+ "Install whole package or REMOVE installation.
+This is main installation controller."
+ (interactive)
+ (tinypgpd "tinypgp-install in:" remove)
+ (tinypgp-install-check-environment)
+
+ (tinypgp-binary-path-set)
+
+ ;; Set the backenmd if thsi is firt time when program loads
+
+ (unless (get 'tinypgp-:pgp-binary 'pgp-now)
+ (tinypgp-backend-select-auto))
+
+ (tinypgp-secring-crypt-mode-detect)
+ (tinypgp-install-default-substitutions)
+
+ (tinypgp-install-hooks remove)
+ (tinypgp-timer-control remove)
+
+;;; this is run from 'update modeline' Do not call here; because
+;;; we're in wrong buffer and TP mode is not on.
+;;;
+;;; (tinypgp-install-menu-bar)
+
+ (unless remove
+ (tinypgp-key-cache-save 'load))
+ (tinypgpd "tinypgp-install out:"))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-install-to-current-emacs ()
+ "Examine every emacs buffer and turn on PGP minor mode when needed."
+ (interactive)
+
+ ;; Forced install. Clear these
+
+ (put 'tinypgp-:hash 'vm-check nil) (tinypgp-install-vm)
+ (put 'tinypgp-:hash 'gnus-check nil) (tinypgp-install-gnus)
+
+ (put 'tinypgp-:hash 'mime-backend-in-use nil)
+ (put 'tinypgp-:hash 'mime-backend-in-use nil)
+ (tinypgp-install-mime-pgp)
+
+ ;; If user loads TinyPgp, it should immediately install itself to
+ ;; appropriate buffers. Otherwise user has to call manually
+ ;; `tinypgp-mode' for every mail buffer and that is not very nice.
+
+ (save-excursion
+ (dolist (elt (buffer-list))
+ (set-buffer elt)
+ (cond
+ ((memq major-mode '(vm-mode
+ rmail-mode
+ rmail-edit-mode
+ mail-mode
+ message-mode
+ gnus-article-mode
+ gnus-article-edit-mode
+ mime/viewer-mode)) ;TM
+ (unless tinypgp-mode (tinypgp-mode 1)))
+
+ ((memq major-mode '(vm-summary-mode
+ rmail-summary-mode
+ gnus-summary-mode))
+ (unless tinypgp-summary-mode
+ (tinypgp-summary-mode 1)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-install-gnus-do ()
+ "Add Headers to GNUS."
+ (let* ((h "X-pgp-signed")
+ (hdr "\\|X-pgp-signed:")
+ (h2 "^X-pgp-signed:")
+ sym
+ val)
+
+ ;; Bytecomp silencer with symbols
+
+ (dolist (sym '(gnus-saved-headers gnus-visible-headers))
+ (setq val (symbol-value sym))
+ (if (not (stringp val))
+ (error "Install problem1: See manual for GNUS installation.")
+ (unless (string-match h val)
+ (set sym (concat val hdr)))))
+
+ (setq sym 'gnus-sorted-header-list val (symbol-value sym))
+
+ (if (not (ti::listp val))
+ (error "Install problem2: See manual for GNUS installation.")
+ (unless (member h2 val)
+ ;; Add to the end
+ (set sym (append val (list h2)) )))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-install-gnus (&optional force)
+ "Check that GNUS is configured right. Optionally FORCE."
+ (when (and (featurep 'gnus)
+ (or (boundp 'gnus-saved-headers) ;Gnus check
+ ;; Not bound, this is old gnus. Do not install
+ ;;
+ (prog1 nil (put 'tinypgp-:hash 'gnus-check t)))
+ (null (get 'tinypgp-:hash 'gnus-check)))
+ (tinypgp-install-gnus-do)
+ ;; Done, do not repeat
+ (put 'tinypgp-:hash 'gnus-check t)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-install-mime-tm-do ()
+ "Install package to TM."
+ (unless (featurep 'tm-tinypgp-setup)
+ (or (load "tm-tinypgp-setup" 'noerr)
+ (progn
+ (message
+ "tm-tinypgp-setup.el not found. Couldn't auto-install to TM")
+ (sleep-for 5)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-install-mime-semi-do ()
+ "Install package to SEMI."
+ (unless (featurep 'mime-tinypgp-setup)
+ (or (load "mime-tinypgp-setup" 'noerr)
+ (progn
+ (message
+ "mime-tinypgp-setup.el not found. Couldn't auto-install to SEMI")
+ (sleep-for 5)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-install-mime-tm (&optional force)
+ "Check that GNUS is configured right. Optionally FORCE."
+ (when (and (null (get 'tinypgp-:hash 'mime-backend-in-use))
+ (ti::mail-mime-tm-featurep-p))
+ (when (ti::mail-mime-semi-featurep-p)
+ (error "\
+TinyPgp: Conflict; Trying to use TM while SEMI is present. Restart Emacs."))
+ (tinypgp-install-mime-tm-do)
+ ;; Done, do not repeat
+ (put 'tinypgp-:hash 'mime-backend-in-use 'tm)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-install-mime-semi (&optional force)
+ "Check that GNUS is configured right. Optionally FORCE."
+ (when (and (null (get 'tinypgp-:hash 'mime-backend-in-use))
+ (ti::mail-mime-semi-featurep-p))
+ (when (ti::mail-mime-tm-featurep-p)
+ (error "\
+TinyPgp: Conflict; Trying to use SEMI while TM is present. Restart Emacs."))
+ (tinypgp-install-mime-semi-do)
+ (put 'tinypgp-:hash 'mime-backend-in-use 'semi)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-install-mime-pgp (&optional force)
+ "Install PGP/MIME support or possible FORCE install. Need TM or SEMI."
+ (interactive "P")
+ (when (or force
+ (null (get 'tinypgp-:hash 'mime-backend-in-use)))
+ (cond
+ ((ti::mail-mime-tm-featurep-p)
+ (tinypgp-install-mime-tm)
+ (tinypgp-install-hooks-vital)) ;Arrange TM look last
+
+ ((ti::mail-mime-semi-featurep-p)
+ (tinypgp-install-mime-semi)
+ ;; Arrange SEMI hook last
+ (tinypgp-install-hooks-vital)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-install-vm ()
+ "Install minor mode indication to VM summary buffer."
+ ;; 1. User loads TinyPgp and VM is not loaded yet
+ ;; --> this function does nothing
+ ;; 2. When user uses commands afterwards in VM, this function
+ ;; is called to chek the situation.
+ ;;
+ (when (and (featurep 'vm)
+ (null (get 'tinypgp-:hash 'vm-check)))
+ (let* ((sym 'vm-mode-line-format)
+ (val (symbol-value sym))
+ (hdr "X-Pgp-Signed:"))
+
+ ;; The modeline format is defined in vm-vars.el::vm-mode-line-format,
+ ;; but it does not have variable minor-mode-alist. That's why TPsum
+ ;; mode is not shown in summary buffer.
+ ;;
+ (save-excursion
+ (dolist (buffer (buffer-list))
+ (set-buffer buffer)
+ (when (and (eq major-mode 'vm-summary-mode)
+ (not (memq 'minor-mode-alist val)))
+ ;; Add this and update modeline
+ (ti::nconc val 'minor-mode-alist)
+ (ti::compat-set-mode-line-format val)
+ (vm-update-summary-and-mode-line))))
+
+ (setq sym 'vm-visible-headers val (symbol-value sym))
+ (tinypgpd "tinypgp-install-vm:" sym val)
+
+ (if (not (ti::listp val))
+ (error "Install problem: See manual for VM installation.")
+ (unless (member hdr val)
+ ;; Add to the end
+ (set sym (append val (list hdr))) ))
+
+ (put 'tinypgp-:hash 'vm-check t))))
+
+;;}}}
+;;{{{ install: modes, keys
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-install-modes (&optional remove)
+ "Install or REMOVE minor modes.
+Calling this always removes old mode and does reinstall."
+ (interactive "P")
+ (cond
+ (remove
+ (ti::keymap-add-minor-mode 'tinypgp-mode nil nil 'remove)
+ (ti::keymap-add-minor-mode 'tinypgp-key-mode nil nil 'remove)
+ (ti::keymap-add-minor-mode 'tinypgp-summary-mode nil nil 'remove))
+
+ (t
+ (setq tinypgp-:mode-map (make-sparse-keymap)) ;; always refresh
+ (run-hooks 'tinypgp-:define-keys-hook)
+ (ti::keymap-add-minor-mode 'tinypgp-mode nil nil 'remove)
+ (ti::keymap-add-minor-mode 'tinypgp-mode
+ 'tinypgp-:mode-name
+ tinypgp-:mode-map)
+
+ (setq tinypgp-:key-mode-map (make-sparse-keymap)) ;; always refresh
+ (run-hooks 'tinypgp-:key-mode-define-keys-hook)
+ (ti::keymap-add-minor-mode 'tinypgp-key-mode nil nil 'remove)
+ (ti::keymap-add-minor-mode 'tinypgp-key-mode
+ 'tinypgp-:key-mode-name
+ tinypgp-:key-mode-map)
+
+ (setq tinypgp-:summary-mode-map (make-sparse-keymap)) ;; always refresh
+ (run-hooks 'tinypgp-:summary-mode-define-keys-hook)
+ (ti::keymap-add-minor-mode 'tinypgp-summary-mode nil nil 'remove)
+ (ti::keymap-add-minor-mode 'tinypgp-summary-mode
+ 'tinypgp-:summary-mode-name
+ tinypgp-:summary-mode-map)
+
+ (setq tinypgp-:newnym-mode-map (make-sparse-keymap)) ;; always refresh
+ (run-hooks 'tinypgp-:newnym-mode-define-keys-hook)
+ (ti::keymap-add-minor-mode 'tinypgp-newnym-mode nil nil 'remove)
+ (ti::keymap-add-minor-mode 'tinypgp-newnym-mode
+ 'tinypgp-:newnym-mode-name
+ tinypgp-:newnym-mode-map))))
+
+;;}}}
+
+;;{{{ menu: main
+
+(put 'tinypgp-:mode-menu 'nymserver nil)
+
+;;; ------------------------------------------------------------ &menu ---
+;;;
+(defun tinypgp-mode-define-menu ()
+ "Define menus."
+ (easy-menu-define
+ tinypgp-:mode-menu
+ (if (ti::xemacs-p) nil (list tinypgp-:mode-map))
+ "TinyPgp menu"
+ (list
+ tinypgp-:mode-menu-name
+ ["Next action" tinypgp-next-action-mail t]
+ ["Sign" tinypgp-sign-mail t]
+ ["Sign, base64" tinypgp-sign-mail-base64 t]
+ ["Sign, detached" tinypgp-sign-mail-detached t]
+ ["Sign, PGP/MIME" tinypgp-sign-mail-mime t]
+
+ ["Encrypt" tinypgp-encrypt-mail t]
+ ["Encrypt and sign (one pass)" tinypgp-encrypt-mail-sign t]
+ ["Encrypt PGP/MIME" tinypgp-encrypt-mail-mime t]
+
+ ["Decrypt" tinypgp-decrypt-mail t]
+ ["Verify" tinypgp-verify-mail t]
+ ["Verify detached signature on file" tinypgp-verify-detached-signature t]
+ ["Conventional crypt" tinypgp-crypt-mail t]
+ ["Insert file, base64 signed" tinypgp-sign-base64-insert-file t]
+
+ "----"
+
+ (list
+ "Region PGP"
+ ["Sign" tinypgp-sign-region t]
+ ["Sign, base64" tinypgp-sign-region-base64 t]
+ ["Sign, detached" tinypgp-sign-region-detached t]
+ ["Encrypt" tinypgp-encrypt-region t]
+ ["Encrypt and sign (one pass)" tinypgp-encrypt-region-sign t]
+ ["Decrypt" tinypgp-decrypt-region t]
+ ["Verify" tinypgp-verify-region t])
+
+ (list
+ "Key handling"
+ ["Fetch by finger" tinypgp-key-find-by-finger t]
+ ["Fetch by http [keyserver]" tinypgp-key-find-by-http-guess t]
+ ["Fetch by email keysrv request" tinypgp-key-find-by-email t]
+ ["Fetch by guess" tinypgp-key-find-by-guess t]
+ "----"
+ ["Insert with batch to pubring" tinypgp-key-add-region-batch t]
+ ["Insert with ask to pubring" tinypgp-key-add-region-interactive t]
+ ["Extract to point" tinypgp-key-extract-to-point t]
+
+;;;#todo menu
+;;; ["Generate new key" tinypgp-key-generate t]
+ ["Remove from keyring" tinypgp-key-delete-region t]
+ "----"
+ ["Info insert matches" tinypgp-key-info-insert t]
+ ["Info show matches" tinypgp-key-info-at-point-show t])
+
+ (list
+ "Pubring and user control"
+ ["Pubring show" tinypgp-pubring-display t]
+ ["Pubring change" tinypgp-pubring-set-current t]
+ "----"
+ ["User show" tinypgp-user-display t]
+ ["User change" tinypgp-user-set-current t])
+
+ (list
+ "Modes and toggles"
+ ["Flip x-pgp header/regular pgp" tinypgp-xpgp-header-toggle t]
+ ["Flip Signature hide/show" tinypgp-hide-show-toggle t]
+ "----"
+ ["Mode Auto action on/off" tinypgp-auto-action-toggle t]
+ ["Mode Auto signing on/off" tinypgp-sign-mail-auto-mode t]
+ ["Mode Header sign on/off" tinypgp-header-sign-mode-toggle t]
+ ["Mode x-pgp on/off" tinypgp-xpgp-header-mode-toggle t]
+ "----"
+ ["Mode Secring crypt on/off" tinypgp-secring-crypt-mode-toggle t]
+ ["Mode Email substitution on/off" tinypgp-email-substitution-toggle t])
+
+;;; "----"
+
+ (list
+ "Extra commands"
+ ["Info Show Encrypt keys used" tinypgp-encrypt-info t]
+ ["Info Show auto action entry" tinypgp-auto-action-verbose t]
+ ["Info Show email conversion" tinypgp-key-id-conversion-check-verbose t]
+ ["Info Show header signing fields" tinypgp-header-list-show t]
+ ["Info Show last finger error" tinypgp-show-last-finger-error t]
+ "----"
+ ["Info Describe mode" tinypgp-mode-describe t]
+ ["Info View pgp register" tinypgp-view-register t]
+ ["Info Sudy PGP stream forward." tinypgp-pgp-stream-forward-study t]
+ "----"
+ ["Wash Anonymize headers" tinypgp-header-move-to-body t]
+ ["Wash expire pass phrases/files" tinypgp-password-expire-now t]
+ ["Wash expire secring password"
+ tinypgp-secring-crypt-expire-password t]
+ ["Wash loose signing information" tinypgp-sign-loose-info t]
+ ["Wash wipe passwords from buffer" tinypgp-password-wipe-buffer t]
+ ["Wash delete running PGP processes" tinypgp-delete-processes t]
+ "----"
+ ["Send email: .plan has no PGP key" tinypgp-sendmail-key-not-in-plan t]
+ ["Send email: keyserver cmd" tinypgp-keysrv-send-email-command t])
+ "----"
+
+ (list
+ "Remailer service"
+ ["Post as Anon " tinypgp-r-post
+ (get 'tinypgp-:mode-menu 'remail)]
+ ["Encrypt-Remail message once" tinypgp-r-chain-1
+ (get 'tinypgp-:mode-menu 'remail)]
+ ["Encrypt-Remail message using chain" tinypgp-r-chain
+ (get 'tinypgp-:mode-menu 'remail)]
+ "----"
+ ["Initialize remailer support" tinypgp-r-init t]
+ ["Update remailer list" tinypgp-r-update-remailer-list t]
+ (list
+ "Reply block"
+ ["Make basic reply block" tinypgp-r-reply-block-basic
+ (get 'tinypgp-:mode-menu 'remail)]
+ ["Construct remailer reply block" tinypgp-r-reply-block-insert
+ (get 'tinypgp-:mode-menu 'remail)]
+ ["Test defined reply blocks" tinypgp-r-reply-block-test
+ (get 'tinypgp-:mode-menu 'remail)])
+
+ (list
+ "Newnym service"
+ ["Show or get account help" tinypgp-newnym-help
+ (get 'tinypgp-:mode-menu 'newnym)]
+ ["Default account in use/not in use" tinypgp-newnym-default-toggle
+ tinypgp-:r-newnym-default-account-table]
+ ["Default account select" tinypgp-newnym-default-set
+ tinypgp-:r-newnym-default-account-table]
+ ["Post as Anon " tinypgp-newnym-post
+ (get 'tinypgp-:mode-menu 'newnym)]
+ "----"
+ (list
+ "Requests"
+ ["acksend" tinypgp-newnym-req-acksend
+ (get 'tinypgp-:mode-menu 'newnym)]
+ ["cryptrecv" tinypgp-newnym-req-cryptrecv
+ (get 'tinypgp-:mode-menu 'newnym)]
+ ["disable" tinypgp-newnym-req-disable
+ (get 'tinypgp-:mode-menu 'newnym)]
+ ["fingerkey" tinypgp-newnym-req-fingerkey
+ (get 'tinypgp-:mode-menu 'newnym)]
+ ["fixedsize" tinypgp-newnym-req-fixedsize
+ (get 'tinypgp-:mode-menu 'newnym)]
+ ["sigsend" tinypgp-newnym-req-sigsend
+ (get 'tinypgp-:mode-menu 'newnym)])
+ (list
+ "Configuration and misc"
+ ["Account expiry status" tinypgp-newnym-account-expiry-warnings t]
+ ["Configuration template" tinypgp-newnym-config-sendmail-template
+ (get 'tinypgp-:mode-menu 'newnym)]
+ ["Create new account" tinypgp-newnym-create
+ (get 'tinypgp-:mode-menu 'newnym)]
+ ["Delete account" tinypgp-newnym-delete
+ (get 'tinypgp-:mode-menu 'newnym)]
+ "----"
+ ["Get used account list" tinypgp-newnym-get-used-list
+ (get 'tinypgp-:mode-menu 'newnym)]
+ ["Get server's PGP key" tinypgp-newnym-get-pgp-key
+ (get 'tinypgp-:mode-menu 'newnym)])
+
+ (list
+ "Nymserver service"
+ ["Post as anon" tinypgp-nymserver-post
+ (get 'tinypgp-:mode-menu 'nymserver)]
+ ["Finger, account status" tinypgp-nymserver-finger
+));;; Yes; you can finger an anon address ok: anNNN@anon-nymserver.com
+;;; (get 'tinypgp-:mode-menu 'nymserver)
+ t]
+ ["Ping, your account status" tinypgp-nymserver-ping
+ (get 'tinypgp-:mode-menu 'nymserver)]
+ ["Help, read file" tinypgp-nymserver-help
+ (get 'tinypgp-:mode-menu 'nymserver)]
+ "----"
+ (list
+ "Change account properties"
+ ["Change account alias" tinypgp-nymserver-newalias
+ (get 'tinypgp-:mode-menu 'nymserver)]
+ ["Change nickname" tinypgp-nymserver-nickname
+ (get 'tinypgp-:mode-menu 'nymserver)]
+ ["Change .plan" tinypgp-nymserver-newplan
+ (get 'tinypgp-:mode-menu 'nymserver)]
+ ["Change .signature" tinypgp-nymserver-newsig
+ (get 'tinypgp-:mode-menu 'nymserver)]
+ ["Change to new address" tinypgp-nymserver-newaddress
+ (get 'tinypgp-:mode-menu 'nymserver)])
+
+ (list
+ "Flags and pgp key"
+ ["flag, paranoid" tinypgp-nymserver-paranoid
+ (get 'tinypgp-:mode-menu 'nymserver)]
+ ["flag, vacation" tinypgp-nymserver-vacation
+ (get 'tinypgp-:mode-menu 'nymserver)]
+ ["flag, no archive" tinypgp-nymserver-noarchive
+ (get 'tinypgp-:mode-menu 'nymserver)]
+ ["flag, anNNN/naNNN" tinypgp-nymserver-setnon
+ (get 'tinypgp-:mode-menu 'nymserver)]
+ "----"
+ ["PGP key upload " tinypgp-nymserver-pgp-upload
+ (get 'tinypgp-:mode-menu 'nymserver)]
+ ["PGP flag, encrypt" tinypgp-nymserver-pgp-encrypt
+ (get 'tinypgp-:mode-menu 'nymserver)]
+ ["PGP flag, sign" tinypgp-nymserver-pgp-sign
+ (get 'tinypgp-:mode-menu 'nymserver)]
+ ["PGP flag, mixmaster" tinypgp-nymserver-pgp-sendmix
+ (get 'tinypgp-:mode-menu 'nymserver)])
+
+ (list
+ "Create"
+ ["Account create" tinypgp-nymserver-create t]
+ ["Account remove" tinypgp-nymserver-remove
+ (get 'tinypgp-:mode-menu 'nymserver)]))
+ "----"
+
+ (list
+ "Cache service"
+ ["Remove last entry" tinypgp-key-cache-remove-entry-last t]
+ ["Display" tinypgp-key-cache-display t])
+
+ (list
+ "Report and backend service"
+ ["Select PGP backend" tinypgp-backend-select t]
+ ["Select PGP backend 2.6.x" tinypgp-backend-select-pgp2 t]
+ ["Select PGP backend 5.x" tinypgp-backend-select-pgp5 t]
+ ["Show TinyPgp version" tinypgp-version-message t]
+ ["Show TinyPgp initial message" tinypgp-initial-message t]
+ ["Submit bug report" tinypgp-submit-bug-report t]
+ "----"
+ ["Debug on/off" tinypgp-debug-toggle t]
+ ["Debug buffer clear" tinypgp-debug-buffer-clear t]
+ "----"
+ ["Display comint" tinypgp-show-buffer-comint t]
+ ["Display debug" tinypgp-show-buffer-debug t]
+ ["Display finger" tinypgp-show-buffer-finger t]
+ ["Display http" tinypgp-show-buffer-http t]
+ ["Display shell" tinypgp-show-buffer-shell t]
+ ["Display tmp" tinypgp-show-buffer-tmp t]))))
+
+;;; I don't know if average user realizes what this command does...
+;;; ["Generate randseed.bin" t]
+
+;;}}}
+;;{{{ menu: echo, newnym
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-mode-define-keys-newnym (map n)
+ ;; Seldom used command in big letter to prevent accidents.
+ ;;
+ (define-key map (concat n "?") 'tinypgp-newnym-help)
+ (define-key map (concat n "a") 'tinypgp-newnym-req-acksend)
+ (define-key map (concat n "b") 'tinypgp-newnym-req-nobcc)
+ (define-key map (concat n "C") 'tinypgp-newnym-create)
+
+ (define-key map (concat n "c")
+ 'tinypgp-newnym-config-sendmail-template)
+
+ (define-key map (concat n "D") 'tinypgp-newnym-delete)
+ (define-key map (concat n "e") 'tinypgp-newnym-req-disable)
+ (define-key map (concat n "f") 'tinypgp-newnym-req-fingerkey)
+ (define-key map (concat n "K") 'tinypgp-newnym-get-pgp-key)
+ (define-key map (concat n "u") 'tinypgp-newnym-get-used-list)
+ (define-key map (concat n "p") 'tinypgp-newnym-post)
+ (define-key map (concat n "r") 'tinypgp-newnym-req-cryptrecv)
+ (define-key map (concat n "s") 'tinypgp-newnym-req-sigsend)
+ (define-key map (concat n "\t") 'tinypgp-newnym-default-set)
+ (define-key map (concat n "t") 'tinypgp-newnym-default-toggle)
+ (define-key map (concat n "x") 'tinypgp-newnym-account-expiry-warnings)
+ (define-key map (concat n "z") 'tinypgp-newnym-req-fixedsize))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defcustom tinypgp-:newnym-echo-menu-use-p t
+ "*Should the 'newnym' commands be accessible from echo-area menu?.
+You can set this only once; otherwise you have to reload package."
+ :type 'boolean
+ :group 'tinypgp-nymserver)
+
+;; Change this mane in the load-hook is need to.
+;;
+(defconst tinypgp-:newnym-echo-menu
+ '(
+ (let* ((srv (get 'tinypgp-:r-newnym-default-account-table 'default-server))
+ (pfx (if current-prefix-arg "+" ""))
+ (def (format "%s[%s]" pfx (or srv "Newnym") )))
+ (tinypgp-backend-set-for-action 'newnym)
+ (format
+ "\
+%s p)ost c)fg t/ab)oggle h)lp req:a)ck b)cc e)nab f)ing s)ig si(z)e [utx CDK]"
+ def))
+ ((?a . ( (call-interactively 'tinypgp-newnym-req-acksend)))
+ (?C . ( (call-interactively 'tinypgp-newnym-create)))
+ (?b . ( (call-interactively 'tinypgp-newnym-req-nobcc)))
+ (?c . ( (call-interactively 'tinypgp-newnym-config-sendmail-template)))
+ (?D . ( (call-interactively 'tinypgp-newnym-delete)))
+ (?e . ( (call-interactively 'tinypgp-newnym-req-disable)))
+ (?f . ( (call-interactively 'tinypgp-newnym-req-fingerkey)))
+ (?h . ( (tinypgp-newnym-help-verbose current-prefix-arg)))
+ (?K . ( (call-interactively 'tinypgp-newnym-get-pgp-key)))
+ (?u . ( (call-interactively 'tinypgp-newnym-get-used-list)))
+ (?p . ( (call-interactively 'tinypgp-newnym-post)))
+ (?r . ( (call-interactively 'tinypgp-newnym-req-cryptrecv)))
+ (?s . ( (call-interactively 'tinypgp-newnym-req-sigsend)))
+ (?t . (t (call-interactively 'tinypgp-newnym-default-toggle)))
+ (?\t . ( (call-interactively 'tinypgp-newnym-default-set)))
+ (?x . ( (tinypgp-newnym-account-expiry-warnings)))
+ (?z . ( (call-interactively 'tinypgp-newnym-req-fixedsize)))))
+ "Nym account menu.
+Esc or q to exit menu without choosing. Less used commands are in uppercase.
+
+Basic Nym commands
+
+ h = Show help file (prefix arg orders help file by mail)
+ p = convert current message to anon (p)ost
+
+Nym account requests
+
+ All these commands send the minus(-) request and request action is
+ explained to the right. Supply prefix argument if you want to send plus(+)
+ request.
+
+ a = (a)cksend disable automatic acknowledgement
+ b = no(b)cc receive bcc carbon copies. Needed if you
+ subscribe to mailing lists.
+ r = c(r)yptrecv disable encryption to you.
+ e = disable re-(e)nable account
+ f = (f)ingerkey disallow people to get your PGP key.
+ z = fixedsi(z)e do not padd messages to 10K
+ s = (s)igsend disable automatic pgp signing
+
+Nym account management
+
+ t = (t)oggle using default account.
+ tab = set default server and account
+ c = prepare (c)onfigure template and enter 'Nym' mode.
+ You can manage you account in details. See tab key in this mode.
+ C = (C)reate account
+ D = (D)elete account
+
+Other
+
+ x = Display count of days to account e(x)piration.
+ u = Get account list ie. (u)sed nym names
+ K = Get server's PGP (k)ey.")
+
+;;}}}
+;;{{{ menu: echo, nymserver
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-mode-define-keys-nymserver (map y)
+ ;; Normal keybindings then. No menu in echo area used.
+
+ (define-key map (concat y "p") 'tinypgp-nymserver-post)
+ (define-key map (concat y "f") 'tinypgp-nymserver-finger)
+ (define-key map (concat y "i") 'tinypgp-nymserver-ping)
+
+ (define-key map (concat y "a") 'tinypgp-nymserver-newalias)
+ (define-key map (concat y "n") 'tinypgp-nymserver-nickname)
+ (define-key map (concat y "w") 'tinypgp-nymserver-newpassword)
+
+ (define-key map (concat y "o") 'tinypgp-nymserver-paranoid)
+ (define-key map (concat y "v") 'tinypgp-nymserver-vacation)
+ (define-key map (concat y "d") 'tinypgp-nymserver-newaddress)
+ (define-key map (concat y "r") 'tinypgp-nymserver-noarchive)
+ (define-key map (concat y "l") 'tinypgp-nymserver-newplan)
+ (define-key map (concat y "g") 'tinypgp-nymserver-newsig)
+ (define-key map (concat y "t") 'tinypgp-nymserver-setnon)
+
+ (define-key map (concat y "k") 'tinypgp-nymserver-pgp-upload)
+ (define-key map (concat y "e") 'tinypgp-nymserver-pgp-encrypt)
+ (define-key map (concat y "s") 'tinypgp-nymserver-pgp-sign)
+ (define-key map (concat y "x") 'tinypgp-nymserver-pgp-sendmix)
+
+ (define-key map (concat y "C") 'tinypgp-nymserver-create)
+ (define-key map (concat y "D") 'tinypgp-nymserver-remove)
+ (define-key map (concat y "A") 'tinypgp-nymserver-abuse)
+
+ (define-key map (concat y "h") 'tinypgp-nymserver-help))
+
+(defcustom tinypgp-:nymserver-echo-menu-use-p t
+ "*Should the 'nymserver' commands be accessible from echo-area menu?.
+You can set this only once; otherwise you have to reload package."
+ :type 'boolean
+ :group 'tinypgp-nymserver)
+
+;; Change this mane in the load-hook is need to.
+;;
+(defconst tinypgp-:nymserver-echo-menu
+ '(
+ (progn
+ (tinypgp-backend-set-for-action 'nymserv)
+ "Nymserv p)ost f)ing p(i)ng n)ick si(g) p(l)an PGP.kesx req.drtovwa [hACR]")
+ ((?p . ( (call-interactively 'tinypgp-nymserver-post)))
+ (?f . ( (call-interactively 'tinypgp-nymserver-finger)))
+ (?i . ( (call-interactively 'tinypgp-nymserver-ping)))
+
+ (?n . ( (call-interactively 'tinypgp-nymserver-nickname)))
+ (?v . ( (call-interactively 'tinypgp-nymserver-vacation)))
+ (?a . ( (call-interactively 'tinypgp-nymserver-newalias)))
+
+ (?l . ( (call-interactively 'tinypgp-nymserver-newplan)))
+ (?g . ( (call-interactively 'tinypgp-nymserver-newsig)))
+ (?r . ( (call-interactively 'tinypgp-nymserver-noarchive)))
+
+ (?y . ( (call-interactively 'tinypgp-nymserver-setnon)))
+ (?o . ( (call-interactively 'tinypgp-nymserver-paranoid)))
+ (?d . ( (call-interactively 'tinypgp-nymserver-newaddress)))
+ (?w . ( (call-interactively 'tinypgp-nymserver-newpassword)))
+
+ (?k . ( (call-interactively 'tinypgp-nymserver-pgp-upload)))
+ (?e . ( (call-interactively 'tinypgp-nymserver-pgp-encrypt)))
+ (?s . ( (call-interactively 'tinypgp-nymserver-pgp-sign)))
+ (?x . ( (call-interactively 'tinypgp-nymserver-pgp-sendmix)))
+
+ (?A . ( (call-interactively 'tinypgp-nymserver-abuse)))
+ (?C . ( (call-interactively 'tinypgp-nymserver-create)))
+ (?D . ( (call-interactively 'tinypgp-nymserver-remove)))
+ (?h . ( (tinypgp-nymserver-help-verbose current-prefix-arg)))))
+ "anon.nymserver.com menu.
+Esc or q to exit menu without choosing.
+
+Basic commands
+
+ p = convert current message to anon (p)ost
+ f = (f)inger account for configuration information.
+
+Common commands
+
+ n = (n)ickname change request
+ g = upload new .(s)ignature file
+ l = upload new .p(l)an file
+
+PGP related requests
+
+ k = upload PGP (k)ey to your account
+ e = (e)ncrypt request
+ s = (s)igning request
+ x = mi(x)master request
+
+Requests
+
+ d = newa(dd)ress request
+ r = noa(r)chive request
+ t = se(t)non request
+ o = paran(o)id request
+ v = (v)acation request
+ w = ne(w)password request
+ a = new(a)lias request. This changes your anNNN to vanity alias.
+
+Other
+
+ h = show (h)elp file, With Prefix arg send help request email.
+ A = Send (a)buse mail
+ C = (C)reate new account. This command can be sent only once.
+ D = (D)elete account. This is opposite of create.")
+
+;;}}}
+;;{{{ menu: echo, remail
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-mode-define-keys-remail (map p)
+ (define-key map (concat p "b") 'tinypgp-r-reply-block-basic)
+ (define-key map (concat p "r") 'tinypgp-r-reply-block-insert)
+ (define-key map (concat p "i") 'tinypgp-r-init)
+ (define-key map (concat p "u") 'tinypgp-r-update-remailer-list)
+ (define-key map (concat p "p") 'tinypgp-r-post)
+ (define-key map (concat p "t") 'tinypgp-r-reply-block-test)
+ (define-key map (concat p "C") 'tinypgp-r-chain-1)
+ (define-key map (concat p "c") 'tinypgp-r-chain))
+
+(defcustom tinypgp-:remail-echo-menu-use-p t
+ "*Should the 'remail' commands be accessible from echo-area menu?.
+You can set this only once; otherwise you have to reload package."
+ :type 'boolean
+ :group 'tinypgp)
+
+(defconst tinypgp-:remail-echo-menu
+ '(
+ (progn
+ (tinypgp-backend-set-for-action 'remail)
+ "remail: p)ost cC)hain b)asic-rb t)est-rb r)b-insert u)pdate i)nit")
+ ((?b . ( (call-interactively 'tinypgp-r-reply-block-basic)))
+ (?r . ( (call-interactively 'tinypgp-r-reply-block-insert)))
+ (?i . ( (call-interactively 'tinypgp-r-init)))
+ (?u . ( (call-interactively 'tinypgp-r-update-remailer-list)))
+ (?p . ( (call-interactively 'tinypgp-r-post)))
+ (?t . ( (call-interactively 'tinypgp-r-reply-block-test)))
+ (?C . ( (call-interactively 'tinypgp-r-chain-1)))
+ (?c . ( (call-interactively 'tinypgp-r-chain)))))
+ "Remail management menu
+
+p convert message to remailer post
+c Chain message using predefined paths. Use (p) first
+C Chain once manually. Use (p) first
+
+b construct basic reply block
+r Insert reply block
+
+i Initialise remailer support
+u update remailer list
+t test reply blocks")
+
+;;}}}
+
+;;{{{ menu: echo, buffer
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-mode-define-keys-buffer (map p)
+ "Define buffer handling keys. Use P prefix key and assign to MAP."
+ ;; Buffer management in prefix "b"
+ ;;
+ (define-key map (concat p "c") 'tinypgp-show-buffer-comint)
+ (define-key map (concat p "d") 'tinypgp-show-buffer-debug)
+ (define-key map (concat p "f") 'tinypgp-show-buffer-finger)
+ (define-key map (concat p "h") 'tinypgp-show-buffer-http)
+ (define-key map (concat p "s") 'tinypgp-show-buffer-shell)
+ (define-key map (concat p "t") 'tinypgp-show-buffer-tmp)
+
+ (define-key map (concat p "\b") 'tinypgp-debug-buffer-clear)
+ (define-key map (concat p "\177") 'tinypgp-debug-buffer-clear)
+ (define-key map (concat p "\C-m") 'tinypgp-show-buffer-debug))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defcustom tinypgp-:show-buffer-echo-menu-use-p t
+ "*Should the 'show-buffer' commands be accessible from echo-area menu?.
+You can set this only once; otherwise you have to reload package."
+ :type 'boolean
+ :group 'tinypgp)
+
+(defconst tinypgp-:show-buffer-echo-menu
+ '(
+ "buffer: c)ache d)ebug,RET f)ing h)ttp s)hell t)emp DEL)debug clear "
+ ((?c . ( (tinypgp-key-cache-display)))
+ (?d . ( (tinypgp-show-buffer-debug)))
+ (?f . ( (tinypgp-show-buffer-finger)))
+ (?h . ( (tinypgp-show-buffer-http)))
+ (?s . ( (tinypgp-show-buffer-shell)))
+ (?t . ( (tinypgp-show-buffer-tmp)))
+ (?\b . ( (tinypgp-debug-buffer-clear)))
+ (?\177 . ( (tinypgp-debug-buffer-clear)))
+ (?\C-m . ( (tinypgp-show-buffer-debug)))))
+ "buffer show menu
+
+c Show key cache buffer
+d Show debug buffer
+f Show finger buffer
+h Show http buffer
+s Show shell buffer
+t Show temp buffer
+
+RET Show debug buffer
+DEL Clear debug buffer")
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-mode-define-keys-user (map p)
+ "Define user keys. Use P prefix key and assign to MAP."
+ (define-key map (concat p "s") 'tinypgp-user-display)
+ (define-key map (concat p "\t") 'tinypgp-user-set-current))
+
+(defcustom tinypgp-:user-echo-menu-use-p t
+ "*Should the 'user' commands be accessible from echo-area menu?.
+You can set this only once; otherwise you have to reload package."
+ :type 'boolean
+ :group 'tinypgp)
+
+(defconst tinypgp-:user-echo-menu
+ '(
+ "user: s)how tab)change"
+ ((?s . ( (call-interactively 'tinypgp-user-display)))
+ (?\t . ( (call-interactively 'tinypgp-user-set-current)))))
+ "User handling menu
+
+s Show current pgp user
+tab Change current pgp user")
+
+;;}}}
+;;{{{ menu: echo, key
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-mode-define-keys-pubring (map p)
+ (define-key map (concat p "s") 'tinypgp-pubring-display)
+ ;; This is little faster key
+ (define-key map (concat p "\t") 'tinypgp-pubring-set-current))
+
+(defcustom tinypgp-:pubring-echo-menu-use-p t
+ "*Should the 'pubring' commands be accessible from echo-area menu?.
+You can set this only once; otherwise you have to reload package."
+ :type 'boolean
+ :group 'tinypgp)
+
+(defconst tinypgp-:pubring-echo-menu
+ '(
+ "pubring: s)how tab)change"
+ ((?s . ( (call-interactively 'tinypgp-pubring-display)))
+ (?\t . ( (call-interactively 'tinypgp-pubring-set-current)))))
+ "User handling menu
+
+s Show current pubring in use
+tab Change current pubring")
+
+;;}}}
+;;{{{ menu: echo, key
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-mode-define-keys-cache (map p)
+ (define-key map (concat p "r")
+ 'tinypgp-key-cache-remove-entry-last)
+ (define-key map (concat p "s") 'tinypgp-key-cache-display))
+
+(defcustom tinypgp-:cache-echo-menu-use-p t
+ "*Should the 'pubring' commands be accessible from echo-area menu?.
+You can set this only once; otherwise you have to reload package."
+ :type 'boolean
+ :group 'tinypgp)
+
+(defconst tinypgp-:cache-echo-menu
+ '(
+ "pubring: s)how tab)change"
+ ((?r . ( (call-interactively 'tinypgp-key-cache-remove-entry-last)))
+ (?s . ( (call-interactively 'tinypgp-key-cache-display)))))
+ "Cache menu
+
+r remove entry from cache.
+s Show cache")
+
+;;}}}
+
+;;{{{ menu: echo, debug
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-mode-define-keys-debug (map p)
+ (define-key map (concat p "d") 'tinypgp-debug-toggle)
+ (define-key map (concat p "c") 'tinypgp-debug-buffer-clear)
+ (define-key map (concat p "s") 'tinypgp-submit-bug-report)
+ (define-key map (concat p "v") 'tinypgp-version-message)
+ (define-key map (concat p "i") 'tinypgp-initial-message)
+ (define-key map (concat p "\e") 'tinypgp-submit-bug-report))
+
+(defcustom tinypgp-:debug-echo-menu-use-p t
+ "*Should the 'debug' commands be accessible from echo-area menu?.
+You can set this only once; otherwise you have to reload package."
+ :type 'boolean
+ :group 'tinypgp)
+
+(defconst tinypgp-:debug-echo-menu
+ '(
+ "debug: d)toggle c)lear s)submit report v)ersion msg i)nit msg"
+ ((?d . ( (call-interactively 'tinypgp-debug-toggle)))
+ (?c . ( (call-interactively 'tinypgp-debug-buffer-clear)))
+ (?s . ( (call-interactively 'tinypgp-submit-bug-report)))
+ (?v . ( (call-interactively 'tinypgp-version-message)))
+ (?i . ( (call-interactively 'tinypgp-initial-message)))))
+ "Debug menu
+d Toggle debug
+c Clear debug buffer
+s Submit bug report
+
+v Show version message
+i Show initial startup message")
+
+;;}}}
+;;{{{ menu: echo, region
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-mode-define-keys-region (map p)
+ (define-key map (concat p "s") 'tinypgp-sign-region)
+ (define-key map (concat p "S") 'tinypgp-sign-region-base64)
+ (define-key map (concat p "D") 'tinypgp-sign-region-detached)
+ (define-key map (concat p "e") 'tinypgp-encrypt-region)
+ (define-key map (concat p "t") 'tinypgp-encrypt-region-sign)
+ (define-key map (concat p "d") 'tinypgp-decrypt-region)
+ (define-key map (concat p "v") 'tinypgp-verify-region)
+ (define-key map (concat p "c") 'tinypgp-crypt-region))
+
+(defcustom tinypgp-:region-echo-menu-use-p t
+ "*Should the 'region' commands be accessible from echo-area menu?.
+You can set this only once; otherwise you have to reload package."
+ :type 'boolean
+ :group 'tinypgp)
+
+(defconst tinypgp-:region-echo-menu
+ '(
+ "region: sSD)sign,base64,detach e)ncrypt t)1pass d)ecrypt v)erify c)rypt "
+ ((?s . ( (call-interactively 'tinypgp-sign-region)))
+ (?S . ( (call-interactively 'tinypgp-sign-region-base64)))
+ (?D . ( (call-interactively 'tinypgp-sign-region-detached)))
+ (?e . ( (call-interactively 'tinypgp-encrypt-region)))
+ (?t . ( (call-interactively 'tinypgp-encrypt-region-sign)))
+ (?d . ( (call-interactively 'tinypgp-decrypt-region)))
+ (?v . ( (call-interactively 'tinypgp-verify-region)))
+ (?c . ( (call-interactively 'tinypgp-crypt-region)))))
+ "Region menu
+
+s Sign
+S Sign with base64 armor
+D Detach sign
+e encrypt
+t encrypt and sign on 1pass
+d decrypt
+v verify
+c crypt
+")
+
+;;}}}
+;;{{{ menu: echo, keyring
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-mode-define-keys-key (map p)
+ ;; #todo key generate
+ ;; A (define-key map (concat p "g") 'tinypgp-key-generate)
+ ;; - "ki" is closer to keyboard than default pgp "kv".
+
+ (define-key map (concat p "i") 'tinypgp-key-info-at-point-show)
+ (define-key map (concat p "I") 'tinypgp-key-info-insert)
+ (define-key map (concat p "v") 'tinypgp-key-info-insert)
+
+ (define-key map (concat p "a") 'tinypgp-key-add-region-batch)
+ (define-key map (concat p "A")
+ 'tinypgp-key-add-region-interactive)
+ (define-key map (concat p "x") 'tinypgp-key-extract-to-point)
+ (define-key map (concat p "r") 'tinypgp-key-delete-region))
+
+(defcustom tinypgp-:key-echo-menu-use-p t
+ "*Should the 'key' commands be accessible from echo-area menu?.
+You can set this only once; otherwise you have to reload package."
+ :type 'boolean
+ :group 'tinypgp)
+
+(defconst tinypgp-:key-echo-menu
+ '(
+ "key: i)nfo show vI)nsert a)dd batch A)add interactive x)tract r)emove"
+ ((?i . ( (call-interactively 'tinypgp-key-info-at-point-show)))
+ (?I . ( (call-interactively 'tinypgp-key-info-insert)))
+ (?v . ( (call-interactively 'tinypgp-key-info-insert)))
+ (?a . ( (call-interactively 'tinypgp-key-add-region-batch)))
+ (?A . ( (call-interactively 'tinypgp-key-add-region-interactive)))
+ (?x . ( (call-interactively 'tinypgp-key-extract-to-point)))
+ (?r . ( (call-interactively 'tinypgp-key-delete-region)))))
+ "Key management menu
+
+i Show keys matching string at point
+I Insert key info mathing string to point
+v ...same... (synonym)
+a add keys in region to pubring
+A add keys in region to pubring (interactive)
+x Extract key from keyring to point
+r removed selected keys in region from keyring
+")
+
+;;}}}
+;;{{{ menu: echo, modes
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-mode-define-keys-mode (map p)
+ (define-key map (concat p "!") 'tinypgp-auto-action-toggle)
+ (define-key map (concat p "c") 'tinypgp-secring-crypt-mode-toggle)
+
+ (define-key map (concat p "e")
+ 'tinypgp-email-substitution-toggle)
+
+ (define-key map (concat p "h") 'tinypgp-xpgp-header-mode-toggle)
+ (define-key map (concat p "H")
+ 'tinypgp-header-sign-mode-toggle)
+
+ (define-key map (concat p "s") 'tinypgp-sign-mail-auto-mode))
+
+(defcustom tinypgp-:mode-echo-menu-use-p t
+ "*Should the 'mode' commands be accessible from echo-area menu?.
+You can set this only once; otherwise you have to reload package."
+ :type 'boolean
+ :group 'tinypgp)
+
+(defconst tinypgp-:mode-echo-menu
+ '(
+ "mode: !)action c)rypt secring e)mail h)x-pgp H)eader sign s)ign"
+ ((?! . ( (call-interactively 'tinypgp-auto-action-toggle)))
+ (?c . ( (call-interactively 'tinypgp-secring-crypt-mode-toggle)))
+ (?e . ( (call-interactively 'tinypgp-email-substitution-toggle)))
+ (?h . ( (call-interactively 'tinypgp-xpgp-header-mode-toggle)))
+ (?H . ( (call-interactively 'tinypgp-header-sign-mode-toggle)))
+ (?s . ( (call-interactively 'tinypgp-sign-mail-auto-mode)))))
+ "Mode handling menu
+
+! Toggle auto action: enable, disable
+c Toggle secring crypt mode
+e Toggle email subtitution mode
+f Toggle fcc encrypt mode
+h Toggle header based x-pgp signing mode
+H Toggle including part of the headers for signing
+s Toggle auto signing mode of outgoing mail")
+
+;;}}}
+;;{{{ menu: echo, key
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-mode-define-keys-extra (map p)
+
+ (define-key map (concat p "a") 'tinypgp-auto-action-verbose)
+
+ (define-key map (concat p "b") 'tinypgp-backend-select)
+ (define-key map (concat p "B") 'tinypgp-secring-backup)
+
+ (define-key map (concat p "D") 'tinypgp-delete-processes)
+
+ (define-key map (concat p "E")
+ 'tinypgp-key-id-conversion-check-verbose)
+
+ (define-key map (concat p "e") 'tinypgp-encrypt-info)
+
+ (define-key map (concat p "h") 'tinypgp-header-list-show)
+ (define-key map (concat p "i")
+ 'tinypgp-pgp-stream-forward-study)
+
+ (define-key map (concat p "f") 'tinypgp-show-last-finger-error)
+
+ (define-key map (concat p "k")
+ 'tinypgp-keysrv-send-email-command)
+
+ (define-key map (concat p "l") 'tinypgp-sign-loose-info)
+
+ (define-key map (concat p "p")
+ 'tinypgp-sendmail-key-not-in-plan)
+
+ (define-key map (concat p "w") 'tinypgp-password-wipe-buffer)
+
+ (define-key map (concat p "x") 'tinypgp-password-expire-now)
+ (define-key map (concat p "X") 'tinypgp-secring-crypt-expire-password))
+
+(defcustom tinypgp-:extra-echo-menu-use-p t
+ "*Should the 'extra' commands be accessible from echo-area menu?.
+You can set this only once; otherwise you have to reload package."
+ :type 'boolean
+ :group 'tinypgp)
+
+(defconst tinypgp-:extra-echo-menu
+ (list
+ "\
+extra: aeh)info f)ing iE)pgp kp)email l)oose b)backend B)up wDxX)pire >dC "
+ (list
+ '(?a . ( (call-interactively 'tinypgp-auto-action-verbose)))
+ '(?b . ( (call-interactively 'tinypgp-backend-select)))
+ '(?B . ( (call-interactively 'tinypgp-secring-backup)))
+ '(?D . ( (call-interactively 'tinypgp-delete-processes)))
+ '(?e . ( (call-interactively 'tinypgp-key-id-conversion-check-verbose)))
+ '(?E . ( (call-interactively 'tinypgp-encrypt-info)))
+ '(?h . ( (call-interactively 'tinypgp-header-list-show)))
+ '(?i . ( (call-interactively 'tinypgp-pgp-stream-forward-study)))
+ '(?f . ( (call-interactively 'tinypgp-show-last-finger-error)))
+ '(?k . ( (call-interactively 'tinypgp-keysrv-send-email-command)))
+ '(?l . ( (call-interactively 'tinypgp-sign-loose-info)))
+ '(?p . ( (call-interactively 'tinypgp-sendmail-key-not-in-plan)))
+ '(?w . ( (call-interactively 'tinypgp-password-wipe-buffer)))
+ '(?x . ( (call-interactively 'tinypgp-password-expire-now)))
+ '(?X . ( (call-interactively 'tinypgp-secring-crypt-expire-password)))
+
+ (cons ?d 'tinypgp-:debug-echo-menu)
+ (cons ?C 'tinypgp-:cache-echo-menu)))
+ "Extra menu
+
+Information
+
+ a Show auto action that would trigger this mail
+ e Show what email conversion would apply to To address
+ h Show what headers would be signed
+ f Show last finger error in echo area
+
+ Pgp block
+
+ E Study encrypted message and show whom it's encrypted to
+ i Study pgp stream forward and show info (type pgp version etc.)
+
+Email
+
+ k Send command to keyserver
+ p Send notice that user's key was not in .plan when fingered.
+
+Miscellaneous
+
+ l Loose signing information
+ b Select backend> pgp 2.6.x or pgp 5.x
+ B Backup secring in encrypted format
+
+Wipe
+
+ d Delete all running PGP processes. Eg. Pgp 5.x may be hung in your
+ emacs. Use this command to get rip of those zombies. See process
+ list with command \\[list-processes]
+ w wipe passwords from buffer
+ x Expire pass phrases
+ X Expire encrypted secring password.")
+
+;;}}}
+
+;;{{{ menu: define keys
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-mode-define-keys ()
+ "Define keys."
+ (let* ((map tinypgp-:mode-map)
+ (p tinypgp-:mode-prefix-key)
+ (r tinypgp-:mode-prefix-key-remailer)
+ (y tinypgp-:mode-prefix-key-nymserver)
+ (n tinypgp-:mode-prefix-key-newnym))
+
+ (if tinypgp-:region-echo-menu-use-p
+ (define-key map (concat p "r")
+ (ti::definteractive (ti::menu-menu 'tinypgp-:region-echo-menu arg)))
+ (tinypgp-mode-define-keys-region map (concat p "r")))
+
+ ;; ................................................. user, pubring ...
+
+ (if tinypgp-:user-echo-menu-use-p
+ (define-key map (concat p "u")
+ (ti::definteractive (ti::menu-menu 'tinypgp-:user-echo-menu arg)))
+ (tinypgp-mode-define-keys-user map (concat p "u")))
+
+ (if tinypgp-:pubring-echo-menu-use-p
+ (define-key map (concat p "p")
+ (ti::definteractive (ti::menu-menu 'tinypgp-:pubring-echo-menu arg)))
+ (tinypgp-mode-define-keys-pubring map (concat p "p")))
+
+ ;; ....................................................... keyring ...
+
+ (if tinypgp-:key-echo-menu-use-p
+ (define-key map (concat p "k")
+ (ti::definteractive (ti::menu-menu 'tinypgp-:key-echo-menu arg)))
+ (tinypgp-mode-define-keys-key map (concat p "k")))
+
+ ;; ........................................................ buffer ...
+
+ (if tinypgp-:show-buffer-echo-menu-use-p
+ (define-key map (concat p "b")
+ (ti::definteractive (ti::menu-menu 'tinypgp-:show-buffer-echo-menu arg)))
+ (tinypgp-mode-define-keys-buffer map (concat p "b")))
+
+ ;; ......................................................... extra ...
+
+ (if tinypgp-:extra-echo-menu-use-p
+ (define-key map (concat p "x")
+ (ti::definteractive (ti::menu-menu 'tinypgp-:extra-echo-menu arg)))
+ (tinypgp-mode-define-keys-extra map (concat p "x")))
+
+ (unless tinypgp-:debug-echo-menu-use-p
+ (tinypgp-mode-define-keys-debug map (concat p "xd")))
+
+ (unless tinypgp-:debug-echo-menu-use-p
+ (tinypgp-mode-define-keys-cache map (concat p "xC")))
+
+ ;; .......................................................... mode ...
+
+ (if tinypgp-:mode-echo-menu-use-p
+ (define-key map (concat p "m")
+ (ti::definteractive (ti::menu-menu 'tinypgp-:mode-echo-menu arg)))
+ (tinypgp-mode-define-keys-mode map (concat p "m")))
+
+ ;; ...................................................... remailer ...
+
+ (if tinypgp-:remail-echo-menu-use-p
+ (define-key map r
+ (ti::definteractive (ti::menu-menu 'tinypgp-:remail-echo-menu arg)))
+ (tinypgp-mode-define-keys-remail map r))
+
+ ;; ..................................................... nymserver ...
+
+ (if tinypgp-:nymserver-echo-menu-use-p
+ (define-key map y
+ (ti::definteractive
+ (ti::menu-menu 'tinypgp-:nymserver-echo-menu arg)))
+ (tinypgp-mode-define-keys-nymserver map y))
+
+ ;; ........................................................ newnym ...
+
+ (if tinypgp-:newnym-echo-menu-use-p
+ (define-key map n
+ (ti::definteractive (ti::menu-menu 'tinypgp-:newnym-echo-menu arg)))
+ (tinypgp-mode-define-keys-nymserver map n))
+
+ ;; ....................................................... regular ...
+
+ (define-key map
+ (concat p (ti::string-right p 1)) 'tinypgp-next-action-mail)
+
+ (define-key map (concat p "?") 'tinypgp-mode-describe)
+
+ (define-key map (concat p "a") 'tinypgp-header-move-to-body)
+ (define-key map (concat p "s") 'tinypgp-sign-mail)
+ (define-key map (concat p "S") 'tinypgp-sign-mail-base64)
+ (define-key map (concat p "D") 'tinypgp-sign-mail-detached)
+
+ (define-key map (concat p "e") 'tinypgp-encrypt-mail)
+ (define-key map (concat p "t") 'tinypgp-encrypt-mail-sign)
+
+ ;; There no particular reason why "q" for mime.
+ ;; I chose it because, Q char is obscure enough to
+ ;; remind that in 1998-03 the PGP/MIME is still new.
+
+ (define-key map (concat p "q") 'tinypgp-sign-mail-mime)
+ (define-key map (concat p "Q") 'tinypgp-encrypt-mail-mime)
+
+ (define-key map (concat p "d") 'tinypgp-decrypt-mail)
+ (define-key map (concat p "v") 'tinypgp-verify-mail)
+ (define-key map (concat p "V")
+ 'tinypgp-verify-detached-signature)
+
+ (define-key map (concat p "c") 'tinypgp-crypt-mail)
+ (define-key map (concat p "i") 'tinypgp-sign-base64-insert-file)
+
+ (define-key map (concat p "h") 'tinypgp-xpgp-header-toggle)
+ (define-key map (concat p "g") 'tinypgp-hide-show-toggle)
+
+ (define-key map (concat p "R") 'tinypgp-view-register)
+ (define-key map (concat p "F") 'tinypgp-key-find-by-finger)
+
+ (define-key map (concat p "G")
+ 'tinypgp-key-find-by-guess)
+
+ (define-key map (concat p "E") 'tinypgp-key-find-by-email)
+
+ (define-key map (concat p "K")
+ 'tinypgp-key-find-by-http-guess)
+
+ (define-key map (concat p "2") 'tinypgp-backend-select-pgp2)
+ (define-key map (concat p "5") 'tinypgp-backend-select-pgp5)
+
+ (define-key map (concat p "\C-m") 'tinypgp-key-find-by-guess)))
+
+;;}}}
+;;{{{ mode: key mode
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-key-mode-define-menu ()
+ "Define menus."
+ (easy-menu-define
+ tinypgp-:key-mode-menu (if (ti::xemacs-p) nil tinypgp-:key-mode-map)
+ "TinyPgp Key management menu"
+ (list
+ tinypgp-:key-mode-menu-name)))
+;;; ["Mail Sign" tinypgp-sign-mail t]
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-key-mode-define-keys ()
+ "Define keys."
+ (let* ((p tinypgp-:key-mode-prefix-key)
+ (map tinypgp-:key-mode-map))
+ (define-key map (concat p "a") 'tinypgp-key-add-region-batch)))
+
+;;}}}
+;;{{{ mode: summary mode
+
+;;; --------------------------------------------------------- &summary ---
+;;;
+(defun tinypgp-summary-mode-define-menu ()
+ "Define menus."
+ (easy-menu-define
+ tinypgp-:summary-mode-menu (if (ti::xemacs-p) nil tinypgp-:summary-mode-map)
+ "TinyPgp Mail Summary management menu"
+ (list
+ tinypgp-:summary-mode-menu-name
+ ["Verify" tinypgp-summary-mode-verify t]
+ ["Decrypt" tinypgp-summary-mode-decrypt t]
+ ["Next action" tinypgp-summary-mode-next-action t]
+ ["Describe mode" tinypgp-summary-mode-describe t]
+
+ "----"
+ (list
+ "Extra commands"
+ ["Wash expire pass phrases/files" tinypgp-password-expire-now t]
+ ["Wash expire secring password"
+ tinypgp-secring-crypt-expire-password t]
+ "----"
+ ["Info Display last finger error" tinypgp-show-last-finger-error t]
+ ["Info View pgp register" tinypgp-view-register t]
+ "----"
+ ["Send email: .plan has no PGP key" tinypgp-sendmail-key-not-in-plan t]
+ ["Send email: keyserver cmd" tinypgp-keysrv-send-email-command t])
+
+ (list
+ "Cache service"
+ ["Remove last entry" tinypgp-key-cache-remove-entry-last t]
+ ["Display" tinypgp-key-cache-display t])
+
+ (list
+ "Report service"
+ ["Submit bug report" tinypgp-submit-bug-report t]
+ ["Debug on/off" tinypgp-debug-toggle t]
+ ["Debug buffer clear" tinypgp-debug-buffer-clear t]
+ "----"
+ ["Display comint" tinypgp-show-buffer-comint t]
+ ["Display debug" tinypgp-show-buffer-debug t]
+ ["Display finger" tinypgp-show-buffer-finger t]
+ ["Display http" tinypgp-show-buffer-http t]
+ ["Display shell" tinypgp-show-buffer-shell t]
+ ["Display tmp" tinypgp-show-buffer-tmp t]))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-summary-mode-define-keys ()
+ "Define keys."
+ (let* ((p tinypgp-:summary-mode-prefix-key)
+ (map tinypgp-:summary-mode-map))
+
+ (tinypgp-mode-define-keys-buffer map p)
+ (tinypgp-mode-define-keys-user map p)
+
+ (define-key map
+ (concat p (ti::string-right p 1)) 'tinypgp-summary-mode-next-action)
+
+ (define-key map (concat p "?") 'tinypgp-summary-mode-describe)
+ (define-key map (concat p "d") 'tinypgp-summary-mode-decrypt)
+ (define-key map (concat p "v") 'tinypgp-summary-mode-verify)))
+
+;;}}}
+;;{{{ code: Mode functions
+
+(eval (ti::macrof-minor-mode-viper-attach "tinypgp-mode-" 'tinypgp-mode))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;
+(ti::macrof-minor-mode
+ tinypgp-mode ;1
+ "PGP minor mode.
+Mode description:
+\\{tinypgp-:mode-map}
+"
+ tinypgp-install-modes ;3
+ tinypgp-mode ;4
+ tinypgp-:mode-name
+
+ tinypgp-:mode-prefix-key ;5
+ tinypgp-:mode-menu ;6
+
+ nil ;7
+ "TinyPgp" ;8
+ tinypgp-:mode-hook
+
+ (progn
+ (if (null tinypgp-:pubring-now)
+ (setq tinypgp-:pubring-now
+ (tinypgp-expand-file-name
+ (nth 1 (car (tinypgp-pubring-table))))))
+
+ (if (not (file-exists-p tinypgp-:pubring-now))
+ (error "TinyPgp: Can't init mode, pubring not found '%s'"
+ tinypgp-:pubring-now))
+
+ (if (not (stringp tinypgp-:user-now))
+ (error "TinyPgp: Can't init mode, user is not defined '%s'"
+ tinypgp-:user-now))
+ (tinypgpd "tinypgp-mode" arg)
+ (tinypgp-update-modeline)))
+
+(defun turn-on-tinypgp-mode ()
+ "Pgp mode on."
+ (tinypgp-mode 1))
+
+(defun turn-off-tinypgp-mode ()
+ "Pgp mode off."
+ (tinypgp-mode 0))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun turn-on-tinypgp-mode-maybe ()
+ "Turn on `tinypgp-mode' only if PGP tags are found from buffer.
+This function is by default installed into `find-file-hooks'."
+ (when (and (null tinypgp-mode)
+ (ti::mail-pgp-p))
+ (turn-on-tinypgp-mode)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-mode-describe ()
+ "Describe mode."
+ (interactive)
+ (describe-function 'tinypgp-mode))
+
+;;; .................................................... &pgp-key-mode ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(ti::macrof-minor-mode
+ tinypgp-key-mode
+ "PGP key handling minor mode. You should extract the the key information
+to some buffer first before turning on this mode.
+Eg. with \\[tinypgp-key-info-at-point-show]
+
+Mode description:
+\\{tinypgp-:key-mode-map}
+"
+ tinypgp-install-modes
+ tinypgp-key-mode
+ tinypgp-:key-mode-name ;5
+
+ tinypgp-:key-mode-prefix-key
+ tinypgp-:key-mode-menu ;7
+
+ nil
+ "TinyPgp Key handling"
+ tinypgp-:key-mode-hook ;10
+
+ (progn
+ (if tinypgp-key-mode
+ (tinypgp-update-modeline))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-key-mode-describe ()
+ "Describe mode."
+ (interactive)
+ (describe-function 'tinypgp-key-mode))
+
+;;; .................................................... &pgp-sum-mode ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(ti::macrof-minor-mode
+ tinypgp-summary-mode
+ "PGP summary minor mode. This function can only be turned on in VM
+RMAIL and GNUS summary buffer. Any PGP action called there is reflected
+on the current message selected.
+
+Mode description:
+\\{tinypgp-:summary-mode-map}
+"
+ tinypgp-install-modes
+ tinypgp-summary-mode
+ tinypgp-:summary-mode-name
+
+ tinypgp-:summary-mode-prefix-key
+ tinypgp-:summary-mode-menu
+
+ nil
+ "TinyPgp Mail Summary"
+ tinypgp-:summary-mode-hook
+
+ (progn
+ (when tinypgp-summary-mode
+ (unless (memq major-mode
+ '(rmail-summary-mode
+ vm-summary-mode
+ gnus-summary-mode
+ mh-show-mode))
+ (setq tinypgp-summary-mode nil)
+ (error "You can use this mode only in Mail summary buffers."))
+
+ ;; This modeline update is a problem only in RMAIL-summary buffer.
+ ;; We cannot use rmail-summary-mode-hook, because turning mode on
+ ;; there does no good (summary buffer is not shown yet)
+ ;;
+ ;; See advised function rmail-new-summary which calls us.
+ ;;
+ (tinypgp-update-modeline))))
+
+(defun turn-on-tinypgp-summary-mode ()
+ "Summary mode." (tinypgp-summary-mode 1))
+
+(defun turn-off-tinypgp-summary-mode ()
+ "Summary mode." (tinypgp-summary-mode 0))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-summary-mode-describe ()
+ "Describe mode."
+ (interactive)
+ (describe-function 'tinypgp-summary-mode))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-summary-mode-verify (&optional arg)
+ "Verify current article with ARG.
+
+Note:
+
+ In GNUS Summary buffer, where the *Article* is guessed to be a newsgroup
+ post, the prefix arg meaning has been reversed. When you verify
+ newsgroup article, the content of the article is not replaced, as it
+ would anywhere else."
+ (interactive "P") (tinypgp-summary-action 'verify arg 'verb))
+
+(defun tinypgp-summary-mode-decrypt (&optional arg)
+ "Decrypt current article with ARG."
+ (interactive "P") (tinypgp-summary-action 'decrypt arg 'verb))
+
+(defun tinypgp-summary-mode-next-action (&optional arg)
+ "Guess next action and pass ARG."
+ (interactive "P") (tinypgp-summary-action 'next-action arg 'verb))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-summary-action-1 (action func arg verb)
+ "See source code for `tinypgp-summary-action' for ACTION FUNC ARG VERB."
+ (save-excursion
+ (pop-to-buffer (current-buffer))
+ (cond
+ ((eq action 'verify) (funcall func arg 'verb))
+ ((eq action 'next-action) (call-interactively func))
+ ((eq action 'decrypt) (tinypgp-decrypt-mail-verbose (quote arg))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-summary-action (action-sym &optional arg verb)
+ "Do ACTION-SYM in summary buffer. ARG is passed to called function. VERB."
+ (let* ((fid "tinypgp-summary-action: ")
+ (win (get-buffer-window (current-buffer)))
+ (list '(verify decrypt next-action))
+ str
+ func)
+ (if (not (memq action-sym list))
+ (error "TinyPgp: Unregognized/Not supported summary action."))
+
+ (setq str (format "tinypgp-%s-mail" (symbol-name action-sym)))
+
+ (if (null (setq func (intern-soft str)))
+ (error "TinyPgp: Function not found %s" str))
+
+ (tinypgpd fid major-mode action-sym func)
+
+ (cond
+ ((eq major-mode 'rmail-summary-mode)
+ (ti::mail-rmail-macro
+ (tinypgp-summary-action-1 action-sym func arg verb)))
+
+ ((eq major-mode 'vm-summary-mode)
+ (ti::mail-vm-macro
+ (tinypgp-summary-action-1 action-sym func arg verb)))
+
+ ((eq major-mode 'gnus-summary-mode)
+ (ti::mail-gnus-macro
+ ;; In newsgroup post the user doesn't want to "open"
+ ;; the message when he verifies it. Reverse the ARG meaning
+ (when (and (eq action-sym 'verify) (ti::mail-news-buffer-p))
+ (ti::bool-toggle arg))
+ (tinypgpd fid action-sym "ARG" arg "NEWS" (ti::mail-news-buffer-p))
+ (tinypgp-summary-action-1 action-sym func arg verb)))
+
+ ((eq major-mode 'mh-show-mode)
+ (ti::mail-mh-macro
+ (tinypgp-summary-action-1 action-sym func arg verb)))
+
+ (t
+ (error "TinyPgp: I Can't do anything in this major mode.")))
+ (if (window-live-p win) ;Back to summary
+ (select-window win))))
+
+;;}}}
+
+;;{{{ code: defadvice
+
+;;; ....................................................... &defadvice ...
+
+(defadvice rmail-new-summary (after tinypgp act)
+ "Update mode line.
+For some reason this couldn't be done from 19.28's`rmail-summary-mode-hook'."
+ (tinypgp-summary-mode))
+
+;;; (ad-unadvise 'vm-edit-message)
+;;;
+(defadvice vm-edit-message (after tinypgp dis)
+ "If Edit is called interactively, call `turn-on-tinypgp-mode'.
+We can't do this in `vm-edit-message-hoo' because the hook function
+doesn't know if the function were called interactively or not."
+ (if (and (interactive-p)
+ (null tinypgp-mode))
+ (turn-on-tinypgp-mode)))
+
+;;}}}
+
+;;{{{ Special: sending email
+
+;;; ........................................................ &sendmail ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-sendmail-key-not-in-plan (email)
+ "Send small mail to EMAIL and ask him to add his PGP key to ~/.plan.
+
+When you finger someone for his pgp key, consider this before you send
+notice to person. (check the content of finger buffer)
+
+o Finger finds the .plan file and the contents seems valid, there is login
+ name and directory information and soon. This would indicate that
+ it is ok to send notice to person.
+o Finger result"
+ (interactive
+ (let* (ret)
+ (and (y-or-n-p
+ ;; someone may think this harrashement
+ ;;
+ "Are you sure you want to send .plan notice? Think twice..." )
+ (y-or-n-p
+ "You did check the content of the finger results: was it ok otw? ")
+ (setq ret
+ (read-from-minibuffer
+ "Mail to: "
+ (ignore-errors (ti::mail-get-field "to" nil 'nil-mode)))))
+ (if (not (string-match "@"))
+ (error "Abort."))
+ (list ret)))
+ (tinypgp-sendmail email 'pk-finger-none)
+ (if (interactive-p)
+ (message "Email sent to: %s" email)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-sendmail (email mode &optional arg1 arg2 arg3)
+ "Send email notice to EMAIL address according to MODE and ARG1 ARG2 ARG3."
+ (let* ((id
+ (format
+ "\nThis is message from TinyPgp.el %s\n\n"
+ (tinypgp-version-number)))
+
+ (subject (format
+ " %s, Notification concerning your PGP."
+ email))
+ msg)
+ (cond
+ ((eq mode 'pk-no-full-format)
+ (setq msg
+ (format
+ (concat
+ "\tWe fingered address %s to get your public key\n\t"
+ "but it was not presented in full format of pgp -fakx.\n\t"
+ "Would you please insert all test starting from\n\t"
+ "'Key for user ID:' line from the -fakx output. \n\t"
+ "That would offer access to your other information\n\t"
+ "that may be needed. \nt"
+ "\n"
+ "Please note that the -kv format is not the same as -fakx\n"
+ "\n"
+ "\tThank you.\n")
+ email)))
+ ((eq mode 'pk-finger-none)
+ (setq msg
+ (format
+ (concat
+ "\tHi!\n\t"
+ "We could finger address %s but there was no PGP \n\t"
+ "Public key available. Would you kindly run \n\t"
+ "'pgp -fakx' on you keyId and put all\n\t"
+ "lines after 'Key for user ID:' to you $HOME/.plan file.\n\n\t"
+ "Thank you. Please excuse this message if you don't have\n"
+ "or use PGP\n")
+ email)))
+ (t
+ (error "TinyPgp: Unknown mode")))
+
+ (ti::mail-sendmail-macro email subject 'send
+ (insert id msg))))
+
+;;}}}
+;;{{{ BBDB
+
+;;; ............................................................ &bbdb ...
+
+(defcustom tinypgp-:bbdb-field 'pgp-mail
+ "*Field to use in BBDB to store PGP preferences.
+Entry in table `tinypgp-:auto-action-table' overrides BBDB definition.
+
+Field can have values:
+
+ 'sign' Sign message
+ 'sign-Keyid' Sign with KeyId
+ 'xpgp' Use X-pgp when signing.
+ 'enccrypt' Encrypt message by looking at To field. If you want to encrypt
+ using some other value, like 0xFFFFFF hex key id, see
+ variable `tinypgp-:email-substitution-table'
+ 'mime-tm' use PGP/MIME with package TM
+ '1pass' Use 1 pass encrypt and sign. The message is signed with
+ active pgp user's key
+ '1pass-keyId' ..same but sign by using KeyId
+
+You can't use `sign' and `encrypt' with `1pass', which has highest
+precedence.
+
+Examples:
+
+ pgp-mail: sign ;; Sign by pgp user
+ pgp-mail: sign mime-tm ;; PGP/MIME sign with TM package
+ pgp-mail: encrypt
+ pgp-mail: 1pass ;; encryt and sign"
+ :type 'symbol
+ :group 'TinyPgp)
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-bbdb-1 (name address field)
+ "Look up user NAME and ADDRESS in BBDB and return FIELD"
+ (let* ((record (bbdb-search-simple name address)))
+ (when record
+ (bbdb-record-getprop record field))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-bbdb-id (&optional email)
+ "Return BBDB `pgp-id' field matching EMAIL or To-field address."
+ (interactive)
+ (when (featurep 'bbdb)
+ (let* ((fid "tinypgp-bbdb-id:")
+ (key 'pgp-id)
+ ret
+ address)
+ (setq ret
+ (if email
+ (tinypgp-bbdb-1 "" email key)
+ (setq address (mail-extract-address-components
+ (or (mail-fetch-field "To" nil t) "")))
+ (when (nth 1 address)
+ (tinypgp-bbdb-1 (or (nth 0 address) "") (nth 1 address) key))))
+ (tinypgpd fid 'ARG email 'address address 'RET ret)
+ ret)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-bbdb-entry ()
+ "Return bbdb auto action entry in format `tinypgp-:auto-action-table'."
+ (when (featurep 'bbdb)
+ (let* ((fid "tinypgp-bbdb-entry:")
+ (to-field (mail-fetch-field "To" nil t))
+ (address (mail-extract-address-components (or to-field "")))
+ elt sign enc mime-mua xpgp)
+ (tinypgpd fid to-field address)
+
+ (when (and (nth 1 address)
+ (setq elt (tinypgp-bbdb-1 (car address) (nth 1 address)
+ tinypgp-:bbdb-field)))
+
+ (if (string-match "mime" elt)
+ (setq mime-mua 'mime))
+
+ (cond
+ ((string-match "sign-\\([^ \t]+\\)" elt)
+ (setq sign (match-string 1 elt)))
+ ((string-match "sign" elt)
+ (setq sign tinypgp-:user-now)))
+
+ (if (string-match "xpgp" elt)
+ (setq xpgp t))
+
+ (setq enc (string-match "encrypt" elt))
+
+ (when (string-match "1pass" elt)
+ (setq sign (make-symbol tinypgp-:user-now))
+ (setq enc t))
+
+ (if (and mime-mua sign)
+ (setq sign (make-symbol sign)))
+
+ ;; '(EVAL-OR-REGEXP [SIGN-KEY-ID] [ENCRYPT]
+ ;; [MIME-MUA] [XPGP] [KEYRING])
+
+ (list
+ (nth 1 address)
+ sign enc mime-mua xpgp)))))
+;;}}}
+
+;;{{{ special: Mode specific actions
+
+;;; ................................................... &mode-specific ...
+
+;;; ----------------------------------------------------------------------
+;;; #todo: tinypgp-mail-do-fcc breaks in VM
+;;;
+(defun tinypgp-mail-do-fcc (&optional cmd user msg string)
+ "Do FCC before the message is encrypted and remove FCC field.
+You don't want sendmail.el to FCC message which was encrypted
+with the other user's public key.
+
+This function Supports MUAs:
+
+ Sendmail Fcc -- mail-mode
+ Gnus Gcc -- message-mode
+
+Input:
+ CMD
+ USER
+ MSG
+ STRING"
+ (let ((fid "tinypgp-mail-do-fcc: ")
+ field-fcc field-gcc
+ hmax)
+
+ ;;#todo VM FCC must be handled differently ?
+ ;;#todo Gnus 5 mail fcc ?
+
+ (tinypgpd fid "in: " cmd user msg string major-mode)
+
+ (setq field-fcc (mail-fetch-field "fcc")
+ field-gcc (mail-fetch-field "gcc"))
+
+ (when (and (memq major-mode '(mail-mode message-mode))
+ (memq cmd '(encrypt encrypt-sign)))
+
+ (setq hmax (ti::mail-hmax))
+
+ (tinypgpd fid 'fcc field-fcc 'gcc field-gcc
+ 'buffer (current-buffer)
+ 'header-max hmax
+ 'point-max (point-max))
+
+ (when (and field-gcc (featurep 'gnus))
+ (gnus-inews-do-gcc))
+
+ (cond
+ ((ti::xemacs-p) ;needs MARKER
+ (save-excursion
+ (goto-char hmax)
+ (setq hmax (point-marker)))
+ (mail-do-fcc hmax) ;Header end
+ (setq hmax nil)) ;kill marker
+
+ (t ;XE19.14 and Emacs needs POINT
+ (mail-do-fcc (ti::mail-hmax))))
+
+ (tinypgp-hash 'fcc 'put 'fcc field-fcc)
+ (tinypgp-hash 'gcc 'put 'gcc field-gcc)
+
+ ;; Message saving happened in another buffer, remove these
+ ;; fields from this original buffer.
+
+ (while (not (ti::nil-p (mail-fetch-field "fcc")))
+ (ti::mail-kill-field "^FCC"))
+
+ (while (not (ti::nil-p (mail-fetch-field "gcc")))
+ (ti::mail-kill-field "^GCC")))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-mode-specific-control-before
+ (cmd &optional user msg string)
+ "Turn on possible edit mode while we do some PGP action.
+This function is called prior the PGP action takes effect in current
+region or buffer. Eg. in RMAIL we have to turn on the edit mode in
+order to modify the message content.
+
+Input:
+
+ The content of these function call parameter depends on the
+ calling CMD which can be 'sign 'encrypt 'decrypt 'verify.
+ You have to look at the source code to see what is passed in each case.
+ CMD OPTIONAL USER MSG STRING
+
+Used hash entries:
+
+ The buffer pointer is recorded to hash table under property
+ 'mode-specific and value 'buffer. This is name of the current buffer
+ where the original message is.
+
+ When edit mode is turned on, the buffer may now be different and
+ the buffer pointer is recorded under property 'mode-specific and value
+ 'buffer-edit.
+
+References:
+
+ `tinypgp-:verify-before-hook' ;; contain this function
+ `tinypgp-cmd-macro' ;; calls this function
+ `tinypgp-mode-specific-control-after' ;; 'the other side of the coin'"
+ (let ((fid "tinypgp-mode-specific-control-before: "))
+
+ (tinypgpd fid "CMD" cmd user msg "BUFFER" (current-buffer) major-mode)
+
+ (tinypgp-mail-do-fcc cmd user msg string)
+
+ ;; When "after" function runs it checks if this flag is non-nil
+ ;; and strores the contents of the "clone" buffer there.
+
+ (tinypgp-hash 'mode-specific 'put 'register nil 'global)
+
+ ;; We have to record the initial buffer, so that the AFTER
+ ;; hook can restore the state in correct buffer. The package
+ ;; may die anywhere in the code and the buffer pointer certainly
+ ;; isn't pointing to the right place any moreon error.
+
+ (tinypgp-hash 'mode-specific 'put 'buffer (buffer-name) 'global)
+ (tinypgp-hash 'mode-specific 'put 'major-mode major-mode 'global)
+ (tinypgp-hash 'vm 'put 'control nil 'global)
+
+ ;; - For some unknown reason the VM window configurations
+ ;; is mixed when we open edit mode and close it afterwards,
+ ;; we must save window configuration now.
+ ;; - We save this every time, but we only use it in VM
+
+ (tinypgp-hash 'mode-specific 'put 'wcfg
+ (current-window-configuration)
+ 'global)
+
+ (tinypgp-hash 'mode-specific 'put 'frame (selected-frame) 'global)
+ (tinypgp-hash 'mode-specific 'put 'window (selected-window) 'global)
+ (tinypgp-hash 'mode-specific 'put 'read-only buffer-read-only 'global)
+
+ (when (featurep 'vm)
+ (tinypgp-hash 'vm 'put 'vm-frame-per-edit vm-frame-per-edit 'global))
+
+ (tinypgp-hash 'mode-specific 'put 'buffer (buffer-name) 'global)
+
+ ;; ....................................................... secring ...
+ (when (and tinypgp-:secring-crypt-mode
+ (not (memq cmd '(verify))))
+ (tinypgp-secring-use))
+
+ ;; ......................................................... modes ...
+
+ ;; We have to quit TM so that underlying mode underneath is
+ ;; exposed.
+ ;;
+ ;; But in Gnus, this wouldn't have any effect, because TM is permanently
+ ;; on. See ESC-t which runs `gnus-summary-toggle-mime'.
+
+ (when (eq major-mode 'mime/viewer-mode) ;TM preview buffer
+ (cond
+ ((and (featurep 'gnus)
+ (string= (buffer-name)
+ (symbol-value 'gnus-article-buffer)))
+ nil) ;Entering article edit quits mime.
+ (t
+;;; (setq buffer-read-only nil)
+ ;; in RMAIL this works
+ (mime-viewer/quit))))
+
+ (cond
+ ((and (featurep 'gnus)
+ (or (string= (buffer-name) (symbol-value 'gnus-article-buffer))
+ (eq major-mode 'gnus-article-mode)))
+ (when (and buffer-read-only
+ (not (eq 'ok (ignore-errors
+ (gnus-summary-edit-article) 'ok))))
+ ;; Eg. NNTP backend doesn't allow editing buffers.
+ (message (substitute-command-keys "\
+Gnus backend doesn't support edit. Use \\[tinypgp-view-register]"))
+ (tinypgp-hash 'mode-specific 'put 'register t 'global)
+ (set-buffer (tinypgp-clone-buffer)))
+
+ ;; Old Gnus versions have a bug, they give *Article* buffer
+ ;; for editing, which is not good. The buffer may have been
+ ;; formatted so that there is gnus buttons in the middle of the PGP
+ ;;
+ ;; noRr110XVahfo/3MaLL2PGlJ/h8rOdZkJCPCQ1OO8BKcXg3NQWTb+RpqSbSRnbEq
+ ;; [...]
+ ;; win0apLYccO+tqhhzK3CIiDbgBGfQLNU9ju+nMOOm1VUfF2A/phMoQg6ucYrXFxk
+ ;;
+ ;; We must edit the `gnus-original-article-buffer', which contains
+ ;; the message "as is".
+
+ ;; I submitted gnus bug report on this, but Lars didn't consider
+ ;; it as a bug: User is expect to do C-u g to view raw article.
+
+ (if (not (buffer-live-p
+ (get-buffer (symbol-value 'gnus-original-article-buffer))))
+ ;; If the original article weren't found, try anyway in
+ ;; this *Article* buffer. It may even succeed if there
+ ;; is no gnus buttons in the PGP block.
+
+ (message "TinyPgp: Wish me luck, I couldn't find original article")
+
+ ;; Ok, found buffer, so play safe
+
+ (delete-region (point-min) (point-max))
+ (insert-buffer (symbol-value 'gnus-original-article-buffer))))
+
+ ((memq major-mode '(rmail-mode))
+ (rmail-edit-current-message))
+
+ ((memq major-mode '(vm-mode))
+
+ ;; - VM opens another frame immediately if you
+ ;; put message in edit mode (that happend when you decrypt mail)
+ ;; - We don't want it to do that; Set this locally to nil
+
+ (setq vm-frame-per-edit nil)
+ (vm-edit-message)
+ (tinypgp-hash 'vm 'put 'control 'edit 'global)))
+
+ ;; Expose any hidden text
+
+ (set-text-properties (point-min) (point-max) nil)
+ (ti::overlay-remove-region (point-min) (point-max))
+
+ (tinypgp-hash 'mode-specific 'put 'buffer-edit (buffer-name) 'global)
+ (tinypgpd fid major-mode "BUFFER-EDIT" (current-buffer))
+ nil))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-mode-specific-label (cmd &optional buffer)
+ "Add mail-agent labels according to CMD. Work buffer is BUFFER."
+ (let* ((fid "tinypgp-mode-specific-label")
+
+ (tbl tinypgp-:label-table)
+ (v+ (nth 0 (nth 1 (assq 'v tbl))))
+ (v- (nth 1 (nth 1 (assq 'v tbl))))
+ (si (nth 1 (assq 's tbl)))
+ (en (nth 1 (assq 'e tbl)))
+ (de (nth 1 (assq 'd tbl)))
+ (pgp (nth 1 (assq 'pgp tbl)))
+ stat)
+ (with-current-buffer (or buffer (current-buffer))
+ (cond
+
+ ;; ...................................................... rmail ...
+
+ ((memq major-mode '(rmail-mode rmail-edit-mode))
+
+ (cond
+ ((eq cmd 'sign)
+ (rmail-kill-label v+)
+ (rmail-kill-label v-)
+ (when (not (ti::nil-p pgp)) (rmail-add-label pgp))
+ (when (not (ti::nil-p si)) (rmail-add-label si)))
+
+ ((eq cmd 'decrypt)
+ (rmail-kill-label en)
+ (when (not (ti::nil-p pgp)) (rmail-add-label pgp))
+ (rmail-add-label de)
+
+ ;; The message may have beeen encrypted and signed (one pass),
+ ;; force checking verify too.
+
+ (setq cmd 'verify))
+
+ ((eq cmd 'encrypt)
+ (rmail-kill-label de)
+ (when (not (ti::nil-p pgp)) (rmail-add-label pgp))
+ (rmail-add-label en))
+
+ ((eq cmd 'encrypt-sign)
+ (rmail-kill-label de)
+ (when (not (ti::nil-p pgp)) (rmail-add-label pgp))
+ (rmail-add-label en)
+ (rmail-add-label si)))
+
+ (when (eq cmd 'verify)
+ ;; This is special, the parameter call order is 'beg end RET'
+ ;;
+ (rmail-add-label "pgp")
+ (setq stat (or (tinypgp-binary-get-result-verify-status) ""))
+ (cond
+ ((string-match "good.*signature" stat)
+ (rmail-kill-label si)
+ (rmail-kill-label v-)
+ (rmail-add-label v+))
+ ((string-match "bad.*signature" stat)
+ (rmail-kill-label si)
+ (rmail-kill-label v+)
+ (rmail-add-label v-)))))
+
+ ;; ......................................................... vm ...
+
+ ((or (memq major-mode '(vm-mode vm-edit-mode))
+ (string-match "edit.*note " (buffer-name)))
+ (tinypgpd fid "LABELING" cmd (current-buffer))
+
+ (cond
+ ((eq cmd 'sign)
+ (vm-delete-message-labels v+ 1)
+ (vm-delete-message-labels v- 1)
+ (vm-add-message-labels si 1)
+ (when (not (ti::nil-p pgp)) (vm-add-message-labels pgp 1)))
+
+ ((eq cmd 'decrypt)
+ (vm-delete-message-labels en 1)
+ (vm-add-message-labels de 1)
+ (when (not (ti::nil-p pgp)) (vm-add-message-labels pgp 1))
+ (setq cmd 'verify))
+
+ ((eq cmd 'encrypt)
+ (vm-delete-message-labels de 1)
+ (vm-add-message-labels en 1)
+ (when (not (ti::nil-p pgp)) (vm-add-message-labels pgp 1)))
+
+ ((eq cmd 'encrypt-sign)
+ (vm-delete-message-labels de 1)
+ (vm-add-message-labels si 1)
+ (vm-add-message-labels en 1)
+ (when (not (ti::nil-p pgp)) (vm-add-message-labels pgp 1))))
+
+ (when (eq cmd 'verify)
+ (when (not (ti::nil-p pgp)) (vm-add-message-labels pgp 1))
+ (setq stat (or (tinypgp-binary-get-result-verify-status) ""))
+ (cond
+ ((string-match "good.*signature" stat)
+ (vm-delete-message-labels si 1)
+ (vm-delete-message-labels v- 1)
+ (vm-add-message-labels v+ 1))
+ ((string-match "bad.*signature" stat)
+ (vm-delete-message-labels si 1)
+ (vm-delete-message-labels v+ 1)
+ (vm-add-message-labels v- 1)
+ (when (not (ti::nil-p pgp))
+ (vm-add-message-labels pgp 1))))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-mode-specific-control-after
+ (cmd &optional user msg string)
+ "See `tinypgp-mode-specific-control-before' for CMD USER MSG STRING."
+ (let* ((fid "tinypgp-mode-specific-control-after: ")
+
+ ;; We have to set this to nil; otherwise TM goes nuts
+ ;; when it calls tm-rmail/preview-message
+ ;; #todo: investigate
+
+ rmail-show-message-hook
+
+ (buffer
+ (tinypgp-hash 'mode-specific 'get 'buffer nil 'global))
+ (buffer-edit
+ (tinypgp-hash 'mode-specific 'get 'buffer-edit nil 'global))
+
+ restore-cfg)
+
+ (when (tinypgp-hash 'mode-specific 'get 'register nil 'global)
+ (with-current-buffer tinypgp-:buffer-tmp-article
+ (ti::mail-hmax 'move)
+ (set-register
+ tinypgp-:register
+ (buffer-substring (point) (point-max)))))
+
+ (if rmail-show-message-hook ;; ByteComp silencer; no-op
+ (setq rmail-show-message-hook nil))
+
+ (tinypgpd fid cmd user "BUFFER" buffer "B-edit" buffer-edit major-mode
+ msg string (buffer-name))
+
+ ;; ....................................................... secring ...
+
+ (when tinypgp-:secring-crypt-mode
+ (tinypgp-secring-kill-maybe))
+
+ ;; .......................................................... mode ...
+ ;; The "before" hook must have been called otherwise, there must be
+ ;; some error somewhere or exist some situation I haven't thought of.
+
+ (with-current-buffer (or buffer-edit
+ (prog1 nil
+ (tinypgpd fid "**CONFLICT; no buffer")
+ (ti::read-char-safe-until
+ "\
+Internal error in AFTER HOOK; send bug report + debug immediately."))
+ (current-buffer))
+ (cond
+ ((memq major-mode '(rmail-mode rmail-edit-mode))
+ ;; ..................................................... rmail ...
+
+ (if (eq major-mode 'rmail-edit-mode)
+ (rmail-cease-edit))
+ (tinypgp-mode-specific-label cmd))
+
+ ;; ....................................................... gnus ...
+ ((eq major-mode 'gnus-article-edit-mode)
+ (gnus-article-edit-done))
+
+ ((memq major-mode '(gnus-article-mode
+ mime/viewer-mode))
+ (setq buffer-read-only ;Restore this value
+ (tinypgp-hash 'mode-specific 'get 'read-only nil 'global)))
+
+ ;; ......................................................... vm ...
+ ((or (memq major-mode '(vm-mode vm-edit-mode))
+ ;; XEmacs 19.14 sources say...
+ ;;
+ ;; In vm-edit.el :: vm-edit-message
+ ;; It says (funcall (or vm-edit-message-mode 'text-mode)),
+ ;; where vm-vars.el:1506:(defvar vm-edit-message-mode 'text-mode
+ ;;
+ ;; --> VM does editing in text mode? Glup; that makes hard
+ ;; to detect its edit buffer.
+ ;;
+ (string-match "edit.*note " (buffer-name)))
+
+ (tinypgpd fid "VM ENTRY" major-mode (current-buffer) (buffer-name))
+
+ (setq restore-cfg 'vm) ;Yes; we need to restore Win cfg
+
+ (setq
+ vm-frame-per-edit
+ (tinypgp-hash 'vm 'put 'vm-frame-per-edit vm-frame-per-edit 'global))
+
+ ;; Only close edit mode if we opened it. If user was inside
+ ;; edit buffer, we don't close it here.
+
+ (when (and (tinypgp-hash 'vm 'get 'control nil 'global)
+ (or (eq major-mode 'vm-edit-mode)
+ (string-match "edit.*note " (buffer-name))))
+ (vm-edit-message-end))
+ (tinypgp-mode-specific-label cmd))))
+
+ (when restore-cfg
+ (let* ((wcfg
+ (tinypgp-hash 'mode-specific 'get 'wcfg nil 'global))
+ (frame
+ (tinypgp-hash 'mode-specific 'get 'frame nil 'global))
+ (window
+ (tinypgp-hash 'mode-specific 'get 'window nil 'global)))
+ (set-window-configuration wcfg)
+ (select-frame frame)
+ (select-window window)))
+
+ (tinypgp-hash 'mode-specific 'put 'buffer nil) ;Clear this
+ ;; hook's return value
+ nil))
+
+;;}}}
+
+;;{{{ remail: misc
+
+;;; .......................................................... &remail ...
+;;; -r- refers to remailing
+;;; -r-h refers to remailer headers
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypgp-r-subject-cookie ()
+ "Return random subject cookie."
+ (nth (1- (rand1 (length tinypgp-:r-subject-table)))
+ tinypgp-:r-subject-table))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypgp-r-elt-email2elt (email)
+ "Return remailer entry when EMAIL is known."
+ (ti::list-find tinypgp-:r-levien-table email
+ (function
+ (lambda (arg elt)
+ (string= arg (nth 1 elt))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypgp-r-elt-remailer (remailer)
+ "Return remailer elt when REMAILER is known."
+ ;; We have the alias name, find the real email address
+ (or (assoc remailer tinypgp-:r-host-table)
+ (error "No such remailer %s" remailer)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypgp-r-type (alias &optional email)
+ "Return post type for remailer. ALIAS and EMAIL are mutually exclusive."
+ (if email
+ (ti::mail-pgpr-reply-type (nth 2 (tinypgp-r-elt-email2elt email))))
+ (ti::mail-pgpr-reply-type (nth 2 (assoc alias tinypgp-:r-levien-table))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinypgp-r-server-macro 'lisp-indent-function 2)
+(defmacro tinypgp-r-server-macro (server account &rest body)
+ "Find SERVER and do body or signal error.
+
+Input:
+
+ SERVER remailer server (alias name)
+ ACCOUNT remailer ACCOUNT@some.remailer.net
+ Can also be nil, in that case the `email' is not constructed.
+ (gains little speed)
+ BODY lisp form to do if server exists.
+
+Defined variables inside BODY
+
+ `info' Full Levien list entry for server
+ `email' Constructed according to ACCOUNT."
+ (`
+ (let* ((info (or (assoc (, server) tinypgp-:r-levien-table)
+ (error "Server is unknown %s" (, server))))
+ email)
+ (if (, account)
+ (setq email (tinypgp-r-format-email-address (, account) info)))
+
+ ;; If these varibles are not used in the macro BODY,
+ ;; then byteCompiler nags. Make it quiet.
+
+ (if (null email) (setq email nil))
+ (if (null info) (setq info nil))
+
+ (,@ body))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypgp-r-post-p (elt)
+ "Check if this remailer ELT can be used for posting."
+ (or (string-match "cut.* hash.* pgp.* post" (nth 2 elt))
+ (error "\
+TinyPgp: not enough properties %s '%s'" (nth 0 elt) (nth 2 elt))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypgp-r-init-maybe ()
+ "Call initialise function is needed."
+ (tinypgp-backend-set-for-action 'remail)
+ (or (tinypgp-hash 'remail 'get 'init nil 'global)
+ (tinypgp-r-init)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-r-init (&optional force)
+ "Initialise remailer support. Set up all necessary variables etc.
+If `tinypgp-:r-levien-table' is non-nil, then this function does nothing.
+
+FORCE tells to discard old values and build all from scratch.
+You usually do this if you have updated your remailer list.
+FORCE is set to t if you call this function interactively.
+
+References:
+ `tinypgp-:r-init-hook' is run after initialise sequences have been completed."
+ (interactive (list 'force)) ;inteactive call always forces init
+
+ (let ((file tinypgp-:r-list-file)
+ (clist tinypgp-:r-control-list)
+ val)
+ (tinypgp-backend-set-for-action 'remail)
+
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... ... . check ...
+
+ (if (not (stringp tinypgp-:r-mail2news-remailer)) ;has default
+ (error "TinyPgp: Please set Usenet post remailer tinypgp-:r-mail2news-remailer."))
+
+ (if (not (stringp tinypgp-:r-user-mail-address)) ;has default
+ (error "TinyPgp: Please set tinypgp-:r-user-mail-address"))
+
+ (when (not (and (stringp tinypgp-:r-list-file)
+ (file-exists-p tinypgp-:r-list-file)))
+ (error "TinyPgp: Hm, no tinypgp-:r-list-file please see manual.")
+
+ ;; 1997-08-30
+ ;; - not a good idea. Person may not have access to ftp or
+ ;; the ftp location does not exist any more.
+
+ (message "TinyPgp: Hm, no tinypgp-:r-list-file; fetching it by finger..")
+ (sit-for 1)
+ ;; Notice the 'no-init parameter. It would otw loop back to us.
+ (tinypgp-r-update-remailer-list 'verb 'no-init))
+
+ ;; It is important that you have new remailer file, print
+ ;; warning regularly if the file is old
+
+ (when (and tinypgp-:r-list-file
+ (progn
+ (setq val (tinypgp-hash 'remail 'get 'file-warning))
+ (if (not (integerp val))
+ (setq val 0))
+ (incf val)
+ (tinypgp-hash 'remail 'put 'file-warning val)
+ (eq 0 (% val 5)))) ;every 5th call
+ (tinypgp-hash 'remail 'put 'file-warning 0)
+ (tinypgp-r-file-old-warning))
+
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... ... do init ...
+
+ ;; If this doesn't exist, init all
+
+ (when (or force (null tinypgp-:r-levien-table))
+ (when (or (not (stringp file))
+ (not (file-exists-p file)))
+ (error
+ (substitute-command-keys
+ (concat
+ "TinyPgp: Please set variable tinypgp-:r-list-file and call"
+ "\\[tinypgp-r-update-remailer-list]"))))
+
+ ;; Full RAPH's list
+
+ (setq tinypgp-:r-levien-table (tinypgp-r-get-list "." nil file clist))
+ (tinypgpd "tinypgp-r-init: " tinypgp-:r-levien-table)
+
+ (setq tinypgp-:r-host-table ;only cpunk and some properties
+ (tinypgp-r-get-list nil tinypgp-:r-levien-table))
+
+ (if (null tinypgp-:r-host-table)
+ (error
+ "TinyPgp: Can't find good remailers from '%s'. Consult maintainer."
+ tinypgp-:r-list-file))
+
+ (setq tinypgp-:r-reply-block-cache nil) ;Build from scratch
+
+ (tinypgp-hash 'remail 'put 'init (or force 'done) 'global)
+ (if tinypgp-:r-init-hook (run-hooks 'tinypgp-:r-init-hook))
+
+ (if (interactive-p)
+ (message "TinyPgp: Remailer support initialised.")))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-r-file-old-warning (&optional file days-old fmt)
+ "Print warning if file is too old.
+Input:
+
+ FILE Defaults to `tinypgp-:r-list-file'
+ DAYS-OLD Defaults to 24 (3 weeks).
+ FMT Message format. First arg is %s file and second %d how old file."
+ (interactive)
+ (let* (days)
+ (or file
+ (setq file tinypgp-:r-list-file)
+ (error "No tinypgp-:r-list-file set."))
+
+ (or days-old
+ (setq days-old (* 3 7)))
+ (setq days (ti::file-days-old file))
+
+ ;; over 3 weeks old remailer list...too old
+ ;;
+ (when (> days days-old)
+ (save-excursion
+ (message
+ (format
+ (or fmt "'%s' is approx %d days old, which is too much.")
+ file days))
+ (sit-for 1)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-r-get-list (&optional re list file control-list)
+ "Get remailer list matching RE.
+
+Input:
+ RE what properties to grep. The properties are sorted
+ and defaults to \"cpunk.* hash.* pgp\". These features are
+ considered minimum features from remailer.
+ LIST prepared list
+ FILE file from where to read the Levien list. LIST must be nil.
+ CONTROL-LIST See `ti::mail-pgpr-parse-levien-list'.
+
+References:
+ `tinypgp-:r-get-list-hook' is run after the Levien file is read into
+ temporary buffer."
+ (let* ((fid "tinypgp-r-get-list:")
+ ret)
+ (setq re (or re "cpunk.* hash.* pgp"))
+
+ (unless list
+
+ ;; Read remailer list from file and parse it
+
+ (if (or (null file)
+ (not (file-exists-p file)))
+ (error "TinyPgp: Can't read remailer file file '%s'" file))
+
+ (with-current-buffer (tinypgp-ti::temp-buffer)
+ (insert-file-contents file)
+ (run-hooks 'tinypgp-:r-get-list-hook)
+ (tinypgp-r-file-old-warning)
+
+ (ti::pmin)
+ (unless (setq list (ti::mail-pgpr-parse-levien-list
+ nil control-list))
+ (tinypgpd fid (buffer-string))
+ (pop-to-buffer (current-buffer))
+ (error "\
+TinyPgp: Cannot parse this buffer: not in levien format. %s " file))))
+
+ (dolist (elt list)
+ (if (string-match re (nth 2 elt))
+ (push elt ret)))
+
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-r-mail-mode-init ()
+ "Turn off all interfering minor modes from remailer mail buffer."
+ (let (s)
+ (setq s 'post-command-hook)
+ (make-local-hook s) ;19.30+
+ (remove-hook s 'timi-post-command) ;disable tinymail.el
+
+ ;; What should we remove from this hook ?
+
+ (setq s 'post-command-idle-hook)
+ (when (boundp s) (make-local-hook s))
+
+ (setq s 'mime/editor-mode-flag) ;tm.el
+ (when (boundp s) (set s nil))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-r-post-before-default ()
+ "Disable/exit known minor modes/features."
+ (ti::mail-mime-turn-off-mode)
+ (if (featurep 'tinymail)
+ (timi-mail 'disable)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-r-latent-time-random (remailer str)
+ "Add 'r' to the time if REMAILER supports it. If STR is nil, do nothing."
+ (when (stringp str)
+ ;;
+ ;; The remailers are not checked yet.
+ ;;
+ (if (not (char= (aref str (1- (length str))) ?r))
+ (setq str (concat str "r"))))
+ str)
+
+;;}}}
+;;{{{ remail: reply block
+
+;;; ................................................... &r-reply-block ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-r-reply-block-read (remailer)
+ "Read reply block for the REMAILER.
+Don't use this function, use `tinypgp-r-reply-block-cache' instead.
+
+Return:
+ '(buffer-pointer
+ pgp-beg ,points
+ pgp-end
+ )"
+ (let ((elt (assoc remailer tinypgp-:r-reply-block-table))
+ file
+ buffer
+ reg
+ beg
+ end)
+ (unless elt
+ (error
+ (format
+ (concat
+ "TinyPgp: No Reply block defined for remailer '%s' "
+ "in tinypgp-:r-reply-block-table")
+ remailer)))
+
+ (setq file (nth 1 elt)
+ buffer (or (find-buffer-visiting file)
+ (if (file-exists-p file)
+ ;;
+ ;; pure find avoigs calling hooks/modes
+ ;; when file is loaded.
+ ;;
+ (ti::find-file-literally file)
+ (error "TinyPgp: No reply block file %s" file))))
+ (with-current-buffer buffer
+ (ti::pmin)
+
+ ;; Make sure it will not be modified.
+
+ (setq buffer-read-only t)
+;;; (rename-buffer (concat " " file))
+
+ (unless (setq reg (ti::mail-pgp-block-area 'any))
+ (pop-to-buffer buffer)
+ (error "TinyPgp: Can't find reply block region?"))
+ (setq beg (point-min) end (cdr reg)))
+ (if buffer
+ (list buffer beg end))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-r-reply-block-cache (mode &optional arg1)
+ "Reply block cache management according to MODE and ARG1.
+
+MODE:
+
+ 'get ARG1 = remailer alias; return reply block.
+ 'put ARG1 = `tinypgp-:r-reply-block-cache' element
+ 'del ARG1 = remailer alias"
+ (let ((table tinypgp-:r-reply-block-table)
+ buffer
+ elt
+ old)
+ (cond
+ ((eq mode 'get)
+ (or (setq elt (assoc arg1 table))
+ (error "TinyPgp: %s not defined in tinypgp-:r-reply-block-table '%s'"
+ arg1 mode))
+
+ ;; Have we read it already?
+ (setq buffer (find-buffer-visiting (nth 1 elt)))
+ (or (setq elt (assq buffer tinypgp-:r-reply-block-cache))
+ ;; No, load it from file then
+ ;;
+ (and (setq elt (tinypgp-r-reply-block-read arg1))
+ (setq old (assq (car elt) tinypgp-:r-reply-block-cache))
+ (setq tinypgp-:r-reply-block-cache
+ (delq old tinypgp-:r-reply-block-cache)))
+ (push elt tinypgp-:r-reply-block-cache))
+
+ ;; Remove non-existing buffers -- keep the list up to date
+
+ (dolist (elt tinypgp-:r-reply-block-cache)
+ (if (buffer-live-p (get-buffer (car elt)))
+ (setq tinypgp-:r-reply-block-cache
+ (delq elt tinypgp-:r-reply-block-cache))))
+
+ elt)
+
+ ((eq mode 'del)
+ (and (setq elt (assoc arg1 table))
+ (setq buffer (get-buffer
+ (file-name-nondirectory
+ (nth 1 elt))))
+ (setq elt (assq buffer tinypgp-:r-reply-block-cache))
+ (setq tinypgp-:r-reply-block-cache
+ (delq elt tinypgp-:r-reply-block-cache)))
+ tinypgp-:r-reply-block-cache)
+
+ ((eq mode 'put)
+ (push arg1 tinypgp-:r-reply-block-cache)
+ arg1))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-r-reply-block-insert (remailer)
+ "Insert REMAILER's reply block."
+ (interactive (list (tinypgp-ask-reply-block-remailer)))
+ (let* ((elt (tinypgp-r-reply-block-cache 'get remailer)))
+ (if (null elt)
+ (error "TinyPgp: Invalid return value.")
+ (insert-buffer-substring (nth 0 elt) (nth 1 elt) (nth 2 elt)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-r-reply-block-header (remailer latent key anon-to)
+ "Return reply block headers of remailer.
+
+Input:
+
+ REMAILER string or symbol or list, The remailer used.
+ If list, then the REMAILER is remailer-elt from
+ `tinypgp-:r-levien-table'
+ LATENT latent time specification. This is not be used if
+ remailer does not support it.
+ KEY The conventional crypt password
+ ANON-TO Where to send the reply block (return address)."
+ (if (symbolp remailer) (setq remailer (symbol-name remailer)))
+ (let* ((properties (cond
+ ((ti::listp remailer) remailer)
+ ((tinypgp-r-elt-remailer remailer))))
+;;; (email (nth 1 properties))
+ (rtype (ti::mail-pgpr-reply-type (nth 2 properties)))
+ ;; What kind of reply block: With/out latent ?
+ ;;
+ (btype (nth 2 properties)))
+ (when latent
+ (if (null (string-match "latent" btype))
+ (setq latent nil) ;Not supported
+ (setq latent (tinypgp-r-latent-time-random remailer latent))))
+
+ (when key
+ (if (null (string-match "ek" btype))
+ (setq key nil)))
+ ;; The Reply string type "cpunk, eric..."
+ (ti::mail-pgpr-block nil rtype anon-to key latent)))
+
+;;}}}
+;;{{{ remail: reply-block: interactive
+
+;;; ................................................... &reply-block-i ...
+;;;
+(defun tinypgp-r-reply-block-test (&optional no-confirm)
+ "Send every reply block listed in `tinypgp-:r-reply-block-table'.
+NO-CONFIRM bypasses asking.
+If you don't receive mail back, there are two possibilities:
+o remailer is down
+o your reply block was not constructed correctly."
+ (interactive "P")
+ (tinypgp-r-init-maybe)
+ (let* ((fid "tinypgp-r-reply-block-test: ")
+ (i 0)
+ remailer
+ email)
+ (dolist (elt tinypgp-:r-reply-block-table)
+ (setq remailer (nth 0 elt))
+ (setq email (nth 1 (assoc remailer tinypgp-:r-levien-table)))
+
+ (tinypgpd fid remailer email)
+
+ (cond
+ ((null email)
+ (ti::read-char-safe-until
+ (format
+ "[%s] Does not exist any more, delete reply block. [press]"
+ remailer)))
+ (t
+ (when (or no-confirm
+ (y-or-n-p (format "Send reply block to %s " remailer)))
+ (incf i)
+ (ti::mail-sendmail-macro email remailer 'send
+ (ti::mail-kill-field
+ "^Subject"
+ (format
+ "r-test %s"
+ (ti::date-standard-date)))
+;;; (pop-to-buffer (current-buffer))
+ ;; (insert (ti::mail-pgpr-block 'epgp "cpunk" ) "\n")
+ (tinypgp-r-reply-block-insert remailer)))))
+;;; (ti::pmin) (ti::d! "testing-rblock")
+
+ (if (interactive-p)
+ (message "Sent %d test reply block%s."
+ i (if (eq i 1) "" "s"))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-r-reply-block-basic
+ (remailer-elt &optional latent key anon-to final verb)
+ "Contruct most basic reply block.
+
+The created encrypted reply block will contain following
+
+ ::
+ Request-Remailing-To: <`tinypgp-:r-user-mail-address'>
+ Encrypt-Key: <key you gave>
+ Latent-Time: <latent time you gave>
+
+Important:
+
+ You must be in empty [mail] buffer. When this function finishes, you
+ should _encrypt_ the mail body.
+
+Input:
+
+ REMAILER-ELT Remailer table entry
+ LATENT \"+1:00\"
+ KEY crypt key, no spaces
+ ANON-TO send-to@some.com
+ FINAL flag, if this is final block, include
+ \"**\" to the end. (See remailer faqs)
+ And kill any extra headers.
+
+ VERB Verbose messages.
+
+Interactive call note:
+
+ LATENT can be passed by prefix arg. Each \\[universal-argument] adds 30 minutes, so
+ 3 times \\[universal-argument] is same as +1:30.
+ Numeric argument gives straigh hours, so M - x 2 means +2:00. Latent time
+ is not always supported by selected remailer and it is ignored if remailer
+ can't use it.
+
+ ANON-TO is `tinypgp-:r-user-mail-address'.
+
+ FINAL is always set to t"
+ (interactive
+ (progn
+
+ (unless (ti::mail-body-empty-p)
+ (if (y-or-n-p "Fresh buffer needed, empty this buffer? ")
+ (progn
+ (ti::mail-text-start 'move) (delete-region (point) (point-max)))
+ (error "TinyPgp: Buffer must be emptied first")))
+
+ (ti::list-merge-elements
+ (tinypgp-ask-remail-args)
+ tinypgp-:r-user-mail-address
+ t)))
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... . interactive end . .
+
+ (let* ()
+ (tinypgp-r-init-maybe)
+ (ti::verb)
+ (unless (ti::mail-body-empty-p)
+ (error "TinyPgp: Buffer must be emptied first"))
+
+ (tinypgp-r-chain-1 remailer-elt latent key anon-to final)
+
+ (if tinypgp-:r-reply-block-basic-hook
+ (run-hooks 'tinypgp-:r-reply-block-basic-hook))
+
+;;; (if verb
+;;; (message "If you encrypt this, you should leave '**' outside."))
+
+ nil))
+
+;;}}}
+;;{{{ remail: interactive
+
+;;; ................................................... &r-interactive ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-r-chain-1 (remailer-elt &optional latent key anon-to final)
+ "Encrypt mail to next remailer.
+Input:
+
+ REMAILER-ELT remailer elt from `tinypgp-:r-levien-table'
+ LATENT latent time e.g. 0:00r (not used if...)
+ KEY Encrypt key (not used if remailer does not support it)
+ ANON-TO send-to@somewhere.com
+ FINAL flag, prefix arg, if this is final block, include
+ \"**\" to the end. (See remailer faqs)
+
+Return:
+ email remailer address"
+ (interactive
+ (ti::list-merge-elements
+ (tinypgp-ask-remail-args)
+ (read-from-minibuffer
+ "Anon to: "
+ (mail-fetch-field "To"))))
+ (tinypgp-r-init-maybe)
+ (let* (tinypgp-:xpgp-signing-mode ;Do not use X-Pgp
+ (properties remailer-elt)
+ (email (nth 1 properties))
+
+ ;; The Reply string type "cpunk, eric..."
+
+ (rtype (ti::mail-pgpr-reply-type (nth 2 properties)))
+
+ (mail (ti::mail-mail-p))
+ str)
+;;; str2
+ (or tinypgp-:r-mode-indication-flag
+ (setq tinypgp-:r-mode-indication-flag 'basic-1))
+
+ (if (and key (string-match "[ \t\n]" key))
+ (error "TinyPgp: Key may not contains spaces '%s'" key))
+
+ ;; ........................................... destination address ...
+
+ (ti::mail-text-start 'move)
+
+ (setq str (tinypgp-r-reply-block-header remailer-elt latent key anon-to))
+
+ (insert str "\n")
+ (tinypgp-encrypt-mail email)
+
+ ;; ................................................ remail address ...
+
+ (ti::mail-text-start 'move)
+
+ ;; The outer block encrypt key is disabled for now because
+ ;; it causes double encryptinn. When you receive the mail,
+ ;; then you have to decrypt it twice...not convenient.
+ ;;
+ ;; The Reply Blocks EK should be enough. User can add the
+ ;; extra Field if he wants it.
+
+ (setq str (ti::mail-pgpr-block nil rtype email nil latent))
+ (insert str "\n")
+
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... ... . final ...
+
+ (when final
+ (ti::mail-pgpr-close)
+
+ (when mail
+ (ti::mail-kill-field "^To" (concat " " email) )
+
+ ;; sysadm in your site probably isn't interested in subjects
+ ;; like this one. We don't want to draw his attention
+
+ (ti::mail-kill-field "^Subject" (tinypgp-r-subject-cookie))
+ (ti::mail-kill-field "^Fcc")
+ (ti::mail-kill-field "^Gcc") ;GNUS 5
+ (ti::mail-kill-field "^Reply-to")))
+
+ email))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-r-chain (chain &optional verb)
+ "Decrypt current message according to remailer CHAIN. VERB.
+Important, before you call this function:
+1. You have called \\[tinypgp-r-post] or \\[tinypgp-newnym-post] to convert
+ the message into remail post format first.
+2. You must have encrypted the message.
+
+Only after these, the additonal chain layers are feasible."
+ (interactive
+ (progn
+ (or tinypgp-:r-chain
+ (error "TinyPgp: tinypgp-:r-chain is empty"))
+ (list
+ (completing-read
+ "Select remailer chain: "
+ tinypgp-:r-chain nil 'match nil 'tinypgp-:history-r-chain))))
+ (let* (to
+ list
+ remailer
+ remailer-elt
+ latent key anon-to
+ final)
+ (ti::verb)
+ (or (setq chain (assoc chain tinypgp-:r-chain))
+ (error "TinyPgp: No such choice in tinypgp-:r-chain"))
+
+ (setq chain (nth 1 chain) list chain)
+
+ (unless (or (vectorp chain)
+ (vectorp (setq list (eval chain))))
+ (error "TinyPgp: %s evaluated to %s, which is not vector." chain list))
+
+ (or (setq list (append list nil)) ;Convert to list :-)
+ (error "TinyPgp: Vector list was empty?"))
+
+ ;; I can't do automatic encryption, because I have no of
+ ;; knowing if user had called C-c / . p to convert the message
+ ;; to post format. It would be disaster to encrypt non-post message
+
+ (or (ti::mail-pgp-encrypted-p)
+ (error "\
+TinyPgp: The message must have been encrypted to mail2news gateway."))
+
+ (dolist (elt list) ;; #todo: Can't use dolist beacause tests FINAL
+ (setq remailer (nth 0 elt)
+ latent (nth 1 elt)
+ key (nth 2 elt)
+ remailer-elt (tinypgp-r-elt-remailer remailer)
+ final (null (cdr list)) ;No more remailers
+ anon-to (mail-fetch-field "to"))
+ (or (ti::nil-p to)
+ (error "TinyPgp: To address is empty, can't use Anon-to"))
+ (tinypgp-r-chain-1 remailer-elt latent key anon-to final))
+
+ ;; Let's do fast check and turn off auto-action
+
+ (when (and verb (tinypgp-auto-action-on-modeline-p))
+ (tinypgp-hash 'auto-action 'put 'user-mode nil))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-r-update-remailer-list (&optional verb no-auto-init)
+ "Finger remailer list maintainer and get updated list.
+VERB allows verbose messages. NO-AUTO-INIT suppresses call to
+`tinypgp-r-init' after file update."
+ (interactive)
+ (let ((file tinypgp-:r-list-file)
+ (email tinypgp-:r-list-finger)
+ (buffer (tinypgp-ti::temp-buffer))
+ ret)
+ (ti::verb)
+
+ (setq ret (ti::process-finger email nil nil buffer verb))
+ (cond
+ ((not (bufferp ret))
+ (setq tinypgp-:last-network-error ret)
+ (error "TinyPgp: finger Failed: %s" ret))
+ (t
+ (ti::file-delete-safe file)
+ (with-current-buffer ret (write-region (point-min) (point-max) file))
+ (if verb
+ (message "TinyPgp: remailer list [%s] updated." file))
+ (call-interactively 'tinypgp-r-init)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-r-post (&optional type)
+ "Anonymize message. See TYPE from `tinypgp-r-post-usenet'."
+ (interactive)
+ (let* ()
+ (or type
+ (setq type 'remail))
+ (tinypgp-r-init-maybe)
+ (run-hooks 'tinypgp-:r-post-before-hook)
+ (if (ti::mail-news-buffer-p)
+ (tinypgp-r-post-usenet type)
+ (call-interactively 'tinypgp-r-post-regular))
+ (run-hooks 'tinypgp-:r-post-after-hook)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-r-post-regular
+ (remailer &optional insert-reply-block remailer-elt)
+ "Normal mail to: send as anonymous post. Bulk mail is not permitted.
+This means that any BCC or FCC field generates error.
+
+The Prefix arg inserts to the message a reply block, so that person
+can answer to the mail if he sends the message back to remailer.
+
+Notes:
+
+ `post-command-hook' and possible `post-command-idle-hook' are
+ bound locally to current buffer and set to nil,
+ so that nothing special happens when you compose and send this mail.
+
+Input:
+
+ REMAILER remailer alias name
+ INSERT-REPLY-BLOCK prefix arg, if non-nil, insert remailer reply block
+ REMAILER-ELT the remailer entry from table `tinypgp-:r-host-table'"
+ (interactive
+ (let (remailer
+ remailer-elt)
+ (setq remailer (tinypgp-ask-remailer))
+ (setq remailer-elt (tinypgp-r-elt-remailer remailer))
+ (list remailer current-prefix-arg remailer-elt)))
+ (let* (tinypgp-:xpgp-signing-mode ;Do not use X-Pgp
+ (var-list '(post-command-hook
+ post-command-idle-hook))
+ (hlist (delete 'newsgroups (ti::mail-required-headers)))
+ (hlist (push 'to hlist))
+ (to (ti::mail-get-field "TO" nil 'nil-mode))
+
+ (reply-msg "To reply to this message, send it to some remailer.")
+ (properties (or remailer-elt
+ (assoc remailer tinypgp-:r-levien-table)
+ (error "TinyPgp: No remailer [%s]" remailer)))
+ (email (nth 1 properties))
+
+ ;; The Reply string type "cpunk, eric..."
+ ;;
+ (rtype (ti::mail-pgpr-reply-type (nth 2 properties)))
+
+ hash-headers
+ header-block
+ message
+ point
+ str)
+
+ (if (or (mail-fetch-field "CC")
+ (mail-fetch-field "BCC"))
+ (error "TinyPgp: sorry, bulk CC or BCC mail is not permitted."))
+
+ (if (null to)
+ (error "TinyPgp: No TO field filled."))
+
+ (tinypgp-r-init-maybe)
+ (setq str (ti::mail-pgpr-block nil rtype to))
+
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... . headers . .
+ ;; Get rid of headers that may reveal your identity
+
+ (ti::mail-kill-non-rfc-fields hlist)
+
+ (if (setq hash-headers (tinypgp-header-move-to-body 'move-to-body 'no-ins))
+ (setq header-block (mapconcat 'concat hash-headers ""))
+ (setq header-block ""))
+
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... . doing message ...
+
+ (ti::mail-kill-field "to" email)
+ (setq point (ti::mail-text-start))
+ (setq message (buffer-substring point (point-max)))
+ (delete-region point (point-max))
+
+ (ti::pmax)
+ (insert
+ str
+ "Cutmarks: --\n\n"
+ "##\n" header-block "\n")
+
+ (when insert-reply-block
+ (tinypgp-r-reply-block-insert remailer))
+
+ (when (and insert-reply-block reply-msg)
+ (insert reply-msg "\n" ))
+ (insert message "\n--\n")
+
+ ;; Make sure there is nothing that interferes sending.
+ ;; make them first local; then set them to nil
+
+ (dolist (sym var-list)
+ (when (boundp sym)
+ (make-local-hook sym)
+ (set sym nil)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;
+(defun tinypgp-r-post-usenet-body-convert
+ (groups email &optional rb rtype rblk)
+ "Convert body text into Remail post.
+Supposes that you have already reformatted the buffer.
+
+Input:
+
+ GROUPS list of newsgroups where to post.
+ EMAIL the mail2news gateway email address
+ RB if string, insert reply block of remailer given.
+ RTYPE Remailer reply type, e.g. 'cpunk'
+ RBLK Header block"
+ (interactive)
+ (let* ((reply-msg "To reply to this message, send it to some remailer.")
+ point
+ message
+ block
+ str)
+
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... doing blocks . .
+
+ (setq point (ti::mail-text-start)
+ message (buffer-substring point (point-max)))
+ (delete-region point (point-max))
+
+ (dolist (grp groups)
+ (setq str (ti::mail-pgpr-block nil rtype grp)
+ block (concat str "\n##\n" rblk "\n"))
+ (ti::pmax)
+ (insert block)
+ (when rb
+ (tinypgp-r-reply-block-insert rb)
+ (insert "**\n")
+ (insert reply-msg "\n" ))
+ (insert message "\n--\n"))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-r-post-usenet (type &optional rb)
+ "Usenet message: Convert current message into anonymous remailer post.
+Call error if buffer is not a newsgroup post.
+
+Input:
+
+ TYPE type of conversion: 'newnym or 'remail
+ RB Insert reply block of remailer RB, so that user can aswer to you
+ directly by using this replay block.
+
+Return:
+
+ '(remailer-email-addr (newsgroup newsgroup ..))
+
+References:
+
+ `tinypgp-:r-mail2news-remailer'"
+ (let* (post-command-hook
+ mail-setup-hook
+ mail-mode-hook
+ message-mode-hook
+
+ hash-headers
+ header-block
+ group-fld
+ group-list
+ phost ;posting host
+ phost-elt
+ phost-prop
+ phost-email
+ rtype
+ sym)
+ (setq tinypgp-:r-mode-indication-flag 'post)
+
+ ;; Why these if statemnts? Because the byteCompiler sees that
+ ;; I have introduced hooks in let*, but I never use them!
+ ;; This fools bytecompiler to believe they are used and it
+ ;; doesn't give any warnings any more
+
+ (if post-command-hook (setq post-command-hook nil)) ;ByteComp silencer
+ (if mail-setup-hook (setq mail-setup-hook nil))
+ (if mail-mode-hook (setq mail-mode-hook nil))
+
+ ;; This does exist between 19.30 - 19.33; but then it was made obsolete
+ ;; This trick gives clean byteCompilation and no warnings
+
+ (setq sym 'post-command-idle-hook)
+
+ (when (fboundp sym)
+ (make-local-hook sym)
+ (set sym nil))
+
+ (setq group-fld (mail-fetch-field "Newsgroups"))
+
+ (when (and t ;Enabled now
+ (ti::nil-p group-fld))
+ (error "TinyPgp: No newsgroups? Buffer must contain a news message."))
+
+ (run-hooks 'tinypgp-:r-post-before-hook)
+
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... variables . .
+ ;; Read needed variables
+
+ (if (or (null (setq phost (eval tinypgp-:r-mail2news-remailer)))
+ (null (setq phost-elt (assoc phost tinypgp-:r-levien-table))))
+ (error "TinyPgp: tinypgp-:r-mail2news-remailer '%s' %s"
+ tinypgp-:r-mail2news-remailer phost))
+
+ (tinypgp-r-post-p phost-elt) ;Calls error is not capable enough
+ (setq phost-email (nth 1 phost-elt)
+ phost-prop (nth 2 phost-elt)
+ rtype (ti::mail-pgpr-reply-type phost-prop))
+
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... . headers . .
+ ;; Get rid of headers that may reveal your identity
+ ;; Don't kill in-reply to because it is used in newsgroup postings.
+
+ (tinypgp-header-kill)
+
+ ;; Save all headers because they are inserted into body
+
+ (if (setq hash-headers (tinypgp-header-move-to-body 'move-to-body 'no-ins))
+ (setq header-block (mapconcat 'concat hash-headers ""))
+ (setq header-block ""))
+
+ ;; The remaier doesn't need this field
+
+ (ti::mail-kill-field "in-reply-to")
+ (ti::mail-kill-field "newsgroups")
+
+ (if (string-match "," group-fld)
+ (setq group-list (split-string group-fld "[,\t\n ]+"))
+ (setq group-list (list group-fld)))
+
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... doing blocks . .
+
+;;; (setq point (ti::mail-text-start)
+;;; message (buffer-substring point (point-max)))
+;;; (delete-region point (point-max))
+
+ (cond
+ ((eq type 'newnym))
+ ((eq type 'remail)
+ (tinypgp-r-post-usenet-body-convert
+ group-list phost rb rtype header-block)))
+
+ (ti::pmin) (insert "To: " phost-email "\n") ;Set destination
+
+ (mail-mode) ;This is not a news message any more.
+ (unless tinypgp-mode (tinypgp-mode 1))
+
+ (list phost-email group-list)))
+
+;;}}}
+
+;;{{{ newnym: misc
+
+;;; ........................................................ &r-newnym ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypgp-newnym-read-word ()
+ "Read newnym configuration command word."
+ (let* (word)
+ (save-excursion
+ (when (char= (char-syntax (following-char)) ?\ ) ;Sitting on whitespace
+ (backward-char 1))
+ (when (setq word (ti::buffer-read-space-word))
+ (ti::string-match "[^-+=]+" 0 word)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypgp-newnym-list (&optional mode force)
+ "Return ELTS for all 'newnym'.
+Normally once the list has been generated; it is stored to hash.
+
+Input:
+
+ MODE nil = return full configuration list
+ 'alias = return alias name list
+ FORCE reread Levien table content and update hash.
+
+References:
+ `tinypgp-:r-levien-table'"
+ (let* ((list (tinypgp-hash 'remail 'get 'newnym)))
+ (tinypgp-r-init-maybe)
+ (when (or force (null list))
+ (or tinypgp-:r-levien-table
+ (error "TinyPgp: Levien list is nil."))
+
+ (setq list (tinypgp-r-get-list "newnym" tinypgp-:r-levien-table))
+ (tinypgp-hash 'remail 'put 'newnym list)
+ (tinypgp-hash 'remail 'put 'newnym-alias (mapcar 'car list)))
+ (cond ;No other choices yet
+ ((eq mode 'alias)
+ (setq list (tinypgp-hash 'remail 'get 'newnym-alias))))
+ list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypgp-r-format-email-address (account remailer-entry)
+ "Return address that has ACCOUNT@site.com derived from REMAILER-ENTRY.
+The remailer-entry is one of the entries in `tinypgp-:r-levien-table'"
+
+ (let* ((email (nth 1 remailer-entry)))
+ (if (null (string-match "^[^@]+" email))
+ (error "TinyPgp Internal error. Call \\[tinypgp-r-init] or maintainer."))
+ ;; Set address to "help@..."
+ ;;
+ (ti::replace-match 0 account email)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypgp-newnym-ask-server (&optional prompt)
+ "Ask newnym server name with completion and PROMPT."
+ (tinypgp-r-init-maybe)
+ (or (get 'tinypgp-:r-newnym-default-account-table 'default-server)
+ (completing-read
+ (or "Newnym account domain: " prompt)
+ (ti::list-to-assoc-menu (tinypgp-newnym-list 'alias))
+ nil
+ 'match)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-newnym-file-stamp-name (server account)
+ "Return Stamp file name according to SERVER and ACCOUNT."
+ (concat tinypgp-:r-newnym-stamp-file-prefix
+ (ti::string-mangle (concat server account))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-newnym-file-stamp (server account)
+ "Stamp Newnym file with with SERVER and ACCOUNT."
+ (let* ((file (tinypgp-newnym-file-stamp-name server account)))
+ (if (and (file-exists-p file)
+ (not (file-writable-p file)))
+ (set-file-modes file (ti::file-mode-make-writable (file-modes file))))
+ (ti::file-touch file)
+ (ti::file-mode-protect file)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-newnym-account-expiry-warnings ()
+ "Print possible account expiry warnings.
+References:
+ `tinypgp-:r-newnym-default-account-table'"
+ (interactive)
+ (let* ((limit 100) ;It's actually 120, but we use 100
+ server account
+ days
+ file
+ ret)
+ (dolist (elt tinypgp-:r-newnym-default-account-table)
+
+ (setq server (nth 1 elt)
+ account (nth 2 elt)
+ file (tinypgp-newnym-file-stamp-name server account))
+
+;;; (setq F file S server A account)
+;;; (ti::d! (file-exists-p file) account server file)
+
+ (cond
+ ((null (file-exists-p file))
+ (message "TinyPgp Warning: No stamp file for %s %s, Creating..."
+ server
+ account)
+ (tinypgp-newnym-file-stamp server account))
+ (t
+ (setq days (ti::file-days-old file)
+ ret (format "%s %s: %d" ret account (- limit days)))
+ (when (> days limit)
+ (message
+ "Tinypgp Newnym stamp is %d days old, account may expire: %s %s"
+ days
+ server
+ account)
+ (sit-for 3)))))
+ (when ret
+ (message ret))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypgp-newnym-ask-account ()
+ "Ask newnym Account name."
+ (tinypgp-r-init-maybe)
+ (let* (nym)
+ (setq
+ nym
+ (or (get 'tinypgp-:r-newnym-default-account-table 'default-account)
+ (if (ti::nil-p
+ (setq nym
+ (read-from-minibuffer
+ "Nym account login name: "
+ nil nil nil)))
+ 'tinypgp-:history-newnym-account
+ (error "TinyPgp: Empty not accepted.")
+ nym)))
+ nym))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-newnym-ask-srv-acc (&optional confirm-msg)
+ "Ask '(server account) with optional CONFIRM-MSG."
+ (tinypgp-r-init-maybe)
+ (let* (srv
+ acc)
+ (if confirm-msg
+ (or (y-or-n-p confirm-msg)
+ (error "Abort")))
+ (setq srv (tinypgp-newnym-ask-server))
+ (setq acc (tinypgp-newnym-ask-account))
+ (list srv acc)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-newnym-ask-srv-acc-arg (&optional confirm-msg)
+ "Ask '(server account prefix_arg) with CONFIRM-MSG."
+ (tinypgp-r-init-maybe)
+ (if confirm-msg
+ (or (y-or-n-p confirm-msg)
+ (error "Abort")))
+ (list
+ (tinypgp-newnym-ask-server)
+ (tinypgp-newnym-ask-account)
+ current-prefix-arg))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypgp-r-sendmail-create-buffer (name &optional subject)
+ "Create mail buffer. The old buffer is killed.
+Input:
+ NAME buffre name. Kill eny existing buffer with NAME without query.
+ SUBJECT Message subject."
+ (ti::kill-buffer-safe name)
+ (with-current-buffer (tinypgp-ti::temp-buffer 'mail "NONE" (or subject ""))
+ (rename-buffer name)
+ (buffer-enable-undo)
+ (setq tinypgp-:r-mode-indication-flag 'newnym)
+ (tinypgpd "tinypgp-r-sendmail-create-buffer" name (current-buffer))
+ (current-buffer)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(eval-and-compile
+ (defun tinypgp-newnym-sendmail-fmacro-1 (func doc account subject msg)
+ "Use `tinypgp-newnym-sendmail-fmacro' instead.
+See FUNC DOC ACCOUNT SUBJECT MSG there."
+ (let* ((sym (intern (symbol-name (` (, func))))))
+ (`
+ (defun (, sym) (alias &optional verb)
+ (, doc)
+ (interactive (list (tinypgp-newnym-ask-server)))
+ (ti::verb)
+ (tinypgp-r-init-maybe)
+ (tinypgp-r-server-macro alias (, account)
+ (ti::mail-sendmail-macro email (, subject) 'send (insert "empty"))
+ (if verb
+ (message "'%s' request sent to %s, wait for answer."
+ (, msg) email))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinypgp-newnym-sendmail-fmacro 'lisp-indent-function 0)
+(defmacro tinypgp-newnym-sendmail-fmacro (func doc account subject msg)
+ "Create interactive function that sends mail to remailer.
+Input:
+
+ FUNC Created function name
+ DOC Function's doc string
+ ACCOUNT the account name where to send email request
+ SUBJECT Subject for email
+ MSG Notification message to interactive user e.g. 'create'."
+ (` (, (tinypgp-newnym-sendmail-fmacro-1
+ func doc account subject msg ))))
+
+;;}}}
+;;{{{ newnym: keys; menus
+
+;;; ................................................... &newnym-mode ...
+
+(defun tinypgp-newnym-mode-define-menu ()
+ "Define menus."
+ (easy-menu-define
+ tinypgp-:newnym-mode-menu (if (ti::xemacs-p)
+ nil
+ tinypgp-:newnym-mode-map)
+ "TinyPgp Newnym management menu"
+ (list
+ tinypgp-:newnym-mode-menu-name
+ ["Nym-Commands: Electric tab" tinypgp-newnym-mode-electric-tab t]
+ ["Nym-Commands: Go to." tinypgp-newnym-mode-nym-commands-goto t]
+ ["Reply-Block: Add" tinypgp-newnym-mode-reply-block t]
+ ["Reply-Block: Kill" tinypgp-newnym-mode-reply-block-kill t]
+ ["Public-key: Add" tinypgp-newnym-mode-public-key t]
+ ["Public-key: Kill" tinypgp-newnym-mode-public-key-kill t]
+ ["Mode description" tinypgp-newnym-mode-describe t]
+ "----")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-newnym-mode-define-keys ()
+ "Define keys."
+ (let* ((p tinypgp-:newnym-mode-prefix-key)
+ (map tinypgp-:newnym-mode-map))
+ (define-key map "\t" 'tinypgp-newnym-mode-electric-tab)
+ (define-key map (concat p "\t") 'tinypgp-newnym-mode-nym-commands-goto)
+ (define-key map (concat p "p") 'tinypgp-newnym-mode-public-key)
+ (define-key map (concat p "P") 'tinypgp-newnym-mode-public-key-kill)
+ (define-key map (concat p "r") 'tinypgp-newnym-mode-reply-block)
+ (define-key map (concat p "R") 'tinypgp-newnym-mode-reply-block-kill)
+ (define-key map (concat p "?") 'tinypgp-newnym-mode-describe)))
+
+;;}}}
+;;{{{ newnym: Mode functions
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;
+(ti::macrof-minor-mode
+ tinypgp-newnym-mode ;1
+ "Newnym account management help mode.
+You turn this mode on in mail buffer and it helps you to
+compose message to nym account. The most interesting command probably
+is `tinypgp-newnym-mode-electric-tab'; which works as follows
+
+ If cursor is anywhere else that at the line Nym-Commands:, then the
+ original tab function is called.
+
+Nym-Commands: create +acksend +fin +
+| | | | |
+| | | | complete all commands
+| | | complete command 'fin'
+| | Show default setting or example (previous word)
+| | *
+| Show command help and advance to '*'.
+If the cursor is over word Nym-Commands:, then advance forward to first
+command word.
+
+In hooks you should use functions
+
+ `turn-on-tinypgp-newnym-mode'
+ `turn-off-tinypgp-newnym-mode'
+
+Mode description:
+\\{tinypgp-:newnym-mode-map}
+"
+ tinypgp-install-modes ;3
+ tinypgp-newnym-mode ;4
+ tinypgp-:newnym-mode-name
+
+ tinypgp-:newnym-mode-prefix-key ;5
+ tinypgp-:newnym-mode-menu ;6
+
+ nil ;7
+ "Newnym acocunt handling" ;8
+ tinypgp-:newnym-mode-hook ;
+
+ (progn
+ (tinypgp-update-modeline)))
+
+(defun turn-on-tinypgp-newnym-mode ()
+ "Newnym mode on."
+ (tinypgp-newnym-mode 1))
+
+(defun turn-off-tinypgp-newnym-mode ()
+ "Newnym mode off."
+ (tinypgp-newnym-mode 0))
+
+;;; .............................................. &newnym-interactive ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-newnym-mode-describe ()
+ "Describe mode."
+ (interactive)
+ (describe-function 'tinypgp-newnym-mode))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-newnym-mode-electric-tab ()
+ "Compose newnym commands if cursor is on field Nym-Commands.
+Otherwise call original mode's tab key. See description of this command
+from `tinypgp-newnym-mode'."
+ (interactive)
+ (let* ((tbl tinypgp-:newnym-cmd-table)
+ elt
+ word)
+ (cond
+ ((null
+ (save-excursion (beginning-of-line) (looking-at "Nym-Commands:")))
+ ;; Turn mode off and call original tab key.
+ ;;
+ (let* (tinypgp-newnym-mode)
+ (call-interactively (key-binding "\t"))))
+ (t
+ (setq word (tinypgp-newnym-read-word))
+
+ (cond
+ ;; ................................................... beg line ...
+ ((and (not (ti::nil-p word))
+ ;; the "-" terminates word; because it is [+-] option,
+ ;; that's why we have to test separate words.
+ (member word '("Nym" "Commands:")))
+ (skip-chars-forward "^ \t\n")
+ (skip-chars-forward " \t"))
+ ;; ............................................... complete all ...
+ ((and (ti::nil-p word) ;User wrote [+-] and wants to complete
+ (ti::char-in-list-case (preceding-char) '(?+ ?-)))
+ (setq word (completing-read "Insert Command: " tbl))
+ (if (not (ti::nil-p word))
+ (insert word)))
+
+ ;; ............................................... example show ...
+ ((and (not (ti::nil-p word))
+ (setq elt (assoc word tbl)) ;Full match
+ ;; after word that is full match; on whitespace
+ (ti::char-in-list-case (following-char) '(?\ ?\t ?\n)))
+ (message (nth 2 elt)))
+
+ ;; ........................................... full match; help ...
+ ((and (not (ti::nil-p word))
+ (setq elt (assoc word tbl))) ;Full match
+ (message (nth 1 elt))
+ (skip-chars-forward "^ \t\n"))
+
+ ;; ........................................... partial complete ...
+ ((and (not (ti::nil-p word)) ;Partial
+ (setq elt (all-completions word tbl)))
+ (cond
+ ((eq 1 (length elt)) ;one match
+ (skip-chars-forward "^ \t\n")
+ (delete-backward-char (length word))
+ (insert (car elt)))
+ (t ;many completions
+ (message (ti::list-to-string elt)))))
+
+ ;; .............................................. nothing works ...
+ (t
+ ;; User is sitting on whitespace and nothing is nearby
+ ;; "Nym-Commands: "
+ (message "Write [+-] before options. Complete with TAB.")))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-newnym-mode-nym-commands-goto ()
+ "Goto Nym-Commands: forward or add that field if it does not exist."
+ (interactive)
+ (let* ((fld "Nym-Commands: ")
+ (point (if (re-search-forward fld nil t)
+ (match-end 0)
+ (save-excursion ;Wrap
+ (ti::pmin)
+ (if (re-search-forward fld nil t)
+ (match-end 0))))))
+ (if point
+ (goto-char point)
+ ;; No such field; add one. Put after From field.
+ ;;
+ ;; Config:
+ ;; From:
+ ;; Nym-Commands:
+ ;;
+ ;;
+ (ti::mail-text-start 'move)
+ (cond
+ ((re-search-forward "From:") (forward-line 1))
+ ((re-search-forward "Config:") (forward-line 1)))
+ (insert fld "\n")
+ (backward-char 1))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-newnym-mode-public-key-kill ()
+ "Kill Public-Key field."
+ (interactive)
+ (tinypgp-newnym-mode-public-key nil 'kill))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-newnym-mode-public-key (key-id &optional kill)
+ "Insert Public-Key field and PGP key block to the end.
+If there already exist Public-Key tag, then insert pgp key block after it
+by possibly deleting old pgp key block.
+
+Input:
+ KEY-ID key-id matching public key
+ KILL if non-nil prefix arg, kill the public key block"
+ (interactive
+ (let* ((default (save-excursion
+ (ti::mail-text-start 'move)
+ ;; find the From command field and suggest
+ ;; inserting pgp key-id amtching it
+ ;;
+ (ti::mail-get-field "From" 'any)))
+ ret)
+ (unless current-prefix-arg ;Don't ask if arg given
+ (setq
+ ret
+ (read-from-minibuffer "Insert pgp key matching key-id: "
+ (if (not (ti::nil-p default))
+ (ti::string-remove-whitespace default))))
+ (if (ti::nil-p ret)
+ (error "TinyPgp: Empty not accepted.")))
+
+ (list ret current-prefix-arg)))
+ (let* ((fld "Public-Key:")
+ stat)
+ (ti::save-with-marker-macro
+ (ti::mail-text-start 'move)
+ (setq stat (re-search-forward fld nil t))
+
+ (cond
+ ((and kill stat)
+ (ti::buffer-kill-line))
+
+ ((null kill)
+ (if stat
+ (forward-line 1)
+ (ti::pmax)
+ (insert fld "\n"))))
+
+ (ti::mail-pgp-block-area-kill-forward 'pkey 'move)
+
+ (when (null kill)
+ (tinypgp-key-extract-to-point key-id 'raw)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-newnym-mode-reply-block-kill (&optional insert remailer)
+ "Kill Reply-Block or INSERT (or replace with) matching REMAILER."
+ (interactive)
+ (let* ((fld "Reply-Block:")
+ stat)
+ (ti::save-with-marker-macro
+ (ti::mail-text-start 'move)
+ (setq stat (re-search-forward fld nil t))
+
+ (cond
+ ((and insert (null stat))
+ (ti::pmax)
+ (insert fld "\n"))
+ ((and insert
+ stat
+ (save-excursion ;Previous reply block?
+ (forward-line 1) ;Peek next line
+ (looking-at "::\n")))
+ (forward-line 1)
+ (delete-region (point) (point-max)))
+ ((and (null insert) stat)
+ (ti::buffer-kill-line)
+ (if (looking-at "::\n")
+ (delete-region (point) (point-max)))))
+
+ (when insert
+ (tinypgp-r-reply-block-insert remailer)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-newnym-mode-reply-block (remailer &optional verb)
+ "Insert Reply-Block field and REMAILER block to the end.
+If there already exist Reply-Block tag, then insert block after it
+by possibly deleting old block.
+
+Input:
+ REMAILER The reply block must have been created beforehand and
+ it must be included in `tinypgp-:r-reply-block-table'
+ VERB Verbose messages."
+ (interactive (list (tinypgp-ask-reply-block-remailer)))
+ (ti::verb)
+ (tinypgp-newnym-mode-reply-block-kill 'insert remailer)
+ (if verb
+ (message "Tinypgp: '%s' reply block inserted" remailer)))
+
+;;}}}
+;;{{{ newnym: misc, interactive(delete; create; toggle)
+
+;;; ............................................ &r-newnym-interactive ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-newnym-default-set (completion-name)
+ "Set default newnym server and account according to COMPLETION-NAME.
+The name must be found from table `tinypgp-:r-newnym-default-account-table'."
+ (interactive
+ (list
+ (if (null tinypgp-:r-newnym-default-account-table)
+ (error "TinyPgp: tinypgp-:r-newnym-default-account-table not defined.")
+ (completing-read
+ "Default Newnym selection: "
+ tinypgp-:r-newnym-default-account-table
+ nil
+ 'match))))
+ (let* ((sym 'tinypgp-:r-newnym-default-account-table)
+ (elt (assoc completion-name (symbol-value sym))))
+ (when elt
+ (put sym 'default-completion completion-name)
+ (put sym 'default-server (nth 1 elt))
+ (put sym 'original-server (nth 1 elt))
+ (put sym 'default-account (nth 2 elt))
+ (put sym 'original-account (nth 2 elt))
+ (if (interactive-p)
+ (message "TinyPgp: Default newnym server and account now: %s %s"
+ (nth 1 elt) (nth 2 elt) ))
+ (tinypgp-update-modeline)
+ elt)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-newnym-default-toggle (&optional arg verb)
+ "Toggle setting and resetting default newnym account.
+Set and restore variable's `tinypgp-:r-newnym-default-account-table' properties
+'default-server and 'default-account.
+
+ARG behaves like mode arg.
+
+ nil toggle
+ 0 set values to nil
+ 1 restore values.
+ 9 Force re-reading values now. You have to call this if you chnage the
+ contents of the values during session manually.
+
+VERB allows verbose messages."
+ (interactive "P")
+
+ (if (null tinypgp-:r-newnym-default-account-table)
+ (error "TinyPgp: tinypgp-:r-newnym-default-account-table not defined."))
+
+ (let* ((sym 'tinypgp-:r-newnym-default-account-table)
+ (srv (get sym 'default-server))
+ (acc (get sym 'default-account))
+ (force (eq arg 9))
+ msg)
+ (ti::verb)
+ ;; Not recorded? Record original value
+ ;;
+ (when (or force (null (get sym 'original-server)))
+ (put sym 'original-server srv))
+
+ (when (or force (null (get sym 'original-account)))
+ (put sym 'original-account acc))
+
+ (cond
+ ((memq arg '(9))
+ (setq msg (format "Default newnym parameters updated: %s %s"
+ srv acc)))
+
+ ((memq arg '(0 -1))
+ (put sym 'default-server nil)
+ (put sym 'default-account nil)
+ (setq msg (format "Default newnym parameters off.")))
+
+ (t ;Toggle
+ (cond
+ (srv
+ (put sym 'default-server nil)
+ (put sym 'default-account nil))
+ (t
+ (put sym 'default-server (get sym 'original-server))
+ (put sym 'default-account (get sym 'original-account))))
+ (setq msg (format "Default newnym server and account now: %s %s"
+ (or (get sym 'original-server) "nil")
+ (or (get sym 'original-account) "nil")))))
+
+ (tinypgp-update-modeline)
+ (if verb
+ (message msg))
+ msg))
+
+;;; ----------------------------------------------------------------------
+;;;
+(tinypgp-newnym-sendmail-fmacro
+ tinypgp-newnym-get-pgp-key
+ "Get PGP key via email from remailer."
+ "remailer-key" "Send PGP key" "PGP key get")
+
+(tinypgp-newnym-sendmail-fmacro
+ tinypgp-newnym-get-used-list
+ "Get list of used 'newnym' account names."
+ "list" "Send used account list" "Used")
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-newnym-help-verbose (&optional arg)
+ "Call `tinypgp-nymserver-help' as interactive would with ARG."
+ (let* ((a (tinypgp-newnym-help-i-args arg)))
+ (tinypgp-newnym-help (nth 0 a) (nth 1 a))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-newnym-help-i-args (&optional arg)
+ "Ask arrgs for `tinypgp-newnym-help'. ARG is prefix arg."
+ (let* ((list (tinypgp-newnym-list)))
+ (when (or (not (stringp tinypgp-:r-newnym-help-file))
+ (null (file-exists-p tinypgp-:r-newnym-help-file))
+ current-prefix-arg)
+ (if (null list)
+ (error "\
+TinyPgp: No 'newnym' type remailers in `tinypgp-:r-levien-table'."))
+
+ (list
+ 'mail-req
+ (tinypgp-newnym-ask-server "Send help request to newnym: ")))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-newnym-help (&optional mail-req nym-alias-name verb)
+ "Print newnym remailer help or send the help request via mail.
+
+Input:
+ MAIL-REQ send mail request [current-prefix-arg]
+ NYM-ALIAS-NAME from where to ask the help file.
+ VERB verbose messages"
+ (interactive (tinypgp-newnym-help-i-args current-prefix-arg))
+ (let* ((file tinypgp-:r-newnym-help-file)
+ (elt (if nym-alias-name
+ (assoc nym-alias-name tinypgp-:r-levien-table)))
+ email)
+ (ti::verb)
+ (cond
+ (mail-req
+ (if (null elt)
+ (error "TinyPgp: Cannot find ELT for '%s'" nym-alias-name))
+
+ ;; Set address to "help@..."
+ (setq email (nth 1 elt))
+
+ (if (null (string-match "^[^@]+" email))
+ (error "TinyPgp Internal error. Call \\[tinypgp-r-init]"))
+
+ (setq email (ti::replace-match 0 "help" email))
+
+ (ti::mail-sendmail-macro email "help" 'send (insert "help\n"))
+ (if verb
+ (message
+ "Email request sent to '%s'.%s"
+ email
+ (if file ""
+ "Update tinypgp-:r-newnym-help-file when you get answer."))))
+
+ ((and file
+ (file-exists-p file))
+ (pop-to-buffer (find-file-noselect file)))
+
+ (t
+ (error "TinyPgp: Don't know what to do. %s %s "
+ mail-req nym-alias-name)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-newnym-config-insert
+ (server nym-name &optional command pgp-key remailer)
+ "Insert Config request to mail buffer. Mail body is supposed to be empty.
+
+Input:
+
+ SERVER newnym server alias name, like 'weasel'
+ NYM-NAME account name i the newnym server
+ COMMAND commands to send
+ PGP-KEY PGP key block.
+ if 'string' insert as is
+ if buffer pointer, insert buffer contents
+ if symbol; call pgp to find key from keyrings matching symbol.
+
+ REMAILER Reply block
+ if 'string', then insert as is
+ if buffer pointer, then insert buffer content.
+ if symbol, it must be remailer alias name to use for
+ reply block. The remailer reply block is then
+ inserted from file pointed by `tinypgp-:r-reply-block-table'."
+ (interactive
+ (list
+ (tinypgp-newnym-ask-server)
+ (read-from-minibuffer "Nym account name: ")))
+ (tinypgp-r-init-maybe)
+ (let* ((fid "tinypgp-newnym-config-insert:")
+ list)
+
+ (tinypgpd fid "in:" server nym-name command pgp-key remailer)
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... compose request ...
+ (tinypgp-r-server-macro server "config"
+
+ (ti::mail-kill-field "^To:" email)
+ (ti::mail-text-start 'move)
+
+ (insert
+ "Config:\n"
+ "From: " (or nym-name "") "\n"
+ "Nym-Commands: " (or command "") "\n")
+
+ (when pgp-key
+ (insert "Public-Key:\n")
+ (cond
+ ((bufferp pgp-key) (insert-buffer pgp-key))
+ ((stringp pgp-key) (insert pgp-key))
+
+ ((symbolp pgp-key)
+ (tinypgp-key-extract-to-point (symbol-name pgp-key) 'raw)
+ ;; check that PGP public key definition contains <> email
+ ;; to this host.
+ ;;
+ (with-current-buffer tinypgp-:buffer-tmp-shell
+ (setq list (ti::mail-email-find-region))
+ (when (or (null list)
+ (not (string-match
+ (replace-regexp-in-string ".*@" "" email 0)
+ ;; Take first email from key-id
+ (or (car list)
+ (progn
+ (pop-to-buffer (current-buffer))
+ (error "\
+TinyPgp: no email found from pgp key?"))))))
+ (pop-to-buffer (current-buffer))
+ (error "TinyPgp: PGP user ID '%s' does not refer to domain '%s'"
+ pgp-key email))))
+
+ ((error "TinyPgp: Oops, wrong argument..."))))
+
+ (when remailer
+ (insert "Reply-Block:\n")
+ (cond
+ ((bufferp remailer) (insert-buffer remailer))
+ ((stringp remailer) (insert remailer))
+ ((symbolp remailer)
+ (tinypgp-r-reply-block-insert (symbol-name remailer)))
+ ((error "TinyPgp: Oops, wrong argument...")))
+ (insert "\n**\n")
+ (ti::pmax)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-newnym-config-sendmail-template (server account &optional verb)
+ "Create mail buffer and inset newnym' configuration template.
+Input:
+
+ SERVER newnym server
+ ACCOUNT login account
+ VERB verbose, show buffer. Interactive call sets this.
+
+Return:
+ buffer pointer"
+ (interactive
+ (list
+ (tinypgp-newnym-ask-server)
+ (tinypgp-newnym-ask-account)))
+ (tinypgp-r-init-maybe)
+ (let* (buffer)
+ (ti::verb)
+ (with-current-buffer (setq buffer
+ (tinypgp-r-sendmail-create-buffer
+ tinypgp-:buffer-newnym
+ "Config request"))
+ (tinypgp-newnym-config-insert server account)
+ (turn-on-tinypgp-mode)
+ (turn-on-tinypgp-newnym-mode)
+ (tinypgp-newnym-mode-nym-commands-goto))
+ (when verb
+ (switch-to-buffer buffer))
+ buffer))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgpg-newnym-account-request
+ (server account cmd &optional pgp-key remailer send)
+ "Set up all necessary things to send command to newnym server account.
+
+Input:
+
+ SERVER newnym server alias
+ ACCOUNT newnym account name
+ CMD Nym-Comands's field content
+
+ PGP-KEY If t, then inser pgp-key matching ACCOUNT
+
+ It symbol but not t, Email address string which
+ matches the key-id from PGP key -- that key is sent to newnym.
+
+ REMAILER Use this remailer's reply block. You must have created this
+ beforehand with `tinypgp-r-reply-block-basic' and stored
+ it to file pointed by `tinypgp-:r-reply-block-table'.
+ SEND if non-nil, encrypt and send the message.
+
+Return:
+ mail buffer pointer if SEND is nil"
+ (let* ((fid "tinypgpg-newnym-account-request: ")
+ buffer
+ to)
+ (tinypgpd fid "ARGS" server account (current-buffer))
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... mail buffer ...
+ (tinypgp-r-server-macro server account
+ (ti::mail-sendmail-pure-env-macro
+ (setq buffer (tinypgp-r-sendmail-create-buffer
+ tinypgp-:buffer-newnym
+ "Account request"))
+ ;; The window excursion is needed so that nothing fancy happens
+ ;; when we send mail. User doesn't want his windows changed
+ ;;
+ (save-window-excursion
+ (save-excursion
+ (set-buffer buffer)
+ (tinypgpd fid server account email info)
+ (if (eq t pgp-key)
+ (setq pgp-key (make-symbol email)))
+
+ (tinypgp-newnym-config-insert server account cmd pgp-key remailer)
+
+ (if (null send)
+ buffer
+ (make-local-variable 'tinypgp-:auto-action-table)
+ (setq tinypgp-:auto-action-table nil)
+ (ti::mail-sendmail-reset-send-hooks)
+
+ (tinypgp-save-state-macro
+ (setq tinypgp-:user-now email)
+ (tinypgp-password-set (format "Newnym Encrypt password: "))
+ (setq to (mail-fetch-field "to"))
+ (tinypgp-encrypt-mail (ti::string-remove-whitespace to) nil))
+ (mail-send-and-exit nil))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-newnym-delete (server account &optional verb)
+ "Send to newbyn SERVER a ACCOUNT delete request. VERB."
+ (interactive
+ (tinypgp-newnym-ask-srv-acc
+ "Are you sure you want to send DELETE request? "))
+ (ti::verb)
+ (tinypgp-r-init-maybe)
+ (pop-to-buffer
+ (tinypgpg-newnym-account-request server account "delete" nil nil))
+ (if verb (message "Newnym Delete request sent.")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-newnym-create-i-args ()
+ "Ask arguments to `tinypgp-newnym-create'."
+ (let* ((site (get 'tinypgp-:r-newnym-default-account-table 'default-server))
+ desc
+ remailer
+ srv-account
+ login)
+ (tinypgp-r-init-maybe)
+ (message "You should check free Nym login names first...ok?")
+ (sit-for 2)
+
+ (setq srv-account (tinypgp-newnym-ask-srv-acc))
+
+ (if (ti::nil-p
+ (setq
+ login
+ (read-from-minibuffer
+ (format
+ "[%s] Create Nym Login: "
+ site))))
+ (error "Abort."))
+
+ (if (ti::nil-p
+ (setq
+ desc
+ (read-from-minibuffer
+ (format
+ "[%s] Describe Nym login name: "
+ site))))
+ (error "TinyPgp: Empty not accepted."))
+
+ (setq remailer
+ (tinypgp-ask-reply-block-remailer
+ (format
+ "[%s] Select Reply block of remailer: "
+ site)))
+
+ (list (nth 0 srv-account)
+ login
+ desc
+ remailer)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-newnym-create (server account desc remailer &optional verb)
+ "Send to newbyn SERVER a ACCOUNT delete request.
+
+Note:
+
+ Before you call this function, make sure you have created new key
+ with 'pgp -kg' and that its key-id line contain email address
+ <yournym@remail.domain.com>
+
+Input:
+
+ SERVER newnym server (alias) name
+ ACCOUNT account name in newnym
+ DESC account description
+ REMAILER remailer's reply block to submit to newnym server.
+ VERB Verbose messages. Shows the buffer and turns on
+ `tinypgp-mode' and `tinypgp-newnym-mode`."
+ (interactive
+ (progn
+ (tinypgpd "tinypgp-newnym-create: INTERACTIVE")
+
+ (or
+ (y-or-n-p
+ "\
+Do have created the ncessary PGP keys for newnym account? (see manual)")
+ ;; Umph; again some impatient user selected this choice without readin
+ ;; the newnym documentation....
+ (error "TinyPgp: Please read the newnym remailer manual first."))
+ (tinypgp-newnym-create-i-args)))
+ (tinypgpd "tinypgp-newnym-create: in" server account desc remailer verb)
+ (tinypgp-r-init-maybe)
+ (let* ()
+ (ti::verb)
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... mail buffer ...
+ (with-current-buffer (tinypgpg-newnym-account-request
+ server account
+ (format "create +acksend +fingerkey name=\"%s\"" desc)
+ t
+ (make-symbol remailer))
+
+ (when verb
+ (turn-on-tinypgp-mode)
+ (switch-to-buffer (current-buffer)) ;Now visible to user
+ (ti::mail-text-start 'move)
+
+ (turn-on-tinypgp-newnym-mode)
+ (ti::mail-mime-turn-off-mode)
+ (tinypgp-email-substitution-toggle 0) ;; Config request
+;;; (tinypgp-auto-action-toggle 0) ;; No auto action here by default
+
+ ;; We havae to "account", bwecause 1pass needs to be signed
+ ;; with the "account" key. Store the active pgp user information
+ ;; to local variables, so that we can restore the user in mail send
+ ;; hook
+ ;;
+
+ (make-local-variable 'tinypgp-pgp-user-original)
+ (make-local-variable 'tinypgp-pgp-user-now)
+
+ (defconst tinypgp-pgp-user-original tinypgp-:user-now)
+ (defconst tinypgp-pgp-user-now account)
+ (setq tinypgp-:user-now account)
+
+ ;; Warn about this change, because user may kill the buffer
+ ;; and the active pgp user still stays "nym" login.
+ ;;
+ (message "Active PGP user changed to: %s" account) (sleep-for 1.5)
+
+ (ti::read-char-safe-until
+ (substitute-command-keys
+ (concat
+ "Check all; do 1pass Encrypt-Sign with NymKey: "
+ "\\[tinypgp-encrypt-mail-sign] [press to continue]")))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-newnym-post (&optional server account verb)
+ "Convert current message into Nym post ueing SERVER and ACCOUNT. VERB.
+The message can be newsgroup post or regular email."
+ (interactive
+ (progn
+ (tinypgp-r-init-maybe)
+ (list
+ (tinypgp-newnym-ask-server)
+ (tinypgp-newnym-ask-account))))
+ (tinypgp-r-init-maybe)
+ (let* ((subj (mail-fetch-field "Subject"))
+ (news (ti::mail-news-buffer-p))
+ (hdr-blk "")
+ hash-headers to
+ hdr
+ ret)
+ (ti::verb)
+
+ (tinypgp-r-server-macro server "send"
+ (cond
+ (news
+ (setq ret (tinypgp-r-post-usenet 'newnym))
+ (ti::mail-kill-field "To")
+ (ti::mail-kill-field "Subject")
+ (ti::mail-kill-field "From")
+ ;; Rest of the headers without "To" field.
+ ;;
+ (setq hdr (buffer-substring (point-min) (ti::mail-hmax)))
+
+ ;; Now send to newnym server
+ ;;
+ (ti::pmin)
+ (insert "To: " email "\n"
+ "Subject: message\n")
+
+ (ti::mail-text-start 'move)
+ (insert "From: " account "\n"
+ "To: " (or (eval tinypgp-:r-newnym-mail2news-address)
+ (error "TinyPgp: no newnym mail2news gateway?"))
+ "\n"
+ "subject: " subj "\n")
+
+ (insert hdr)
+ (insert "Newsgroups: " (ti::list-to-string (nth 1 ret)) "\n\n")
+ (ti::mail-kill-field-in-body '("fcc" "gcc")))
+ (t
+ (setq to (mail-fetch-field "to"))
+ (tinypgp-header-kill)
+ ;; Save all headers because they are inserted into body
+ ;;
+ (if (setq hash-headers
+ (tinypgp-header-move-to-body 'move-to-body 'no-ins))
+ (setq hdr-blk (mapconcat 'concat hash-headers "")))
+ (ti::mail-kill-field "To" email)
+ (ti::pmin) (insert "To: " email "\n")
+
+ (ti::mail-text-start 'move)
+ (insert "From: " account "\n"
+ "To: " to "\n"
+ hdr-blk))))
+ (when verb
+ (unless tinypgp-newnym-mode (turn-on-tinypgp-newnym-mode))
+ ;; (tinypgp-auto-action-update-modeline)
+ (message
+ (substitute-command-keys
+ (concat
+ "Nym-Commands can be set per message basis, press "
+ "\\[tinypgp-newnym-mode-nym-commands-goto] and "
+ "\\[tinypgp-newnym-mode-electric-tab]"))))))
+
+;;}}}
+;;{{{ newnym: interactive requests
+
+;;; ------------------------------------------------------ &newnym-req ---
+;;;
+(eval-and-compile
+ (defun tinypgp-newnym-req-fmacro-1 (func req)
+ "Use `tinypgp-newnym-req-fmacro' instead. See FUNC REQ there."
+ (let* ((sym (intern (symbol-name (` (, func))))))
+ (`
+ (defun (, sym) (server account &optional plus verb)
+ "Send to newnym SERVER ACCOUNT an minus(default) or PLUS request. VERB."
+ (interactive (tinypgp-newnym-ask-srv-acc-arg))
+ (ti::verb)
+ (setq plus (concat (if plus "+" "-") (, req)))
+ (tinypgpg-newnym-account-request
+ server account plus nil nil 'send)
+ (tinypgp-newnym-file-stamp server account)
+ (when verb
+ (message "[%s] Newnym request sent: %s" server plus)
+ ;; If mouse pressed, don't wipe message immediately
+ (sleep-for 1)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinypgp-newnym-req-fmacro 'lisp-indent-function 0)
+(defmacro tinypgp-newnym-req-fmacro (func req)
+ "Create interactive function that sends newnym request.
+Input:
+
+ FUNC Created function name
+ REQ request to send; without +- option at front."
+ (` (, (tinypgp-newnym-req-fmacro-1 func req))))
+
+;;; ----------------------------------------------------------------------
+;;; We have to tell the autoloads by hand; because the functions are
+;;; created by separate macro.
+;;;
+;;;###autoload (autoload 'tinypgp-newnym-req-acksend "tinypgp" "" t)
+;;;###autoload (autoload 'tinypgp-newnym-req-sigsend "tinypgp" "" t)
+;;;###autoload (autoload 'tinypgp-newnym-req-cryptrecv "tinypgp" "" t)
+;;;###autoload (autoload 'tinypgp-newnym-req-fixedsize "tinypgp" "" t)
+;;;###autoload (autoload 'tinypgp-newnym-req-disable "tinypgp" "" t)
+;;;###autoload (autoload 'tinypgp-newnym-req-fingerkey "tinypgp" "" t)
+;;;###autoload (autoload 'tinypgp-newnym-req-nobcc "tinypgp" "" t)
+
+(tinypgp-newnym-req-fmacro tinypgp-newnym-req-acksend "acksend")
+(tinypgp-newnym-req-fmacro tinypgp-newnym-req-sigsend "sigsend")
+(tinypgp-newnym-req-fmacro tinypgp-newnym-req-cryptrecv "cryptrecv")
+(tinypgp-newnym-req-fmacro tinypgp-newnym-req-fixedsize "fixedsize")
+(tinypgp-newnym-req-fmacro tinypgp-newnym-req-disable "disable")
+(tinypgp-newnym-req-fmacro tinypgp-newnym-req-fingerkey "fingerkey")
+(tinypgp-newnym-req-fmacro tinypgp-newnym-req-nobcc "nobcc")
+
+;;}}}
+
+;;{{{ Nymserver: misc
+
+;;; .................................................. &nymserver-misc ...
+;;; anon.nymserver.com successor of anon.penet.fi
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-nymserver-mail-p (&optional alias)
+ "Check if there is Anon X-headers in the buffers. ALIAS."
+ (setq alias (car (car tinypgp-:nymserver-table)))
+ (and
+ (ti::re-search-check "^X-Anon-Password\\|^X-Anon-To")
+ (ti::re-search-check (format "^To:.*%s" alias))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypgp-nymserver-service-elt (alias)
+ "Return service entries or call error is no such ALIAS."
+ (or (assoc alias tinypgp-:nymserver-table)
+ (error "TinyPgp: No server alias '%s'" alias)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypgp-nymserver-mailto (alias)
+ "Return address where user can send mail so that it gets anynymized. ALIAS."
+ (or (nth 3 (assoc alias tinypgp-:nymserver-table))
+ (error "TinyPgp: No post email address")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypgp-nymserver-address (string alias)
+ "Return nymserver email address prepended with STRING as account name. ALIAS.
+
+Return:
+ STRING@NYMSERVER-ADDRESS"
+ (concat
+ string
+ (ti::string-match
+ "\\(@.*\\)" 1
+ (nth 2 (assoc alias tinypgp-:nymserver-table)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-nymserver-ask (&optional msg)
+ "Ask server alias name with MSG."
+ (if nil ;disabled now
+ (completing-read
+ (or msg "Use pent server: ")
+ (ti::list-to-assoc-menu (mapcar 'car tinypgp-:nymserver-table))
+ nil
+ 'match)
+ ;; 1997-02-13 Jari aalto
+ ;; - We don't support other nymserver accounts currently
+ ;;
+ (car (car tinypgp-:nymserver-table))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-nymserver-password (alias)
+ "Return password or nil for ALIAS."
+ (let* ((elt (assoc alias tinypgp-:nymserver-account-table))
+ (pass (nth 2 elt)))
+ pass))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-nymserver-sendmail (action alias &optional verb arg1 arg2)
+ "Send ACTION mail to nymserver ALIAS.
+Mail will be encrypted if `tinypgp-:nymserver-request-encrypt' is non-nil.
+See variables documentation for more detailed usage.
+
+Input:
+ ACTION ALIAS VERB ARG1 ARG2
+
+Note:
+ following variables are bound to nil to prevent any interference when
+ sending mail commands.
+
+ `mail-archive-file-name'
+ `mail-default-headers'
+ `mail-mode-hook'
+ `mail-setup-hook'"
+ (let* ((elt (assoc alias tinypgp-:nymserver-account-table))
+ (account (or (nth 1 elt)
+ (error "TinyPgp: No account")))
+ (pass (or (nth 2 elt)
+ (error "TinyPgp: No account password")))
+ (my-from (nth 4 elt))
+
+ (fld1 "X-Anon-Password: ")
+ (fld2 "X-Anon-Subject: ")
+ (encrypt tinypgp-:nymserver-request-encrypt)
+
+ ;; Make sure email substitution mode is on when we send
+ ;; mail to anon server. User may have forgotten it off
+
+ (tinypgp-:read-email-after-hook
+ (or (get 'tinypgp-:read-email-after-hook 'original)
+
+ ;; if the above fails, that means that the 'original
+ ;; property is not used yet and not available.
+
+ tinypgp-:read-email-after-hook))
+
+ (email (tinypgp-nymserver-address (symbol-name action) alias))
+ (enc-key (car (tinypgp-key-id-conversion email)))
+ subject
+ buffer)
+
+ (tinypgpd "tinypgp-nymserver-sendmail in: " action alias verb arg1 arg2)
+
+ (save-window-excursion
+ (cond
+ ((memq action '(finger ping remove help abuse))
+ (ti::mail-sendmail-macro email "None" 'send
+ (insert fld2 (or arg1 "No subject data") "\n")
+
+ ;; This field will confuse Nymserver server. Remove it
+ ;;
+ (ti::mail-kill-field "Reply-To")
+ (if my-from (ti::mail-add-field "From" my-from "To"))
+
+ (if encrypt (tinypgp-encrypt-mail-find-keyring enc-key))))
+;;; (pop-to-buffer (current-buffer)) (ti::d! 101)
+
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. upload pgp key . .
+ ((eq action 'newpgp)
+ (unless arg1 ;Nor a remove request?
+ (with-current-buffer (setq buffer (tinypgp-ti::temp-buffer 'finger))
+ (erase-buffer)
+ (tinypgp-key-extract-to-point account)
+
+ (ti::pmin)
+ (if (re-search-forward "matching keys found" nil t)
+ (error "TinyPgp: [%s' didn't match exactly." arg1))))
+
+ (ti::mail-sendmail-macro email "No subject" 'send
+ (if my-from (ti::mail-add-field "From" my-from "To"))
+
+ (insert fld1 pass "\n")
+
+;;; (pop-to-buffer (current-buffer)) (ti::d! 10)
+
+ (if (string= "remove" arg1)
+ (insert fld2 "remove" "\n")
+ (insert-buffer buffer))
+
+ (if encrypt
+ (tinypgp-encrypt-mail-find-keyring enc-key))))
+
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. plan and sig . .
+ ((memq action '(newplan newsig))
+ (ti::mail-sendmail-macro email "No subject" 'send
+ (insert fld1 pass "\n")
+
+ (ti::mail-kill-field "Reply-To")
+ (if my-from (ti::mail-add-field "From" my-from "To"))
+
+ (if (string= "remove" arg1)
+ (insert fld2 "remove" "\n")
+ (insert-file arg1))
+
+ (if encrypt
+ (tinypgp-encrypt-mail-find-keyring enc-key))))
+
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. flags . .
+ ((memq action '(paranoid newalias nick
+ newpassword vacation noarchive
+ newaddress setnon
+ pgpencrypt pgpsign sendmix))
+ (setq subject (or arg1 "No subject")) ;this is the new alias name
+ (ti::mail-sendmail-macro email "No subject" 'send
+ (insert fld1 pass "\n"
+ fld2 subject "\n")
+
+ (ti::mail-kill-field "Reply-To")
+ (if my-from (ti::mail-add-field "From" my-from "To"))
+
+;;; (pop-to-buffer (current-buffer)) (ti::d! 10)
+ (if encrypt (tinypgp-encrypt-mail-find-keyring enc-key))))
+;;; (pop-to-buffer (current-buffer)) (ti::d! 10)
+ (t
+ (error "TinyPgp: unknown action '%s'" action)))
+ (if verb (message "Nymserver: %s request sent."
+ (capitalize (symbol-name action)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-nymserver-create-1 (email)
+ "Send EMAIL to create account."
+ (interactive)
+ (ti::read-char-safe-until
+ "[press] Store received account info into tinypgp-:nymserver-account-table.")
+ (ti::mail-sendmail-macro email "No subject" 'send))
+
+;;}}}
+;;{{{ Nymserver: interactive
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-nymserver-post (alias &optional verb)
+ "Convert message so that it can be posted to through nymserver. ALIAS VERB."
+ (interactive
+ (list
+ (progn
+ (tinypgp-nymserver-i-enable)
+ (tinypgp-nymserver-ask))))
+
+ (let* ((srv (tinypgp-nymserver-service-elt alias))
+ (mailto (or (nth 3 srv)
+ (error "TinyPgp: No server mailto address.")))
+ (grp-limit (nth 4 srv))
+
+ (elt (or (assoc alias tinypgp-:nymserver-account-table)
+ (error "TinyPgp: Unknown server %s" alias)))
+;;; (email (or (nth 1 elt)
+;;; (error "No account email")))
+
+ (pass (or (nth 2 elt)
+ (error "TinyPgp: No account password")))
+ (name (nth 3 elt))
+ (my-from (nth 4 elt))
+
+ (fld1 "X-Anon-Password: ")
+ (fld2 "X-Anon-To: ")
+ (fld3 "X-Anon-Name: ")
+ (fld4 "X-Anon-Subject: ")
+;;; (fld-ref "X-Anon-references: ") references
+ to subject
+ hlist
+ grp)
+
+ (ti::verb)
+
+ (unless (ti::mail-mail-p)
+ (error "TinyPgp: This is not email buffer."))
+
+ (setq to (mail-fetch-field "to")
+ subject (mail-fetch-field "subject")
+ hlist (delete 'newsgroups (ti::mail-required-headers)))
+
+ (when (ti::nil-p subject)
+ (error "TinyPgp: No subject. Aborted"))
+
+ (ti::save-with-marker-macro
+ (ti::mail-text-start 'move)
+ (if (looking-at "X-Anon")
+ (if verb
+ (message "Already in anon post format."))
+
+ (cond
+ ((not (ti::nil-p to)) ;regular email message
+
+ ;; tinymail.el / we have to add 2 spaces to the beginning of field
+ ;; so that CC tracking goes off.
+ ;;
+ (ti::mail-kill-field "to" (concat " " mailto))
+ (if my-from (ti::mail-add-field "From" my-from "To"))
+
+ (insert fld1 pass "\n"
+ fld2 to "\n"
+ (if name (concat fld3 name "\n") "")
+ fld4
+ subject "\n")
+ (tinypgp-update-modeline))
+
+ ((not (ti::nil-p (setq grp (mail-fetch-field "newsgroups"))))
+ (if (and grp-limit
+ (> (count-char-in-string ?, grp) grp-limit))
+ (error "\
+TinyPgp: Too many newsgroups, only %d allowed" grp-limit))
+
+;;; (setq references (mail-fetch-field "references"))
+ (push 'in-reply-to hlist )
+ (ti::mail-kill-non-rfc-fields hlist)
+
+ (ti::mail-add-field "To" mailto)
+ (when my-from
+ ;; it may be possible that this field is there already,
+ ;; kill it first
+ ;;
+ (ti::mail-kill-field "^From:")
+ (ti::mail-add-field "From" my-from "To"))
+
+ (ti::mail-text-start 'move)
+ (insert fld1 pass "\n"
+ fld2 grp "\n"
+ (if name (concat fld3 name "\n") "")
+ fld4
+ subject "\n")
+ (tinypgp-update-modeline))
+
+ (t
+ (if verb
+ (error "\
+TinyPgp: Don't know what to do: To or Newsgroup field empty."))))
+ (ti::mail-kill-field "subject" " None")
+
+ ;; Add 'cutmarks' so that all the rest of the text are
+ ;; ripped.
+ ;;
+ (ti::pmax)
+ (if (bolp)
+ (insert "--")
+ (insert "\n--"))))
+
+ (run-hooks 'tinypgp-:nymserver-post-hook)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-nymserver-send ()
+ "Handle sending mail addressed to Nymserver.
+This function is called after C -c C -c to sned the mail.
+If there are no multiple recipients, this function does nothing
+
+Return:
+ nil
+ t"
+ (let* ((fid "tinypgp-nymserver-send: ")
+ (email "anon@anon.nymserver.com")
+ (to (mail-fetch-field "to"))
+ (cc (mail-fetch-field "cc"))
+ (fcc (mail-fetch-field "fcc"))
+ (subject (mail-fetch-field "subject"))
+ (elist (delete
+ email
+ (append
+ (ti::mail-email-from-string to)
+ (if cc (ti::mail-email-from-string cc)))))
+
+ (enc-key (car (tinypgp-key-id-conversion email)))
+ (encrypt tinypgp-:nymserver-request-encrypt)
+
+ (len (length elist))
+;;; (i 0)
+ (send-flag t)
+
+ message-body
+ ret)
+
+ ;; - Nymserver doesn't accept CC or many addresses in To field,
+ ;; it can only have one X-anon-To destination.
+ ;; - What we do here is, that we copy the message and send it
+ ;; individually to each destination
+ ;; - We need confirmation for this
+
+ (when (or (> len 1)
+ ;; If there is CC, then automatically suppose multiple
+ ;; recipients. The To field is already in X-Anon-To
+ ;; So this CC makes at least 2 recipients.
+ ;;
+ cc)
+ (tinypgpd fid subject to cc fcc elist)
+
+ ;; The X-Anon-To is inside PGP envelope, we can't use this message
+ ;; body to CC it to others.
+ ;;
+ (if (ti::mail-pgp-encrypted-p 'double-check)
+ (error "\
+TinyPgp: You have CC in Nymserver mail. Can't process encrypted message."))
+
+ (if (null
+ (y-or-n-p
+ (format
+ "CC %d: You have multiple anon recipients, are you sure? "
+ len)))
+ (error "Abort.")
+ (setq message-body
+ (buffer-substring (ti::mail-text-start) (point-max)))
+ (dolist (elt elist)
+ (ti::mail-sendmail-macro email "None" send-flag
+ (insert message-body)
+ (pop-to-buffer (current-buffer))
+ (ti::pmin)
+ (re-search-forward "X-Anon-To:\\(.*\\)")
+ (ti::replace-match 1 (concat " " elt))
+ (pop-to-buffer (current-buffer))
+;;; (incf i) (message "Sending-quick %d/%d %s" i len elt)
+ (if encrypt
+ (tinypgp-encrypt-mail-find-keyring enc-key))))
+ (ti::read-char-safe-until
+ "[press]Anon CC copies sent, now sending this mail buffer.")
+ (ti::mail-kill-field "cc")
+ (if encrypt
+ (tinypgp-encrypt-mail-find-keyring enc-key))
+ (setq ret t)))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-nymserver-create (alias)
+ "Send account create request. ALIAS."
+ (interactive (list (tinypgp-nymserver-ask)))
+ (let ((srv (tinypgp-nymserver-service-elt alias)))
+ (if (yes-or-no-p
+ "Are you absolutely sure you want to send 'create' request ")
+ (funcall (nth 1 srv) (nth 1 srv)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-nymserver-remove (alias)
+ "Remove your anonymous account. ALIAS."
+ (interactive
+ (list
+ (progn
+ (tinypgp-nymserver-i-enable)
+ (tinypgp-nymserver-ask))))
+ (if (yes-or-no-p
+ "Are you absolutely sure you want to terminate anonymous account ")
+ (tinypgp-nymserver-sendmail 'remove alias (interactive-p))))
+
+;;; ----------------------------------------------------------------------
+;;; Hm. This function does not have paramaeter 'alias'.
+;;; So it's not general purpose for other accounts
+;;; #todo: Should rethink it sometime.
+;;;
+(defun tinypgp-nymserver-finger (account)
+ "Finger account's email address for its configuration.
+If ACCOUNT is in format vanity.an@site or vanity.na@site.com, it is converted
+into vanity@site.com before sending finger request."
+ (interactive
+ (progn
+;;; (tinypgp-nymserver-i-enable)
+ (let* ((elt (assoc (tinypgp-nymserver-ask)
+ tinypgp-:nymserver-account-table))
+ (from (car-safe
+ (ti::mail-email-from-string
+ (or (mail-fetch-field "from") ""))))
+ (account (nth 1 elt))
+ (list (if account
+ (ti::list-to-assoc-menu (list account)))))
+ ;; If user has reveived mail from anNNN@anon.nymserver.com
+ ;; Then we offer to finger that account too
+ ;;
+ (when (and from (string-match "an[0-9]@\\|\\.[an][na]@" from))
+ (setq list (ti::list-to-assoc-menu
+ (if account
+ (list from account)
+ (list from))))
+ (setq account from))
+
+ (list
+ (completing-read
+ "Finger nymserver account [give email address]: "
+ list
+ nil
+ nil
+ account)))))
+
+ ;; Use may press <empty> RET in completing-read
+
+ (if (not (string-match "@" account))
+ (error "TinyPgp: Need email address."))
+
+ ;; silent converion to 'an' format
+
+ (setq account (ti::mail-nymserver-email-convert account))
+
+ (tinypgp-nymserver-sendmail
+ 'finger (tinypgp-nymserver-ask) (interactive-p) account))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-nymserver-abuse (alias)
+ "Send ABUSE request. ALIAS."
+ (interactive (list (tinypgp-nymserver-ask)))
+ (let* ((buffer "*mail-nymserver-abuse*"))
+ (ti::kill-buffer-safe buffer)
+ (when (y-or-n-p "Nymserver: Are you sure you want to report ABUSE? ")
+ (ti::mail-sendmail-macro
+ (tinypgp-nymserver-address "abuse" alias)
+ "ABUSE"
+ nil
+ (rename-buffer buffer)
+ (pop-to-buffer (current-buffer))
+ (message "Write message and possibly encrypt it.")))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-nymserver-ping (alias)
+ "Send Ping request. ALIAS.
+In order to send ping, you have to be sending
+mail FROM AN ACCOUNT WHERE YOU SENT the create command. You can't send ping
+from any other location."
+ (interactive
+ (progn
+ (tinypgp-nymserver-i-enable)
+ (list (tinypgp-nymserver-ask))))
+ (tinypgp-nymserver-sendmail 'ping alias (interactive-p)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-nymserver-paranoid (alias)
+ "Toggle paranoid setting. ALIAS."
+ (interactive
+ (progn
+ (tinypgp-nymserver-i-enable)
+ (list (tinypgp-nymserver-ask))))
+ (tinypgp-nymserver-sendmail 'paranoid alias (interactive-p)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-nymserver-vacation (alias)
+ "Toggle vacation setting. ALIAS."
+ (interactive
+ (progn
+ (tinypgp-nymserver-i-enable)
+ (list (tinypgp-nymserver-ask))))
+ (tinypgp-nymserver-sendmail 'vacation alias (interactive-p)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-nymserver-noarchive (alias)
+ "Toggle USENET achive setting. ALIAS."
+ (interactive
+ (progn
+ (tinypgp-nymserver-i-enable)
+ (list (tinypgp-nymserver-ask))))
+ (tinypgp-nymserver-sendmail 'noarchive alias (interactive-p)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-nymserver-setnon (alias)
+ "Toggle anNNN/naNNN mode when you get private mail. ALIAS."
+ (interactive
+ (progn
+ (tinypgp-nymserver-i-enable)
+ (list (tinypgp-nymserver-ask))))
+ (tinypgp-nymserver-sendmail 'setnon alias (interactive-p)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-nymserver-newplan (alias file)
+ "ALIAS. Upload plan FILE. If file is 'remove' then remove plan."
+ (interactive
+ (progn
+ (tinypgp-nymserver-i-enable)
+ (list
+ (tinypgp-nymserver-ask)
+ (if (y-or-n-p "y = upload .plan, n = remove plan" )
+ (call-interactively
+ '(lambda (arg) (interactive "fNymserver plan file: ") arg))
+ "remove"))))
+ (tinypgp-nymserver-sendmail 'newplan alias (interactive-p) file))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-nymserver-newsig (alias file)
+ "ALIAS. Upload signature FILE. If file is 'remove' then remove signature."
+ (interactive
+ (progn
+ (tinypgp-nymserver-i-enable)
+ (list
+ (tinypgp-nymserver-ask)
+ (if (y-or-n-p "y = upload .signature, n = remove plan" )
+ (call-interactively
+ '(lambda (arg) (interactive "fNymserver signature file: ") arg))
+ "remove"))))
+ (tinypgp-nymserver-sendmail 'newsig alias (interactive-p) file))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-nymserver-newaddress (alias new)
+ "ALIAS. Change your mailbox address.
+You must be mailing from the NEW ADDRESS currently."
+ (interactive
+ (progn
+ (tinypgp-nymserver-i-enable)
+ (list
+ (tinypgp-nymserver-ask)
+ (read-from-minibuffer
+ "[You must be in NEW site now] Your old address: "))))
+ (if (ti::nil-p new) ;User may have pressed ENTER...
+ (error "TinyPgp: No address."))
+ (tinypgp-nymserver-sendmail 'newaddress alias (interactive-p) new))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-nymserver-newalias (alias name)
+ "ALIAS NAME. Change you anNNN@ account to NEWALIAS@."
+ (interactive
+ (progn
+ (tinypgp-nymserver-i-enable)
+ (list
+ (tinypgp-nymserver-ask)
+ (read-from-minibuffer
+ "newalias request; vanity alias [word]: "))))
+ (if (or (< (length name) 3)
+ (> (length name) 15))
+ (error "TinyPgp: Invalid string size [3-15]; %s has %d characters."
+ name (length name)))
+ (tinypgp-nymserver-sendmail 'newalias alias (interactive-p) name))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-nymserver-nickname (alias name)
+ "ALIAS. Change you nick NAME that appears in anon post From field."
+ (interactive
+ (progn
+ (tinypgp-nymserver-i-enable)
+ (list
+ (tinypgp-nymserver-ask)
+ (read-from-minibuffer "Nickname [string or word 'remove']: "))))
+ (tinypgp-nymserver-sendmail 'nick alias (interactive-p) name))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-nymserver-newpassword (alias password)
+ "ALIAS. Change your PASSWORD."
+ (interactive
+ (progn
+ (tinypgp-nymserver-i-enable)
+ (list
+ (tinypgp-nymserver-ask)
+ (ti::compat-read-password "New nymserver password: "))))
+ (tinypgp-nymserver-sendmail 'newpassword alias nil password)
+ (ti::read-char-safe-until
+ "Update your password _now_ to tinypgp-:nymserver-account-table"))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-nymserver-pgp-upload (alias &optional remove)
+ "ALIAS. Upload or REMOVE pgp key. Before you call this commaand note:
+
+o You must have created the PGP public key for your Nymserver account.
+o You must have defined the `tinypgp-:nymserver-account-table'; the key
+ uploaded must have the email address.
+o If you change your vanity name, remember to start all over(New key,
+ and update table)"
+ (interactive
+ (progn
+ (tinypgp-nymserver-i-enable)
+ (list
+ (tinypgp-nymserver-ask)
+ (not (y-or-n-p
+ "Y = upload your PGP key to Anon account [N = remove] ")))))
+ (tinypgp-nymserver-sendmail 'newpgp alias (interactive-p) remove))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-nymserver-pgp-encrypt (alias)
+ "Toggle receiving PGP encryped mail. ALIAS.
+You have to upload PGP key first with \\[tinypgp-nymserver-pgp-upload]"
+ (interactive
+ (progn
+ (tinypgp-nymserver-i-enable)
+ (list (tinypgp-nymserver-ask))))
+ (tinypgp-nymserver-sendmail 'pgpencrypt alias (interactive-p)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-nymserver-pgp-sign (alias)
+ "Turn on/off PGP siging. ALIAS."
+ (interactive
+ (progn
+ (tinypgp-nymserver-i-enable)
+ (list (tinypgp-nymserver-ask))))
+ (tinypgp-nymserver-sendmail 'pgpsign alias (interactive-p)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-nymserver-pgp-sendmix (alias)
+ "Turn on/off Mixmaster support. ALIAS."
+ (interactive
+ (progn
+ (tinypgp-nymserver-i-enable)
+ (list (tinypgp-nymserver-ask))))
+ (tinypgp-nymserver-sendmail 'sendmix alias (interactive-p)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-nymserver-help-i-args (arg)
+ "Ask args for `tinypgp-nymserver-help' using ARG."
+ (list
+ (tinypgp-nymserver-ask)
+ arg))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-nymserver-help-verbose (&optional arg)
+ "Call `tinypgp-nymserver-help' as interactive would with ARG."
+ (let* ((a (tinypgp-nymserver-help-i-args arg)))
+ (tinypgp-nymserver-help (nth 0 a) (nth 1 a))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-nymserver-help (alias &optional mail-req verb)
+ "Print help or send the help request via mail.
+
+Input:
+ ALIAS ,from where to ask the help file.
+ MAIL-REQ ,send mail request [current-prefix-arg]
+ VERB ,verbose messages"
+ (interactive (tinypgp-nymserver-help-i-args current-prefix-arg))
+ (let* ((elt (assoc alias tinypgp-:nymserver-account-table))
+ (file (or (nth 5 elt) "_#_#")))
+ (ti::verb)
+ (cond
+ (mail-req
+ (tinypgp-nymserver-sendmail 'help alias verb))
+ (t
+ (cond
+ ((file-exists-p file)
+ (pop-to-buffer (find-file-noselect file)))
+
+ ((not (file-exists-p file))
+ (error "TinyPgp: File not exists %s" file))
+
+ (t
+ (message "No HELP file defied in tinypgp-:nymserver-account-table")
+ (sit-for 2)
+ (message " You get the help file, when you create account.")))))))
+
+;;}}}
+
+;;{{{ misc: ask
+
+;;; ........................................................... &r-ask ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-ask-reply-block-remailer (&optional msg)
+ "Ask which remailer's reply block to use. Return remailer.
+References:
+ `tinypgp-:r-reply-block-tab.le'"
+ (or tinypgp-:r-reply-block-table
+ (error "TinyPgp tinypgp-:r-reply-block-table is empty."))
+ (completing-read
+ (or msg "Select Reply block of remailer: ")
+ (ti::list-to-assoc-menu (mapcar 'car tinypgp-:r-reply-block-table))
+ nil
+ 'match))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-ask-remailer (&optional msg)
+ "Select REMAILER with optional MSG."
+ (let* (list)
+ (tinypgp-r-init-maybe)
+ (unless (setq list
+ (ti::list-to-assoc-menu
+ (mapcar 'car tinypgp-:r-host-table)))
+ (error "TinyPgp Internal error, tinypgp-:r-host-table is nil."))
+ (completing-read
+ (or msg "Select remailer: ")
+ list
+ nil 'match
+ nil
+ 'tinypgp-:r-history)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-ask-email-keyserver (&optional msg)
+ "Ask which email keyserver to use using MSG."
+ (tinypgp-alias2name
+ (completing-read
+ (or msg "Email key server: ")
+ (ti::list-to-assoc-menu (mapcar 'car tinypgp-:keyserver-mail-table))
+ nil
+ 'match-it
+ (car (car tinypgp-:keyserver-mail-table)))
+ tinypgp-:keyserver-mail-table))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-ask-http-keyserver ()
+ "Ask which http keyserver to use. Return keyserver elt."
+ (let* (elt)
+ (setq
+ elt
+ (assoc
+ (completing-read
+ "Key server: "
+ (ti::list-to-assoc-menu (mapcar 'car tinypgp-:keyserver-http-table))
+ nil 'match
+ (or (tinypgp-hash 'keyserver 'get 'used nil 'global) ;; last used
+ (car (car tinypgp-:keyserver-http-table))) ;; or first in list
+ 'tinypgp-:history-http-keyserver)
+ tinypgp-:keyserver-http-table))
+
+ ;; Remember the last used keyserver
+ ;;
+ (tinypgp-hash 'keyserver 'put 'used (car-safe elt) 'global)
+ (tinypgp-hash 'keyserver 'put 'elt elt 'global)
+ elt))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-ask-remail-args (&optional msg)
+ "Ask remail arguments for REMAILER with crypt key ask MSG.
+Return:
+ '(remailer-elt latent key)"
+ (let (remailer
+ remailer-elt
+ latent
+ key)
+
+ (setq remailer (tinypgp-ask-remailer))
+ (setq remailer-elt (tinypgp-r-elt-remailer remailer))
+
+ (if (string-match "ek" (nth 2 remailer-elt)) ;Supports this ?
+ (if (ti::nil-p
+ (setq
+ key (read-from-minibuffer
+ "Use crypt key: ")))
+ (setq key nil)))
+
+ (if (string-match "latent" (nth 2 remailer-elt))
+ (cond
+ ((ti::nil-p
+ (setq
+ latent (read-from-minibuffer
+ "Latent time e.g. +0:00r [empty = no latent]: ")))
+ (setq latent nil))
+ (t ;Some checkings
+ (setq latent (ti::string-remove-whitespace latent))
+ (or (string-match "^\\+[0-9]:[0-9][0-9]r?$" latent)
+ (error "TinyPgp: Invalid latent time format '%s'" latent)))))
+ (list remailer-elt latent key)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-i-args-decrypt ()
+ "Ask suitable decrypt password and return decrypt type.
+This function tries to determine if it should ask conventional password of
+pgp password by looking at the pgp stream.
+
+Return:
+ string decrypt-type"
+ (let* ((fid "tinypgp-i-args-decrypt: ")
+ (c-point (ti::mail-pgp-encrypted-p))
+ (tlist (ti::list-to-assoc-menu '("pgp" "base64" "conventional")))
+ (type "pgp")
+ var-sym)
+ (tinypgpd fid c-point)
+
+ (unless c-point
+ ;; couldn't find "Encrypted: PGP" tag, ask type then
+ ;;
+ (setq type
+ (and tinypgp-:pgp-encrypted-p-function
+ (funcall tinypgp-:pgp-encrypted-p-function)))
+
+ ;; See if the type was set to sensible value. Ask from
+ ;; user if it wasn't
+ ;;
+ (if (or (not (stringp type))
+ (not (assoc type tlist)))
+ (setq type (completing-read
+ "Decrypt type: " tlist nil 'match "pgp"))))
+
+ (cond
+ ((string= type "conventional")
+ (setq var-sym type)
+ (ti::vector-table-get tinypgp-:hash-password var-sym 'allocate)
+ (ti::vector-table-property
+ tinypgp-:hash-password var-sym 'password nil 'force)
+ (tinypgp-password-set nil 'conventional))
+
+ ((string= type "pgp")
+ (tinypgp-save-state-macro
+ (tinypgp-user-change-macro
+ ;; Now We are right user to ask the PGP pass phrase
+ ;;
+ (tinypgp-ask-pass-phrase-decrypt)))))
+ type))
+
+;;}}}
+;;{{{ PGP entry i-macros
+
+;;; ........................................................ &i-macros ...
+;;; functions that are normally used in (interactive) spec.
+;;;
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-i-args-read-email
+ (&optional barf-if-not-email-buffer prompt history-sym)
+ "Read email addresses from buffer or ask from use with completion.
+
+Input:
+
+ BARF-IF-NOT-EMAIL-BUFFER as name says
+ PROMPT display this string
+ HISTORY-SYM use this history"
+ (let* ((fid "tinypgp-i-args-read-email:")
+ to-field
+ ret
+ init
+ tmp)
+
+ (tinypgpd fid "in: " barf-if-not-email-buffer prompt)
+
+ (if (and barf-if-not-email-buffer
+ (not (ti::mail-mail-p)))
+ (error "TinyPgp: This is not an mail buffer."))
+
+ (or tinypgp-:pgp-email-list-completions ;make sure this exist
+ (tinypgp-update-mail-abbrevs))
+
+ (cond
+ ((and (string-match "news\\|message\\|mail" (symbol-name major-mode))
+ (not (ti::nil-p
+ (mail-fetch-field "To")))) ;Just check this
+
+ (setq to-field (ti::mail-get-all-email-addresses
+ nil
+ tinypgp-:pgp-email-abbrev-list))
+
+ (tinypgpd fid "cond1: to-field" to-field)
+
+ ;; Slim down "Mr. ABC <abc@com>" --> "abc@com"
+ ;;
+ (setq to-field
+ (mapcar
+ (function
+ (lambda (x)
+ (ti::string-remove-whitespace
+ (ti::remove-properties (tinypgp-email-or-string x)))))
+ to-field))
+
+ (setq ret to-field)
+
+ ;; Confirm only if there is multiple recipients
+ ;; 07.03.97 I have disbled the confimation with 'and'.
+ ;;
+ (if (> (length to-field) 1)
+ (and
+ nil
+ (ti::read-char-safe-until
+ (format "%d email recipients found. Press to continue."
+ (length to-field))))
+ ;; See if point in on line that has email
+ ;;
+ (when
+ (setq
+ tmp
+ (car-safe (ti::mail-email-from-string
+ (ti::remove-properties (ti::read-current-line)))))
+ (push tmp to-field)
+ (setq tmp
+ (completing-read
+ "You were on email line, use it? [empty=skip]: "
+ (ti::list-to-assoc-menu to-field) nil nil
+ tmp))
+
+ (if (not (ti::nil-p tmp))
+ (setq ret tmp)))))
+
+ (t
+ (setq init
+ (ti::string-remove-whitespace
+ (or (ti::mail-get-field "Request-Remailing-To" 'any)
+ (ti::mail-get-field "Anon-To" 'any)
+ tinypgp-:user-now)))
+
+ (tinypgpd fid "cond t: ")
+ (setq
+ ret
+ (completing-read
+ (or prompt "User: ")
+ tinypgp-:pgp-email-list-completions
+ nil nil
+ init
+ (or history-sym
+ 'tinypgp-:history-email)))
+ (setq ret (tinypgp-email-or-string ret))
+ (if ret
+ (setq ret (ti::string-remove-whitespace ret)))))
+
+ (tinypgpd fid "hook call: " ret)
+
+ (setq ret (tinypgp-key-id-conversion ret))
+
+ (tinypgpd fid "RET: " ret)
+
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-i-args-pass-phrase (&optional msg)
+ "The MSG defaults to asking signing pass phrase."
+ (tinypgp-password-set
+ (format "[%s] %s"
+ (or tinypgp-:user-now
+ (error "TinyPgp Internal error: current pgp user unknown."))
+ (or msg
+ "Sign pass phrase: "))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-ask-pass-phrase-decrypt ()
+ "See `tinypgp-i-args-pass-phrase'."
+ (tinypgp-i-args-pass-phrase "Decrypt pass phrase: "))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-i-args-reg-email (&optional prompt barf-not-mail-buffer)
+ "Read region + String. PROMPT BARF-NOT-MAIL-BUFFER."
+ (ti::i-macro-region-body
+ (tinypgp-i-args-read-email barf-not-mail-buffer)))
+
+;;}}}
+;;{{{ PGP entry command macros, email,exe
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinypgp-cmd-macro-email 'lisp-indent-function 1)
+(defmacro tinypgp-cmd-macro-email (message &rest body)
+ "(MESSAGE &rest BODY). Select email body or whole buffer.
+
+You must locally define variable `beg' `end' in let statement
+before using this macro."
+ (`
+ (cond
+ ((or (ti::mail-text-start)
+ (progn
+ ;; The region is defined beforehand, now.
+ ;;
+ (setq beg (point-min) end (point-max))
+ (y-or-n-p
+ (format "Not a mail buffer, %s whole buffer? "
+ (or (, message) "Use")))))
+ (,@ body)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinypgp-cmd-macro 'lisp-indent-function 3)
+(defmacro tinypgp-cmd-macro
+ (cmd user password &optional msg reg options mode-specific &rest body)
+ "Common command macro for all PGP commands.
+Macro, used to contruct user command. CMD and USER must be
+variables. You must bound 'beg' and 'end' variables before calling this
+macro.
+
+Args:
+
+ (cmd user password &optional msg reg options &rest body mode-specific)
+
+Input:
+
+ CMD USER PASSWORD parameters. CMD is symbol for logical command
+
+ MSG message shown to user before initiating command
+
+ REG non-nil = put results to register instead
+ of replacing the region with pgp output.
+
+ OPTIONS extra switched that are added to the pgp command.
+
+ MODE-SPECIFIC If non-nil, Do not run mode specific actions.
+
+ BODY code to execute when real pgp command is known.
+ If there is no body, then execute the command
+ that is found from table.
+
+ Body must assign the result of command to
+ macro variable 'ReS'
+
+ The default command executed in macro is, where
+ Rcmd is the real shell command. However the
+ command can still contains macros that start
+ like #MACRONAME.
+
+ (tinypgp-binary-do-command-region Rcmd beg end msg (, reg))
+
+Hooks:
+ `tinypgp-before-do-cmd-region-hook'
+ `tinypgp-after-do-cmd-region-hook'"
+ (`
+ (let* ((FiD "tinypgp-cmd-macro: ")
+ (Rcmd (tinypgp-binary-get-cmd (, cmd) (, options))) ;Real command
+ (enter-buffer (current-buffer))
+ (msg (if (or verb (interactive-p))
+ (, msg)))
+ edit-buffer
+ ReS
+ beg-mark
+ end-mark)
+
+ ;; VM: edit mode changes the current buffer
+ ;; Gnus: sometimes we must clone the buffer (nntp doesn't allow edit)
+
+ (unless (, mode-specific)
+ (tinypgp-mode-specific-control-before
+ (, cmd) (, user) msg (, reg)))
+
+ (tinypgpd FiD "in:" enter-buffer
+ beg end
+ "CMD" (, cmd)
+ "USER" (, user)
+ "pass" (, password)
+ msg
+ "register" (, reg)
+ "MODE-SPEC" (, mode-specific))
+
+ (setq edit-buffer (current-buffer))
+ (tinypgpd FiD "EDIT-BUFFER" major-mode edit-buffer)
+
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. . setting markers ..
+ (cond
+ ((eq (, cmd) 'decrypt)
+ (setq ReS (save-excursion (ti::pmin) (ti::mail-pgp-block-area 'msg)))
+ (goto-char (or
+ ;; This checks "encrypted: PGP" tag.
+ (ti::mail-pgp-encrypted-p)
+ ;; Nope, there was none, use this.
+ ;;
+ (car ReS)))
+
+ (setq beg-mark (point-marker))
+ (goto-char (cdr ReS)) (setq end-mark (point-marker))
+ (tinypgpd FiD "DECRYPT marks" beg-mark end-mark)
+ (setq ReS nil))
+ (t
+ ;; If user hasn't set END variable, we suppose
+ ;; rest of the buffer. It is important that END variable
+ ;; gets set here when MAIL message is handled, because
+ ;; only now the message is trimmed and whitespaces
+ ;; removed
+ ;;
+ (if (null end)
+ (setq end (point-max)))
+
+ (if (null beg)
+ (setq beg (if (ti::mail-mail-p)
+ (ti::mail-text-start)
+ (point-min))))
+
+ ;; We use markers, because hook is called and it
+ ;; may change the buffer content. The area must still be
+ ;; available for us after changes.
+ ;;
+ (save-excursion
+ (goto-char beg) (setq beg-mark (point-marker))
+ (goto-char end) (setq end-mark (point-marker)))))
+
+ (tinypgpd FiD "BEG END" beg end "MARKER-BEGIN" beg-mark end-mark
+ (current-buffer))
+ (tinypgpd FiD (buffer-substring beg-mark end-mark))
+
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. . user funcall ..
+
+ (if tinypgp-:cmd-macro-before-hook
+ (run-hook-with-args-until-success 'tinypgp-:cmd-macro-before-hook
+ (, cmd) (, user) msg (, reg)))
+
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. checking markers ..
+
+ (if (or (null (setq beg (marker-position beg-mark)))
+ (null (setq end (marker-position end-mark)))
+ (eq beg end)) ;This is error too.
+ (error "\
+TinyPgp: tinypgp-:cmd-macro-before-hook modified text too much."))
+
+ (setq beg-mark nil end-mark nil) ;kill the markers
+
+ (if ReS (setq ReS nil)) ;NoOp XE ByteComp silencer
+
+ (if (null (, user))
+ (setq (, user) (user-login-name)))
+
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. . make command ..
+
+ (setq Rcmd (tinypgp-cmd-compose Rcmd (, user) ))
+
+ (tinypgpd FiD "vars:" "USER" (, user)
+ "CUR-BUF" (current-buffer) beg end
+ "CMD" Rcmd
+ "BODY-NIL" (equal 'nil (quote (, body))))
+
+;;; (ti::d! "Doing COMMAND" beg end (current-buffer))
+
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. . DO ACTION ..
+ ;; Check if BODY is omitted
+
+ (cond
+ ((equal 'nil (quote (, body)))
+ (setq
+ ReS
+ (if (or (tinypgp-backend-pgp2-p)
+ (tinypgp-backend-gpg-p))
+ (tinypgp-binary-do-command-region
+ Rcmd
+ beg
+ end
+ (tinypgp-hash 'mode-specific 'get 'buffer-edit nil 'global)
+ msg
+ (, reg))
+ (tinypgp-binary-do-command-region-with-expect
+ Rcmd
+ beg end
+ (tinypgp-hash 'mode-specific 'get 'buffer-edit nil 'global)
+ msg
+ (, reg)))))
+
+ (t
+ (,@ body)))
+
+ (tinypgp-binary-header-field-fix (, cmd) 'force)
+
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. results ..
+;;; (setq PTR ReS)
+
+ (when (, reg) ;Save results
+ (set-register
+ tinypgp-:register
+ (tinypgp-binary-get-result-as-string ReS)))
+
+ (tinypgpd FiD "cmd-macro done. calling mode specific...")
+
+ (if tinypgp-:cmd-macro-after-hook
+ (run-hook-with-args-until-success 'tinypgp-:cmd-macro-after-hook
+ (, cmd) (, user) msg (, reg)))
+
+ (tinypgpd "cmd-macro out:")
+ ReS)))
+
+;;}}}
+;;{{{ PGP exe command compose
+
+;;; ................................................. &command-compose ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-cmd-compose (cmd user &optional password args)
+ "Compose PGP command.
+
+Input:
+
+ CMD list of strings which may contain #TAGS
+ '(binary base-command-set options)
+ USER
+ PASSWORD
+ ARGS"
+ (let* ((cat (if (eq (tinypgp-backend-type) 'win32)
+ "type "
+ "cat "))
+ (binary-type (tinypgp-backend-type))
+ (binary (car cmd))
+ tmp)
+
+ (setq cmd (format "%s %s" (nth 1 cmd) (or (nth 2 cmd) "")))
+
+ ;; Decide where to put the binary itself. Is there a token #bin
+ ;; where to put it?
+
+ (cond
+ ((string-match "#bin" cmd)
+ (setq cmd (ti::replace-match 0 binary cmd)))
+ (t
+ (setq cmd (concat binary " " cmd))))
+
+ (if tinypgp-:pgp-command-compose-function
+ (setq cmd (funcall tinypgp-:pgp-command-compose-function cmd)))
+
+ (tinypgpd "[cmd-compose] in: USER"
+ tinypgp-:user-now "PRING" tinypgp-:pubring-now)
+
+ (tinypgpd "[cmd-compose] in: cmd"
+ cmd "USER" user "PASS" password )
+
+ (unless (stringp tinypgp-:pubring-now)
+ (error "TinyPgp: no current pubring? tinypgp-:pubring-now"))
+
+ (unless (file-exists-p tinypgp-:pubring-now)
+ (error "TinyPgp: %s (tinypgp-:pubring-now) does not exist."))
+
+ (tinypgpd "[cmd-compose] in2: global user, pring"
+ tinypgp-:user-now tinypgp-:pubring-now )
+
+ (unless (stringp tinypgp-:user-now) ;; make sure this variable exists
+ (error "TinyPgp: user is unknown."))
+
+ (when (string-match "#PUBRING" cmd)
+ (setq cmd (ti::replace-match
+ 0
+ (concat "+pubring="
+ (tinypgp-expand-file-name
+ tinypgp-:pubring-now binary-type)
+ " ")
+ cmd)))
+
+ (when (string-match "#PGP-USER" cmd)
+ (setq cmd (ti::replace-match
+ 0 (concat
+ "-u \""
+ ;; Always treat this as list
+ (ti::list-to-string (ti::list-make tinypgp-:user-now))
+ "\" ")
+ cmd)))
+
+ (when (and user
+ (string-match "#USER" cmd))
+
+ ;; With PGP 2: -u "user"
+ ;; With pgp 5: -u user
+
+ (setq tmp (if (or (tinypgp-backend-pgp2-p)
+ (tinypgp-backend-gpg-p))
+ "\""
+ ""))
+ (setq cmd (ti::replace-match
+ 0 (concat "-u " tmp
+ ;; Always treat this as list
+ (ti::list-to-string (ti::list-make user ))
+ tmp " ")
+ cmd)))
+
+ (when (string-match "#OUT-FILE" cmd)
+ (setq cmd (ti::replace-match
+ 0
+ (concat "-o "
+ (tinypgp-expand-file-name
+ tinypgp-:file-output binary-type)
+ " ")
+ cmd)))
+
+ (when (and user
+ (string-match "#MUSER" cmd))
+ (cond
+ ((tinypgp-backend-pgp2-p)
+ (let ((type (save-match-data (tinypgp-binary-get-version 'symbol))))
+ (cond
+ ((eq type 'international)
+ (setq cmd
+ (ti::replace-match
+ 0
+ (concat
+ "-@"
+ (tinypgp-expand-file-name
+ tinypgp-:file-user-list binary-type)
+ " ")
+ cmd)))
+ (t ;doesn't know -@ switch
+ (setq cmd
+ (ti::replace-match
+ 0
+ (format "`%s %s`"
+ cat
+ (tinypgp-expand-file-name
+ tinypgp-:file-user-list binary-type))
+ cmd))))
+ (tinypgp-file-control 'users-write user)))
+ (t ;; pgp 5.x
+ (setq tmp "")
+ (dolist (elt user)
+ (setq tmp (concat tmp " -r " elt)))
+
+ (setq cmd (ti::replace-match 0 tmp cmd))
+ (tinypgpd "[cmd-compose] #MUSER" user cmd))))
+
+ ;; ........................................................... other ...
+ ;; These are called from tinypgp-binary-do-command-region when parameters
+ ;; are better known.
+
+ (when (and args (string-match "#PIPE" cmd))
+ ;; REST ARGS 1 = pipe file
+ ;;
+ (setq cmd (ti::replace-match
+ 0
+ (concat cat
+ (tinypgp-expand-file-name
+ (or (nth 0 args)
+ tinypgp-:file-source)
+ binary-type)
+ " | ")
+ cmd)))
+
+ (when (string-match "#SOURCE-FILE" cmd)
+ (let ((file (or (nth 0 args)
+ tinypgp-:file-source)))
+ ;; ARGS = filename
+ ;;
+ (setq cmd (ti::replace-match
+ 0
+ (concat " "
+ (tinypgp-expand-file-name file binary-type)
+ " ")
+ cmd))))
+
+ ;; .......................................................... password ...
+
+ (when (string-match "#password" cmd)
+ (when (ti::nil-p password)
+ (setq password (tinypgp-password-get)))
+
+ (when (null password)
+ (error
+ "TinyPgp Internal error: Command composing failed. No passwd."))
+
+ (when (tinypgp-backend-gpg-p)
+ (setq cmd (ti::replace-match
+ 0
+ (concat "\"" password "\" | ") cmd)))
+
+ (when (tinypgp-backend-pgp2-p)
+ (if (or nil ;Enabled now!
+ (null tinypgp-:password-protection))
+ (setq cmd (ti::replace-match
+ 0
+ (concat "-z\"" password "\" ") cmd))
+
+ (setq cmd (ti::replace-match 0 nil cmd))
+ (tinypgp-file-control 'password-write password)
+
+ ;; PGP gets the password from file descriptor 3. This way
+ ;; 'ps' listing doesn't show the password like it does
+ ;; with -z option
+ ;;
+ (setq cmd (format (concat "PGPPASSFD=3; export PGPPASSFD; "
+ " #PIPE %s 3< %s ")
+ cmd
+ (tinypgp-expand-file-name
+ tinypgp-:file-password binary-type))))))
+
+ (tinypgpd "[cmd-compose] out: "
+ cmd tinypgp-:pgp-command-compose-function )
+
+ cmd))
+
+;;}}}
+;;{{{ PGP exe result, general, macros, error
+
+;;; ........................................................ &pgp-core ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-binary-header-field-set (field value)
+ "Set FIELD with VALUE in PGP Signature header."
+ (ti::pmax)
+ (when (or (re-search-backward (ti::mail-pgp-signature-begin-line) nil t)
+ (re-search-backward (ti::mail-pgp-msg-begin-line) nil t))
+ (tinypgpd "tinypgp-binary-header-field-set: " field value)
+ (cond
+ ((re-search-forward field nil t)
+ (delete-region (point) (line-end-position))
+ (insert " " value)
+ (forward-line 1))
+ ((re-search-forward "^[ \t]*$") ;Must exist
+ (insert field " " value "\n")))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-binary-header-field-fix (command &optional force)
+ "Change PGP headers for COMMAND. Optionally FORCE in spite of backend.
+In Windows NT not all the command line options cannot passed
+with the call, so we patch resulte manually."
+ (when (and (or force
+ (ti::win32-p)
+ (not (tinypgp-backend-pgp2-p)))
+ (ti::re-search-check (ti::mail-pgp-signature-begin-line)))
+ (save-excursion
+ (let* ((comment
+ (get 'tinypgp-:pgp-binary-interactive-option 'comment)))
+ (when (eq command 'sign)
+ ;; (tinypgp-binary-header-field-set "Charset:" tinypgp-:pgp-binary-charset)
+ (if comment
+ (tinypgp-binary-header-field-set "Comment:" comment)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinypgp-excute-in-tmp 'lisp-indent-function 2)
+(defmacro tinypgp-excute-in-tmp (beg end &rest body)
+ "Copy region BEG END from current buffer and execute BODY.
+Uses buffer `tinypgp-:buffer-tmp-shell'."
+ (`
+ (let* ((ob (current-buffer))
+ (tmp (tinypgp-ti::temp-buffer 'shell)))
+ (with-current-buffer tmp
+ (insert-buffer-substring ob (, beg) (, end))
+ (tinypgp-x-headers-deinstall)
+ (,@ body)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypgp-binary1-command-table (cmd)
+ "Return right command table"
+ (cond
+ ((eq 'pgp2 (tinypgp-backend-now))
+ (assq cmd tinypgp-:pgp-command-table))
+ ((eq 'gpg (tinypgp-backend-now))
+ (assq cmd tinypgp-:gpg-command-table))
+ (t
+ (assq cmd tinypgp-:pgp-command-table5))))
+
+;;; ----------------------------------------------------------------------
+;;; http://www.pgpi.org/products/pgp/versions/freeware/
+;;; => Unix => PGP 2.6.3i => Download PGP 2.6.3i
+;;; => Download PGP 2.6.3i source code
+;;;
+;;; Win32/Cygwin compile command:
+;;;
+;;; cd /tmp
+;;; gzip -dc pgp263is.tar.gz | tar -xvf
+;;; tar -xvf pgp263ii.tar
+;;; cd src/
+;;; make -f makefile CFLAGS='-DUNIX -DPORTABLE' CC=gcc linux
+;;;
+(defun tinypgp-binary-path-set (&optional verb)
+ "Define backend properties in variable `tinypgp-:pgp-binary'.
+
+This function stores the executable paths in variable
+`tinypgp-:pgp-binary'."
+ (interactive)
+ (let ((fid "tinypgp-binary-path-set: ")
+ (list '("pgpk" "pgpv" "pgpe" "pgps"))
+ (ext (if (ti::win32-p)
+ ".exe"
+ ""))
+ (cygwin-root (ti::win32-cygwin-p))
+ (search (delete "." exec-path))
+ (count 0)
+ exe
+ str
+ path)
+
+ (ti::verb)
+
+ ;; Clear all first
+
+ (dolist (sym '(pgp-set
+ pgp
+ pgp2-type
+ pgp5-type
+ gpg-type
+ gpg
+ pgpk pgpv pgpo pgpe))
+ (put 'tinypgp-:pgp-binary sym nil))
+
+ ;; ......................................................... 2.6.x ...
+
+ (cond
+ ((setq path (ti::file-get-load-path (concat "pgp" ext) search 'all))
+ (dolist (bin (ti::list-make path))
+
+ ;; Is this really 2.6.x? The PGP 5.x kit may contain binary
+ ;; "pgp" too
+
+ (setq str (ti::mail-pgp-exe-version-string bin))
+ (tinypgpd fid "Verifying 2.6" bin str)
+
+ (when (stringp str)
+ (cond
+ ((string-match "2\\.6" str)
+ (put 'tinypgp-:pgp-binary 'pgp bin)
+ (put 'tinypgp-:pgp-binary 'pgp-backends '(pgp2))
+
+ ;; It is impossible to say if the pgp.exe is Cygwin
+ ;; compiled or pure DOS version, because "pgp -h" gives
+ ;; identical message.
+ ;;
+ ;; The cygwin status is needed, because it affects
+ ;; how file names are passed.
+ ;;
+ ;; It is supposed that "cygwin version" WILL reside under
+ ;; Cygwin hierarchy. This test fails if user uses
+ ;; mount points that refer to external disks
+
+ (let* ((cygwin-p (and cygwin-root
+ (string-match
+ (ti::file-path-to-unix cygwin-root)
+ (ti::file-path-to-unix bin))))
+ (type (if (and (ti::win32-p)
+ (not cygwin-p))
+ 'win32
+ 'unix)))
+ (put 'tinypgp-:pgp-binary 'pgp2-type type))
+ (return))
+ (t
+ (message "TinyPgp: `pgp' found but that's not 2.6 version"))))))
+
+ (verb
+ (message "Tinypgp: Hm, no pgp 2.x binary found.")
+ (sit-for 1)))
+
+ ;; ........................................................... GPG ...
+
+ (cond
+ ((setq path (ti::file-get-load-path (concat "gpg" ext) search 'all))
+ (dolist (bin (ti::list-make path))
+
+ (setq str (ti::mail-pgp-exe-version-string bin))
+ (tinypgpd fid "Verifying GPG 1.x" bin str)
+
+ (when (stringp str)
+ (cond
+ ((string-match "1\\." str)
+ (put 'tinypgp-:pgp-binary 'gpg bin)
+ (put 'tinypgp-:pgp-binary
+ 'pgp-backends
+ (append '(gpg) (tinypgp-backend-list)))
+
+ ;; It is impossible to say if the gpg.exe is Cygwin
+ ;; compiled or pure DOS version, because "pgp -h" gives
+ ;; identical message.
+
+ (let* ((cygwin-p (and cygwin-root
+ (string-match
+ (ti::file-path-to-unix cygwin-root)
+ (ti::file-path-to-unix bin))))
+ (type (if (and (ti::win32-p)
+ (not cygwin-p))
+ 'win32
+ 'unix)))
+ (put 'tinypgp-:pgp-binary 'gpg-type type))
+ (return))
+ (t
+ (message "TinyPgp: `gpg' found but that's not 1.x version"))))))
+
+ (verb
+ (message "Tinypgp: Hm, no gpg 1.x binary found.")
+ (sit-for 1)))
+
+ ;; ........................................................... 5.x ...
+
+ (dolist (bin list)
+ (setq exe (concat bin ext)
+ path (ti::file-get-load-path exe search 'all))
+ (cond
+ ((null path)
+ (when verb
+ (message "TinyPgp: Can't find PGP[56] executable %s:%s" exe search))
+ (tinypgpd fid "Verifying 5.x FAILED" exe path))
+ (path
+ (dolist (binary (ti::list-make path))
+
+ ;; #todo: what should be done to multiple occurrances of BIN?
+
+ (tinypgpd fid "Verifying 5.x" binary)
+ (incf count)
+ (put 'tinypgp-:pgp-binary (intern bin) binary)))))
+
+ ;; if all pgp 5.x executables were found; then installation went okay
+
+ (when (eq count 4)
+ (setq list (tinypgp-backend-list))
+ (add-to-list 'list 'pgp5)
+ (put 'tinypgp-:pgp-binary 'pgp-backends list))
+
+ (tinypgpd
+ fid
+ "count" count
+ "extension" ext
+ "pgp-set" (tinypgp-backend-list)
+ "pgp" (get 'tinypgp-:pgp-binary 'pgp)
+ "pgpk" (get 'tinypgp-:pgp-binary 'pgpk))
+
+ (if verb
+ (message "Tinypgp: found %s"
+ (or
+ (and (tinypgp-backend-list)
+ (mapconcat
+ (function (lambda (elt) (symbol-name elt)))
+ (tinypgp-backend-list)
+ " "))
+ "(nothing)")))
+
+ (tinypgp-backend-list)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-backend-select (backend &optional verb)
+ "Select BACKEND 'pgp2 or 'pgp5 executables for use. VERB."
+ (interactive
+ (let* ((list (mapcar
+ (function
+ (lambda (elt)
+ (cons
+ (symbol-name elt)
+ elt)))
+ (tinypgp-backend-list)))
+ ret)
+ (setq ret (completing-read "Select pgp: " list nil 'match))
+ (list (cdr (assoc ret list)))))
+
+ (let* ((fid "tinypgp-backend-select: ")
+ secring
+ pubring)
+
+ (ti::verb)
+
+ ;; Check that arg is part of known list
+ (unless (member backend (tinypgp-backend-list))
+ (error
+ "\
+TinyPgp: Feature %s is not configured or available: Call tinypgp-binary-path-set"
+ backend))
+
+ (put 'tinypgp-:pgp-binary 'pgp-now backend)
+
+ (setq secring (tinypgp-secring-file))
+ (unless (file-exists-p secring)
+ (error "\
+TinyPgp: Secring %s does not exist. See tinypgp-:file-secring %s" secring))
+
+ (setq pubring (tinypgp-pubring-default))
+ (unless (file-exists-p pubring)
+ (error
+ "\
+TinyPgp: Can't find pubring %s. Check tinypgp-:pubring-table for backend %s"
+ pubring
+ backend))
+
+ (setq tinypgp-:pubring-now pubring)
+
+ ;; Each time backend is changed, the cache must be updated and
+
+ (tinypgp-key-cache-remove-entry-last)
+ (setq tinypgp-:key-cache nil)
+ (tinypgp-key-cache-save 'load)
+
+ (tinypgpd fid backend pubring secring)
+ (tinypgp-update-modeline)
+
+ (if verb
+ (message "Tinypgp: backend %s" (symbol-name backend)))
+
+ secring))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-variable-state-control (&optional restore)
+ "Save or RESTORE variables. Used when changing backends."
+ (let* ((opt (get 'tinypgp-:pgp-binary-interactive-option 'original)))
+ ;; PGP 5.x doesn't know +comment option.
+
+ (cond
+ (restore
+ (setq tinypgp-:pgp-binary-interactive-option opt))
+ (t
+ (put 'tinypgp-:pgp-binary-interactive-option 'original
+ tinypgp-:pgp-binary-interactive-option)
+ (setq tinypgp-:pgp-binary-interactive-option nil)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-backend-select-pgp2 ()
+ "Select pgp 2.6.x backend"
+ (interactive)
+ (tinypgp-variable-state-control 'restore)
+ (tinypgp-backend-select 'pgp2 (interactive-p)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-backend-select-pgp5 ()
+ "Select pgp 5.x backend"
+ (interactive)
+ (tinypgp-variable-state-control)
+ (tinypgp-backend-select 'pgp5 (interactive-p)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-backend-select-auto ()
+ "Select pgp 2 if it exists else use pgp 5. Otherwise flag error."
+ (let* ((list (get 'tinypgp-:pgp-binary 'pgp-backends)))
+ (cond
+ ((memq 'pgp2 list)
+ (tinypgp-backend-select-pgp2))
+ ((memq 'pgp5 list)
+ (tinypgp-backend-select-pgp5))
+ (t
+ (error "\
+Check PATH for pgp executable(s): maybe tinypgp-binary-path-set failed.")))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-backend-set-for-action (action &rest args)
+ "Select right backend for ACTION.
+Action may be 'remail 'newnym 'nymserv or 'pgp
+Die if can't select right backend."
+ (when (memq action '(remail newnym nymserv))
+ (unless (tinypgp-backend-pgp2-p)
+ (unless (tinypgp-backend-exist-pgp2)
+ (error "Pgp 2 not available for Action %s" action))
+ (tinypgp-backend-select-pgp2))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-binary1 (cmd)
+ "Return right pgp executable for COMMAND type 'encrypt ...."
+ (interactive)
+ (let* (ret)
+ (setq
+ ret
+ (cond
+ ((tinypgp-backend-pgp2-p)
+ (get 'tinypgp-:pgp-binary 'pgp))
+
+ ((tinypgp-backend-gpg-p)
+ (get 'tinypgp-:pgp-binary 'gpg))
+
+ ((eq 'pgp5 (tinypgp-backend-now))
+ (cond
+ ((memq cmd '(sign
+ sign-detach))
+ (get 'tinypgp-:pgp-binary 'pgps))
+
+ ((memq cmd '(encrypt
+ encrypt-sign
+ encrypt-info
+ crypt))
+ (get 'tinypgp-:pgp-binary 'pgpe))
+
+ ((memq cmd '(decrypt
+ decrypt-base64))
+ (get 'tinypgp-:pgp-binary 'pgpv))
+
+ ((eq cmd 'verify)
+ (get 'tinypgp-:pgp-binary 'pgpv))
+
+ ((string-match "key" (symbol-name cmd))
+ (get 'tinypgp-:pgp-binary 'pgpk))))))
+
+ (if (or (not (stringp ret))
+ (not (file-exists-p ret)))
+ (error "Install failure: Please run tinypgp-binary-path-set (%s)" cmd))
+
+ ;; In WinNT the maximum command length is 255, so we can't
+ ;; afford to use absolute path here. (It would have been faster)
+ ;;
+
+ (if (ti::win32-p)
+ (file-name-nondirectory ret)
+ ret)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-binary-get-cmd (cmd &optional options)
+ "Return pgp shell command according to logical CMD with appended OPTIONS."
+ (let* ((exe (tinypgp-binary1 cmd))
+ (elt (tinypgp-binary1-command-table cmd)))
+ (if (null elt)
+ (error "PGP exe command error: No logical command in table '%s'" cmd)
+ (list
+ exe
+ (nth 1 elt)
+ options))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro tinypgp-binary-result-data-win32 (beg end)
+ "Set result of PGP2 in WindowsNt shell buffer.
+In unix the output is printed so that 1)stderr 2)results
+but in Windows NT it could be printed in reverse order.
+
+We check here if the data is put to the beginning of the buffer,
+before the PGP logo.
+
+Variables BEG and END are modified if data starts from `point-min'."
+ (`
+ (progn
+ ;; 1) If variables are both nil
+ ;; 2) they are equal
+ ;;
+ (when (or (not (and (, beg) (, end)))
+ (eq (, beg) (, end)))
+ (save-excursion
+ (ti::pmin)
+ ;; No configuration file found.
+ ;; \aPretty Good Privacy(tm) 2.6.3ia -
+ ;;
+ (when (and (re-search-forward
+ (concat
+ "^config.txt: \\|"
+ "^No configuration file found.$\\|"
+ "\C-g?Pretty Good Privacy(tm)")
+ nil t)
+ (prog1 t (beginning-of-line))
+ (not (eq (point) (point-min))))
+ (setq beg (point-min) end (point))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinypgp-binary-get-result-re1-macro 'lisp-indent-function 1)
+(defmacro tinypgp-binary-get-result-re1-macro (options &rest body)
+ "If case-sensitive REGEXP match, execute BODY.
+The OPTIONS is a list containing an alist of options:
+
+'((regexp REGEXP) - Search REGEXP
+ (loop [t|nil])) - if LOOP is t, run while loop for REGEXP"
+ (`
+ (with-current-buffer tinypgp-:buffer-tmp-shell
+ (let (case-fold-search ;Case sensitive matching
+ (re (nth 1 (assq 'regexp (, options))))
+ (loop (nth 1 (assq 'loop (, options)))))
+ (ti::pmin)
+ (when (re-search-forward re nil t)
+ (if loop
+ (while (re-search-forward re nil t)))
+ (tinypgpd "exe-get-result-re1-macro:" (match-string 0) )
+ (,@ body))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypgp-binary-insert-command-log (&optional point cmd)
+ "Insert last command log into POINT[current point] or insert CMD."
+ (if point (goto-char point))
+
+ (setq cmd
+ (if cmd
+ (prin1-to-string cmd)
+ (prin1-to-string tinypgp-:last-pgp-exe-command)))
+
+ (insert "\n\nTinyPgp report, last command and parameters:\n\n"
+
+ "explicit-shell-file-name: "
+ (or explicit-shell-file-name "<>") "\n"
+
+ "shell-file-name : " (or shell-file-name "<>") "\n"
+ "command length : " (int-to-string (length cmd)) "\n\n"
+
+ cmd
+
+ "\n"))
+
+;;}}}
+;;{{{ PGP exe result get,check
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-binary-check-error (&optional ignore-output-error cmd buffer)
+ "Return non-nil, if the PGP output is not valid.
+
+Input:
+
+ IGNORE-OUTPUT-ERROR this skips checking the output: --- TAGS
+ CMD command used
+ BUFFER Where the pgp output is
+
+References:
+ `tinypgp-:error' stored error message"
+ (let ( ;; the re-ok does not produce re-block, but it's still valid
+ ;; pgp answer, not an error condition.
+
+ (fid "tinypgp-binary-check-error:" )
+ (re-ok (concat
+ "Good signature \\(from\\|made\\)"
+ "\\|Bad signature from"
+ "\\|Pass phrase +\\(is\\|appears\\) +good"
+ "\\|WARNING: +"))
+ (re-block "-----BEGIN.*PGP")
+ (re tinypgp-:pgp-binary-error-regexp)
+ case-fold-search) ;; Case is important here !!
+
+ (or buffer
+ (setq buffer tinypgp-:buffer-tmp-shell))
+
+ (setq tinypgp-:error nil)
+
+ ;; - See if buffer DOES not contain ok sign, then GO AND
+ ;; check error. Once I have message where
+ ;; "You do not have the secret" was written in message body.
+ ;; and that was not an error condition.
+
+ (with-current-buffer buffer
+ (unless (and (ti::re-search-check
+ "^Pass phrase is good. Just a moment[.][.]+")
+
+ ;; Funny; The previous message is ouputted, but
+ ;; if one pass encryption&sign fails; this is message
+ ;; will be seen. Make3 sure we don't see it.
+ ;;
+ ;; Including "pgp-lst"...
+ ;; Pass phrase is good. Just a moment....
+ ;; ^GKey matching userid 'a@b.if' not found
+ ;; in file '/aa7bb/ring-all.pgp'
+ ;;
+ ;; ^GCannot find the public key matching userid 'a@b.if'
+ ;; This user will not be able to decrypt this message.
+ ;; ^GEncryption error
+
+ (null (ti::re-search-check "Encryption error$")))
+ (tinypgp-binary-get-result-re1-macro (list (list 'regexp re))
+ (tinypgpd fid "MB" (match-beginning 0) "ME" (match-end 0)
+ (current-buffer))
+ (tinypgp-highlight 'match 0 nil tinypgp-:face-error nil
+ (match-beginning 0)
+ (match-end 0))
+ (setq tinypgp-:error (ti::remove-properties (ti::read-current-line)))
+ (tinypgp-binary-insert-command-log (point-max) cmd))))
+
+ (unless ignore-output-error
+ (with-current-buffer buffer
+ (when (and (null tinypgp-:error) ;Not already set?
+ (not (ti::re-search-check re-ok 0 '(point-min)))
+ (not (ti::re-search-check re-block 0 '(point-min))))
+ (setq tinypgp-:error "Internal error. No output from PGP.")
+ (tinypgp-binary-insert-command-log (point-max) cmd))))
+
+ ;; If this was encryption and it failed, then remove entry from
+ ;; cache.
+
+ (if tinypgp-:error
+ (tinypgp-key-cache-remove-entry tinypgp-:error))
+
+ (tinypgpd fid "RET" tinypgp-:error )
+
+ tinypgp-:error))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-binary-get-result (&optional buffer)
+ "Return the result of PGP output from BUFFER or `tinypgp-:buffer-tmp-shell'.
+Look for markers -----BEGIN PGP, -----END PGP.
+Return:
+ '(buffer beg end)"
+ (let* ((re1 "[.]*\\(-----BEGIN.*PGP\\)")
+ (re2 "^-----END.*PGP")
+ beg
+ ret)
+ (with-current-buffer (or buffer tinypgp-:buffer-tmp-shell)
+ (ti::pmin)
+ (when (re-search-forward re1 nil t)
+ (setq beg (match-beginning 1))
+ (ti::pmax)
+ (when (re-search-backward re2 nil t)
+ (setq ret (list (current-buffer) beg (line-end-position))))))
+ (tinypgpd "exe-get-result ret: " ret )
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-binary-get-result-decrypt (&optional buffer)
+ "Read BUFFER after decrypt and sign (international version).
+
+Return position of result in buffer.
+ '(buffer beg end)"
+ (let* (ret
+ tmp)
+ ;; Note how international version spits string "pass phrase",
+ ;; and US version doesn't
+ ;; +++++++++++++++++++++++++++
+ ;;
+ ;; International version - not for use in the USA. Does not useRSAREF.
+ ;; Current time: 1997/05/19 12:10 GMT
+ ;; Pass phrase is good. Just a moment....-----BEGIN PGP SIGNED
+ ;;
+ ;;
+ ;; Export of this software may be restricted by the U.S. government.
+ ;; Current time: 1997/05/16 20:40 GMT
+ ;; Pass phrase is good.
+ ;; Key for user ID: xxxxk
+ ;; 768-bit key, Key ID xxxx
+ ;; Also known as:
+ ;; Also known as:
+ ;; Just a moment....-----BEGIN PGP SIGNED MESSAGE-----
+
+ ;; note: When you call command -seatf; encrypt and sign in one pass,
+ ;; the output is bit different.
+ ;; +++++++++++++++++++++++++++
+ ;;
+ ;; International version - not for use in the USA. Does not use RSAREF.
+ ;; Current time: 1997/06/26 20:29 GMT
+ ;;
+ ;; Including "/users/jaalto/.pgp/pgp-lst"...
+ ;; Pass phrase is good. Just a moment....
+ ;; Key for user ID: Foo <foo@example.com>
+ ;; 512-bit key, key ID 47141D35, created 1996/06/03
+ ;; Also known as: Jari Aalto, Finland <ssjaaa@uta.fi>
+ ;; .-----BEGIN PGP MESSAGE-----
+ ;; Version: 2.6.3ia
+ ;; Comment: Processed by Emacs TinyPgp.el 1.222
+ ;;
+ ;; hEwDwLrt1UcUHTUBAgCFBDvkHJ7dEffIGiqyPi2WtdOPwWQ+Duw6/be/7FjJYEUV
+
+ (tinypgp-binary-get-result-re1-macro ; -seatf
+ '((regexp "Pass phrase is good. Just a moment[.]+"))
+ (when (and (save-excursion
+ (forward-line 1)
+ (looking-at ".*Key for user ID:"))
+ (re-search-forward (ti::mail-pgp-msg-begin-line) nil t))
+ (setq
+ tmp "-seatf[1]"
+ ret (list (current-buffer) (match-beginning 0) (point-max)))))
+
+ (unless ret
+ (tinypgp-binary-get-result-re1-macro
+ (list
+ (list
+ 'regexp
+ (concat
+ "Pass phrase is good. Just a moment[.]+"
+ ;; #todo: warning handling in decrypting
+ ;;
+ "\\|WARNING: Can't find.*can't check signature integrity.*\n")))
+ (setq
+ tmp "[2]"
+ ret (list (current-buffer) (point) (point-max)))))
+
+ (unless ret
+ ;; This is from conventional decrypt
+ (tinypgp-binary-get-result-re1-macro
+ '((regexp "Pass phrase appears good\\. \\."))
+ (setq
+ tmp "[3]"
+ ret (list (current-buffer) (point) (point-max)))))
+
+ ;; gpg: encrypted with 1024-bit ELG-E key, ID E7114155, created 2002-01-15
+ ;; "foo <foo@some.com>"
+ ;; <THE MESSAGE FOLLOWS>
+
+ (unless ret
+ ;; This is from conventional decrypt
+ (tinypgp-binary-get-result-re1-macro
+ '((regexp "^gpg: encrypted with.*[\r\n\]+.*[\r\n\][\r\n\]?"))
+ (setq
+ tmp "[gpg]"
+ ret (list (current-buffer) (point) (point-max)))))
+
+ ;; GPG is different. It will not give any indication if
+ ;; Pass phrase was good. It simply decrypted the message and
+ ;; possibly gave warnings:
+ ;; gpg: Please note that you don't have secure memory on this system
+ ;; gpg: Warning: unsafe permissions on file "~/.gnupg/options"
+ ;; gpg: Warning: unsafe permissions on file "~/.gnupg/random_seed"
+ ;; gpg: Warning: unsafe permissions on file "~/.gnupg/secring.gpg"
+ ;; gpg: Warning: unsafe permissions on file "~/.gnupg/pubring.gpg"
+ ;; <THE MESSAGE FOLLOWS>
+
+ (unless ret
+ ;; This is from conventional decrypt
+ (tinypgp-binary-get-result-re1-macro
+ '((regexp "^gpg: Warning:.*[\r\n]")
+ (loop t))
+ (setq
+ tmp "[gpg]"
+ ret (list (current-buffer) (point) (point-max)))))
+
+ (tinypgpd "exe-get-result-decrypt ret: " tmp ret )
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-binary-get-result-encrypt-info (&optional buffer)
+ "Return pointer to block 'This message can only be read by:'"
+ (with-current-buffer (or buffer tinypgp-:buffer-tmp-shell)
+ (ti::pmin)
+ (when (re-search-forward
+ "This message can only be read by:" nil t)
+ (beginning-of-line)
+ (let* ((beg (point)))
+ (or (re-search-forward "^[ \t]*$" nil t) (ti::pmax))
+ (beginning-of-line)
+ (list (current-buffer) beg (point))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;; This message can only be read by:
+;;; keyID: EFDB16AD
+;;; foo <foo@some.com>
+;;;
+(defun tinypgp-binary-get-result-encrypt-info-list (&optional pointer)
+ "Return list of users in 'This message can only be read by:'.
+POINTER is region where to read the results: (buffer beg end)"
+ (interactive)
+ (let* (list)
+ (or pointer
+ (setq pointer (tinypgp-binary-get-result-encrypt-info)))
+ (when pointer
+ (with-current-buffer (car pointer)
+ (goto-char (nth 1 pointer))
+ (forward-line 1)
+ (while (or (looking-at ".*keyID: +\\(.*\\)")
+ (looking-at "^ +\\(.*\\)"))
+ (push (ti::remove-properties (match-string 1)) list)
+ (forward-line 1))))
+ list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-binary-get-result-verify-status (&optional buffer)
+ "Return result STRING after verify from BUFFER."
+ (tinypgp-binary-get-result-re1-macro
+ (list
+ (list
+ 'regexp
+ (concat "Good signature \\(from\\|made\\)"
+
+ ;; This warning is preceeded by lines:
+ ;; File has signature. Public key is required to check...
+ ;; Key matching expected Key ID 1CEB1F55 not found
+ ;;
+ "\\|WARNING: Can't find the right public"
+ "\\|Bad signature from"
+ "\\|Key matching.*not found")))
+ (if (or (tinypgp-backend-pgp2-p)
+ (tinypgp-backend-gpg-p))
+ (ti::read-current-line)
+ (forward-line 1)
+
+ (let* ((case-fold-search t)
+ (id (ti::buffer-match ".*key +id +\\([0-9A-Z]+\\)" 1))
+ list)
+ (forward-line 1)
+ (setq list
+ (ti::mail-email-find-region
+ (point)
+ (progn (forward-line 5) (point))))
+ (format "Good signature from %s%s"
+ (if id (format " %s " id) "")
+ (if list
+ (ti::list-to-string list)
+ "<unknown>"))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-binary-get-result-using-function (function &optional buffer)
+ "Call FUNCTION with arg BUFFER and return result in string format.
+Function is the one that returns `pointer' object, like
+`tinypgp-binary-get-result-verify'"
+ (let* ((pointer (funcall function buffer)))
+ (when pointer
+ (inline (tinypgp-binary-get-result-as-string pointer)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-binary-insert-pointer-data (pointer &optional beg)
+ "Read POINTER '(buffer beg end) and insert data to point.
+Input:
+ pointer '(BUFFER BEG END)
+ beg flag, keep poin in beginnning instead of end of inserted data.
+"
+ (if (not (eq 3 (length pointer)))
+ (error "Invalid pointer")
+ (let ((point (point)))
+ (insert-buffer-substring (car pointer) (nth 1 pointer) (nth 2 pointer))
+ (if beg
+ (goto-char point)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-binary-get-result-as-string (pointer)
+ "Read string from POINTER '(buffer beg end)."
+ (with-current-buffer (car pointer)
+ (buffer-substring (nth 1 pointer) (nth 2 pointer))))
+
+;;; ----------------------------------------------------------------------
+;;; File has signature. Public key is required to check signature.
+;;; .
+;;; Good signature from user "XXX xxx <xxx@example.com>
+;;; Signature made 1998/03/04 08:22 GMT using 512-bit key, key ID 47141D35
+;;; PGP-DATA-FOLLOWS
+;;;
+(defun tinypgp-binary-get-result-verify (&optional buffer)
+ "Return result after verify from BUFFER. '(buffer beg end)."
+ (let ((fid "tinypgp-binary-get-result-verify")
+ ret
+ beg
+ end)
+ (tinypgp-binary-get-result-re1-macro
+ (list
+ (list
+ 'regexp
+ (concat "Good signature \\(from\\|made\\)"
+ "\\|Bad signature"
+ ;; This warning is preceeded by lines:
+ ;; File has signature. Public key is required to check...
+ ;; Key matching expected Key ID 1CEB1F55 not found
+ ;;
+ "\\|WARNING: Can't find the right public")))
+ (re-search-forward "Signature made" nil t)
+
+ (if (or (tinypgp-backend-pgp2-p)
+ (tinypgp-backend-gpg-p)
+ (forward-line 1)
+ (goto-char (tinypgp-hash 'expect 'get 'point nil 'global)))
+
+ (setq beg (point)
+ end (point-max))
+
+ (if (or (tinypgp-backend-pgp2-p)
+ (tinypgp-backend-gpg-p))
+ (tinypgp-binary-result-data-win32 beg end))
+
+ ;; Sometimes PGP says this:
+ ;;
+ ;; Looking for next packet in '/users/jaalto/junk/pgptemp.$00'...
+ ;;
+ ;; File has signature. Public key is required to check signature.
+ ;;
+ ;; File '/users/jaalto/junk/pgptemp.$01' has signature, but with no text.
+
+ (when (re-search-forward "Looking for next packet in '" nil t)
+ (beginning-of-line)
+ (setq end (point)))
+
+ (setq ret (list (current-buffer) beg end)))
+
+ (tinypgpd fid "POINTER" ret)
+ ret)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-binary-get-result-base64 (&optional buffer)
+ "Get contents after the 'Signature made 1996/11 ...' from BUFFER.
+Return:
+ pointer '(buffer beg end)"
+ (let (ret)
+ (tinypgp-binary-get-result-re1-macro
+ '((regexp "^Good signature from"))
+ ;; Good signature from user
+ ;; Signature made 1996/11/07
+ ;; DATA-HERE
+ ;;
+ (forward-line 2)
+ (setq ret (list (current-buffer) (point) (point-max))))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-binary-get-result-key-add (&optional buffer)
+ "Return result of key adding from BUFFER."
+ (interactive)
+ (let (ret
+ list)
+ (cond
+ ((tinypgp-binary-get-result-re1-macro
+ (list
+ (list
+ 'regexp
+ (concat
+ "you need a newer version of PGP"
+ "\\|Bad ASCII armor"
+ "\\|^No +keys found\\|.*added.*\\|ERROR: Bkad ASCII armor.*"
+ "\\|.*error\\|No new keys or signatures")))
+ (setq ret (ti::read-current-line))))
+ ((with-current-buffer tinypgp-:buffer-tmp-shell
+ (ti::pmin)
+ (setq list (ti::buffer-grep-lines "new key(s)")))
+ (setq ret (format "%d New keys added." (length list)))))
+
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-binary-get-result-key-sign (&optional buffer)
+ "Return result of key signing from BUFFER."
+ (interactive)
+ (let (ret)
+ (cond
+ ((tinypgp-binary-get-result-re1-macro
+ (list
+ (list
+ 'regexp
+ (concat
+ "^No +keys found\\|ERROR\\|.*error"
+ "\\|Key is already signed by")))
+ (setq ret (ti::read-current-line)))))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-binary-get-result-key-remove (&optional buffer)
+ "Return result of key remove from BUFFER."
+ (let (ret)
+ (cond
+ ((tinypgp-binary-get-result-re1-macro
+ (list
+ (list
+ 'regexp
+ (concat
+ ;; PGP can't remove key if it asks this
+ ;;
+ ;; Key has more than one user ID.
+ ;; Do you want to remove the whole key (y/N)? << WAITS HERE
+ ;;
+ "^Key has more than one user ID"
+ "\\|Keyring remove error")))
+ (setq ret (ti::read-current-line)))))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-binary-exit-code-ok-p (number)
+ "Check if exit code NUMBER is ok."
+ (if (and (tinypgp-backend-pgp2-p)
+ (memq number '(0 1)))
+ t
+ nil))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-binary-exit-status-entry (number)
+ "Check PGP's exit code NUMBER and return appropriate error message."
+ (let* ((table tinypgp-:pgp-binary-exit-code-table)
+ elt)
+ (cond
+ ((tinypgp-backend-pgp2-p)
+ (setq elt (cdr (assq 'pgp2 table)))))
+ ;; (unless elt (error "Unknown PGP executable."))
+ (assq number elt)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-binary-handle-result (&optional status)
+ "Show `tinypgp-:buffer-tmp-shell' buffer if error, otherwise return result.
+STATUS is Shell processes exit code.
+
+Return
+ '(buffer beg end) or call error"
+ (tinypgpd "tinypgp-binary-handle-result: in" status)
+ (let* ((fid "tinypgp-binary-handle-result")
+ (action (tinypgp-hash 'action 'get 'now nil 'global))
+ (elt (if status (tinypgp-binary-exit-status-entry status)))
+;;; (sym (if elt (nth 1 elt)))
+;;; (re (if elt (nth 2 elt)))
+ (ok (if status (tinypgp-binary-exit-code-ok-p status)))
+ error
+ ret)
+
+ (tinypgpd fid "Status" status "OK" ok )
+
+ ;; There is one case where pgp return 0 status(ok): encrypt with
+ ;; multiple keys, but some key is not found from keyring.
+ ;; --> I'd say this is fatal error
+ ;;
+ ;; That's why we always check the verbal results in spite of STATUS
+
+ (setq error (tinypgp-binary-check-error))
+
+ (unless error
+ (setq ret (or
+ ;; verifying the message also unpacks
+ ;; encrypted message if sig was good
+ ;;
+ (tinypgp-binary-get-result-verify)
+
+ (tinypgp-binary-get-result)
+ (and (string-match "decrypt" (symbol-name action))
+ (tinypgp-binary-get-result-decrypt)))))
+
+ (tinypgpd fid
+ "STATUS" status
+ "elt" elt
+ "error" error
+ "POINTER" ret
+ "ACTION" action)
+
+ (cond
+ ((and (null error)
+ (not (null ret)))
+ ret)
+ (t
+ (tinypgp-error (or error "No PGP output or error; huh?"))))))
+
+;;}}}
+;;{{{ PGP exe
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-binary-command-region-fix (cmd pointer)
+ "If the CMD failed when PGP asked random bits, fix it. POINTER is PGP data."
+ (tinypgpd "tinypgp-binary-command-region-fix in:" pointer )
+ (with-current-buffer (car pointer)
+ (when (ti::re-search-check
+ "We need to generate \\([0-9]+\\)" 0 '(point-min))
+ (tinypgpd "tinypgp-binary-command-region-fix done:" pointer "\n")
+ (tinypgp-error "randseed.bin must be generated."))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypgp-send (string)
+ "Send STRING to open expect process."
+ (expect-send (concat string (if (ti::win32-p) "\r" "\n"))))
+
+;;; ---------------------------------------------------------- &engine ---
+;;;
+(defun tinypgp-binary-do-command-region-with-expect
+ (cmd beg end o-buffer &optional msg ret-ptr)
+ "Execute shell CMD on region BEG END with USER.
+
+Input:
+
+ CMD str, full PGP command.
+ BEG int, region beg to feed to PGP
+ END int, region end to feed to PGP
+ O-BUFFER bfr, original buffer where BEG END are
+ MSG str, message
+ RET-PTR flag, instead of replacing previous content return pointer
+
+Return:
+
+ REGION END REPLACED point at beg, if ret-ptr = nil
+ POINTER '(buffer beg end) if ret-ptr = non-nil"
+ (let* ((fid "tinypgp-binary-do-command-region-with-expect: ")
+ (binary-process-input t)
+ (out-p (string-match "-o\\|#OUT" cmd))
+ (orig-buffer (current-buffer))
+ pgp-error
+ split
+ bin-name
+ args
+ expect-start
+ process pass
+ out-buffer
+ point
+
+ ret
+ pointer)
+
+ (if (null binary-process-input) ;quiet ByteCompiler
+ (setq binary-process-input nil))
+
+ (tinypgp-hash 'expect 'put 'process nil 'global)
+
+ (tinypgp-do-shell-env
+ (tinypgp-excute-in-tmp beg end ;results in temp buffer
+
+ (if msg
+ (message msg))
+
+ (tinypgp-file-control 'all-kill)
+
+ (ti::pmin)
+ (tinypgp-file-control 'source-write)
+
+ (cond
+ ((string-match "#PIPE" cmd)
+ (setq cmd (tinypgp-cmd-compose cmd nil nil '(nil))))
+ ((string-match "#SOURCE-FILE" cmd)
+ (setq cmd (tinypgp-cmd-compose cmd nil nil '(nil)))))
+
+ ;; If this command requires password, it contains marker #password
+ ;; --> get the password from cache or ask from user.
+
+ (when (string-match "#password" cmd)
+ (setq cmd (ti::replace-match 0 nil cmd) ;; Delete tag from command
+ pass (tinypgp-password-get)))
+
+ ;; The command is given as plain string. Explode it to individual
+ ;; arguments "pgp -s +batchmode=1" --> '("pgpg" "-s" "+batchmode=1")
+
+ (setq split (split-string cmd "[ ]+")
+ bin-name (nth 0 split)
+ args (cdr split)
+ out-buffer (current-buffer))
+
+ (setq tinypgp-:last-pgp-exe-command cmd)
+
+ (tinypgpd fid "in:"
+ "COMMAND" cmd
+ "CURRENT" (current-buffer)
+ "ORIG" orig-buffer
+ beg end
+ "min-max" (point-min) (point-max)
+ "MSG" msg
+ "RET-PTR" ret-ptr
+ "BIN" bin-name
+ "ARGS" args
+ "CMD" cmd)
+
+ (erase-buffer)
+
+ (setq expect-start (point-max)
+ process (apply
+ 'start-process
+ "PGP"
+ out-buffer
+ bin-name
+ args))
+
+ (unwind-protect
+ (with-expect process
+
+ (unless (ti::win32-p) ;; Unix is slower than NT, add delay
+ (sit-for 0.3))
+
+ (expect-cond
+
+ ;; Error! Unable to load string ENTER_PASSPHRASE
+
+ ("Enter pass phrase:\\|ENTER_PASSPHRASE"
+ (tinypgpd "Expect: triggered password prompt, sending it...")
+ (unless (stringp pass)
+ (delete-process process)
+ (tinypgp-error "Internal error. No pass phrase available."))
+ (sit-for 0.3) ;Small delay so that PGP is ready
+ (tinypgp-send pass)
+
+ (expect-cond
+ ("Error: Bad pass phrase."
+ (interrupt-process process)
+ (setq pgp-error 'bad-pass-phrase))
+
+ ("Enter pass phrase:"
+ (interrupt-process process)
+ (setq pgp-error 'bad-pass-ohrase))
+
+ ("Cannot decrypt message. It can only be decrypted by:"
+ (interrupt-process process)
+ (setq pgp-error 'cannot-decrypt)))))
+
+ ;; WRN: WARNING: The above key is not trusted to belong to:
+ ;; WRN: Mr. Foo <foo.site.com>
+ ;; QRY: Do you want to use the key with this name? [y/N]
+
+ (unless pgp-error
+ (expect-cond
+ ("Do you want to use the key with this name"
+ (tinypgpd "Expect: Use this kay ok...")
+ (tinypgp-send "y"))))
+
+ (unless pgp-error
+ (expect-cond
+ (exit
+ (delete-process process))
+
+ (timeout
+ (tinypgpd "Expect: timeout")
+ (delete-process process)
+ (error
+ (substitute-command-keys
+ (concat
+ "Expect: timeout occurred: send bug report "
+ "\\[tinypgp-submit-bug-report]"))))
+
+ )) ;; expect-cond
+
+ ;; Killing killed process won't hurt. Make sure the
+ ;; Expect-cond didn't fall through.
+
+ (delete-process process)
+
+ ;; ......................................... read results ...
+
+ (cond
+ (pgp-error
+ (tinypgpd "Expect: Terminated on error" pgp-error)
+ (tinypgp-error
+ (format "Expect error %s" (symbol-name pgp-error))))
+
+ ((null out-p)
+ (insert "\n")
+ (setq point (point)))
+
+ (t
+ (tinypgpd "Expect: reading input"
+ (current-buffer)
+ out-buffer
+ tinypgp-:file-output)
+
+ ;; Expect may move us out of the buffer
+
+ (unless (eq (current-buffer) out-buffer)
+ (if (buffer-live-p (get-buffer out-buffer))
+ (set-buffer out-buffer)
+ (error "Expect: Can't insert data: buffer has changed")))
+
+ ;; point is nil if there was no output file in
+ ;; this command, so the eq test will work in those
+ ;; cases too.
+
+ (if (eq (point) point)
+ (tinypgp-error "Expect: no output from PGP"))
+
+ (insert "\n")
+ (setq point (point))
+
+ (if (file-exists-p tinypgp-:file-output)
+ (insert-file-contents tinypgp-:file-output)
+ (if (buffer-live-p (get-buffer out-buffer))
+ (pop-to-buffer out-buffer)
+ (error "No expected output-file %s "
+ tinypgp-:file-output))))) ;; end of cond
+
+ ;; ...................................... handle results ...
+
+ (tinypgp-hash 'expect 'put 'point point 'global)
+
+ ;; Remove possible ^M chars
+
+ (ti::buffer-lf-to-crlf 'dos2Unix 'doReadOnly)
+ (setq pointer (list (current-buffer) point (point-max)))
+
+ (tinypgpd "Expect: pointer" pointer)
+
+ (when (eq point (point-max))
+ (tinypgp-error "No output from pgp"))
+
+ (tinypgp-file-control 'source-kill)))))
+
+ (unless (eq (current-buffer) orig-buffer) ;Restore buffer we left
+ (set-buffer orig-buffer))
+
+ (cond
+ (ret-ptr
+ (setq ret pointer))
+ (t
+ (goto-char beg)
+ (delete-region beg end)
+ (insert-buffer-substring
+ (car pointer) (nth 1 pointer) (nth 2 pointer))
+ (goto-char beg)))
+
+ ret))
+
+;;; ---------------------------------------------------------- &engine ---
+;;;
+(defun tinypgp-binary-do-command-region
+ (cmd beg end o-buffer &optional msg ret-ptr)
+ "Execute shell CMD on region BEG END with USER.
+
+Input:
+
+ CMD string, full PGP command.
+ BEG integer, region beg to feed to PGP
+ END integer, region end to feed to PGP
+ O-BUFFER buffer, original buffer where BEG END are
+ MSG string, message
+ RET-PTR flag, instead of replacing previous content return pointer
+
+Return:
+
+ REGION END REPLACED point at beg, if ret-ptr = nil
+ POINTER '(buffer beg end) if ret-ptr = non-nil
+
+References:
+
+ `tinypgp-:pgp-sh-exe'
+ `tinypgp-:last-pgp-exe-command'
+ `tinypgp-:file-output'
+ `tinypgp-:file-source'"
+ (let* ((fid "tinypgp-binary-do-command-region: ")
+ (action (tinypgp-hash 'action 'get 'now nil 'global))
+ (loop t)
+ (final-newline "\n")
+ (binary-process-input t)
+ status
+ ret pointer pointer-orig)
+
+ (if (null binary-process-input) ;quiet ByteCompiler
+ (setq binary-process-input nil))
+
+ (tinypgp-do-shell-env
+
+ (if msg
+ (message msg))
+
+ (tinypgpd fid "in:" (current-buffer)
+ beg end "min-max" (point-min) (point-max)
+ "MSG" msg
+ "ACTION" action
+ ret-ptr)
+
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... loop start ...
+ (while loop ;If we should repeat the task?
+ (setq loop nil)
+ (tinypgpd fid "loop-beg" loop (current-buffer) cmd "\n")
+
+ (tinypgp-excute-in-tmp beg end ;results in temp buffer
+
+;;; (pop-to-buffer (current-buffer)) (ti::d! "DOING PGP")
+
+ (setq pointer-orig (list (current-buffer) (point-min) (point-max)))
+
+ (ti::pmin)
+ (tinypgp-file-control 'source-write)
+
+ ;; PGP: Cannot use INPUT file as a parameter to pgp, but
+ ;; we must feed the file through pipe to pgp. Fix some
+ ;; commands.
+
+ (when (tinypgp-backend-pgp2-p)
+ (cond
+ ((string-match "#PIPE" cmd)
+ (setq cmd (tinypgp-cmd-compose cmd nil nil '(nil))))
+ ((string-match "#SOURCE-FILE" cmd)
+ (setq cmd (ti::replace-match 0 nil cmd))
+ (setq cmd (concat " #PIPE " cmd))
+ (setq cmd (tinypgp-cmd-compose cmd nil nil '(nil))))
+ (t
+ (setq cmd (concat " #PIPE " cmd))
+ (setq cmd (tinypgp-cmd-compose cmd nil nil '(nil))))))
+
+ (tinypgpd fid "last-cmd:" (current-buffer) cmd )
+
+ (setq tinypgp-:last-pgp-exe-command cmd)
+
+ (if tinypgp-:do-command-region-before-hook
+ (run-hook-with-args-until-success
+ 'tinypgp-:do-command-region-before-hook
+ cmd msg ret-ptr))
+
+ (erase-buffer)
+
+ ;; ............................................. save command ...
+
+ (when nil ;; only t if development version
+ (with-temp-buffer
+ (let ((file "~/.tinypgp-cmd"))
+ (insert cmd "\n")
+ (write-region (point-min) (point-max) file)
+ (ti::file-mode-protect file))))
+
+ ;; .............................................. run command ...
+
+ (ti::file-delete-safe tinypgp-:file-output)
+
+ (setq status
+ (shell-command cmd (current-buffer)))
+
+ ;; If there is output file (which was not sent stdout),
+ ;; then read it. This happens with GPG, which is unable to send
+ ;; to stdout, if stdin is used for password.
+
+ (when (file-exists-p tinypgp-:file-output)
+ (ti::pmax)
+ (tinypgpd fid "READING OUTPUT FILE" tinypgp-:file-output)
+ (insert-file-contents-literally tinypgp-:file-output))
+
+ (tinypgpd fid "SHELL-STATUS" status)
+
+ (if tinypgp-:do-command-region-after-hook
+ (run-hook-with-args-until-success
+ 'tinypgp-:do-command-region-after-hook
+ cmd msg ret-ptr))
+
+ ;; sometimes PGP need new randseed file, this generates it
+ ;; and runs the command again.
+ ;;
+ ;; WinNT: If PGP tries to ask for ranadseed, it hangs whole emacs.
+
+ (when (and t ;enable for now..
+ (not (ti::win32-p))
+ (tinypgp-binary-command-region-fix cmd pointer-orig))
+ (setq loop t))
+
+ ;; Arggh, When decrypting message in WinNT with 2.6.x The output
+ ;; is not correct: there is extra "..." at the end of DATA.
+ ;;
+ ;; Pass phase is good. Just a moment...DATA-DATA
+ ;; ...
+
+ (when (ti::win32-p)
+ (ti::pmax)
+ (if (not (eq 0 (skip-chars-backward ".")))
+ (delete-region (point) (line-end-position))))
+
+ ;; Remove possible ^M chars
+ (ti::buffer-lf-to-crlf 'dos2Unix 'force)))
+
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... .. loop end ...
+
+;;; (tinypgp-binary-insert-command-log)
+;;; (pop-to-buffer (car pointer-orig)) (ti::d! 1234)
+
+ (setq pointer (tinypgp-binary-handle-result status))
+
+ ;; We kill these only after the results have been examined,
+ ;; because user may want to check the contents if error happend.
+
+ (tinypgp-file-control 'password-kill) ;Remove password file
+ ;; (tinypgp-file-control 'source-kill)
+
+ ;; For some reason PGP does not output final newline
+ ;; after its TAGS. Check this and add it, otherwise replacing
+ ;; the buffer content doesn't go right.
+
+ (when pointer
+ (with-current-buffer (car pointer)
+ (when (string= "---"
+ (buffer-substring
+ (nth 1 pointer) (+ 3 (nth 1 pointer))))
+ (goto-char (nth 2 pointer))
+ (insert final-newline)
+ (setq pointer
+ (list (current-buffer)
+ (nth 1 pointer)
+ (1+ (nth 2 pointer)))))))
+ (cond
+ (ret-ptr
+ (setq ret pointer))
+ (t
+ (goto-char beg)
+ (delete-region beg end)
+ (insert-buffer-substring
+ (car pointer) (nth 1 pointer) (nth 2 pointer))
+ (goto-char beg)))
+ ret)))
+
+;;}}}
+
+;;{{{ PGP public key 'find by'
+
+;;; ..................................................... &pgp-key-get ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-finger-discard-by-regexp (string-or-list)
+ "Discards some email addresses from STRING-OR-LIST.
+See variable `tinypgp-:finger-discard-email-hook'"
+ (let (ret)
+ (tinypgpd "[tinypgp-:finger-discard-email-hook] in:"
+ tinypgp-:finger-discard-by-regexp "#" string-or-list )
+
+ (when string-or-list
+ (if (not (stringp tinypgp-:finger-discard-by-regexp))
+ (setq ret string-or-list)
+ (dolist (x (ti::list-make string-or-list))
+ (if (string-match tinypgp-:finger-discard-by-regexp x)
+ (tinypgpd "[tinypgp-:finger-discard-email-hook doing]:" x )
+ (push x ret)))))
+ (nreverse ret)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-key-network-spawn (mode &optional arg1 arg2 verb)
+ "Get key by fingering EMAIL.
+Examine the returned information and ask user help if there is more than
+one public key.
+
+Input:
+
+ MODE 'finger
+ ARG1 ARG2 if 'finger then arg1 is email
+ if 'http then arg1 is host, arg2 is command
+ VERB flag, verbose messages.
+
+Return:
+
+ string if only one public key
+ (string) internal finger error string
+
+References:
+
+ `tinypgp-:buffer-tmp-shell' ,results of finger
+ `tinypgp-:last-network-error' ,if error happened."
+ (let ((fid "tinypgp-key-network-spawn:")
+ (buffer (tinypgp-ti::temp-buffer 'finger))
+ (email arg1) ;if command is finger
+ stat
+ data
+ data2
+ len
+ ret)
+
+ (tinypgpd fid "in:" mode arg1 arg2 verb)
+
+ (setq tinypgp-:last-network-error nil)
+
+ (cond
+ ((eq mode 'finger)
+ (setq stat (ti::process-finger email nil nil buffer verb)))
+ (t
+ (error "Wrong mode '%s' " mode)))
+
+ (cond
+ ((stringp stat)
+ (setq tinypgp-:last-network-error stat)
+ (setq ret (list stat)))
+
+ ((bufferp stat)
+ (ti::mail-pgp-trim-buffer) ;Remove garbage around keys.
+
+ (or (setq data
+ (ti::mail-pgpk-public-get-region nil nil buffer))
+ (setq data2
+ (ti::mail-pgpk-public-get-region nil nil buffer 'relax)))
+
+ (when data2
+ (setq data data2))
+
+ ;; I don't think people undertand this mail very well,
+ ;; they only know how to do -kxa and -kv, not -fkxa
+ ;;
+;;; (if (y-or-n-p
+;;; (concat
+;;; "Public key found, but not in full -fakx format "
+;;; "Send email notice? "))
+;;; (tinypgp-sendmail email 'pk-no-full-format))
+
+ (setq len (length data))
+
+ (cond
+ ((and (eq 1 len) ;only 1 public key found
+ (not
+ (null
+ ;; P-key block must not me empty
+ (setq ret (nth 1 (car data))))))
+ ret)
+
+ ((null data)
+ (ti::read-char-safe-until
+ "finger ok, but no Public key in his ~/.plan file.[press]")
+ (setq ret nil))
+
+ (t
+ ;; #todo
+;;; (ti::d! "FSTAT" stat (length data))
+ (error "Multiple keys not implemented yet.")))))
+
+ (tinypgpd fid email ret )
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-key-finger-guess-email ()
+ "Check Whole buffer for PGP email address.
+Return:
+ nil Nothing cound
+ email"
+ (let* ((set "[^ \t\n<=\"';:]+")
+ (email-re (concat "\\(" set "@" set "\\)"))
+ ;; finger ssjaaa@uta.fi | pgp -fka for pgp key
+ ;;
+ (kaf-re "[ \t]*|[ \t]*pgp[ \t]+-\\(fka\\|kaf\\|afk\\|fak\\)")
+ email
+ line
+ list)
+
+ (save-excursion
+ (cond
+
+ ((and
+ buffer-read-only ;Incoming message RMAIL
+ (ti::pmin)
+ ;; X-Pgp-Signed:
+ ;; access-type=Finger; Address=foo@site.com;
+ ;;
+ (setq list (tinypgp-xpgp-get-info))
+ (setq email (assoc "address" list))))
+
+ ((and
+ (ti::pmin)
+ ;; If's faster first look for simple regexp, and match
+ ;; it against complex regexp
+ ;;
+ (re-search-forward kaf-re nil t)
+ (setq line (ti::read-current-line))
+ (string-match (concat email-re kaf-re) line)
+ (setq email (ti::remove-properties (match-string 1 line)))))
+
+ ((and
+ (ti::pmin)
+ (re-search-forward
+ (concat
+ "public.*key.*@\\|@.*public.*key"
+
+ ;; |Boudewijn Visser|E-mail:visser@ph.tn.tudelft.nl |finger for |
+ ;; |University of Technology |PGP-key |
+ ;;
+ "\\|@.*finger\\|finger.*@"
+
+ ;; steve*windsong.demon.co.uk (for which PGP is preferred)
+ ;;
+ "\\|@.*pgp.*prefered\\|pgp.*prefered.*@")
+ nil t)
+ (setq line (ti::read-current-line))
+ (string-match email-re line)
+ (setq email (ti::remove-properties (match-string 1 line)))))))
+
+ (tinypgpd "tinypgp-key-finger-guess-email out:" email )
+
+ email))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-key-finger-add (email &optional no-ask)
+ "Ask where to store the public key for EMAIL; optionally NO-ASK.
+
+Return
+ non-nil if added
+ nil"
+ (let ((finger-buffer tinypgp-:buffer-tmp-finger)
+ ans)
+ (cond
+ (no-ask
+ ;; Put into temporary keyring ... #todo
+ (error "Not supported no-ask"))
+ (email
+ (setq ans
+ (tinypgp-pubring-alias2file
+ (tinypgp-pubring-complete
+ (format
+ "%s: Store the public key to pubring[empty=cancel]: "
+ (or (car-safe (ti::mail-email-from-string email))
+ (ti::string-left email 20))))))
+ (if (ti::nil-p ans)
+ (setq ans nil)
+ ;; #todo, should add the key to keyring.
+ ;;
+ (with-current-buffer finger-buffer
+ ;; (tinypgp-key-add-region-interactive)
+ (tinypgp-key-add-region-batch (point-min) (point-max)))
+;;; (ti::d! "Cacheing finger>>" ans)
+ ;; email, keyring
+ (tinypgp-key-cache 'put email ans))))
+ ans))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-key-find-by-finger-verbose (email-list)
+ "EMAIL-LIST. See `tinypgp-key-find-by-finger'."
+ (tinypgp-key-find-by-finger email-list nil 'verb))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-key-find-by-finger (&optional email-list no-ask verb)
+ "Find a PGP key using finger.
+
+The exact references searched are like:
+
+ finger foo@site.com for pgp public key
+ finger foo@site.com | pgp -fka
+ ...
+
+If finger fails then user is offered a list of all email
+addresses and each one selected is fingered.
+
+Input:
+ EMAIL-LIST ,if this is given, then do not search
+ current buffer for email addresses.
+ All entries that do not contain @ are filtered out.
+ This can be string list or single string
+ NO-ASK ,store all fingered keys without asking
+ to current keyring.
+ VERB ,enable verbose messages
+
+Return:
+ string ,pgp publick key block
+ nil"
+ (interactive)
+ (tinypgpd "tinypgp-key-find-by-finger in:")
+ (let* (email
+ stat
+ ans
+ list
+ ret)
+
+ (ti::verb)
+
+ ;; ... ... ... ... ... ... ... ... ... ... ... exact match search ...
+
+ (if email-list
+ (setq list (ti::list-make email-list))
+
+ ;; ... ... ... ... ... ... ... ... ... ... ... .. list not given . .
+ (setq email (tinypgp-key-finger-guess-email)
+ email (tinypgp-email-discard-default list)
+ email (tinypgp-finger-email-filter email))
+
+ (if (ti::listp email)
+ (setq email (car email)))
+
+ (when email ;Try adding the exact match
+ (setq ret (tinypgp-key-network-spawn 'finger email nil verb)))
+
+ (if (stringp ret)
+ (setq ret (tinypgp-key-finger-add email))
+ (setq list
+ (tinypgp-email-find-region
+ (point-min)
+ ;; For large buffers, look only the start
+ ;; of buffer. The point-min offset is
+ ;; needed because buffer may be narrowed (RMAIL)
+ ;;
+ (if (> (point-max) (+ (point-min) 1000))
+ (+ (point-min) 1000)
+ (point-max))))))
+
+ (if (and list tinypgp-:finger-discard-email-hook)
+ (setq list (run-hook-with-args-until-success
+ 'tinypgp-:finger-discard-email-hook list)))
+
+ (when list
+ (setq list (tinypgp-email-discard-default list))
+ (setq email (car-safe list)))
+
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... . loop-finger . .
+ (while (and list
+ (not (stringp ret))
+ (not (ti::nil-p email)))
+
+ (when (null no-ask)
+ (setq
+ ans
+ (completing-read
+ (format "%sFinger [e(x)it, !, empty=skip]: "
+ (if (> (length list) 1)
+ (format "%d: " (length list)) ""))
+ (ti::list-to-assoc-menu list) nil nil email))
+
+ (cond
+ ((string= "!" ans)
+ (setq no-ask t))
+
+ ((string= "x" ans)
+ (setq list nil
+ email nil))
+
+ ((ti::nil-p ans)
+ (setq email nil))
+
+ (t
+ (setq email ans))))
+
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... results ...
+
+ (when (not (ti::nil-p email))
+ (setq stat (tinypgp-key-network-spawn 'finger email nil t))
+
+ (cond
+ ((and (ti::listp stat) verb)
+ (message (format "[press]Finger internal error: %s" (car stat)))
+ (sit-for 3)
+ (discard-input))
+
+ ((stringp stat)
+ (setq ret stat)
+ (if verb
+ (message "Fingered PGP key found."))))
+ ;; Used, remove
+ (setq list (delete email list)))
+
+ ;; ................................................ go to next ...
+ (unless ret ;not found yet?
+ (if email
+ (setq list (delete email list)))
+ (setq email (car list)
+ list (cdr list))))
+
+ (if ret
+ (tinypgp-key-finger-add email no-ask))
+
+ (tinypgpd "tinypgp-key-find-by-finger out:" ret )
+
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-key-http-study-buffer (&optional buffer)
+ "Search public key from HTTP keyserver request result BUFFER."
+ (let* ()
+ (tinypgpd "tinypgp-key-http-study-buffer in: " buffer (current-buffer))
+ (with-current-buffer buffer
+ (ti::mail-pgp-trim-buffer))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-key-find-by-http-url-verbose (&rest args) ;Called from hook
+ "Call `tinypgp-key-find-by-http-url' interactively."
+ (call-interactively 'tinypgp-key-find-by-http-url))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-key-find-by-http-url (url &optional verb)
+ "Send http request and try to read key from URL page. VERB.
+
+Interactive call note:
+
+ This function searches only X-Pgp field for possible key location
+ pointer in format Access-type=URL; URL=http://me.org/~me/pgp.html"
+ (interactive
+ (list (tinypgp-xpgp-key-address
+ 'http
+ "(http) X-Pgp information is not present.")))
+
+ (let* ((fid "tinypgp-key-find-by-http-url: ")
+ (buffer (tinypgp-ti::temp-buffer 'http))
+ (obuffer (current-buffer))
+ (win-count (length (ti::window-list)))
+ stat
+ ret)
+
+ (ti::verb)
+ (tinypgpd fid "URL" url "VERB" verb)
+
+ (when (stringp url)
+ (setq stat (ti::process-http-request url nil nil buffer verb)))
+
+ (tinypgpd fid "STAT" stat buffer)
+
+ (cond
+ ((and (nth 1 stat)
+ verb)
+ (message "Http internal error: %s" stat)
+ (sit-for 2)
+ (discard-input))
+
+ ((bufferp (setq stat (car stat)))
+ (pop-to-buffer stat)
+ (ti::pmin)
+ (if (setq
+ stat
+ (cond
+ ((ti::mail-pgp-public-key-p (point-min))
+ (if verb
+ (call-interactively 'tinypgp-key-add-region-batch)
+ (tinypgp-key-add-region-batch (point-min) (point-max))))))
+ ;;
+ ;; See tinypgp-key-add-region-batch documentation
+ ;;
+ (setq ret tinypgp-:return-value)
+
+ ;; If user had only 1 window visible, make this 'new' buffer
+ ;; small. But if he had more windows, don't shrink the
+ ;; just shown buffer (it shocks if your window settings are
+ ;; modified !)
+ ;;
+ (when (eq win-count 1)
+ (shrink-window-if-larger-than-buffer))
+
+ ;; Keep cursor in the original buffer
+ ;;
+ (pop-to-buffer obuffer)
+
+ (if verb
+ (message "Http request didn't find public key."))))) ;cond end
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-key-find-by-http-keyserver-i-args (&optional string)
+ "Ask args for function `tinypgp-key-find-by-http-keyserver'.
+If STRING is already know then do not ask for it.
+
+Return:
+ (srv cmd str)"
+ (let* ((fid "tinypgp-key-find-by-http-keyserver: ")
+ (dummy (tinypgpd fid "in: "))
+
+ (to-field (if buffer-read-only ;; RMAIL VM
+ (mail-fetch-field "from")
+ (mail-fetch-field "to"))) ;; mail buffer
+
+ (line-end-position (or (ti::mail-hmax) (point-max)))
+
+ (elist (tinypgp-email-find-region
+ (point-min)
+
+ ;; Search up till character limit 3000
+ (if (> line-end-position (+ (point-min) 3000))
+ (+ (point-min)3000) line-end-position)))
+ (key-id (tinypgp-key-id-find))
+ elt
+ srv
+ cmd)
+
+ (if dummy (setq dummy t)) ;No-op, byte-comp silencer.
+
+ (tinypgpd fid to-field key-id elist
+ (current-buffer) (point-min) line-end-position)
+
+ (if to-field
+ (setq to-field (car (ti::mail-email-from-string to-field))))
+
+ (if (setq elt (tinypgp-ask-http-keyserver))
+ (setq srv (nth 0 elt)
+ cmd (nth 1 elt))
+ (error "Internal.")) ;should not happen
+
+ (if key-id ;Add this to completion list too
+ (push key-id elist))
+
+ (or string
+ (setq string
+ (completing-read
+ "Search string, no spaces: "
+ (ti::list-to-assoc-menu elist) nil nil
+ (if key-id
+ key-id
+ (ti::remove-properties
+ (or to-field (ti::buffer-read-space-word))))
+ 'tinypgp-:history-http-keyserver-string)))
+ (list srv cmd string)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-key-find-by-http-keyserver-verbose (string)
+ "See `tinypgp-key-find-by-http-keyserver'. STRING."
+ (let ((a (tinypgp-key-find-by-http-keyserver-i-args string)))
+ (tinypgp-key-find-by-http-keyserver (nth 0 a) (nth 1 a) string 'verb)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-key-find-by-http-keyserver
+ (server command string &optional verb)
+ "Send http request to keyserver to get a key.
+
+Interactive note:
+
+ All email addresses are read from `point-min' to end of
+ current line where your cursor sits. The default search string
+ offered is read from the To field but you can delete the prompt
+ and enter other found email addresses via Tab completion.
+
+Functional note:
+
+ Please understand that waiting for a HTTP response may be painfully
+ slow many times. If you can, prefer the finger and instruct
+ poeople to include their publick key information in the
+ $HOME/.plan file in full -fkax format.
+
+Input:
+
+ SERVER www.xx.com
+ COMMAND command to run in server
+ STRING the search string without spaces. If this parameter is nil
+ or contains spaces, thi function returns immediately.
+ VERB Verbose messages.
+
+Return:
+
+ keyring If htttp call succeeded and key was inserted to some keyring
+ nil no keys added or found"
+ (interactive (tinypgp-key-find-by-http-keyserver-i-args))
+ (tinypgpd "tinypgp-key-find-by-http-keyserver in: " string )
+
+ (unless (ti::nil-p string)
+ (let* ((cmd (format (concat "http://%s" command) server string)))
+ (ti::verb)
+ (tinypgpd "tinypgp-key-find-by-http-keyserver cmd: " cmd)
+ (tinypgp-key-find-by-http-url cmd verb))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-key-find-by-http-guess ()
+ "Select X-pgp URL if it exists or suggest keyserver search.
+This function is stricly for interactive use."
+ (interactive)
+ (let* ((url (tinypgp-xpgp-key-address 'http))
+ tried
+ ret)
+ (if (and url
+ (setq tried (y-or-n-p "X-Pgp key url found; obey it ")))
+ (setq ret (tinypgp-key-find-by-http-url url 'verb)))
+
+ (unless ret
+ (cond
+ (tried
+ (message "No luck, Inform person about possible defective X-URL")
+ (sit-for 1.5))
+ (t
+ (setq ret (call-interactively 'tinypgp-key-find-by-http-keyserver)))))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-key-find-by-email (email-srv string)
+ "Send email to nearest Public key mail service to get the Key.
+Notice that this sends _mail_ and doesn't return any values.
+
+This function should not be put into any key find nook, but
+called by user with clear intention to find key as last resort.
+
+Input:
+ EMAIL-SRV full string placed in To: field where to send the
+ request.
+ STRING what to request from the server normally
+ \"FirstName Surname\""
+ (interactive
+ (let (srv
+ string)
+ (setq srv (tinypgp-ask-email-keyserver))
+ (setq ;ARG 2
+ string
+ (read-from-minibuffer "Search string [firstname surname]: "))
+ (list srv string)))
+
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... .. function start . .
+ (let* (cmd)
+
+ (if (or (ti::nil-p email-srv)
+ (ti::nil-p string)
+ (not (string-match "@" email-srv)))
+ (error "Invalid arguments."))
+
+ (setq cmd (format "GET %s" string))
+
+ (ti::mail-sendmail-macro email-srv cmd 'send
+ (insert cmd "\n"))))
+
+;;; ----------------------------------------------------------------------
+;;; - We don't make this a macro! It could be installed into hooks...
+;;;
+(defun tinypgp-key-find-by-cache (string &optional who)
+ "Check cache for STRING.
+
+Input:
+ STRING string to find
+ WHO who calls this function (for debug purposes)
+
+Return:
+ pubring
+ nil"
+ (tinypgpd "tinypgp-key-find-by-cache: " string who)
+ (if (stringp string)
+ (tinypgp-key-cache 'get string)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypgp-key-cache-update (&optional user)
+ "Update cache with current USER/pubring parameters."
+ (setq user (or user tinypgp-:user-now))
+
+ (tinypgpd "tinypgp-key-cache-update: " user tinypgp-:pubring-now )
+
+ ;; The USER must at least contain 3 character, it's no use to
+ ;; cache 2 character user, because that may be a bug in program
+ ;;
+ (if (> (length user) 2)
+ (tinypgp-key-cache 'put user tinypgp-:pubring-now)
+ (error "TinyPgp: cache update internal error %s" user)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-key-find-by-keyrings-1 (string-or-list)
+ "Search all keyrings and cache.
+
+Input:
+ STRING-OR-LIST string or list of search strings, first one found
+ is used.
+
+Return:
+ (string . keyring) STRING is the one in string-or-list that was found
+ first.
+ nil"
+ (let* ((tinypgp-:pubring-now tinypgp-:pubring-now)
+ (fid "tinypgp-key-find-by-keyrings-1:")
+ list
+ kring
+ ret
+ search-string)
+ (tinypgpd fid "in:" string-or-list)
+ (setq string-or-list (ti::list-make string-or-list))
+
+ (dolist (search-string string-or-list) ;; #todo: Can't use dolist/2 loop
+ (setq list (tinypgp-pubring-list))
+
+ (tinypgp-save-state-macro
+ (with-current-buffer (tinypgp-ti::temp-buffer 'shell)
+ (dolist (kring list) ;; #todo: Can't use dolist/2 loop
+ (if (not (file-exists-p kring))
+ (error "\
+Check tinypgp-:pubring-table/Config error, no exist '%s'" kring))
+
+ (setq tinypgp-:pubring-now kring) ;Search this
+
+ (when (tinypgp-key-info-insert search-string)
+ ;; That's it, stop the loop by setting list to nil
+ (setq ret (cons search-string kring)
+ string-or-list nil ;Stop loop 1
+ list nil) ;Stop loop 2
+ (tinypgp-key-cache 'put search-string kring))))))
+ (tinypgpd fid "out:" search-string kring ret)
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-key-find-by-keyrings-verbose (string)
+ "See `tinypgp-key-find-by-keyrings'. STRING."
+ (tinypgp-key-find-by-keyrings string 'verb))
+
+(defun tinypgp-key-find-by-keyrings (string &optional verb)
+ "Try all available keyrings and try to find the public key.
+If pubring file searched does not exist, signal error.
+
+Input:
+
+ STRING ,search string
+ VERB ,if non-nil, then ask for search string if STRING search fails.
+
+Note:
+
+ This function caches the pubring and string information
+ The cache is always looked first, before doing any outside search.
+
+Sets global
+
+ `tinypgp-:return-value' and property 'find-by-keyrings
+
+ If you call this function with argument VERB
+ user can change the search STRING. if the user's string is found
+ from the keyrings then the original STRING is changed. The
+ property has value nil if STRING is original or
+ it has the user's input value if that match was found.
+
+ You need the information if you try to encrypt with key
+ xxx@foo.site.com and user changes it to 'doodle'. Then if
+ 'doodle' is found, you should use that for encryption and not
+ the original xxx@foo.site.com
+
+Return:
+
+ string public keyring
+ nil"
+ (let ((fid "tinypgp-key-find-by-keyrings:")
+ (loop t)
+ ret)
+
+ (tinypgpd "tinypgp-key-find-by-keyrings in:" string )
+ (put 'tinypgp-:return-value 'find-by-keyrings nil)
+
+ (while (and loop (null ret))
+ (setq loop nil) ;User sets this 't' if retry
+
+ (or (setq ret (tinypgp-key-find-by-keyrings-1 string))
+ (and verb
+ (ti::mail-mail-p)
+ (progn
+ (message "\
+Hm, Consider using tinypgp-email-substitution-add in tinypgp rc file: TO hdr")
+ (sit-for 5)
+
+ (setq
+ string
+ (completing-read
+ (format
+ "[%s] No keyring, try another string? : "
+ string)
+ (ti::list-to-assoc-menu (tinypgp-email-make-choices string))))
+ (if (ti::nil-p string) ;RET pressed --> ""
+ nil
+ (setq loop t)
+ (tinypgpd fid "RETRY" string)
+ (setq ret (tinypgp-key-find-by-keyrings-1 string)))))))
+
+ ;; tinypgp-key-find-by-keyrings-1 return cons cell
+ ;;
+ (when (ti::listp ret)
+ (put 'tinypgp-:return-value 'find-by-keyrings (car ret))
+ (setq ret (cdr ret)))
+
+;;; (ti::d! "fbk" (get 'tinypgp-:return-value 'find-by-keyrings))
+ (tinypgpd "tinypgp-key-find-by-keyrings out:" string ret )
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-key-find-by-guess (string &optional verb)
+ "Try to determine where to get the Public key-id STRING.
+For best results, the STRING should be in 0xFFFFF format to
+uniquely match single person. Second best choice is full email address.
+VERB activates verbose messages.
+
+The order of search depends on the variable:
+
+ `tinypgp-:find-by-guess-hook'
+
+Which is list of functions."
+ (interactive
+ (list
+ (ti::string-remove-whitespace
+ (read-from-minibuffer
+ "Search string: "
+ (ti::string-remove-whitespace
+ (or (ti::mail-get-field "from" nil 'null-mode)
+ (ti::mail-get-field "to" nil 'null-mode)))))))
+ (let* ((fid "tinypgp-key-find-by-guess:")
+ ret)
+ (ti::verb)
+ (if (ti::nil-p string) (error "Invalid arg"))
+
+ ;; Is there substitution for this ?
+ ;;
+ (setq ret (car-safe (tinypgp-key-id-conversion string)))
+ (tinypgpd fid "in: STRING" string "key-subst" ret verb)
+
+ (if ret (setq string ret))
+
+ (tinypgpd fid "RUN HOOKS" tinypgp-:find-by-guess-hook)
+
+ (setq ret (run-hook-with-args-until-success
+ 'tinypgp-:find-by-guess-hook string))
+
+ (if ret (tinypgp-key-cache 'put string ret))
+
+ (when verb
+ (cond
+ (ret
+ ;; maybe the previous call cached they KEY whose indicator "k"
+ ;; is not shown in modeline. Show "k" now
+ ;;
+ (tinypgp-update-modeline)
+ (message "TinyPgp Guess found: [%s] keyring %s"
+ string
+ (file-name-nondirectory ret)))
+ (t
+ (message "TinyPgp Guess failure: (maybe converted) %s" string))))
+ ret))
+
+;;}}}
+;;{{{ PGP key management
+
+;;; ......................................................... &pgp-key ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-key-ring-at-point (&optional alias)
+ "See if there is keyring by looking backward.
+First empty line terminates search. Eg.
+
+Key ring: '/users/jaalto/.pgp/pubring.pgp', looking for
+user ID \"foo@site.com\".
+Type Bits/KeyID Date User ID
+pub 1024/20378F71 1995/08/19 Mr. foo <foo@site.com>
+
+Input:
+ ALIAS ,flag, return keyring alias name"
+ (let (ret)
+ (save-excursion
+
+ ;; move away from empty line
+ ;;
+ (if (looking-at "^[ \t]*$")
+ (forward-line -1))
+
+ (while (and (not (bobp))
+ (not (looking-at "^[ \t]*$"))
+ (null ret))
+ (if (looking-at ".*Key ring:[ \t]+'\\([^']+\\)")
+ (setq ret (match-string 1)))
+ (forward-line -1)))
+
+ (if alias
+ (setq ret (tinypgp-pubring-file2alias ret)))
+
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinypgp-key-trust-ask (&optional id)
+ "Ask trust parameter. If user gives empty line, 'undefined' is returned.
+ID is user-id."
+ (let ((ans
+ (completing-read
+ (format "%s%strust parameter? " (or id "") (if id " " ""))
+ (ti::list-to-assoc-menu
+ '("undefined" "untrusted" "marginal" "complete"))
+ nil 'match-it
+ "undefined")))
+ (if (ti::nil-p ans)
+ "undefined"
+ ans)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-key-info-insert-current-user ()
+ "Insert current user's key information to point.
+The current pubring is set temporarily to first
+entry in `tinypgp-pubring-table'."
+ (tinypgp-save-state-macro
+ (setq tinypgp-:pubring-now (nth 1 (car (tinypgp-pubring-table))))
+ (tinypgp-key-info-insert tinypgp-:user-now 'verb)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-key-info-insert (string &optional verb)
+ "Run pgp -kvc to get key information matching the STRING.
+Insert the content to current point. VERB allows verbose messages.
+
+References:
+ `tinypgp-:buffer-tmp-shell'
+
+Return:
+ t something inserted
+ nil error condition"
+ (interactive
+ (list
+ (read-from-minibuffer
+ (format "insert key matching [pubring: '%s']: "
+ (or (tinypgp-pubring-file2alias tinypgp-:pubring-now)
+ "<unknown>")))))
+
+ (barf-if-buffer-read-only)
+ (tinypgpd "tinypgp-key-info-insert in: " string verb )
+
+ (let* ((bcmd (tinypgp-binary-get-cmd 'key-info)) ;;base command
+ (cmd (tinypgp-cmd-compose bcmd nil nil '(nil)))
+ (fid "tinypgp-key-info-insert: ")
+ shell-cmd
+ buffer
+ ret)
+
+ (ti::verb)
+
+ (cond
+ ((and (string-match "[ \t]" string) (ti::win32-p))
+ (error "STRING must not contain whitespace in WInNT"))
+ (t
+ (setq string (format "\"%s\"" string))))
+
+ (tinypgp-do-shell-env
+ (with-current-buffer (setq buffer (tinypgp-ti::temp-buffer 'shell))
+ (setq shell-cmd (format "%s %s" cmd string))
+ (tinypgpd fid "run: " shell-cmd)
+ (shell-command shell-cmd buffer)
+ ;; (pop-to-buffer (current-buffer)) (ti::d! "::key" string)
+
+ (ti::pmin)
+ (cond
+ ((re-search-forward "0 matching keys found\\." nil t)
+ (if verb
+ (message "0 matching keys found.")))
+ (t
+ (setq ret t)))))
+
+ (if ret
+ (insert-buffer buffer))
+
+ (tinypgpd fid "out: " ret )
+
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-key-info-at-point-show (string &optional pubring-list)
+ "Find match using STRING from current keyring or PUBRING-LIST.
+When called interactively, read space-separated-word
+under point and find matches from current keyring and
+show them in temporary buffer."
+ (interactive
+ (let (str)
+ (setq str
+ (read-from-minibuffer
+ "Display key info matching: "
+ (if (null (setq str (ti::buffer-read-word "-0-9a-zA-Z@.")))
+ ""
+ ;; If underlying word is Key-id 12345678, then
+ ;; prepend 0x to it because that is only valid search string
+ ;;
+ (if (and (eq (length str) 8)
+ (string-match "^[0-9A-Z]+$" str))
+ (concat "0x" str)
+ (ti::string-left str 35)))
+ nil
+ nil
+ 'tinypgp-:history-key-info))
+ (list str (tinypgp-pubring-list))))
+
+ (let ((tmp (tinypgp-ti::temp-buffer 'show)))
+ (if (not (stringp string))
+ (error "Arg error")
+
+ (with-current-buffer tmp
+ (tinypgp-save-state-macro
+ (dolist (elt pubring-list)
+ (setq tinypgp-:pubring-now elt)
+
+ (insert "\n" elt ":")
+
+ (beginning-of-line)
+ (if (looking-at "^.*/\\(.*:\\)")
+ (tinypgp-highlight 'match 1))
+ (end-of-line) (insert "\n")
+
+ (tinypgp-key-info-insert string)
+ (ti::pmax))))
+ (pop-to-buffer tmp)
+ (ti::pmin))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-key-add-region-batch (beg end &optional noerr verb)
+ "Add all public keys in region to active keyring.
+The region is handled by PGP directly. No checkings are done here.
+
+Input:
+
+ BEG END region
+ NOERR if nil, then signal error if PGP reports error.
+ VERB allow verbose messages
+
+Interactive call:
+
+ The region is cecked for public key. If none exist offer using
+ whole buffer.
+
+Sets global:
+ `tinypgp-:return-value' pubring where the key was inserted
+
+Return:
+
+ string
+ nil no keys were added"
+
+ (interactive
+ (progn
+ (ti::compat-activate-region) ;Make sure user sees region
+ ;; Check this before going further
+ (if (null (ti::mail-pgp-public-key-p (point-min)))
+ (error "No public key area in buffer"))
+ (ti::i-macro-region-ask
+ "No region selected, use whole buffer for key insert? ")))
+
+ (tinypgpd "tinypgp-key-add-region-batch in: pring"
+ tinypgp-:pubring-now (current-buffer) )
+
+ (let* ((tinypgp-:pubring-now tinypgp-:pubring-now) ;make local copy
+ (logical-cmd 'key-add)
+ (bcmd (tinypgp-binary-get-cmd logical-cmd)) ;;base command
+ (copy (tinypgp-ti::temp-buffer))
+ (buffer (tinypgp-ti::temp-buffer 'shell))
+ (i 0)
+ cmd
+ pring
+ ret)
+
+ (ti::verb)
+ (tinypgpd "tinypgp-key-add-region-batch in:"
+ (current-buffer) beg end bcmd cmd )
+
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. . verbose part ..
+ ;; Many times there may be old region active and user doesn't
+ ;; realize that,. Do little check first...
+
+ (when verb
+ (when (and (not (ti::narrow-safe beg end
+ (ti::mail-pgp-public-key-p (point-min))))
+ (y-or-n-p
+ (concat
+ "Can't find public key block in region.. "
+ "Use full buffer [C-g to abort]")))
+ (setq beg (point-min) end (point-max)))
+
+ (if (setq pring (tinypgp-pubring-ask))
+ (setq tinypgp-:pubring-now pring)))
+
+ ;; Only now can we compose the command: pubring is known or
+ ;; set by user.
+ ;;
+ (setq tinypgp-:return-value tinypgp-:pubring-now)
+ (setq cmd (tinypgp-cmd-compose bcmd nil nil '(nil)))
+
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. do it ..
+ (tinypgp-do-shell-env
+ (save-window-excursion
+ (append-to-buffer copy beg end)
+ (append-to-buffer buffer beg end)
+ (with-current-buffer buffer
+;;; (pop-to-buffer (current-buffer)) (ti::d! 12345)
+ ;; Remove spaces: "intended PGP key", but only if there is
+ ;; only one key. Ignore "chop" if there is multiple keys.
+ ;;
+ (ti::pmin)
+ (while (re-search-forward (ti::mail-pgp-pkey-begin-line) nil t) (incf i))
+ (if (eq 1 i) (ti::mail-pgp-chop-region (point-min) (point-max)))
+
+ ;; If there is error situation, the "after" hook runs.
+ (tinypgp-mode-specific-control-before logical-cmd)
+
+ (shell-command-on-region ;This shows the buffer, gawk!
+ (point-min) (point-max) (format "%s " cmd) buffer))))
+
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. results ..
+ (setq ret (tinypgp-binary-get-result-key-add))
+ (when (and verb ret)
+ (message "Key add note: %s" ret))
+
+ (when (and (stringp ret)
+ (string-match "error" ret))
+ (if noerr
+ (setq ret nil)
+ (tinypgp-error ret)))
+
+ (when (and (stringp ret)
+ (string-match "No keys found" ret))
+ (setq ret nil))
+
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-key-add-region-interactive (beg end)
+ "Parse BEG END and ask if key should be added to the active keyring."
+ (interactive (ti::i-macro-region-ask))
+ (tinypgpd "tinypgp-key-add-region-interactive in: pring"
+ tinypgp-:pubring-now (current-buffer) beg end )
+ (let ((data (ti::mail-pgpk-public-get-region
+ nil nil tinypgp-:buffer-tmp-shell))
+ (verb (interactive-p))
+ id
+ pkey)
+;;; trust
+
+ (tinypgp-unfinished-function)
+ (cond
+ ((null data)
+ (if verb
+ (message
+ "'Key for user ID:' tags not found to signify public key blocks.")))
+ (t
+ (dolist (elt data)
+ (setq id (nth 0 elt) pkey (nth 1 elt))
+ (cond
+ ((null pkey)
+ (ti::read-char-safe
+ (format "Public key empty: %s" (or id "<id not known>"))))
+
+ ((y-or-n-p (format"Add: %s" id))
+;;; (setq trust (tinypgp-key-trust-ask id))
+ (with-current-buffer (tinypgp-ti::temp-buffer)
+ (insert pkey)
+ (tinypgp-key-add-region-batch (point-min) (point-max))
+ (error "#todo trust not set."))))))
+
+)));;; ----------------------------------------------------------------------
+;;; Called by TM.el
+;;;
+(defun tinypgp-key-extract-to-point-current-user ()
+ "Extract `tinypgp-:user-now' key to current point."
+ (tinypgp-key-extract-to-point tinypgp-:user-now))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-key-extract-to-point (string &optional raw noerr)
+ "Insert public key matching STRING to current point.
+
+Note:
+
+ If Pgp extracts file to some temporary file, that file will be deleted
+ automatically, because the key will be available from emacs buffer.
+ This prevents temporary files accumulating in your tmp directory.
+ Also the line that containbs sentence
+
+ Key extracted to file '/users/xxx/junk/pgptemp.$07'.
+
+ is removed from the shell output buffer before yanking.
+
+References:
+
+ `tinypgp-:buffer-tmp-shell'
+
+Input:
+
+ STRING string to search
+ RAW only insert the PGP block
+ NOERR if non-nil no error is signalled is string is not found,
+ also the output is _not_ inserted to the current point,
+ but returned.
+
+Return:
+
+ string
+ nil"
+ (interactive
+ (list
+ (read-from-minibuffer "Insert public key matching: " tinypgp-:user-now)
+ current-prefix-arg))
+
+ (barf-if-buffer-read-only)
+ (tinypgpd "tinypgp-key-extract-to-point in: pring" tinypgp-:pubring-now )
+ (let* ((fid "tinypgp-key-extract-to-point:")
+ (bcmd (tinypgp-binary-get-cmd 'key-extract))
+ (out (tinypgp-ti::temp-buffer 'shell))
+
+ cmd
+ kring
+ ret)
+
+ (tinypgpd fid "in:" (current-buffer) string noerr )
+
+ (unless (setq kring (tinypgp-key-find-by-keyrings string))
+ (error "No PGP key for '%s'" string))
+
+ (tinypgpd fid "cmd,out,kring" cmd out kring )
+
+ (tinypgp-save-state-macro
+ (setq tinypgp-:pubring-now kring)
+ (setq cmd (tinypgp-cmd-compose bcmd nil nil '(nil)))
+ (setq cmd (format "%s '%s'" cmd string)))
+
+ (tinypgp-do-shell-env (shell-command cmd out))
+
+ (with-current-buffer out
+ (ti::pmin)
+ (when (and (null (setq ret (ti::mail-pgp-pkey-read raw 'kill-file)))
+ (null noerr))
+ ;; Remove cache entry, maybe user has moved the key
+ ;; to another keyring?
+ ;;
+ (tinypgp-key-cache-remove-entry string)
+ (pop-to-buffer out)
+ (error "\
+PGP error; Maybe cache has old keyring information? Check cache.")))
+
+ (when (and ret
+ (null noerr))
+ (insert ret))
+
+ (tinypgpd fid "out:" ret )
+
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-key-delete-region (beg end &optional mode plist verb)
+ "Remove all keys from keyring that are found from region.
+The picked key items are:
+o all email addresses
+o All regular pgp key lines \"pub 512/47141D35 1996/06/03 ...\"
+
+In interactive or verb mode, all removed KeyId's used are marked
+with overlays after command completes. Overlays have property '(owner tinypgp)
+
+Input:
+ BEG END
+ MODE nil = key id 0x based deletion
+ 1 or 'email = key id email based deletion
+ 2 or 'any = both methods used.
+ PLIST list of pubring filenames to touch.
+ Interactive call:
+ all public keyring are stepped through;
+ permission to use the pubring is asked from user.
+ Lisp call:
+ If this list oi nil, active pubring is used
+ VERB Enable verbose asking/message mode.
+
+If VERB is non-nil, error is generated if it happens. if VERB is nil,
+then the possible error string is returned."
+ (interactive
+ (let* ((plist (list tinypgp-:pubring-now))
+ (kring (or (tinypgp-key-ring-at-point 'alias)
+ (tinypgp-pubring-file2alias tinypgp-:pubring-now)))
+ ans
+ reg)
+ (if (not (region-active-p))
+ (error "Region not selected.")
+ (setq reg (ti::i-macro-region-ask)))
+
+ (setq
+ ans
+ (tinypgp-pubring-complete
+ (format
+ (concat
+ "%sDel keys from all prings or one ring? "
+ "[empty=all] ")
+ (cond
+ ((eq 1 current-prefix-arg) "@: ")
+ ((eq 2 current-prefix-arg) "0x@: ")
+ ((eq nil current-prefix-arg) "0x: ")
+ (t
+ (error "No such prefix arg mode"))))
+ kring))
+
+ (if (not (ti::nil-p ans))
+ (setq plist (list (tinypgp-pubring-alias2file ans)))
+ (setq plist (tinypgp-pubring-list)))
+
+ (list
+ (nth 0 reg) (nth 1 reg)
+ current-prefix-arg
+ plist)))
+
+ (tinypgpd "tinypgp-key-delete-region in: " beg end mode plist verb )
+ (let* ((buffer-orig (current-buffer))
+ (BCMD (tinypgp-binary-get-cmd 'key-delete)) ;base command
+ (delete-count 0)
+ buffer
+ buffer-shell
+ bcmd
+ cmd
+ list1 list2 email-list keyid-list
+ elt elt2
+ err err1 err2
+ permission)
+
+ (ti::verb)
+ ;; #todo: use comint to delete keys ?
+ ;;
+;;; (error "PGP can't use batch mode...needs new implementation.")
+
+ (tinypgpd "tinypgp-key-delete-region in: BCMD " BCMD)
+ (if (null plist) ;Set default value
+ (setq plist tinypgp-:pubring-now))
+
+ (setq plist (ti::list-make plist)) ;make sure it is list
+
+ (if (and verb
+ (not (y-or-n-p
+ "TinyPgp: are you sure about this (region right)? ")))
+ (error "Aborted."))
+
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... ... narrow ...
+ ;; We narrow so that highlighting finds right matches
+ ;;
+ (ti::narrow-safe beg end
+ (tinypgp-run-in-tmp-buffer nil
+ (cond ;Gather key-ids first
+ ((memq mode '(nil 2 any))
+ (setq keyid-list
+ (ti::mail-pgpk-id-0x-lines-in-region (point-min) (point-max))))
+ ((memq mode '(1 email))
+ (setq email-list (tinypgp-email-find-region (point-min) (point-max))))
+ (t
+ (error "Unknown mode %s" mode))))
+
+ (and verb (tinypgp-highlight 'delete-all))
+
+ (tinypgp-do-shell-env
+ (tinypgp-save-state-macro
+ (setq buffer (tinypgp-ti::temp-buffer)
+ buffer-shell (tinypgp-ti::temp-buffer 'shell))
+ (with-current-buffer buffer
+ (dolist (pring plist)
+
+ (setq tinypgp-:pubring-now pring)
+ (setq list1 email-list list2 keyid-list)
+
+ (tinypgpd "email-list" list1 "keyid-list" list2)
+
+ ;; ... ... ... ... ... ... ... ... ... ... ... . user-ask ..
+ (when (and verb
+ (not (string= "!" (or permission ""))))
+ (setq permission
+ (read-from-minibuffer
+ (format
+ (concat
+ "Keyring %s "
+ "[ret=ok, !=all, s=skip]: ")
+ (file-name-nondirectory pring)))))
+
+ ;; ... ... ... ... ... ... ... ... ... ... user-response ..
+ (while (and
+ (member permission '("!" ""))
+ (null err)
+ (or list1 list2))
+ (setq elt nil elt2 nil)
+ (setq bcmd (tinypgp-cmd-compose BCMD nil nil '(nil)))
+ ;; ... ... ... ... ... ... ... ... ... ... ... .. email ..
+ (when list1
+ (setq elt (pop list1))
+ (when elt
+ (setq cmd (format "%s '%s'" bcmd elt))
+ (shell-command cmd buffer-shell)
+ (tinypgpd "tinypgp-key-delete-region shell: " cmd )
+ (incf delete-count)
+ ;;
+ ;; "Key not found in keyring"
+ ;; But that's no error and we don't report it.
+ ;;
+ (setq err1 (tinypgp-binary-check-error 'ignore-output cmd))
+ (when (and verb err1) (tinypgp-error err1))))
+
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... . 0x ..
+ (when list2
+ (setq elt2 (pop list2))
+ (when (stringp elt2)
+ (setq cmd (format "%s '0x%s'" bcmd elt2))
+ (shell-command cmd buffer-shell)
+ (incf delete-count)
+ (tinypgpd "tinypgp-key-delete-region shell: " cmd )
+ (setq err1 (tinypgp-binary-check-error 'ignore-output cmd))
+ (when (and verb err2) (tinypgp-error err2))))
+
+ (tinypgpd "tinypgp-key-delete-region do: " pring
+ elt elt2 err1 err2 )
+
+ ;; Highlight the line so that user sees it was processed.
+ ;;
+ (if (and verb (or elt elt2))
+ (with-current-buffer buffer-orig
+ (if elt (tinypgp-highlight elt))
+ (if elt2 (tinypgp-highlight elt2 nil nil 'region))))))))
+
+)) ;; ... ... ... ... ... ... ... ... ... ... ... ... ... ... message ...
+ (when (and verb (null err))
+ (cond
+ ((zerop delete-count)
+ (message "TinyPgp: Hm. It appears that no keys were found to delete."))
+ (t
+ (message "TinyPgp: Deleted keys have been marked with color. [%d]"
+ delete-count))))
+
+ (when (and verb
+ (setq err (tinypgp-binary-get-result-key-remove buffer-shell)))
+ (pop-to-buffer buffer-shell)
+ (error "TinyPgp: Key remove problem; remove manually "))
+
+ err))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-key-sign-1 (your-keyid her-keyid &optional noerr)
+ "Sign key-id to current pubring.
+
+Input:
+ YOUR-KEYID HER-KEYID NOERR"
+ (tinypgpd "tinypgp-key-sign-1 in: " your-keyid her-keyid noerr )
+ (let* ((BCMD (tinypgp-binary-get-cmd 'key-sign)) ;base command
+ (bcmd (tinypgp-cmd-compose BCMD nil nil '(nil)))
+ (buffer-shell (tinypgp-ti::temp-buffer 'shell))
+ stat
+ cmd)
+ (tinypgp-unfinished-function)
+ (setq cmd (format "%s %s" bcmd your-keyid her-keyid))
+ (error "#todo") (ti::d! (ti::string-right cmd 50))
+ (shell-command cmd buffer-shell)
+
+ ;; #todo: check results of signing
+ ;;
+ (if (setq stat (tinypgp-binary-get-result-key-sign))
+ stat stat)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-key-sign-0x-forward (&optional verb)
+ "Sign current 0x key forward. VERB.
+The lines must contain valid key info entry extracted from pubring."
+ (interactive)
+ (let (keyid
+ line)
+ (error "#todo")
+ (tinypgpd "tinypgp-key-sign-0x-forward in:")
+ (ti::verb)
+
+ (when (and (ti::mail-pgp-re-search 'kpub)
+ (setq keyid (match-string 1)))
+ (setq line (buffer-substring (match-end 0) (line-end-position)))
+
+ (if (or (null verb)
+ (and verb
+ (y-or-n-p
+ (format "Sign key %s , %s: " line keyid ))))
+ (tinypgp-save-state-macro
+ (tinypgp-user-in-use-confirm
+ (tinypgp-key-sign-1 tinypgp-:user-now keyid)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-key-mode-set-trust (mode)
+ "Set the trust MODE on current key/email in the line or point."
+ (interactive "*r")
+ (let* ()
+ (cond
+ ((eq mode 'undefined))
+ ((eq mode 'untrusted))
+ ((eq mode 'marginal))
+ ((eq mode 'complete)))))
+
+;;}}}
+;;{{{ PGP main code
+
+;;; ............................................................. &pgp ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-delete-processes (&optional verb)
+ "Kill all PGP processes found from `process-list'. VERB."
+ (interactive)
+ (let* ((count 0))
+ (ti::verb)
+ (dolist (elt (process-list))
+ (when (string-match "pgp" (prin1-to-string elt))
+ (incf count)
+ (delete-process elt)))
+ (if verb
+ (message "TinyPgp: %d processes deleted" count))
+
+ ;; Return t if processes were deleted.
+ (not (eq count 0))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-signature-user-info ()
+ "Return User's X-Pgp information.
+
+References:
+ `tinypgp-:xpgp-user-info'
+
+Return:
+ nil
+ string"
+ (let ((ret (if (stringp tinypgp-:xpgp-user-info)
+ tinypgp-:xpgp-user-info
+ (eval tinypgp-:xpgp-user-info))))
+ (if (ti::nil-p ret)
+ nil
+ ret)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-signature-move-to-header (&optional just-delete no-cnv)
+ "Move Normal PGP signature to email headers.
+If there is no PGP signature info, do nothing.
+Works for read-only buffers too.
+
+You can call this function only after you have composed the
+message and attached the normal PGP signature.
+
+Input:
+ JUST-DELETE delete Normal PGP signature: do not move.
+ NO-CNV Do not convert '- -' to '-' when deleting old signature."
+ (tinypgpd "tinypgp-signature-move-to-header in:" just-delete)
+ (let* (buffer-read-only
+ (fid "tinypgp-signature-move-to-header:")
+ (hlist tinypgp-:header-sign-smf-info)
+ (psig "X-Pgp-Signed")
+
+ data
+ hdr-smf
+ user-info
+ sig-fld
+
+ sig-list
+ info-list
+ fld
+ str)
+
+ (when (and (null just-delete)
+ (setq data ;only if there is PGP
+ (save-excursion
+ (ti::pmin) (ti::mail-pgp-signature-normal-info))))
+ (setq hdr-smf (if hlist
+ (concat
+ "SignedHeaders="
+ (mapconcat
+ 'concat
+ (nth 1 tinypgp-:header-sign-smf-info)
+ ", ")
+ ";")))
+
+ (tinypgpd fid "DATA" data
+ "HDR-SMF" hdr-smf tinypgp-:header-sign-smf-info)
+ ;; moving signature in buffer is not really a modification
+ ;;
+ (with-buffer-modified
+ (ti::save-with-marker-macro
+ (setq info-list (nth 1 data)
+ sig-list (nth 2 data))
+
+;;; (setq I info-list S sig-list)
+;;; (ti::d! I B E)
+
+ (tinypgpd fid "INFO-LIST" info-list "SIG-LIST" sig-list)
+
+ (unless just-delete
+ (setq user-info (tinypgp-signature-user-info))
+
+ (dolist (elt info-list)
+ ;; For each PGP id, we just use that ID as
+ ;; additional header name.
+ ;;
+ (when (string-match "\\(.*\\):[ \t]+\\(.*\\)" elt)
+ (setq fld (match-string 1 elt)
+ str (match-string 2 elt))
+
+ (if (string-match "Version\\|Charset" fld)
+ (setq sig-fld (format "%s%s=%s; "
+ (or sig-fld "")
+ fld str)))))
+
+ (setq sig-fld (format "%sSignature=\n" sig-fld))
+
+ (dolist (elt sig-list)
+ ;; Last one Must have terminating colon
+ ;;
+ (if (null (cdr sig-list))
+ (setq sig-fld (format "%s \"%s\";\n" sig-fld elt))
+ (setq sig-fld (format "%s \"%s\"\n" sig-fld elt))))
+
+ (tinypgpd fid "SIG-FLD" sig-fld)
+
+ (setq str
+ (concat (if user-info (concat user-info "\n " ) " ")
+ (if hdr-smf
+ ;; Fit in the same line?
+ ;;
+ (cond
+ ((< (+ (length hdr-smf) (length sig-fld))
+ ;; If there is no user info, then
+ ;; these fields go directly after
+ ;; X-Pgp-Signed: (value 60)
+ ;;
+ (if user-info 77 60))
+ (concat hdr-smf sig-fld "\n "))
+
+ ((< (length hdr-smf) 40)
+ (concat hdr-smf " \n " sig-fld))
+
+ (t
+ (concat "\n " hdr-smf "\n " sig-fld)))
+ sig-fld)))
+ (ti::mail-add-field psig str)))))
+
+ ;; We can do this without knowing if there is PGP sig,
+ ;; The previous statements already got rid of it
+ ;; Remove the traditional signature.
+ ;;
+ (ti::mail-pgp-signature-remove nil no-cnv)
+
+ (tinypgpd fid "out: hooks" tinypgp-:sig-to-header-hook)
+
+ (if tinypgp-:sig-to-header-hook
+ (run-hook-with-args-until-success 'tinypgp-:sig-to-header-hook))))
+
+;;; ----------------------------------------------------------------------
+;;; The parameter 'delete' is optional, because
+;;; - we may want to convert Headers to INFO block
+;;; - do something when the block is there
+;;; remove that blocka.
+;;;
+;;; And we don't have no Moving back to headers.
+;;;
+(defun tinypgp-signature-from-header (&optional just-delete)
+ "Convert X-Pgp signature to regular PGP signature.
+
+Input:
+ JUST-DELETE do not move but delete header signature info."
+ (let* ((fid "tinypgp-signature-from-header:" )
+ (pbase "X-Pgp-")
+ (sig-b-line (ti::mail-pgp-re (ti::mail-pgp-signature-begin-line)))
+ (sig-e-line (tinypgp-cnv (ti::mail-pgp-signed-end-line)))
+ buffer-read-only
+
+ data
+ hdr-smf
+ sig-list
+ info-list
+ beg
+ end)
+
+ (tinypgpd fid "in:" "DEL FLAG" just-delete )
+
+ (cond
+ (just-delete
+ ;; Old v2.xx x-pgp standard
+ ;;
+ (setq sig-list '("^X-Pgp-Charset" "^X-Pgp-Version"
+ "^X-Pgp-Signed" "^X-Pgp-Comment"))
+ (dolist (elt sig-list) (ti::mail-kill-field elt))
+ (ti::mail-pgp-signature-remove))
+
+ ((setq data (ti::mail-pgp-signature-header-info))
+ (tinypgpd fid "X-pgp" data)
+ (ti::save-with-marker-macro
+ (ti::mail-pgp-signature-remove 'add)
+ (setq beg (car (nth 0 data)) ;headers are here
+ end (cdr (nth 0 data))
+ info-list (nth 1 data)
+ sig-list (nth 2 data))
+
+ (ti::pmin)
+ (when (setq hdr-smf (tinypgp-header-sign-make-smf 'xpgp))
+ (ti::mail-text-start 'move)
+ (forward-line 2)
+ (insert (car hdr-smf)))
+ (re-search-forward sig-b-line)
+
+ (forward-line 1)
+ ;; There must be absolutely nothing after it.
+ ;;
+ (delete-region (point) (point-max))
+
+ (unless just-delete
+;;; (insert sig-b-line "\n")
+ (dolist (elt info-list)
+ (setq elt (replace-regexp-in-string (concat "^" pbase) "" elt))
+ (insert elt "\n"))
+
+ (insert "\n") ;blank line
+ (dolist (elt sig-list) (insert elt "\n"))
+
+ (insert sig-e-line "\n"))
+
+;;; (ti::d! "DEL" beg end delete)
+
+ (if (and beg end)
+ (delete-region beg end)
+ ;; v3.xx has only one heder field
+ (ti::mail-kill-field "^X-Pgp-signed"))
+
+ (run-hooks 'tinypgp-:sig-from-header-hook))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-signature-move-to-header-maybe (&optional verb)
+ "If current mode is mail or news then move signature to header.
+But only if this is not a remailer message.
+
+Input:
+ VERB Verbose messages.
+
+References:
+ `tinypgp-:xpgp-signing-mode'
+ `tinypgp-:header-sign-table' ,overrides all"
+ (tinypgpd "tinypgp-signature-move-to-header-maybe in:")
+
+ (let* ((fid "tinypgp-signature-move-to-header-maybe:")
+ elt
+ (tinypgp-:xpgp-signing-mode ;take local copy
+ tinypgp-:xpgp-signing-mode)
+ (allowed (tinypgp-mail-buffer-p))
+ (remail (or (ti::mail-pgp-remail-p)
+ tinypgp-:r-mode-indication-flag))
+
+ (do-it tinypgp-:xpgp-signing-mode)
+ (count (tinypgp-hash 'sign 'get 'sign-remind-counter nil 'global)))
+ (tinypgpd fid "ALLOWED" allowed "DO" do-it "REMAIL" remail)
+
+ (when (and
+ allowed do-it
+ (null remail)
+ (if (setq elt (tinypgp-header-sign-active-list))
+ (null (nth 2 elt)) ;if this entry is NIL then proceed
+ t))
+
+ (tinypgp-signature-move-to-header nil 'no-cnv)
+
+ (when verb
+ (unless (integerp count)
+ (setq count 0)
+ (tinypgp-hash 'sign 'put 'sign-remind-counter 0 'global))
+
+ (incf count)
+ ;;
+ ;; Display message every 5th time
+ ;;
+ (when (eq 0 (% count 5))
+ (setq count 0)
+ (message
+ (concat
+ "Do not modify buffer, otherwise "
+ "PGP signature must be generated again.")))
+ (tinypgp-hash 'sign 'put 'sign-remind-counter count 'global)))
+ (tinypgpd fid "out:")))
+
+;;}}}
+;;{{{ secring management
+
+;;; ......................................................... &secring ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-secring-file ()
+ "Return current backends secring."
+ (or (cdr (assq (tinypgp-backend-now) tinypgp-:file-secring ))
+ (error "No secring in tinypgp-:file-secring")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-crypt-command-get (from to password)
+ "Return 'crypt' command for files FROM TO using PASSWORD."
+ ;; Store to property so that we don't have to ask it again
+ ;;
+ (let* ((fid "tinypgp-crypt-command")
+ (sym 'tinypgp-:pgp-binary)
+ crypt)
+ (unless (setq crypt (get sym 'crypt))
+ (setq crypt (or (executable-find "crypt")
+ (error "Can't find 'crypt' on `exec-path'.")))
+ (put sym 'crypt crypt))
+ (unless (and (stringp from) (stringp to) (stringp password))
+ (error "Invalid crypt command parameters."))
+
+ (tinypgpd fid crypt from to)
+ (format "%s %s < %s > %s" crypt password from to)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-crypt-do-with-pgp (from to password &optional comment)
+ "Use PGP to conventionally crypt file.
+
+Input:
+
+ FROM source file
+ TO destination file
+ PASSWORD crypt password
+ COMMENT the +comment string. Default is
+ 'FILE is conventionally encrypted.'
+ Set to \"\" if you don't want comment.
+
+Note:
+
+ If the FROM file is pgp armored, it will be assumed that it is already
+ encrypted conventionally and that it should be restored. If the file
+ has no ascii armor, then it will be crypted.
+
+ So, depending on input file, the file is either locked or unlocked.
+ You don't get double conventional encryption if you specify FROM
+ as already crypted file."
+ (let* ((fid "tinypgp-crypt-do-with-pgp")
+ (buffer (tinypgp-ti::temp-buffer 'shell))
+ (opt tinypgp-:pgp-command-options)
+ (pgp-exe (tinypgp-binary1 'crypt))
+
+ ;; in case there is error these hooks are called to
+ ;; restore buffer. But because this function deals with
+ ;; files; no emacs buffer is involved. Prevent
+ ;; calling these functions.
+ ;;
+ tinypgp-:cmd-macro-after-hook
+ encrypted-p
+ cmd
+ err)
+
+ (tinypgpd fid "in:" from to "comment:" comment)
+
+ (if (not (file-exists-p from))
+ (error "no FROM file"))
+
+ (if (file-exists-p to)
+ (delete-file to))
+
+ (or (stringp comment)
+ (setq comment
+ (format "Conventionally crypted %s" from)))
+
+ ;; We have to know if the file is already crypted to select right
+ ;; command. We only read part of the file to determine if it has ascii
+ ;; armor
+
+ (with-current-buffer buffer
+ (insert-file-contents from nil 0 300)
+ (setq encrypted-p (ti::mail-pgp-re-search 'msg))
+ (erase-buffer))
+
+ (tinypgpd fid "ENCRYPTED stat" encrypted-p)
+
+ ;; cat T | pgp +comment="Crypted secring.pgp" -caf -z foo > T.asc
+ ;; cat T.asc | pgp -f -z foo > T
+
+ (cond
+ (encrypted-p
+ (setq cmd (format
+ "%s %s | %s -f -z %s %s +batch > %s "
+ (if (ti::win32-p) "type " "cat ")
+ from
+ pgp-exe
+ password
+ opt
+ to))
+ (tinypgpd fid "CRYPT --> regular ."))
+ (t
+ (setq cmd (format
+ "%s %s | %s -caf -z %s %s +batch %s > %s"
+ (if (ti::win32-p) "type " "cat ")
+ from
+
+ pgp-exe
+ password
+ opt
+ (if (not (ti::nil-p comment))
+ (format "+comment=\"%s\"" comment)
+ "")
+ to))
+ (tinypgpd fid "REGULAR --> crypt" cmd)))
+
+ (setq tinypgp-:last-pgp-exe-command cmd)
+ (shell-command cmd buffer)
+ (when (setq err (tinypgp-binary-check-error 'ignore-output))
+ (tinypgp-error err)
+ err)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-crypt-do-with-crypt (from to password)
+ "Crypt FROM source TO destination using PASSWORD using 'crypt'."
+ ;;
+ ;; Maybe I add something here later.
+ ;; It's too bad that we can't check if the (de)crypting was done
+ ;; with right password. The 'crypt' command won't tell success or
+ ;; failure so be _sure_ you type it right in the prompt.
+ ;;
+ (tinypgpd "tinypgp-crypt-do-with-crypt" from to)
+ (shell-command (tinypgp-crypt-command-get from to password)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-crypt-do (from to password)
+ "Crypt FROM source TO destination using PASSWORD."
+ (funcall tinypgp-:secring-crypt-function from to password))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-ask-secring-password (&optional force)
+ "Ask secring password. Return old or FORCE asking again."
+ (let* ((sym 'tinypgp-:hash)
+ (ret (get sym 'secring-passwd)))
+ (when (or force (null ret))
+ (setq ret (ti::compat-read-password "Password for secring: "))
+ (put sym 'secring-passwd ret))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-secring (&optional set)
+ "Return secring from memory or set secring from current buffer.
+SET can be
+ 'kill Empty secring from memory
+ non-nil read buffer content into memory as secring
+ nil return secring from memory."
+
+ (cond
+ ((null set)
+ (get 'tinypgp-:hash 'secring))
+ ((eq set 'kill)
+ (put 'tinypgp-:hash 'secring nil))
+ (t
+ (put 'tinypgp-:hash 'secring (buffer-string)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-secring-use ()
+ "Make sure we have secring available."
+ (let* ((fid "tinypgp-secring-use")
+ (secring (tinypgp-secring-file))
+ (enc tinypgp-:file-secring-encrypted)
+ pass)
+ (tinypgpd fid)
+ (when (not (file-exists-p secring)) ;Ahem, it's encrypted...
+
+ (if (not (file-exists-p enc)) ;Nope, something is very wrong here
+ (error "Panic, no secring! Pull out your backup..."))
+
+ (cond
+ ((and (file-exists-p enc) ;In memory
+ (tinypgp-secring))
+ (tinypgpd fid "Write")
+ (tinypgp-secring-crypt-read nil 'write))
+ ((and (file-exists-p enc)
+ (null (tinypgp-secring))) ;Not in Memory
+ (tinypgpd fid "read & rrite")
+ (setq pass (tinypgp-ask-secring-password))
+ (tinypgp-secring-crypt-read pass)
+ (tinypgp-secring-crypt-read nil 'write))))))
+
+;;; ----------------------------------------------------------------------
+;;; Why I dind't use PGP? because I can't control to what file it
+;;; produces the output. It always writes to .pgp or .asc (-a) and
+;;; that not very friendly.
+;;;
+(defun tinypgp-secring-crypt (password &optional decrypt)
+ "Conventionally encrypt secrig with PASSWORD secring.
+This function doesn't use PGP, but calls external 'crypt' command.
+If DECRYPT is non-nil, move encrypted secring back.
+
+Caution: Make backup first. This fuction deletes or modifies the
+secring.pgp !!
+
+References:
+ `tinypgp-:file-secring-encrypted'"
+ (interactive
+ (list
+ (ti::compat-read-password
+ (format "[%s] Secring password: "
+ (if current-prefix-arg "decrypt" "encrypt")))
+ current-prefix-arg))
+ (let* ((fid "tinypgp-secring-crypt")
+ (from (if decrypt
+ tinypgp-:file-secring-encrypted
+ (tinypgp-secring-file)))
+ (to (if decrypt
+ (tinypgp-secring-file)
+ tinypgp-:file-secring-encrypted)))
+ (tinypgpd fid "in:" decrypt from to)
+ (if (not (file-exists-p from))
+ (error "Fatal condition, no file: %s" from))
+
+ ;; If this fails; then we can't execute crypt command that
+ ;; overwrites file.
+ ;;
+ (if (file-exists-p to)
+ (delete-file to))
+
+ (tinypgp-crypt-do from to password)
+
+ (if (interactive-p)
+ (message "Secring %s"
+ (if decrypt
+ "decrypted"
+ "encrypted")))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-secring-crypt-read (&optional password write force)
+ "Read encrypted secring, open it, and put to to memory.
+If file already exists in memory, do nothing.
+
+Input:
+
+ PASSWORD password string
+ WRITE write secring from memory to (tinypgp-secring-file)
+ FORCE If non-nil force reading encrypted secring to memory"
+ (let* ((fid "tinypgp-secring-crypt-read")
+ (secring (tinypgp-secring-file))
+ (from tinypgp-:file-secring-encrypted)
+ (to tinypgp-:file-source))
+ (tinypgpd fid (if write "WRITE" "READ") force)
+ (cond
+ (write
+ (if (null (setq from (tinypgp-secring)))
+ (error "Read secring first to memory."))
+ (with-temp-buffer
+ (erase-buffer)
+ (insert from)
+ (tinypgp-secring 'read-to-memory)
+ (write-region (point-min) (point-max) secring)))
+ (t
+ ;; ........................................................ read ...
+ (when (or (not (tinypgp-secring))
+ (null force))
+ (unless (file-exists-p from)
+ (error "There is no encrypted secring."))
+
+ (if (file-exists-p to)
+ (delete-file to))
+
+ (tinypgp-crypt-do from to password)
+
+ (unwind-protect
+ (progn
+ (with-temp-buffer
+ (erase-buffer)
+ (insert-file-contents to)
+ (if (ti::buffer-empty-p)
+ (error "No results after opening encrypted secring?"))
+ (tinypgp-secring 'read-to-memory)))
+ (tinypgp-file-control 'source-kill)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-secring-crypt-maybe ()
+ "Make encrypted secring if it doesn't exist already."
+ (unless (file-exists-p (tinypgp-secring-file))
+ (call-interactively 'tinypgp-secring-crypt)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-secring-kill-maybe ()
+ "Kill secring.pgp if there is encrypted keyring.
+`tinypgp-:secring-crypt-mode' must be non-nil too."
+ (when (and tinypgp-:secring-crypt-mode
+ (file-exists-p (tinypgp-secring-file)))
+ (delete-file (tinypgp-secring-file))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-secring-restore-maybe ()
+ "Restore (tinypgp-secring-file) if there is encrypted keyring.
+If there already is (tinypgp-secring-file) then do nothing."
+ (unless (file-exists-p (tinypgp-secring-file))
+ ;; - Be sure that there exists encrypted secring in the disk
+ ;; - We may have the secring in the memory, but nevertheless
+ ;; I must require that is also in disk.
+ ;;
+ (when (or (file-exists-p tinypgp-:file-secring-encrypted)
+ (error "Can't find encrypted scring?"))
+ (tinypgp-secring-crypt (tinypgp-ask-secring-password) 'restore))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-secring-backup (file password &optional verb)
+ "Backup (tinypgp-secring-file) in crypted format to FILE with PASSWORD.
+Previous FILE is deleted. VERB."
+ (interactive
+ (progn
+ (let* ((default-directory (concat (tinypgp-path ".") "/")))
+ (list
+ (read-file-name "Backup secring to: ")
+ (ti::compat-read-password "Backup password: ")))))
+ (let* ((from (tinypgp-secring-file)))
+ (ti::verb)
+ (unless (file-exists-p from)
+ (error "There is no secring to be backed up."))
+ (if (file-exists-p file) (delete-file file))
+
+ (prog1
+ (tinypgp-crypt-do from file password)
+ (if (not (file-exists-p file))
+ (error "Couldn't make backup."))
+ (if verb
+ (message "TinyPgp: secring backup done.")))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-secring-crypt-mode-detect ()
+ "Set correct `tinypgp-:secring-crypt-mode'."
+ (if (and tinypgp-:secring-crypt-mode
+ (not (file-exists-p tinypgp-:file-secring-encrypted)))
+ (setq tinypgp-:secring-crypt-mode nil))
+
+ ;; If mode is off; then this condition must be true
+ ;; - there must be secring.pgp
+ ;; - there must not be secring.enc
+
+ (if (null tinypgp-:secring-crypt-mode)
+ (cond
+ ((file-exists-p tinypgp-:file-secring-encrypted)
+ (setq tinypgp-:secring-crypt-mode t))
+ ((or (not (file-exists-p (tinypgp-secring-file) )) ;; .pgp missing
+ (file-exists-p tinypgp-:file-secring-encrypted)) ;; .enc found
+ (error "Fatal, no secring.pgp or secring.enc found."))))
+ tinypgp-:secring-crypt-mode)
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-secring-crypt-expire-password (&optional verb)
+ "Reset the secring password so that you can change it. VERB.
+The password is set once when you turn on crypt mode
+with `tinypgp-secring-crypt-mode-toggle' and it never chages during the
+lifetime of program.
+
+However if you want to change the password; you must
+o turn off the crypt mode
+o call this function
+o turn on the crypt mode"
+ (ti::verb)
+;;; (or (tinypgp-secring-crypt-mode-detect)
+;;; (error
+;;; (substitute-command-keys
+;;; "\
+;;;Can't expire secring password: Use \\[tinypgp-secring-crypt-mode-toggle]")))
+;;;
+
+ (let* ((pass (get 'tinypgp-:hash 'secring-passwd)))
+ (if (stringp pass) (fillarray pass ?\0))
+ (put 'tinypgp-:hash 'secring-passwd nil)
+ (when verb
+ (message "TinyPgp: Secring Password expired."))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-secring-crypt-mode-toggle (arg &optional verb)
+ "Toggle using crypted secring.
+
+Input:
+
+ ARG Mode arg. nil = toggle, 0 = off, 1 = on.
+ VERB If non-nil, print verbose messages.
+
+Caution
+
+ Before turning on this mode make backup of your keyring removable media.
+ Prefer ancrypting that backup too, otherwise you have defeated the
+ purpose of this mode by letting people to access your secring
+ in some other readable file. See command \\[tinypgp-secring-backup]
+
+ See also \\[tinypgp-secring-crypt-expire-password]
+
+Description
+
+ When this mode is enabled. You secring is immediately moved to
+ conventionally encrypted format if it already isn't crypted.
+ The ecrypted secring is located at `tinypgp-:file-secring-encrypted'
+ and (tinypgp-secring-file), `Secring' , is deleted.
+
+ When programs needs the secring it temporarily opens the encrypted
+ secring and write to `Secring'. When the PGP operation
+ that needed secring is over, the `Secring' is removed.
+
+ If you are in multi-user environment, be aware that all your files
+ are propable taped due to regular backups in the file system.
+ Thus your PGP keys are available to the sysadm.
+
+ And even if your're in single user environment, somebody may sit
+ down to your computer console and copy the secring.pgp withing
+ seconds.
+
+ If you're paranoid at all, you keep this mode permanently on by
+ setting `tinypgp-:secring-crypt-mode' to t.
+
+Files
+
+ When you turn on the mode the `Secring' is deleted and
+ encrypted `tinypgp-:file-secring-encrypted'. When you turn off this
+ mode reverse happens and `Secring' is restored.
+
+Note
+
+ Turning on or off this mode causes a slight delay because
+ the command to encyprt or decypt the password is called.
+
+ While the mode is active, you cannot use all pgp commands
+ from the shell command prompt because there is no secring.pgp
+ directly available. Eg. if you want to generate new key, which
+ modifies secring; you should turn off this mode to temprarily
+ reveal secring.pgp.
+
+Return:
+ value of `tinypgp-:secring-crypt-mode'"
+ (interactive "P")
+ (let* ((fid "tinypgp-secring-crypt-mode-toggle")
+ old-mode)
+
+ (ti::verb)
+ (tinypgpd fid "in:" arg)
+ (setq old-mode (tinypgp-secring-crypt-mode-detect))
+ (ti::bool-toggle tinypgp-:secring-crypt-mode arg)
+ (tinypgpd fid "ARG" arg "MODE" old-mode tinypgp-:secring-crypt-mode verb)
+
+ ;; If MODE was ON; and we were called with parameter 1,
+ ;; then do nothing; because mode hasn't changed.
+
+ (when (not (eq old-mode tinypgp-:secring-crypt-mode))
+ ;; When mode is turned off
+ ;; o Remove secring from memory, because user may now change it
+ ;; on disk.
+ ;; When mode is on
+ ;; o Read it from disk to memory. Secring is nor in encrypted
+ ;; format on disk.
+
+ (cond
+ (tinypgp-:secring-crypt-mode
+ ;; Display messages so that user doesn't get nervous. This
+ ;; may take 1-3 seconds.
+ ;;
+ (when verb (message "Secring conversion in progress...2"))
+ (tinypgp-secring-crypt (tinypgp-ask-secring-password))
+ (tinypgp-secring-kill-maybe)
+ (when verb (message "Secring conversion in progress...1"))
+ (tinypgp-secring-crypt-read (tinypgp-ask-secring-password)))
+ (t
+ (when verb (message "Secring conversion in progress..."))
+ (tinypgp-secring-restore-maybe)
+ ;; We must delete this
+ ;; o In many places program checks if this exist; but because
+ ;; mode is off it should not be used. Safest is to destroy it.
+ ;; o If user starts adding new secret keys; he turns this mode off
+ ;; --> he should see just regular secring.pgp and not get confused
+ ;; by secring.enc
+ ;;
+ (delete-file tinypgp-:file-secring-encrypted)
+ (tinypgp-secring 'kill))))
+
+ (tinypgp-secring-crypt-mode-detect)
+
+ (when verb
+ (message
+ (concat "TinyPgp: SECRING encrypt mode: "
+ (if tinypgp-:secring-crypt-mode
+ "on" "off")
+ (if (null tinypgp-:secring-crypt-mode)
+ (concat ". "
+ (file-name-nondirectory
+ (tinypgp-secring-file))
+ " restored")))))
+
+ (tinypgp-update-modeline)
+ tinypgp-:secring-crypt-mode))
+
+;;}}}
+;;{{{ interactive, guess next action
+
+;;; .................................................... &guess-action ...
+
+;;; ----------------------------------------------------------------------
+;;; - If you have used vc.el, then you know why this function ....
+;;;
+(defun tinypgp-next-action-mail (&optional arg)
+ "Try to guess next action. ARG is passed to called function.
+If buffer has auto action active or if function cannot guess what
+to do, this command does nothing.
+
+In mail buffer,
+
+o If buffer is read-only, try to decrypt it. We suppose that the
+ buffer is used by some mail reader.
+o -- Check if there is only one email in TO field. If the
+ user is cached (you have previously encrypted message to him),
+ then ask permission to encrypt the message.
+ -- Sign the message
+
+In some other buffer:
+
+o If not signed, sign.
+o If signed, verify and if that reveals inner folders, open them all.
+o If encrypted, decrypt. (Mail buffers are ignored, because you can't
+ decrypt other users encrypted message.)
+
+Prefix argument:
+
+o Is passed to decrypt command"
+ (interactive "P")
+ (tinypgpd "tinypgp-next-action-mail in:" arg)
+ (let ((auto-action-pending (and (not buffer-read-only)
+ (tinypgp-auto-action-p)
+ (tinypgp-hash 'auto-action 'get 'user-mode)))
+ (fid "tinypgp-next-action-mail: ")
+ pring
+ to
+ type)
+
+ (tinypgpd fid "auto action:" auto-action-pending )
+
+ (cond
+ (auto-action-pending
+ (message "TinyPgp.el ...note, auto action is pending."))
+ (t
+ (cond
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... regular ..
+ ((not (ti::mail-mail-p)) ;not a mail buffer
+ (tinypgpd fid "non-mail buffer start:")
+
+ (cond
+ ((not (ti::mail-pgp-signed-p))
+ (tinypgpd fid "regular not pgp-signed:")
+ (tinypgp-sign-region (point-min) (point-max)))
+
+ ((ti::mail-pgp-signed-p)
+
+ (tinypgpd fid "regular signed:")
+ (while (or (if (ti::mail-pgp-signed-p) (setq type 'sign))
+ (if (ti::mail-pgp-p) (setq type 'other)))
+ (tinypgpd fid "regular; envelope" type)
+
+ (cond
+ ((eq type 'sign)
+ (tinypgp-verify-region (point-min) (point-max)))
+ ((eq type 'other)
+
+ ;; When we verify message...
+ ;; a) an encrypted message envelope surfaces
+ ;; b) it was base64 signed -> regular text
+ ;; c) signed
+
+ (tinypgp-decrypt-region
+ (point-min) (point-max)
+ (car (tinypgp-i-args-decrypt)))))))))
+
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... ... mail ..
+
+ ((ti::mail-mail-p)
+ (setq to (mail-fetch-field "to"))
+
+ (tinypgpd fid "mail: to" to
+ "see pgp? " (ti::mail-pgp-p)
+ "multi ,? " (count-char-in-string ?, (or to "")))
+
+ (cond
+ ((and (not buffer-read-only)
+ (not (ti::nil-p to)) ;; Must have TO email
+ (null (ti::mail-pgp-p)) ;; No PGP yet, okay...
+ (eq (count-char-in-string ?, to) 0) ;; only one email?
+ (setq to (car-safe (ti::mail-email-from-string to)))
+ ;; Have we sent encrypted mail to him?
+ ;;
+ (setq pring (tinypgp-key-find-by-cache to)))
+ (tinypgpd fid "mail: 1 encrypt")
+ (tinypgp-save-state-macro
+ (setq tinypgp-:pubring-now pring)
+ (call-interactively 'tinypgp-encrypt-mail)))
+
+ ((and (ti::mail-pgp-signed-p)
+ (ti::mail-pgp-encrypted-p 'double-check))
+ (tinypgpd fid "mail: verify/decrypt")
+ (call-interactively 'tinypgp-verify-mail)
+ (sit-for 1.7) ;let user see "Good signature..."
+ (tinypgp-decrypt-mail-verbose (quote arg)))
+
+ ((and (null buffer-read-only)
+ (not (ti::mail-pgp-headers-p))
+ (not (ti::mail-pgp-signed-p)))
+ (tinypgpd fid "mail: sign")
+ (call-interactively 'tinypgp-sign-mail))
+
+ ((and (ti::mail-pgp-signed-p)
+ (not (ti::mail-pgp-encrypted-p 'message-tag-too)))
+ (tinypgpd fid "mail: 3")
+ (call-interactively 'tinypgp-verify-mail))) ;Cond end
+
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. ..
+ ;;
+ ;; Still pgp ? Maybe we should decrypt it ?
+ ;; But what if this is mail that is meant to be sent to
+ ;; someone else --> we assume that non-read-only buffer
+ ;; is mail to someone else
+ ;;
+ ;; This is looped two times because:
+ ;; - Nym account sends use [ENCRYPT [conventional CRYPT]] envelope
+ ;; - Loop1 open CRYPT envelope and the second loop checks
+ ;; is there was still real encrypted message (by your nym key)
+ ;;
+ ;; but I don't dare...2 envelopes should suffice.
+
+ (while (and buffer-read-only
+ (not (ti::mail-pgp-signed-p))
+ (ti::mail-pgp-p))
+ (tinypgpd fid "mail: still pgp")
+ (tinypgp-decrypt-mail-verbose (quote arg)))
+
+ (goto-char (ti::mail-text-start))))))))
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... mail end ..
+
+;;}}}
+;;{{{ signing
+
+;;; ......................................................... &signing ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-sign-modify-check ()
+ "Detect if signed message is modified.
+References:
+ `tinypgp-:sign-data'"
+ (let* ((mail (ti::mail-mail-p))
+ (mime (ti::mail-mime-maybe-p)))
+ (when (and mail
+ (not mime)
+ (ti::mail-pgp-headers-p)
+ (tinypgp-sign-data-same-p))
+ (message "TinyPgp: Body changed, signature invalid; resigning...")
+ (sit-for 0.7)
+ (tinypgp-sign-loose-info)
+ (call-interactively 'tinypgp-sign-mail))
+
+ (tinypgpd "sign-modify-check:" (current-buffer) "MAIL" mail "MIME"
+ (ti::mail-message-length)
+ tinypgp-:sign-data)
+ ;; hook return value
+ nil))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-sign-mail-auto-p ()
+ "Check if auto signing would happen."
+ (and tinypgp-mode
+ (not (ti::mail-pgp-signed-p))
+ (not (ti::mail-mime-maybe-p))
+ (null tinypgp-:r-mode-indication-flag)
+ (or (null tinypgp-:sign-mail-p-function)
+ (funcall tinypgp-:sign-mail-p-function))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-sign-mail-func ()
+ "Maybe sign current buffer. This function is called from hooks.
+If buffer is already signed or remailer action is in progress,
+do nothing.
+
+References:
+ `tinypgp-:sign-mail-p-function'"
+ (if (inline (tinypgp-sign-mail-auto-p))
+ (call-interactively 'tinypgp-sign-mail)))
+
+;;; ----------------------------------------------------------------------
+;;; on/off function can be used in hooks
+;;;
+(defun tinypgp-sign-mail-auto-mode-on ()
+ "Turn on automatic signing."
+ (tinypgp-sign-mail-auto-mode 1))
+
+(defun tinypgp-sign-mail-auto-mode-off ()
+ "Turn off automatic signing."
+ (tinypgp-sign-mail-auto-mode 0))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinypgp-sign-mail-auto-mode (&optional arg)
+ "Toggle autosigning mode according to ARG.
+
+Input:
+ 0, -1 off
+ nil toggle
+ t, 1 on
+
+ 'push-on Record previous value and turn on auto signing.
+ 'push-off Record previous value and turn off auto signing.
+ 'pop pop previous autosign value.
+
+Return:
+ nil autosigning off
+ non-nil autosigning on"
+ (interactive)
+ (let* ((fid "tinypgp-sign-mail-auto-mode")
+ (stack (get 'tinypgp-sign-mail-auto-mode 'stack))
+ (func 'tinypgp-sign-mail-func)
+ (hooks tinypgp-:mail-send-hook-list)
+ (now-on-p (tinypgp-sign-mail-auto-mode-on-p))
+ remove)
+
+ (tinypgpd fid arg)
+
+ ;; ......................................................... stack ...
+ (when (and (not (null arg))
+ (symbolp arg))
+ (cond
+ ((eq arg 'push-on)
+ (push now-on-p stack)
+ (setq arg 1))
+
+ ((eq arg 'push-off)
+ (push now-on-p stack)
+ (setq arg 0))
+
+ ((eq arg 'pop)
+ (if (not (ti::listp stack))
+ (error "Nothing to pop from stack.")
+ (setq arg (car stack))
+ (setq stack (cdr stack))))
+ (t
+ (error "Not known arg")))
+ (put 'tinypgp-sign-mail-auto-mode 'stack stack))
+
+ (tinypgpd fid arg "STACK" stack)
+
+ ;; ...................................................... mode arg ...
+ (cond
+ ((null arg)
+ (if now-on-p
+ (setq remove t)))
+
+ ((memq arg '(0 -1))
+ (setq remove t)))
+
+ (ti::add-hooks hooks func remove)
+ (tinypgp-update-modeline)
+
+ (if (interactive-p)
+ (message
+ (format
+ "TinyPgp: mail auto signing mode %s"
+ (if remove "off" "on"))))
+
+ remove))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinypgp-sign-loose-info (&optional verb)
+ "Loose signature info.
+Input:
+ VERB Verbose messages."
+ (interactive)
+ (let* (tinypgp-:sig-to-header-hook ;must be disabled for now
+ (allow (tinypgp-mail-buffer-p)))
+ (ti::verb)
+ (when (and allow
+ (ti::mail-pgp-headers-p))
+ (ti::mail-kill-field "X-Pgp-Signed"))
+ (ti::save-with-marker-macro
+ (tinypgp-signature-from-header 'just-delete))
+
+ (when (and verb (null allow))
+ (message "PGP action maybe partially completed...") (sit-for 2))
+
+ (run-hooks 'tinypgp-:sign-loose-info-hook)
+ (if verb
+ (message "PGP signing information deleted."))
+ t))
+
+;;; ----------------------------------------------------------------------
+;;; - parameters BEG and END _must_ be nil
+;;;
+;;;###autoload
+(defun tinypgp-sign-mail (&optional register user options verb noxpgp)
+ "Sign message in mail buffer.
+
+Input:
+
+ REGISTER flag, if non-bil store the signature to register.
+ This is the prefix arg user passes to program.
+ This will automatically turn off X-pgp.
+ USER key-id
+ VERB allow verbose messages
+ NOXPGP Prohibit X-Pgp
+
+Notes:
+
+ if VERB is non-nil (set in interactive call), the pubring is
+ changed if it the information is on the cache."
+ (interactive
+ (progn
+ (tinypgp-hash 'action 'put 'now 'sign 'global)
+ (tinypgp-hash 'action 'put 'detail 'mail 'global)
+
+ (tinypgpd "tinypgp-sign-mail: interactive")
+
+ (tinypgp-user-change-macro
+ (list
+ current-prefix-arg
+ tinypgp-:user-now
+ (eval tinypgp-:pgp-binary-interactive-option)
+ t
+ current-prefix-arg))))
+
+ (barf-if-buffer-read-only)
+ (tinypgp-i-args-pass-phrase)
+
+ (let* ((fid "tinypgp-sign-mail: ")
+ (tinypgp-:pubring-now tinypgp-:pubring-now)
+ (signed-p (ti::mail-pgp-signed-conventional-p))
+ (signed-xpgp-p (ti::mail-pgp-signed-xpgp-p))
+ (signed-multi-p (ti::mail-pgp-signed-conventional-multi-p))
+ (mail-p (ti::mail-mail-p))
+ (write-point (point))
+ beg
+ write-mark
+ write-line
+ write-col
+ sign-user
+ buffer
+ hdr-smf
+ pring
+ end)
+
+ (ti::verb)
+ (tinypgp-hash 'action 'put 'now 'sign 'global)
+ (tinypgp-hash 'action 'put 'detail 'mail 'global)
+
+ (tinypgpd fid "signed" signed-p signed-xpgp-p signed-multi-p
+ "mail-p" mail-p
+ "User:" user verb
+ (current-buffer)
+ (buffer-name))
+
+ ;; Note: It sis very unfortunate that the signature separator
+ ;; is "-- ". Thazt extra space will be gone below, because we trim
+ ;; the message before signing it.
+ ;;
+ ;; To my opinion it's more important to trim the message than
+ ;; preserve trailing spaces at the end of lines.
+
+ (tinypgp-add-signature-if-signing)
+ (ti::mail-trim-buffer)
+
+ (ti::mail-pgp-header-kill-in-body)
+
+ ;; Actually; someone else could have signed using X-pgp,
+ ;; and when we sign the message, the Right Thing would be
+ ;; - check if X-pgp is ours --> remove it. If not, then convert
+ ;; it to regular pgp signature.
+ ;; - add out signing (if there is regular signature, then
+ ;; do ot use X-pgp)
+
+ (when signed-xpgp-p (tinypgp-sign-loose-info))
+
+ (save-excursion
+ (goto-char (if mail-p
+ (ti::mail-text-start)
+ (point-min)))
+ (setq beg (point)))
+
+ (if (or (eq beg (point-max))
+ (and mail-p ;Check only mail buffer
+ (save-excursion
+ (goto-char (or beg (point-min)))
+ ;; there must be text, not just emptly lines
+ ;;
+ (null (re-search-forward "[^ \t\n]" nil t)))))
+ (error "Nothing to do, no text found."))
+
+ (tinypgp-save-state-macro
+ ;; Turn this off if buffer is not mail or if there already is signature
+ (when (or (not mail-p)
+ signed-p)
+ (setq tinypgp-:xpgp-signing-mode nil))
+
+ (when verb
+ (if (null (setq pring (tinypgp-key-find-by-cache tinypgp-:user-now)))
+ (tinypgp-pubring-in-use-confirm)
+ (setq tinypgp-:pubring-now pring)))
+
+ (tinypgpd fid "PRING NOW" tinypgp-:pubring-now pring)
+
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... tmp buffer ...
+
+ (tinypgp-mode-specific-control-before 'sign tinypgp-:user-now)
+
+ (tinypgp-run-in-tmp-buffer nil
+ (tinypgp-user-change-macro
+ (tinypgp-set-session-parameters 'sign)
+
+ (goto-char write-point)
+ (setq buffer (current-buffer)
+ sign-user tinypgp-:user-now ;Save this value
+ write-mark (point-marker)
+ write-line (ti::read-current-line)
+ write-col (current-column))
+ ;; ............................................ do signing ...
+;;; (ti::d! "::sign do" tinypgp-:pubring-now)
+ (tinypgp-cmd-macro-email "sign"
+ (cond
+ ((and (ti::mail-mail-p)
+ (setq hdr-smf (tinypgp-header-sign-make-smf)))
+ (goto-char beg)
+ (insert (car hdr-smf))))
+
+ (tinypgp-cmd-macro 'sign user nil
+ "Signing..." register options 'no-mode-funcs)
+
+ ;; (pop-to-buffer (current-buffer)) (ti::d! "::sign done")
+
+ (tinypgp-signature-move-to-header-maybe verb)
+ (setq write-point (marker-position write-mark)
+ ;; kill marker
+ write-mark nil))))
+ ;; ........................................... signing end ...
+
+;;; (tinypgp-mode-specific-control-after 'sign tinypgp-:user-now nil nil nil)
+
+ ;; - Copy signed data to original buffer.
+ ;; - restore original write position: this is tricky because the
+ ;; buffer has changed: Search line string and goto column OR
+ ;; got to marker position.
+ ;;
+ (unless register
+ (erase-buffer)
+ (insert-buffer buffer)
+ (ti::pmin)
+ (if (and (not (ti::nil-p write-line)) ; can't search empty line
+ (search-forward write-line nil 'noerr))
+ (move-to-column write-col)
+ ;; This doesn't necessarily succeed to preserve position,
+ ;; but it's better than nothing.
+ ;;
+ (goto-char write-point)
+ ;; If this changes, signing is not valid
+ (tinypgp-sign-data-set)))
+
+ ;; ............................................. verbose message ...
+ (when verb
+ (message "%sSigned with key: %s"
+ (if register
+ (format "[Result in register %c] " tinypgp-:register)
+ "")
+ sign-user)
+ (sit-for 1))
+
+ t)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-sign-mail-base64 (&optional register )
+ "Uuencode message with pgp.
+Store output to `tinypgp-:register' if REGISTER is non-nil.
+This function turns off clearsig, so that mail is signed, compressed,
+and uuencoded in base64."
+ (interactive
+ (progn
+ (barf-if-buffer-read-only)
+ (list
+ current-prefix-arg)))
+ (tinypgp-i-args-pass-phrase "[Base64] Sign pass phrase: ")
+ (tinypgp-hash 'action 'put 'now 'sign 'global)
+ (let* ((beg (or (ti::mail-text-start) (point-min)))
+ (end (point-max)))
+ (if (eq beg end)
+ (error "TinyPgp: sign mase64, There is no text in message body."))
+ (tinypgp-sign-region-base64 beg end register nil (interactive-p))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-sign-base64-insert-file (file &optional options)
+ "Insert uuencoded FILE into point using OPTIONS.
+This function inserts the given file into point and turns
+off clearsig, so that the file is signed, compressed, and uuencoded
+in base64.
+
+It is encouraged that insert big files with this function
+to the buffer when you're going to send them via email."
+ (interactive "*f[base64 sign] Insert file: ")
+ (let ((buffer (tinypgp-ti::temp-buffer 'finger)) ;This is free for us.
+ comment
+ size)
+ (barf-if-buffer-read-only)
+ (tinypgp-hash 'action 'put 'now 'sign 'global)
+ ;; Hm. This should be interactive part...
+ ;;
+ (tinypgp-i-args-pass-phrase)
+
+ ;; Insert file leaves point before the file, but we need to know
+ ;; where it ends...
+ ;;
+ (with-current-buffer buffer
+ (insert-file-contents file)
+
+ (unless options
+ (setq size (/ (buffer-size) 1000)) ;in kilos
+ (setq
+ comment
+ (format
+ "Base64 signed. File: %s uncompresses to approx. %s"
+ (file-name-nondirectory file)
+
+ (if (eq 0 size) ;Hm. very small file
+ (format "%dbytex" (buffer-size))
+ (format "%dK" size)))))
+
+ ;; In Unix we pass the option directly to pgp.
+ ;; This way UNDO can undo whole PGP response at once
+ ;;
+ (when (and comment (not (ti::win32-p)))
+ (setq options (format "+comment=\"%s\"" comment)))
+
+ (tinypgp-sign-region-base64 (point-min) (point-max) nil options)
+
+ ;; But in Windows we have to manually patch the genrated output.
+ ;; You have to ress twice UNDO to get original text
+
+ (when (and comment
+ (or (not (tinypgp-backend-pgp2-p))
+ (ti::win32-p)))
+ (tinypgp-binary-header-field-set "Comment:" comment))
+
+ (ti::pmin)
+ (run-hook-with-args-until-success
+ 'tinypgp-:insert-file-sign-base64-hook
+ file))
+ (insert-buffer buffer)
+ ;; It may be big file, don't leave into emacs
+ (ti::erase-buffer buffer)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-sign-region-base64
+ (beg end &optional register options verb )
+ "Sign as base64 (uuencode).
+
+Input:
+
+ BEG END
+ REGISTER if non-nil; then store contents to `tinypgp-:register'
+ OPTIONS option string passed to pgp.
+ VERB Verbose messages.
+
+This function turns off clearsig, so that region is signed,
+compressed, and uuencoded in base64."
+ (interactive
+ (progn
+ (barf-if-buffer-read-only)
+ (list
+ (region-beginning) (region-end)
+ current-prefix-arg)))
+ (ti::verb)
+ (barf-if-buffer-read-only)
+ (tinypgp-i-args-pass-phrase "Region Sign base64 pass phrase:" )
+
+ (tinypgp-hash 'action 'put 'now 'sign 'global)
+ (tinypgp-hash 'action 'put 'detail 'base64 'global)
+
+ (let* ((orig-opt options)
+ (comment
+ (concat
+ "base64 signed. "
+ "run signature verify to to dearmor to clear text. ")))
+
+ (when (and (null orig-opt) (not (ti::win32-p)))
+ (setq options (format "+comment=\"%s\"" comment)))
+
+ ;; Add user options to the end
+ ;;
+ (setq options (concat "+clearsig=off " options))
+ (tinypgp-sign-region beg end verb options nil register )
+
+ (when (and (null orig-opt) (ti::win32-p))
+ (tinypgp-binary-header-field-set "Comment:" comment)))
+
+ (if (and verb register)
+ (message
+ (substitute-command-keys
+ (format
+ (concat
+ "Results in register `%c'. View it with "
+ "\\[tinypgp-view-register]")
+ tinypgp-:register)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-sign-mail-mime ()
+ "Sign buffer as PGP/MIME using SEMI or TM.
+Function activates mime mode if needed."
+ (interactive)
+
+ (unless (ti::re-search-check mail-header-separator)
+ (error "Tinypgp: MPGP/MIME Must have mail buffer."))
+
+ (tinypgpd "tinypgp-sign-mail-mime: MIME-P" (ti::mail-mime-feature-p))
+
+ (when (ti::mail-mime-feature-p)
+ (ti::mail-mime-turn-on-mode))
+
+ (unless (ti::mail-mime-sign-region)
+ (error "Can't sign PGP/MIME. TM or SEMI is not active."))
+
+ (ti::mail-mime-turn-off-mode))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-sign-mail-detached ()
+ "Create detached signature to register `tinypgp-:register' using PASSWORD."
+ (interactive)
+ (tinypgp-i-args-pass-phrase "Detach sign password: ")
+ (let* ((beg (ti::mail-text-start))
+ (end (point-max)))
+ (if (eq beg end)
+ (error "TinyPgp: sign detached, There is no text in message body."))
+ (tinypgp-sign-region-detached beg end (interactive-p))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-sign-region-detached
+ (beg end &optional verb options noerr)
+ "Put detached signature to register `tinypgp-:register'.
+
+Input:
+
+ BEG END region
+ VERB verbose messages
+ OPTIONS additional option string for PGP
+ NOERR do not call error
+
+Note:
+ If verb is non-nil, correct keyring containing the key is
+ first set according to `tinypgp-:user-now' before signing."
+ (interactive
+ (progn
+ (if (null (region-active-p))
+ (error "region not active"))
+ (list
+ (region-beginning)
+ (region-end)
+ t
+ nil)))
+
+ (let* ((fid "tinypgp-sign-region-detached:"))
+ (ti::verb)
+ (tinypgp-i-args-pass-phrase "Region detach sign pass phrase: ")
+ (tinypgpd fid "in:" beg end verb options noerr)
+
+ (tinypgp-hash 'action 'put 'now 'sign 'global)
+ (tinypgp-hash 'action 'put 'detail 'detach 'global)
+
+ ;; This is an ugly hack, but the previous SIGN options are replaced
+ ;; with the new ones. User options are added before -bfast.
+
+ (setq options (format "%s %s" (or (eval options) "")
+ (if (tinypgp-backend-pgp2-p)
+ " -bfast "
+ " -b -atv ")))
+
+ (set-register tinypgp-:register nil) ;Clear it
+
+ (tinypgp-sign-region beg end verb options nil 'register 'as-is)
+
+ (if verb
+ (message "Detached signature in register '%s'"
+ (char-to-string tinypgp-:register)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinypgp-sign-region
+ (beg end &optional verb options noerr register as-is)
+ "Sign region.
+
+Input:
+
+ BEG END ints, region
+ VERB flag, verbose messages
+ OPTIONS string, flags to add to the real pgp command.
+ NOERR flag, return nil or t only
+ REGISTER flag, save results to register
+ AS-IS flag, if non-nil. no buffer modification is done.
+ Normally would delete whitespaces at the end of lines.
+"
+ (interactive
+ (progn
+ (barf-if-buffer-read-only)
+ (if (null (region-active-p))
+ (error "region not active"))
+ (list
+ (region-beginning)
+ (region-end)
+ t
+ nil
+ nil
+ current-prefix-arg)))
+
+ (let ((fid "tinypgp-sign-region:")
+ ret)
+ (barf-if-buffer-read-only)
+ (tinypgp-i-args-pass-phrase "Sign region pass phrase:")
+
+ (tinypgp-hash 'action 'put 'now 'sign 'global)
+ (tinypgp-hash 'action 'put 'detail 'region 'global)
+
+ (unless as-is
+ (ti::buffer-trim-blanks beg end)) ;EOL whitespace strip
+
+ (tinypgpd fid "in:" beg end verb options)
+
+ (tinypgp-save-state-macro
+ (tinypgp-user-change-macro
+ (cond
+ ((null noerr)
+ (tinypgp-set-pgp-env-macro tinypgp-:user-now 'verb
+ (tinypgp-cmd-macro 'sign tinypgp-:user-now nil
+ "Signing..." register options))
+ (setq ret t))
+
+ (t
+ (ignore-errors
+ (tinypgp-set-pgp-env-macro tinypgp-:user-now 'verb
+ (tinypgp-cmd-macro 'sign tinypgp-:user-now nil
+ "Signing..." register options))
+ (setq ret t))))))
+
+ (when ret
+ (tinypgp-key-cache-update)
+ (tinypgp-sign-data-set))
+
+ ret))
+
+;;}}}
+;;{{{ interactive, verifying
+
+;;; ....................................................... &verifying ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-verify-maybe-fetch-key (status-string)
+ "If verify fails, asks if we should try to fetch key.
+
+Input:
+ STATUS-STRING ,the result of verify
+
+Return:
+ t ,if key fetch tried.
+ nil"
+ (let* ((fid "tinypgp-verify-maybe-fetch-key:")
+ (tinypgp-:find-by-guess-hook (copy-list tinypgp-:find-by-guess-hook))
+ key-id)
+ ;; We already tried these methods, there is finger
+ ;; and http left
+ (setq tinypgp-:find-by-guess-hook
+ (delq
+ 'tinypgp-key-find-by-cache
+ (delq
+ 'tinypgp-key-find-by-keyrings-verbose
+ tinypgp-:find-by-guess-hook)))
+
+ (when (setq key-id
+ (ti::string-match "ID \\([^ \t]+\\) not found"
+ 1 status-string))
+
+ ;; Key matching expected Key ID C4AF0331 not found in file
+ ;; '/home/xxx/.pgp/pubring.pgp'.
+
+ (tinypgpd fid "status" status-string key-id)
+
+ (when (y-or-n-p
+ (format "Can't verify: fetch key for %s ? "
+ key-id))
+ (tinypgp-key-find-by-guess key-id)
+ t))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-verify-region (beg end &optional no-replace verb)
+ "Verify message in region.
+
+If signature is good and there is some PGP message inside it,
+say encrypted to you, then message is replaced
+with the output of PGP. In short: message is unpacked.
+
+If there is no PGP, this function does nothing.
+
+Input:
+
+ BEG END region which is feed to PGP. If both are nil, then whole
+ buffer is used.
+
+ NO-REPLACE If non-nil prefix argument, the result is put into
+ register instead. RBEG and REND are replace position beg
+ and end points. They default to BEG and END. These
+ arguments are useful if you feed whole buffer to PGP but
+ want the replace tho happen only in cerating region.
+ VERB Verbose messages
+
+References:
+ `tinypgp-:verify-before-hook'
+ `tinypgp-:verify-after-hook'"
+ (interactive "r")
+ (tinypgpd "tinypgp-verify-region in:" no-replace verb)
+
+ (let* ((cmd (tinypgp-binary-get-cmd 'verify))
+ (fid "tinypgp-verify-region: ")
+ (sig-holder (ignore-errors
+ (or (car-safe
+ (ti::mail-email-from-string
+ (mail-fetch-field "from")))
+ ;; Maybe this is mail message that user has
+ ;; just signed and he want to varify it himself
+ tinypgp-:user-now)))
+ (do-it t)
+ stat
+ region
+ pring
+ msg
+ ret
+;;; stat
+ info)
+
+ (ti::verb)
+
+ (tinypgp-hash 'action 'put 'now 'verify 'global)
+ (tinypgp-hash 'action 'put 'no-replace no-replace 'global)
+
+ (setq msg (if verb
+ "Verifying signature..."
+ nil))
+
+ (if (null (ti::mail-pgp-p))
+ (if verb (message "No PGP tags found."))
+
+ (run-hook-with-args-until-success
+ 'tinypgp-:verify-before-hook 'verify beg end)
+
+ ;; Because we have our own hooks, we can use the
+ ;; command macro, because if we'd call it see what happens:
+ ;;
+ ;; V-B-hook
+ ;; macro (macro-B-hook macro-E-hook)
+ ;; V-E-hook
+ ;;
+ ;; The macro-E-hook would e.g. cease rmail-edit-mode
+ ;; already. That's why we don't use the macro here at all.
+
+ (tinypgpd fid "verb sig-holder" verb sig-holder "BEG" beg end )
+
+ (tinypgp-save-state-macro
+ (when (and verb sig-holder)
+ (if (or (setq pring (tinypgp-key-find-by-keyrings
+ (tinypgp-key-id-conversion sig-holder)))
+ ;; Hmmm, User's email weren't found, find HEX key-id
+ ;; from base64 signature them. This is slower way
+ ;;
+ (and (setq info (ti::mail-pgp-stream-forward-and-study t))
+ (setq sig-holder
+ (concat "0x"
+ (ti::mail-pgp-stream-data-elt
+ info 'key-id)))
+ (setq pring
+ (tinypgp-key-find-by-keyrings
+ (tinypgp-key-id-conversion sig-holder)))
+ (message "\
+Need From addr -- key-id conversion: use `tinypgp-email-substitution-add'")
+ (sit-for 5)))
+ (setq tinypgp-:pubring-now pring)
+ (tinypgpd fid "--Can't find key-id from keyrings")
+ (if (null
+ (setq
+ do-it
+ (y-or-n-p
+ (format "Can't find %s from keyrings, call pgp anyway?"
+ sig-holder))))
+ (setq stat (format "ID %s not found" sig-holder)))))
+
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. . action ..
+ (when do-it
+ (tinypgpd fid "DO-IT" cmd beg end (current-buffer))
+ (setq cmd (tinypgp-cmd-compose cmd nil))
+ (if (or (tinypgp-backend-pgp2-p)
+ (tinypgp-backend-gpg-p))
+ (setq ret (tinypgp-binary-do-command-region
+ cmd beg end (current-buffer) msg 'string))
+ (setq ret (tinypgp-binary-do-command-region-with-expect
+ cmd beg end (current-buffer) msg 'string))))
+
+ ) ;;save-state
+
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. result . .
+
+ ;; Was it encrypted + signed message? The result removes
+ ;; the signature around the region
+ ;;
+ (cond
+ (no-replace
+ (if verb
+ (setq ret "Good signature. Results unpacked to register.")))
+ (t
+ (cond
+ ((save-excursion ;Normal PGP signing
+ (ti::mail-hmax 'move)
+ (setq region
+ (or
+ (ti::mail-pgp-block-area 'signed)
+ ;; Base64 signed then
+ (ti::mail-pgp-block-area 'msg)))))
+ ((and (ti::mail-pgp-headers-p) ;X-Pgp signed message?
+ (save-excursion
+ (ti::mail-text-start 'move)
+
+ ;; Message is not yet verified if this is found
+ ;;
+ (not (re-search-forward "^--+BEGIN.*PGP" nil t))))
+ (setq region (cons (ti::mail-text-start) (point-max))))
+ (t
+ (error "\
+Cannot find PGP signature. Already verified or signature hidden?")))
+
+ (tinypgpd "REGION" region (current-buffer))
+
+ (delete-region (car region) (cdr region))
+ (goto-char (car region) )
+ (tinypgp-binary-insert-pointer-data ret 'beg)
+
+ (setq ret
+ (tinypgp-binary-get-result-using-function
+ 'tinypgp-binary-get-result-verify))
+
+;;; (setq stat (or (tinypgp-binary-get-result-verify-status) ""))
+ (when (and (null no-replace) (ti::mail-pgp-headers-p))
+ ;; We must remove the X-Pgp too.
+ ;;
+ (tinypgp-signature-from-header 'just-remove-all))))
+
+ (run-hook-with-args-until-success
+ 'tinypgp-:verify-after-hook 'verify beg end ret)
+
+ (setq stat (or stat
+ (tinypgp-binary-get-result-verify-status)
+ ""))
+ (cond
+ ((and verb (tinypgp-verify-maybe-fetch-key stat))
+ nil) ;Nothing more to do
+ (verb
+ (setq msg (or (tinypgp-binary-get-result-verify-status)
+ "<unknown verify status>"))
+ (if (fboundp tinypgp-:verify-message-function)
+ (funcall tinypgp-:verify-message-function msg)
+ (message msg)))))
+ (tinypgpd fid "out: " ret "stat" stat)
+
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-verify-detached-signature (file key-id &optional pring verb)
+ "Verify detached signature in current buffer against file on disk.
+
+Input:
+
+ FILE
+ KEY-ID If this string has '@' e.g. 'mister foo <qf@site.com>'
+ the key-id is automatically shortened to 'qf@site.com'.
+ PRING If nil; all pubrings are searched to contain key-id and if none
+ found, funtion calls error. The found keyring is used to call
+ pgp with option +pubring
+ VERB Verbose messages.
+
+Return:
+
+ nbr PGP error code
+ nil verify successfull.
+
+References:
+ `tinypgp-:buffer-tmp-shell' pgp response"
+
+ (interactive
+ (let* ((data (ti::mail-pgp-stream-forward-and-study 'search 'any))
+ (type (car data))
+ (key-id (and (eq type 'signed)
+ (ti::mail-pgp-stream-data-elt data 'key-id))))
+ (if (not (stringp key-id))
+ (error "Can't find key id from PGP stream?")
+ (setq key-id (concat "0x" key-id)))
+
+ (list
+ (read-file-name "Verify detach signed file: " nil nil t)
+ key-id)))
+ (let* ((fid "tinypgp-verify-detached-signature:")
+ out
+ status
+ email)
+ (ti::verb)
+ (tinypgp-hash 'action 'put 'now 'verify 'global)
+ (if (and (string-match "@" key-id)
+ (setq email (car-safe (ti::mail-email-from-string key-id))))
+ (setq key-id email))
+
+ (tinypgpd fid "in:" file key-id "OPT" pring verb)
+
+ (setq file (tinypgp-expand-file-name file))
+ ;; First we have to know in what pubring the key is in, because
+ ;; PGP needs pubring when it checks the key.
+ ;;
+ (or pring
+ (or (setq pring (tinypgp-key-find-by-cache key-id))
+ (setq pring (tinypgp-key-find-by-keyrings key-id)))
+ (error "Can't find '%s' from any pubring." key-id))
+ (tinypgpd fid "pring" pring)
+
+ (setq out (tinypgp-ti::temp-buffer 'shell))
+ (save-excursion (ti::pmin) (tinypgp-file-control 'source-write))
+
+ ;; call-process-region
+ ;; START END PROGRAM
+ ;; &optional DELETE DESTINATION DISPLAY
+ ;; &rest ARGS
+ ;;
+ ;; % pgp sig-file original-file
+ ;;
+ (setq
+ status
+ (call-process-region (point-min) (point-max) "pgp"
+
+ (not 'text-delete)
+ out
+ (not 'constant-display)
+
+ tinypgp-:file-source
+ file
+ (format "+pubring=%s" pring)))
+ (tinypgp-file-control 'source-kill)
+
+;;; (pop-to-buffer (current-buffer)) (ti::d! orig-file pring)
+;;; (pop-to-buffer out)
+
+ (if verb
+ (message (or (tinypgp-binary-get-result-verify-status)
+ (and (pop-to-buffer out)
+ "<unknown verify results>"))))
+
+ ;; Convert 0(pgp ok) to nil(lisp ok) return code
+ ;;
+ (if (eq 0 status)
+ nil
+ status)))
+
+;;; ----------------------------------------------------------------------
+;;; - parameters BEG and end _must_ be nil
+;;;
+(defun tinypgp-verify-mail (&optional no-replace verb)
+ "Verify message in mail buffer. See `tinypgp-verify-region' for more details.
+
+Input:
+ NO-REPLACE flag, store results to `tinypgp-:register'
+ VERB flag, display verbose messages"
+ (interactive "P")
+ (let ((fid "tinypgp-verify-mail:")
+ hidden
+ stat)
+
+ (ti::verb)
+ (tinypgp-hash 'action 'put 'now 'verify 'global)
+ (tinypgp-hash 'action 'put 'no-replace no-replace 'global)
+
+ (tinypgpd fid "in:" no-replace verb)
+
+ (when (tinypgp-hidden-p)
+ (tinypgp-hide 'show)
+ (setq hidden t))
+
+ (tinypgp-verify-region
+ nil nil ;it is not a good idea to pass region
+ no-replace
+ verb)
+
+ (setq stat (or (tinypgp-binary-get-result-verify-status)
+ ""))
+ (when (and (null no-replace)
+ (ti::mail-pgp-headers-p)
+ (not (string-match "bad\\|not found" stat)))
+ ;; We must remove the X-Pgp signed fields, if the status was ok
+ ;;
+ (tinypgp-signature-from-header 'just-delete))
+
+ (if hidden
+ (tinypgp-hide))))
+
+;;}}}
+;;{{{ interactive, encrypting
+
+;;; .......................................................... &encypt ...
+
+(defun tinypgp-encrypt-add-remailer-tag ()
+ "Add' Encrypted: PGP' remailer tag to the point in mail mode buffers."
+ (if (ti::mail-mail-mode-p)
+ (insert "::\nEncrypted: PGP\n\n")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-encrypt-allowed-check ()
+ "In certains situations it is not allowed to encrypt the mail message.
+Check those cases and call error."
+ (let* ()
+ (cond
+ ((and (tinypgp-nymserver-mail-p)
+ (or (string-match "," (or (mail-fetch-field "To") ""))
+ (mail-fetch-field "CC")))
+ (error "\
+Impossible to encrypt Nymserver mail to multiple recipients.")))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-encrypt-by-cache (string func &rest args)
+ "If the STRING is found from cache, encrypt with FUNC and ARGS.
+
+Return:
+ t
+ nil"
+ (tinypgpd "tinypgp-encrypt-by-cache: " string func args )
+ (let* ((pring (tinypgp-key-find-by-cache string)))
+ ;; # todo: not tested
+ (when pring
+ (tinypgp-save-state-macro
+ (setq tinypgp-:pubring-now pring)
+ (apply func args)
+ t))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-encrypt-mail-mime ()
+ "Sign buffer as PGP/MIME using SEMI or TM."
+ (interactive)
+
+ (unless (ti::re-search-check mail-header-separator)
+ (error "Tinypgp: PGP/MIME needs mail buffer."))
+
+ (tinypgpd "tinypgp-encrypt-mail-mime: MIME-P" (ti::mail-mime-feature-p))
+
+ (when (ti::mail-mime-feature-p)
+ (ti::mail-mime-turn-on-mode))
+
+ (unless (or (not (ti::mail-mime-feature-p))
+ (ti::mail-mime-encrypt-region))
+ (error "Can't encrypt PGP/MIME. TM or SEMI is not active."))
+ (ti::mail-mime-turn-off-mode))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-encrypt-mail-verbose (&optional arg)
+ "Call `tinypgp-encrypt-mail' like user would with ARG."
+ (eval
+ (`
+ (tinypgp-encrypt-mail
+ (,@ (tinypgp-encrypt-mail-i-args arg nil 'bquote))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-encrypt-mail-find-keyring (single &optional sign-pwd)
+ "Find keyring for SINGLE key-id and encrypt and optionally use SIGN-PWD."
+ (tinypgp-encrypt-mail single nil sign-pwd nil 'verb))
+
+;;; ----------------------------------------------------------------------
+;;; - parameters BEG and end _must_ be nil
+;;;
+;;;###autoload
+(defun tinypgp-encrypt-mail-sign
+ (single-or-list &optional no-replace sign-pwd options verb noerr)
+ "See `tinypgp-encrypt-mail'. Raise parameter 'sign'.
+SINGLE-OR-LIST NO-REPLACE SIGN-PWD OPTIONS VERB NOERR."
+ (interactive (tinypgp-encrypt-mail-i-args
+ current-prefix-arg
+ 'pwd))
+ (ti::verb)
+ (tinypgp-encrypt-mail
+ single-or-list no-replace sign-pwd options verb noerr))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-encrypt-mail-i-args (&optional arg pwd bquote)
+ "Read args for `tinypgp-encrypt-mail'.
+Input:
+ ARG prefix arg
+ PWD If non-nil, ask password
+ BQUOTE If you call this function in macro which uses ,@ you must
+ set this flag to non-nil"
+ (tinypgpd "tinypgp-encrypt-mail-i-args")
+
+ (list
+ (if bquote
+ ;; We need to protect this list or else Backquote
+ ;; tries to call first element as a function
+ ;;
+ (quote (tinypgp-i-args-read-email nil "Encrypt to: "))
+ (tinypgp-i-args-read-email nil "Encrypt to: "))
+ (or arg current-prefix-arg)
+ pwd
+ (if (null tinypgp-:r-mode-indication-flag)
+ (eval tinypgp-:pgp-binary-interactive-option))))
+
+;;; ----------------------------------------------------------------------
+;;; - parameters BEG and end _must_ be nil
+;;;
+;;;###autoload
+(defun tinypgp-encrypt-mail
+ (single-or-list &optional no-replace sign-flag options verb noerr)
+ "Encrypt mail buffer.
+
+Input:
+
+ SINGLE-OR-LIST List of key-ids. Interactive call reads To,CC,BCC.
+ NO-REPLACE prefix arg, store result to `tinypgp-:register'.
+ SIGN-FLAG if non-nil, sign at the same time as you encrypt.
+ OPTIONS Additional pgp option string.
+ VERB If non-nil, verbose messages.
+ NOERR If non-nil, do not call error.
+
+Function call note:
+
+ [interactive]
+ In case the EMAIL address you're sending doesn't have entry in your
+ keyring, but you know that person has a PGP public key, then
+ please remove the email address prior calling this function and
+ it will prompt you a string to match for USER.
+
+ If this function is called interactively, it tries to set right
+ pubring by querying cache and other keyrings (user prompted)
+ Also the `tinypgp-:pgp-binary-interactive-option' is suppressed if
+ `tinypgp-:r-mode-indication-flag' is non-nil
+
+ Normally the To field's address is read and used for encryption.
+ However, if you are _on_ line that has email address in format
+ <foo@site.com> then your are asked if you want to use this email
+ instead. You can complete between this and To address.
+
+ [when called as lisp function]
+ Be sure to take precaution when passing OPTIONS if the message is
+ sent to remailer. Any extra keyword, like 'Comment:'
+ may reveal your identity.
+
+ SINGLE-OR-LIST is not processed with `tinypgp-key-id-conversion'.
+ You should call it manually if you want to respect user's
+ substitution definitions.
+
+ [Genenal note]
+ If there are multiple recipiens in the To, CC, BCC field the
+ last keyring in the `tinypgp-pubring-table' is used when doing the
+ encryption.
+
+Input:
+
+ single-or-list list of email addresses or KEY ID's
+ no-replace flag, do not replace area with encryption
+ options string, extra options passed to pgp exe
+ verb flag, allow printing messages."
+ (interactive (tinypgp-encrypt-mail-i-args current-prefix-arg))
+ (let* ((fid "tinypgp-encrypt-mail:")
+ (beg-text (ti::mail-text-start))
+ beg
+ end
+ elt)
+
+ (ti::verb)
+ (tinypgp-hash 'action 'put 'now 'encrypt 'global)
+ (tinypgp-hash 'action 'put 'detail nil 'global)
+ (tinypgp-hash 'action 'put 'no-replace no-replace 'global)
+
+ (tinypgp-encrypt-allowed-check)
+
+ (put 'tinypgp-:return-value 'find-by-keyrings nil) ;reset
+
+ (tinypgpd "tinypgp-encrypt-mail in: "
+ single-or-list
+ "no-rep" no-replace
+ "1pass" sign-flag
+ "options" options
+ "verb" verb
+ "BEG" beg (point-max))
+
+ (unless single-or-list
+ (error "single-or-list is empty"))
+
+ (if (eq beg-text (point-max))
+ (error "Nothing to do, no text found."))
+
+ (setq single-or-list (tinypgp-user-list single-or-list))
+
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. do it . .
+ (setq single-or-list (ti::list-make single-or-list))
+
+ (tinypgp-cmd-macro-email "Encrypt"
+ (tinypgp-set-pgp-env-macro single-or-list 'verb
+
+ ;; See the tinypgp-key-find-by-keyrings function.
+ ;; Effective encrypt key may have changed
+
+ (when (setq elt (get 'tinypgp-:return-value 'find-by-keyrings))
+ (tinypgpd "tinypgp-encrypt-mail: KEY CHANGED " elt )
+ (setq single-or-list (ti::list-make elt)))
+
+ ;; Beacuse the Encrypt and signing is done
+ ;; in 'One pass' both keys must be in same pubring.
+
+ (when sign-flag
+ (tinypgpd fid "1pass: PUBRING CHANGED TO BIG")
+ (tinypgp-hash 'action 'put '1pass nil 'global)
+ (tinypgp-pubring-set-big))
+
+ ;; single-or-list will be changed if it is nil.
+ ;; --> user login name
+
+ (tinypgp-cmd-macro
+ (if sign-flag 'encrypt-sign 'encrypt)
+ single-or-list
+ nil
+ "Encrypting...." no-replace options)
+
+ ;; If all went ok, then we update cache, user XXX in in pubring YYY
+ ;; All users must be in same pubring otherwise the previous command
+ ;; didn't succeed.
+
+ (dolist (elt single-or-list)
+ (when (stringp elt)
+ (tinypgp-key-cache 'put elt tinypgp-:pubring-now)))))
+
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. . results . .
+
+ (when (and (null no-replace)
+ (null buffer-read-only)
+ tinypgp-:encrypt-after-function)
+ (if (ti::mail-mail-p)
+ (goto-char (ti::mail-text-start)) ;ignore other buffers
+ (ti::pmin))
+
+ (ti::save-with-marker-macro
+ (funcall tinypgp-:encrypt-after-function)))
+
+ (when verb
+ (message
+ "%d: Encrypted to %s %s"
+ (length single-or-list)
+ (ti::list-to-string single-or-list)
+ (if (null sign-flag) ""
+ (format "and signed [%s]" tinypgp-:user-now)))
+ ;; Make sure this is seen
+ (sleep-for 2))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-encrypt-region-i-args (&optional pwd)
+ "Ask arguments for `tinypgp-encrypt-region-i-args' possibly also asking PWD."
+ (ti::list-merge-elements
+ (tinypgp-i-args-reg-email "Encrypt to: ")
+ current-prefix-arg
+ (if pwd (tinypgp-password-set
+ (format "[%s] Sign password: " tinypgp-:user-now)))
+ (if (null tinypgp-:r-mode-indication-flag)
+ (eval tinypgp-:pgp-binary-interactive-option))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinypgp-encrypt-region-sign
+ (beg end user &optional no-replace sign-pwd options verb)
+ "Same as `tinypgp-encrypt-region' but raise 'sign' parameter.
+BEG END USER NO-REPLACE SIGN-PWD OPTIONS VERB"
+ (interactive (tinypgp-encrypt-region-i-args 'pwd))
+ (ti::verb)
+ (tinypgp-encrypt-region
+ beg end user no-replace sign-pwd options verb))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinypgp-encrypt-region
+ (beg end user &optional no-replace sign-pwd options verb)
+ "Encrypt region.
+
+Input:
+
+ BEG END region
+ USER key-id (possibly email) or list of keyIds.
+ NO-REPLACE prefix arg, store results to `tinypgp-:register'
+ SIGN-PWD if non-nil string, Sign at the same time as you encrypt.
+ OPTIONS Additional option string for PGP.
+ VERB If non-nil, Verbose messages."
+ (interactive (tinypgp-encrypt-region-i-args))
+ (tinypgpd "tinypgp-encrypt-region in:"
+ beg end user "replace" no-replace options verb)
+
+ (ti::verb)
+ (tinypgp-encrypt-allowed-check)
+ (tinypgp-password-set (format "[%s] Encrypt password: " tinypgp-:user-now))
+
+ (tinypgp-hash 'action 'put 'now 'encrypt 'global)
+ (tinypgp-hash 'action 'put 'no-replace no-replace 'global)
+
+ (setq user (tinypgp-user-list user))
+
+ (tinypgp-set-pgp-env-macro user 'verb
+ (tinypgp-cmd-macro
+ (if sign-pwd 'encrypt-sign 'encrypt )
+ user
+ sign-pwd
+ "Encrypting...." no-replace options))
+
+ ;; If all went ok, then we update cache, use XXX in in pubring YYY
+ (tinypgp-key-cache-update (car (ti::list-make user))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-encrypt-info (&optional register verb)
+ "Check encrypted message and who can read it.
+If Flag REGISTER is non-nil store results to `tinypgp-:register'. VERB."
+ (interactive)
+ (let* ((user tinypgp-:user-primary)
+ ptr
+ list
+ str
+ beg
+ end)
+ (ti::verb)
+ (ignore-errors ;We know this generates error.
+ (tinypgp-set-pgp-env-macro user 'verb
+ (tinypgp-cmd-macro
+ 'encrypt-info
+ user
+ nil
+ "Checking encrypt users...." 'no-replace (not 'options))))
+ (setq ptr (tinypgp-binary-get-result-encrypt-info))
+
+ (cond
+ ((null ptr)
+ (message
+ "TinyPgp: Can't find list of encrypt users. Maybe not encrypted."))
+ (register
+ (with-current-buffer (car ptr)
+ (set-register tinypgp-:register
+ (buffer-substring (nth 1 ptr) (nth 2 ptr))))
+ (if verb
+ (message "Encrypt info in register '%s'"
+ (char-to-string tinypgp-:register))))
+ (t
+ (setq list (tinypgp-binary-get-result-encrypt-info-list ptr)
+ str (ti::list-to-string list ","))
+
+ (if (< (length str) 75)
+ (message "Encrypt: %s" str)
+ ;; Hm, Doesn't fit in echo area, so display in another window
+ (tinypgp-ti::temp-buffer 'show)
+ (display-buffer tinypgp-:buffer-tmp-show)
+ (with-current-buffer (car ptr)
+ (append-to-buffer tinypgp-:buffer-tmp-show
+ (nth 1 ptr) (nth 2 ptr))))))))
+
+;;}}}
+;;{{{ interactive, decrypting
+
+;;; .......................................................... &decypt ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-decrypt-signed-base64
+ (beg end user &optional no-replace verb)
+ "Decrypt conventinally signed but base64 coded text.
+
+Input:
+
+ BEG END region
+ USER key-id string (possibly email)
+ NO-REPLACE store results to `tinypgp-:register'
+ VERB Verbose messages."
+ (let* ((fid "tinypgp-decrypt-signed-base64: ")
+ pointer
+ file-out
+ file-write)
+
+ (ti::verb)
+ (tinypgp-hash 'action 'put 'now 'decrypt 'global)
+ (setq file-out (ti::mail-pgp-comment-file-p beg))
+
+ (tinypgpd fid "in:" beg end user no-replace verb)
+
+ (when file-out
+ (setq
+ file-write
+ (read-file-name
+ "Base64 block save contents to file: "
+ nil (concat default-directory file-out) nil file-out))
+ (cond
+ ((ti::nil-p file-write)
+ (setq file-write nil))
+
+ ((not (file-exists-p (file-name-directory file-write)))
+ (error "No such directory %s" file-write))
+
+ ((file-exists-p file-write)
+ (if (y-or-n-p "File exists, overwrite?")
+ (delete-file file-write)
+ (error "Abort.")))))
+
+ (if file-write
+ (setq no-replace t))
+
+ (tinypgp-cmd-macro 'decrypt-base64 user nil "Decrypting..." no-replace)
+
+ ;; The result of PGP is not delimited by any
+ ;; --- TAG, so we cannot request replace now, but read the contents
+ ;; by hand first
+ ;;
+ (with-current-buffer tinypgp-:buffer-tmp-shell
+ (setq pointer (tinypgp-binary-get-result-base64))
+ (unless pointer (tinypgp-error "No output from PGP.")))
+
+ (cond
+ (file-write
+ (with-current-buffer (tinypgp-ti::temp-buffer)
+ (tinypgp-binary-insert-pointer-data pointer)
+ (write-region (point-min) (point-max) file-write)
+ (erase-buffer))
+ (message "Wrote %s" file-write))
+ (no-replace
+ (set-register tinypgp-:register
+ (tinypgp-binary-get-result-as-string pointer)))
+ (t
+ (delete-region beg end)
+ (tinypgp-binary-insert-pointer-data pointer)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-decrypt-arg-function (arg)
+ "See how we should interpret the passed prefix ARG.
+If buffer is read-only, then assume, that it may be MAIL buffer
+or the like and honor the variable `tinypgp-:decrypt-arg-interpretation'
+
+If buffer is not read-only. return ARG as is."
+ (if (not buffer-read-only) ;regular buffer
+ arg
+
+ ;; This may be MAIL buffer, because it is read only,
+ ;; see how user want the arg to be intepreted.
+
+ (if (null tinypgp-:decrypt-arg-interpretation)
+ arg ;as is
+ (if arg ;reverse sense
+ nil
+ tinypgp-:decrypt-arg-interpretation))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-decrypt-mail-verbose (&optional prefix-arg)
+ "Call `tinypgp-decrypt-mail' like user would with PREFIX-ARG."
+ ;; Loonks cryptic? Not really, because i-args returns a
+ ;; list and tinypgp-decrypt-mail needs individual args,
+ ;; we use eval + backquote to construct command that
+ ;; turns list into individual args before
+ ;; it calls tinypgp-decrypt-mail.
+ ;;
+ ;; Got it? No? Then you must learn backquote syntax first.
+ ;;
+ (eval
+ (` (tinypgp-decrypt-mail
+ (,@ (tinypgp-decrypt-mail-i-args prefix-arg))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-decrypt-mail-i-args (&optional arg)
+ "Ask args to function `tinypgp-decrypt-mail'.
+ARG passed can be `current-prefix-arg' if that is known."
+ (tinypgpd "tinypgp-decrypt-mail-i-args: ")
+ (tinypgp-hash 'action 'put 'now 'decrypt 'global)
+
+ (if (null (ti::mail-pgp-p))
+ (error "Nothing to do. No pgp found."))
+
+ (list
+ (funcall tinypgp-:pgp-decrypt-arg-function arg)
+ (tinypgp-i-args-decrypt)
+ ;; c-point
+ nil))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinypgp-decrypt-mail (&optional no-replace type verb)
+ "Decrypt mail buffer.
+The PGP data in the buffer is detected by reading the CTB bits:
+see pgpformat.doc in pgp documentation.
+
+Input:
+
+ NO-REPLACE flag, prefix arg instructs to show the cotent in
+ separate buffer. See refrerence note too.
+ If this is 'preview and verb argument is nil-nil,
+ then automatically show content is different buffer.
+
+ TYPE nil or \"pgp\" --> PGP encrypted
+ \"base64\" --> base64 signed and
+ \"conventional\" --> encrypted with conventional key.
+
+ VERB Verbose mode.
+
+References:
+
+ `tinypgp-:pgp-encrypted-p-function'
+ `tinypgp-:decrypt-arg-interpretation' for interactive calls
+ `tinypgp-:pgp-decrypt-arg-function' for interactive calls
+ `tinypgp-:user-identity-table'"
+
+ (interactive (tinypgp-decrypt-mail-i-args current-prefix-arg))
+ (tinypgpd "tinypgp-decrypt-mail in:" no-replace type verb)
+
+ (let* ((fid "tinypgp-decrypt-mail:")
+ (region (save-excursion (ti::pmin) (ti::mail-pgp-block-area 'msg)))
+ (beg (car-safe region))
+ (end (cdr-safe region))
+ (buffer (current-buffer))
+ stat)
+
+ (ti::verb)
+
+ (tinypgp-hash 'action 'put 'now 'decrypt 'global)
+ (tinypgp-hash 'action 'put 'type type 'global)
+ (tinypgp-hash 'action 'put 'no-replace no-replace 'global)
+
+ (if (null region)
+ (error "No PGP encrypt block found."))
+
+ (tinypgp-save-state-macro
+ (tinypgpd fid "user" tinypgp-:user-now)
+
+ ;; ... ... ... ... ... ... ... ... ... ... ... normally encrypted ...
+
+ (cond
+ ((member type '("conventional" "pgp"))
+ (tinypgp-save-state-macro
+ (tinypgp-user-change-macro
+ (tinypgp-cmd-macro-email "Decrypt"
+ (tinypgp-decrypt-region beg end no-replace type verb)))))
+
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... ... base64 ..
+
+ ((member type '("base64"))
+
+ (when no-replace
+ (setq buffer (tinypgp-ti::temp-buffer))
+ (append-to-buffer buffer beg end))
+
+ (with-current-buffer buffer
+
+ ;; There may be several blocks, open them all.
+ ;; This is the first one.
+
+ (tinypgp-decrypt-signed-base64 beg end nil no-replace)
+ (while (and (setq region
+ (save-excursion
+ (goto-char end)
+ (ti::mail-pgp-block-area 'msg)))
+ (setq beg (car region) end (cdr region)))
+ (tinypgp-decrypt-signed-base64 beg end nil no-replace))))
+ (t
+ (error "Unkown decrypt type '%s'" type))))
+
+ (goto-char (ti::mail-text-start))
+
+ ;; The message may have been encrypted and signed (one pass).
+ ;; Check it too.
+
+ (when (and verb
+ (setq stat (tinypgp-binary-get-result-verify-status)))
+ (message "[was signed] %s" stat))
+
+ (tinypgp-hash 'action 'put 'type nil 'global) ;Clear this
+ (tinypgpd "tinypgp-decrypt-mail out: user" tinypgp-:user-now)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinypgp-decrypt-region (beg end &optional no-replace type verb)
+ "Decrypt region. Signal error is there is no decrypt message.
+
+Input:
+
+ BEG END int, region
+ NO-REPLACE flag, store contents to `tinypgp-:register'.
+ If values is 'review and verb is non-nil, also display
+ content in separate buffer. Calls `tinypgp-view-register'
+ TYPE string, Decrypt type: conventional, base64 or pgp
+ VERB flag, verbose messages"
+ (interactive
+ (progn
+ (tinypgpd "tinypgp-decrypt-region interactive")
+ (ti::list-merge-elements
+ (ti::i-macro-region-body)
+ current-prefix-arg
+ 'iact
+ (tinypgp-i-args-decrypt))))
+
+ (let* ((fid "tinypgp-decrypt-region")
+ user) ;Must be defined due to macro
+
+ (tinypgpd fid "in:" beg end no-replace type verb (current-buffer))
+
+ (tinypgp-hash 'action 'put 'now 'decrypt 'global)
+ (tinypgp-hash 'action 'put 'type type 'global)
+ (tinypgp-hash 'action 'put 'no-replace no-replace 'global)
+
+ (if (null (save-excursion (ti::pmin) (ti::mail-pgp-block-area 'msg)))
+ (error "No PGP encrypt block found."))
+
+ (tinypgpd fid "in:" beg end no-replace verb)
+ (tinypgp-cmd-macro 'decrypt user nil "Decrypting..." no-replace)
+
+ (when (and no-replace verb)
+ (or (get-buffer-window tinypgp-:buffer-view t) ;already visible
+ (eq no-replace 'preview)
+ (y-or-n-p "View content in temp buffer? "))
+ (tinypgp-view-register))
+
+ (tinypgp-hash 'action 'put 'type nil 'global)))
+
+;;}}}
+;;{{{ interactive: regular crypting
+
+;;; ............................................................ &cypt ...
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinypgp-crypt-mail (password &optional no-replace comment verb)
+ "Crypt mail buffer.
+
+Input:
+
+ PASSWORD pass phrase
+ NO-REPLACE store contents to `tinypgp-:register'.
+ COMMENT Additional comment added
+ VERB verbose messages"
+ (interactive
+ (list
+ (ti::compat-read-password "Crypt password: ")
+ current-prefix-arg))
+ (let* ((beg (ti::mail-text-start))
+ (end (point-max))
+ (verb (or verb (interactive-p))))
+ (tinypgp-hash 'action 'put 'now 'crypt 'global)
+ (tinypgp-crypt-region beg end password no-replace comment verb)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinypgp-crypt-region
+ (beg end password &optional no-replace comment verb)
+ "Crypt region.
+
+Input:
+
+ BEG END region
+ PASSWORD pass phrase
+ NO-REPLACE store contents to `tinypgp-:register'.
+ COMMENT The comment string.
+ VERB verbose messages"
+ (interactive
+ (progn
+ (barf-if-buffer-read-only)
+ (ti::i-macro-region-body
+ (read-from-minibuffer "Crypt password: ")
+ current-prefix-arg
+ "")))
+
+ (let* ((obuffer (current-buffer)))
+ (tinypgp-hash 'action 'put 'now 'crypt 'global)
+
+ (with-current-buffer (tinypgp-ti::temp-buffer)
+ (insert-buffer-substring obuffer beg end)
+ (ti::pmin) (tinypgp-file-control 'source-write)
+
+ (tinypgp-crypt-do-with-pgp
+ tinypgp-:file-source tinypgp-:file-output password (or comment ""))
+
+ (cond
+ (no-replace
+ (erase-buffer)
+ (insert-file-contents tinypgp-:file-output)
+ (set-register tinypgp-:register (buffer-string)))
+ (t
+ (with-current-buffer obuffer
+ (delete-region beg end) (goto-char beg)
+ (insert-file-contents tinypgp-:file-output)))))
+ (tinypgp-file-control 'source-kill)))
+
+;;}}}
+;;{{{ interactive, extra, header toggle
+
+;;; ..................................................... &interactive ...
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinypgp-xpgp-header-mode-toggle (&optional arg)
+ "Toggle X-pgp header mode with ARG.
+
+References
+ `tinypgp-:header-sign-table' ,this variable overrides the signing mode."
+ (interactive "P")
+ (ti::bool-toggle tinypgp-:xpgp-signing-mode arg)
+ (if (interactive-p)
+ (message
+ (concat "TinyPgp: X-Pgp header mode: "
+ (if tinypgp-:xpgp-signing-mode
+ "on" "off"))))
+
+ (tinypgp-update-modeline)
+ tinypgp-:xpgp-signing-mode) ;return the changed value
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinypgp-xpgp-header-toggle ()
+ "Togle moving signature FROM/TO headers."
+ (interactive)
+ (cond
+ ((null (tinypgp-mail-buffer-p 'message)))
+ (t
+ (ti::save-line-column-macro nil nil ;preserve user's position
+ (with-buffer-modified
+ (cond
+ ((ti::mail-pgp-headers-p)
+ (tinypgp-signature-from-header))
+ ((ti::mail-pgp-normal-p)
+ (tinypgp-signature-move-to-header nil 'no-cnv))
+ (t
+ (message "No PGP signature found..."))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-hide-gnus (&optional unhide)
+ "Hide or UNHIDE pgp signature in GNUS."
+ (let* ((buffer (if (boundp 'gnus-article-buffer)
+ ;; Silence byteComp.
+ (symbol-value 'gnus-article-buffer))))
+ (when (stringp buffer)
+ (with-current-buffer buffer
+ (tinypgp-hide)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-hide (&optional unhide)
+ "Hide PGP signatures, optionally UNHIDE."
+ (ti::mail-pgp-signature-normal-do-region
+ (tinypgp-invisible-region area-beg area-end unhide)
+ ;; return value on success
+ t))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-show ()
+ "Show PGP signature."
+ (tinypgp-hide 'show))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinypgp-hide-show-toggle ()
+ "Togle hiding and showing the PGP signature."
+ (interactive)
+ (let* (ret)
+ (setq ret
+ (if (tinypgp-hidden-p)
+ (tinypgp-show)
+ (tinypgp-hide)))
+ (if (and (interactive-p)
+ (null ret))
+ (message "No signature found to un/hide"))))
+
+;;}}}
+;;{{{ interactive, keyserver submit
+
+;;; ................................................ &keyserver-submit ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-keysrv-send-email-command (email command &optional arg)
+ "Send to EMAIL address a keyserver COMMAND with ARG.
+The COMMAND is placed in the subject line. If command is 'add' then
+the current buffer is sent to keyserver.
+
+See keyserver documentation for more up to date command definitions:
+
+Command Message body contains
+--------------------------------------------------------------------
+ADD Your PGP public key (key to add is body of msg) (-ka)
+INDEX List all PGP keys the server knows about (-kv)
+VERBOSE INDEX List all PGP keys, verbose format (-kvv)
+GET Get the whole public key ring (-kxa *)
+GET <userid> Get just that one key (-kxa <userid>)
+MGET <userid> Get all keys which match <userid>
+LAST <n> Get all keys uploaded during last <n> days
+--------------------------------------------------------------------"
+ (interactive
+ (let* ((obuffer (current-buffer))
+ arg1
+ arg2
+ arg3
+ elt)
+ (setq arg1 (tinypgp-ask-email-keyserver))
+ (setq arg2 (completing-read
+ "Send command: "
+ (ti::list-to-assoc-menu
+ '("help" "add" "index" "verbose index" "get"
+ "mget" "last"))))
+
+ (if (setq elt
+ (assoc
+ arg2
+ '(("get" . "<userid>")
+ ("mget" . "<userid>")
+ ("last" . "<nbr of days>"))))
+ (setq
+ arg3
+ (read-from-minibuffer
+ (format "%s, possible additional parameter %s: "
+ arg2 (cdr elt)))))
+
+ (list arg1 arg2 arg3)))
+
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. . interactive end ..
+ (let ((obuffer (current-buffer))
+ insert-flag)
+
+ (if (ti::nil-p email) (error "email is invalid."))
+ (if (ti::nil-p command) (error "command is invalid."))
+
+ (cond
+ ((string= "index" command)
+ (if (null (y-or-n-p "\
+Really List all PGP keys the server knows about (-kv)? "))
+ (error "Abort.")))
+
+ ((string= "verbose index" command)
+ (if (null (y-or-n-p "\
+Really List all PGP keys, verbose format (-kvv) "))
+ (error "Abort.")))
+
+ ((string= "get" command)
+ (if (null (y-or-n-p "\
+Really Get the whole public key ring (-kxa *) "))
+ (error "Abort.")))
+
+ ((string= "mget" command)
+ (if (null (y-or-n-p (format "\
+Really Get all keys which match <userid %s> " arg)))
+ (error "Abort.")))
+
+ ((and (string= "add" command)
+ (save-excursion
+ (ti::pmin)
+ (unless (ti::mail-pgp-public-key-p)
+ (error "I can't send this buffer, no public key found."))
+ t))
+ (setq insert-flag t))
+
+ ((member command '("help" "last"))
+ nil)
+
+ (t
+ (error "unsupported command %s to %s" command email)))
+
+ (ti::mail-sendmail-macro email command 'send
+;;; (pop-to-buffer (current-buffer)) (ti::d! "__ksrv")
+ (if insert-flag
+ (insert-buffer obuffer)))))
+
+;;}}}
+;;{{{ interactive: misc
+
+;;; ........................................................... &imisc ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinypgp-pgp-stream-forward-study (&optional verb)
+ "Find PGP stream and display information from it. VERB.
+The information is stored to `tinypgp-:register'.
+
+Interactive call note:
+
+ If can't find stream forward, then go to `point-min' and try searching
+ again."
+ (interactive)
+ (let* (info)
+ (ti::verb)
+ (if (setq info (ti::mail-pgp-stream-forward-info 'search 'any))
+ (set-register tinypgp-:register info)
+ (setq info "Can't intepret/find PGP stream."))
+ (message info)))
+
+;;}}}
+;;{{{ examples
+
+;;; ........................................................ &examples ...
+;;; - Rip code with tinylib.el/ti::package-rip-magic
+;;; - Here is how I control PGP message sending: For company mail,
+;;; I don't use PGP, but for outside wordl I use quite often.
+;;; - Do not use autosigning if you decide to use this kind of control.
+
+;;* (add-hook 'mail-send-hook 'my-tinypgp-ask-if-send-pgp-mail)
+
+;;* ;;; ----------------------------------------------------------------------
+;;* ;;;
+;;* (defun my-tinypgp-ask-if-send-pgp-mail ()
+;;* "See if we should ask to sign the mail with PGP.
+;;* - If there is already PGP blocks, do nothing.
+;;* - If these are local host email addresses, do not ask PGP signing.
+;;* "
+;;* (require 'tinylibmail)
+;;* (save-excursion
+;;* (let* ((to (or (mail-fetch-field "to") ""))
+;;* (subject (or (mail-fetch-field "subject") ""))
+;;* ;; Exclude my local host addresses, Anon and remail posts
+;;*
+;;* (skip-address-p
+;;* (or (string-match (concat
+;;* "ntc\\|nokia\\|tne[0-9]\\|[an][na][0-9]"
+;;* "\\|remail\\|@anon"
+;;* )
+;;* to)
+;;* ;; local mail addresses do not have @ --> skip PGP
+;;* ;; TO field does not exist in news article
+;;*
+;;* (not (string-match "@" to))
+;;* ))
+;;* (mime (ti::re-search-check
+;;* "^--[[]\\|^--+Multi\\|--pgp-"
+;;* 0 '(ti::pmin)))
+;;* (diff (ti::re-search-check
+;;* "diff[ \t]+-[ucr]\\|^--- .*199[0-9]"))
+;;* pgp-ask-no
+;;* start
+;;* )
+;;* (defvar my-:pgp-previous-mail-subject nil)
+;;* _
+;;* _
+;;* ;; .............................................. untabify maybe ...
+;;* ;; Remove TABS; so that receiver can see the text as written
+;;*
+;;* (when (and (null diff) ;Skip diff message
+;;* (not (ti::mail-pgp-encrypted-p)) ;already encrypted
+;;* (not (ti::mail-pgp-p)) ;or other pgp
+;;* )
+;;* (untabify (ti::mail-text-start) (point-max))
+;;* )
+;;* _
+;;* ;; ........................................ should we sign this? ...
+;;* ;; Raise flag if NO.
+;;* ;;
+;;* (setq pgp-ask-no
+;;* (or (not (featurep 'tinypgp))
+;;* mime
+;;* diff
+;;* skip-address-p
+;;* ;; In news this function is called twice, prevent asking
+;;* ;; in the second time.
+;;* ;;
+;;* (string= (or my-:pgp-previous-mail-subject "") subject)
+;;* ))
+;;* _
+;;* ;; ............................................ do signing maybe ...
+;;* (when (and (null (ti::mail-pgp-p)) ;no previous pgp
+;;* (null pgp-ask-no) ;Not a special message
+;;* (y-or-n-p "PGP sign message? ")
+;;* )
+;;* (call-interactively 'tinypgp-sign-mail))
+;;* _
+;;* ;; - Well, I just want to have confirmation after C-c C-c
+;;* ;; - Many times I have changed my mind, or missed something I
+;;* ;; should have added. At this point there is a short break to
+;;* ;; have a glimpse on the message
+;;* ;; - I want to see the "Subject", because I may have auto-replied
+;;* ;; and started talking about whole different things -->
+;;* ;; I should have chnaged the subject. This way I don't
+;;* ;; forgot to change it.
+;;*
+;;* (if (null (y-or-n-p (concat "Sending msg: " subject " ")))
+;;* (error "Abort"))
+;;* _
+;;* (setq my-:pgp-previous-mail-subject subject)
+;;* nil ;hook return value
+;;* )))
+
+;;}}}
+;;{{{ final install
+
+(setq tinypgp-:debug t)
+(when (null debug-on-error)
+ (setq debug-on-error t))
+
+(tinypgp-install)
+(tinypgp-install-modes) ;; Do this every time when package is loaded
+(tinypgp-install-to-current-emacs)
+
+;; Until this package is labelled Alpha
+
+(unless (featurep 'tinypgp)
+ (setq debug-on-error t)
+ (tinypgp-initial-message))
+
+(tinypgp-newnym-account-expiry-warnings) ;when Newnym defined
+
+(provide 'tinypgp)
+(run-hooks 'tinypgp-:load-hook)
+
+(error "TinyPgpg is no longer maintained. It will be removed in newar future.")
+
+;;}}}
+
+;;; tinypgp.el ends here
--- /dev/null
+;;; tinyprocmail.el --- Emacs procmail minor mode. Lint code checker.
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 1997-2007 Jari Aalto
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;; Created: 1997-09
+;; Keywords: extensions
+;;
+;; To get information on this program, call M-x tinyprocmail-version.
+;; Look at the code with folding.el.
+
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;;; Install:
+
+;; ....................................................... &t-install ...
+;; Put this file on your Emacs-Lisp load path, add following into your
+;; $HOME/.emacs startup file. This must be the very first entry before
+;; any keybindings take in effect.
+;;
+;; ;; - Tell which procmail version you're using, see procmail -v
+;; ;; - Uf you do not set this, tinyprocmail.el will call shell
+;; ;; to find out the procmail version. (slower)
+;;
+;; (setq tinyprocmail-:procmail-version "v3.11pre7")
+;; (add-hook 'tinyprocmail-:load-hook 'tinyprocmail-install)
+;; (require 'tinyprocmail)
+;;
+;; You can also use the preferred way: autoload
+;;
+;; (autoload 'turn-on-tinyprocmail-mode "tinyprocmail" "" t)
+;; (autoload 'turn-off-tinyprocmail-mode "tinyprocmail" "" t)
+;; (autoload 'tinyprocmail-mode "tinyprocmail" "" t)
+;; (add-hook 'tinyprocmail-:load-hook 'tinyprocmail-install)
+;;
+;; ;; Procmail files usually end to suffix "*.rc", like file-name.rc
+;; ;; Some older procmail files start with "rc.*", like rc.file-name
+;;
+;; (autoload 'aput "assoc")
+;; (aput 'auto-mode-alist
+;; "\\.\\(procmail\\)?rc$"
+;; 'turn-on-tinyprocmail-mode)
+;;
+;; This source file includes sample procmail test file for Lint. You
+;; can unpack it if you have `pgp' and `tar' commands in your system.
+;; When the file has been unpacked, load pm-lint.rc file into buffer,
+;; and follow instructions in the file.
+;;
+;; M-x tinyprocmail-install-files
+;;
+;; If you have any questions, use this function to contact author
+;;
+;; M-x tinyprocmail-submit-bug-report
+
+;;}}}
+;;{{{ Documentation
+
+;; ..................................................... &t-commentary ...
+
+;;; Commentary:
+
+;; Preface, Sep 1997
+;;
+;; Procmail may revolutionize your daily email management. If you
+;; receive more than 10 spam messages per day, you may start to wonder
+;; if there were any automatic way to handle mail, so that spam never
+;; lands on a $MAIL mailbox. Procmail can be one answer. It can be
+;; used to pre-filter all incoming mailing list messages and sort them
+;; out separately without bloating the primary inbox. You may already
+;; use Gnus to read the mailing lists, but the mail splitting work is
+;; best left to procmail. Why? Because procmail is always running,
+;; while your Emacs and Gnus isn't. Procmail processes incoming
+;; messages as soon as they are received and takes care of them, like
+;; saving UBE (unsolicited bulk email) messages to
+;; separate folders. And when Gnus us fired up, you can read the
+;; sorted mailboxes immediately.
+;;
+;; What is Procmail?
+;;
+;; Procmail is a mail processing utility for Unix (included also
+;; in Win32/Cygwin), which can help you filter your mail;
+;; sort incoming mail according to sender, Subject line, length
+;; of message, keywords in the message, etc; implement an
+;; ftp-by-mail server, and much more. Procmail is also a
+;; complete drop-in replacement for your MDA. (If this doesn't
+;; mean anything to you, you don't want to know.) Learn more
+;; about procmail at <http://www.procmail.org/>.
+;;
+;; Some terms
+;;
+;; ._UBE_ = Unsolicited Bulk Email.
+;; ._UCE_ = (subset of UBE) Unsolicited Commercial Email.
+;;
+;; _Spam_ = Spam describes a particular kind of Usenet posting (and
+;; canned spiced ham), but is now often used to describe many kinds of
+;; inappropriate activities, including some email-related events. It
+;; is technically incorrect to use "spam" to describe email abuse,
+;; although attempting to correct the practice would amount to tilting
+;; at windmills
+;;
+;; Overview of features
+;;
+;; o Minor mode for writing procmail recipes (use tab for indenting)
+;; o Linting procmail code: from a batch command line or
+;; interactively. In interactive mode, user can auto-correct recipes
+;; on the fly.
+;; o Font-lock supported.
+;; o files that have extension .rc or name .procmailrc trigger
+;; turning on `tinyprocmail-mode' (see `auto-mode-alist'). Please
+;; check that the first line does not have anything that would
+;; override this, like "-*- text -*-".
+;;
+;; Quick reference
+;;
+;; o M-x `tinyprocmail-mode' toggles Procmail recipe write mode
+;; o C-c ' L to Lint whole buffer interactively
+;; o C-u C-c ' L to Lint whole buffer and gathers info.
+;; o C-u C-u C-c ' L, same as above, but be less pedantic.
+;;
+;; Required packages
+;;
+;; o tinylib*.el Emacs/XEmacs/Cygwin support libraries
+;; o tinytab.el General programming mode. TAB key handling
+;; o tinycompile.el General parser for compile output. See Lint.
+;;
+;; Writing procmail code
+;;
+;; The coding functions are provided by other modules. The tab key
+;; advances 4 characters at a time, and minimalistic brace alignment
+;; is supported when you press tab before the ending brace.
+;;
+;; TAB tinytab-tab-key tinytab.el
+;;
+;; The RET autoindents, but this can be turned off by calling
+;;
+;; C-c ' RET tinytab-return-key-mode
+;;
+;; Whole regions can be adjusted with commands
+;;
+;; C-TAB tinytab-indent-by-div-factor -->
+;; A-S-TAB tinytab-indent-by-div-factor-back <--
+;; C-c TAB tinytab-indent-region-dynamically <-->
+;;
+;; Tabs and spaces
+;;
+;; When the procmail mode is active, the tab key does not produce a
+;; tab character, but sufficient amount of spaces. There is a reason
+;; for this, mostly due to Lint parser which has to move up and down
+;; columnwise when checking the code. The movements can't be done if
+;; the code includes tabs. If you need a literal tab in your regexps,
+;; you can get it with standard emacs way 'C-q` `TAB'.
+;;
+;; Aligning continuation lines with backslashes
+;;
+;; In procmail, you use backslashes a lot, like in the following example.
+;; The backslashes here are put after each line, but this construct is
+;; error prone, because if you later on add new `echo' commands or
+;; otherwise modify the content, you may forget to update the
+;; backslashes.
+;;
+;; :0 fh
+;; * condition
+;; | (formail -rt | \
+;; cat -; \
+;; echo "Error: you requested file"; \
+;; echo "that does not exist";\
+;; ) | $SENDMAIL -t
+;;
+;; To fix this code block, you can use command C-c ' \ or
+;; `tinyprocmail-fix-backslashes-paragraph'. It would have been
+;; enough to write the _first_ backslash and then call C-c ' \
+;; and the rest of the backslashes would have been added below
+;; the same cloumn.
+;;
+;; :0 fh
+;; * condition
+;; | (formail -rt | \
+;; cat -; \
+;; echo "Error: you requested file"; \
+;; echo "that does not exist"; \
+;; ) | $SENDMAIL -t
+;;
+;; Rules on how to write Procmail recipe
+;;
+;; In order to use the linting service, this package requires that
+;; you write your procmail code in following manner. These rules are
+;; needed, so that it would be possible to parse the procmail code
+;; efficiently and more easily.
+;;
+;; [recipe start]
+;;
+;; : # (old way) although legal procmail, illegal here. Use `:0'
+;;
+;; [flag order]
+;;
+;; In order to autocorrect read flags from the buffer, the flag order
+;; must be decided: and here is a suggestion. The one presented
+;; in the procmail man page "HBDAaEehbfcwWir" is errourneous, because
+;; flags "aAeE" must be first, otherwise it causes error in procmail.
+;; The idea here is that the most important flags are
+;; put to the left, like giving priority 1 for `aAeE', which affect
+;; the receipe immedately. Priority 2 has been given to flag `f',
+;; which tells if receipe filters somthing. Also (h)eader and (b)ody
+;; should immediately follow `f', this is considered priority 3.
+;; In the middle there are other flags, and last flag is `c', which
+;; ends the receipe, or allows it to continue."
+;;
+;; :0 aAeE HBD fhbwWirc: LOCKFILE
+;; | | | | |
+;; | | | | (c)ontinue or (c)opy flag last.
+;; | | | (w)ait and Other flags
+;; | | (f)ilter flag and to filter what: (h)ead or (b)ody
+;; | (H)eader and (B)ody match, possibly case sensitive (D)
+;; The `process' flags first. Signify (a)ad or (e)rror
+;; receipe.
+;;
+;; Every recipe starts with `:0' `flags:', but if you prefer `:0flags:'
+;; more, you can use following statement. This 'flag-together (or not)
+;; format is automatically retained when everytime you call lint.
+;;
+;; (setq tinyprocmail-:flag-and-recipe-start-style 'flags-together)
+;;
+;; [lockfile]
+;;
+;; The lockfile names must be longer than two characters. Shorter
+;; lockfile name trigger an error. Also lockfile must have
+;; extension $LOCKEXT or .lock or .lck; no other non-standard
+;; extensions are allowed. The lockfile name must be within
+;; charsert [-_$.a-zA-Z0-9/] and anything else is considered as
+;; a suspicious lock file name.
+;;
+;; :0 : c # Error, should this read :0 c: instead?
+;; :0 : file # Invalid, should read "file.$LOCKEXT"
+;; :0 : file.tmp # Invalid, non-standard extension.
+;; :0 : file=0 # Invalid filename (odd characters in name)
+;;
+;; [condition line]
+;;
+;; Do not add inline commnts immediately to the right of the
+;; condition line. Although never procmail reciped mail allow
+;; the comment below, this parser does not recognize it and
+;; will flag it as an error. There another reason to avoid writing
+;; the comment into condition lines: if recipe is in another system
+;; that does not have the most recent procmail, the recpipe will break.
+;; All in all, put comments *before* recipe, just below it.
+;;
+;; * H B ?? regexp # valid procmail, llegal here: write "HB"
+;;
+;; [Variables]
+;;
+;; The literal value on the right-hand side must be quoted with
+;; double quotes if a simple string is being assigned. If there
+;; are no double or single quotes, then Lint assumes that you forgot
+;; to add variable dollar($). Try to avoid extra spaces in the
+;; variable initialisation construct that use `:-'.
+;;
+;; DUMMY = yes # Warning, did you mean DUMMY = $yes ?
+;; VAR = ${VAR:-1} # No spaces allowed: "$ {" is illegal.
+;;
+;; [program names]
+;;
+;; Program `sendmail' must be named sendmail, but it can also be
+;; variable $SENDMAIL. Similarly, program `formail' must be named
+;; `formail' or it can be variable $FORMAIL. Use of $MY_SENDMAIL
+;; or $MY_FORMAIL are illegal and cause missing many lint checks.
+;;
+;; [commenting style]
+;;
+;; In recent procmail releases you're allowed to place comments
+;; inside condition lines. Lint will issue a warning about this
+;; practise if your procmail version does not support this. But
+;; while you may place comments inside conditions, they should be
+;; indented by some amount of spaces. The default indent is 4
+;; spaces.
+;;
+;; * condition1 --> * condition
+;; # comment # comment
+;; # comment # comment
+;; * condition2 * condition
+;;
+;; This is recommended for readability (separating conditions
+;; from comments) and Lint will try to fix these comment misplacements.
+;;
+;; [redirecting to a file]
+;;
+;; If you print something to file, then the shell redirection
+;; tokens, like `>', must have surrounding spaces. Otherwise they
+;; are not found from the procmail recipe code. (because > can be used in
+;; regexps).
+;;
+;; :0 :
+;; | echo > test.tmp # Ok. Do not use "echo>test.tmp"
+;;
+;; Linting procmail code
+;;
+;; Writing procmail recipes is very demanding, because you have
+;; to watch your writing all the time. Forgetting a flag or two,
+;; or adding unnecessary flag may cause your procmail code to
+;; work improperly. The Lint interface in this module requires
+;; that
+;;
+;; o You write your procmail code in certain way. (see above)
+;; o buffer is writable and can be modified. This is due
+;; to fact that program moves up and down to the same column
+;; as previous or next line. In order to make such movements,
+;; the tabs must be expanded when necessary.
+;;
+;; To help *Linting* you procmail code, there are two functions
+;;
+;; C-c ' l tinyprocmail-lint-forward
+;; C-c ' L tinyprocmail-lint-buffer
+;;
+;; These functions check every recipe and offer corrective
+;; actions if anything suspicious is found. If you don't want to
+;; correct the recipes, you can pass prefix argument, which
+;; gathers Lint run to separate buffer. In parentheses you see
+;; the buffer that was tested and to the right you see the
+;; program and version number. In this buffer you can press
+;; Mouse-2 or RET to jump to the line.
+;;
+;; *** 1997-10-19 19:37 (pm-test.rc) tinyprocmail.el 1.10
+;; cd /users/foo/pm/
+;; pm-test.rc:02: Error, Invalid or extra flags.
+;; pm-test.rc:10: Error, Invalid or extra flags.
+;; pm-test.rc:10: info, Redundant `Wc:' because `c:' implies W.
+;; pm-test.rc:11: String `>' found, recipe should have `w' flag.
+;; pm-test.rc:15: info, flag `H' is useless, because it is default.
+;;
+;; The output buffer can be sorted and you can move between blocks
+;; with commands
+;;
+;; sl tinyprocmail-output-sort-by-line
+;; se tinyprocmail-output-sort-by-error
+;; b tinyprocmail-output-start
+;; e tinyprocmail-output-end
+;;
+;; Lint: auto-correct
+;;
+;; In many cases the Lint functions are able to autocorrect the
+;; code: answer `y' to auto-correct question at current point. If
+;; you want to correct the place yourself, abort the Linting
+;; with `C-g' and fix the indicated line.
+;;
+;; Lint: directives
+;;
+;; Most of the time the Lint knows what might be best, but
+;; there may be cases where you have very complex procmail code
+;; and you know exactly what you want. Here are the Lint
+;; directives that you can place immediately before the recipe
+;; start to prevent Lint from whining. The word `Lint:' can have
+;; any number of surrounding spaces as long as it is the first
+;; word after comment.
+;;
+;; # Lint: <Lint flags here>
+;; :0 FLAGS
+;;
+;; The comment must be in the previous line, the following is _not_
+;; recognized.
+;;
+;; # Lint: <Lint flags here>
+;; # I'm doing some odd things here and ....
+;; :0 FLAGS
+;;
+;; Here is list of recognized Lint directives. each directive must have
+;; leading space.
+;;
+;; o `-w'. In pipe "|" recipe, ignore exit code. If you don't give
+;; this directive, the missing "w" flag is suggested to put there.
+;; o `-i'. If you have recipe that, 1) has no "f" 2) has no ">"
+;; 3) has "|" action, then the recipe doesn't seem to store
+;; the stdin anywhere. This may be valid case e.g. if you use
+;; MH's rcvstore. You can suppress the "-i" flag check with
+;; this directive.
+;; o `-c'. This is used in conjunction with `-i' when you only
+;; do something as a side effect and you reaally don't want to use
+;; (c) copy flag.
+;;
+;; Lint: error messages
+;;
+;; The error messages should be self-explanatory, but if you
+;; don't understand the message, please refer to *pm-tips.txt*
+;; file available at Sourceforge project "pm-doc".
+;; See `pm-tips.txt' and section that talks about variable
+;; definitions.
+;;
+;; Lint: batch mode from command line
+;;
+;; You can also lint procmail files from command line prompt
+;; like this.
+;;
+;; % emacs -batch -q -eval \
+;; '(progn (load "cl") \
+;; (push "~/elisp" load-path) \
+;; (load "tinyprocmail" ) \
+;; (find-file "~/pm/pm-test.rc") \
+;; (tinyprocmail-lint-buffer-batch)) '
+;;
+;; Change the filename "~/pm/pm-test.rc" to targetted for
+;; linting. The Lint results will appear in file
+;; `tinyprocmail-:lint-output-file' which is ~/pm-lint.out by
+;; default. Below you see a shell script to run the above command
+;; more easily. Rip code with `ti::package-rip-magic'
+;;
+;;* #!/bin/sh
+;;* # pm-lint.sh -- LINT A procmail batch lint with emacs tinyprocmail.el
+;;* #
+;;* file=$1
+;;* #
+;;* EMACS=emacs
+;;* out=$HOME/pm-lint.lst
+;;* #
+;;* # notice all these 3 lines must be concatenaed together! There must be
+;;* # no \ continuation characters. to the right.
+;;* #
+;;* $EMACS -batch -q -eval
+;;* '(progn (load "cl") (push "~/elisp" load-path) (load "tinyprocmail")
+;;* (find-file "'"$file"'") (tinyprocmail-lint-buffer-batch) ) ' 2>&1 $out
+;;* #
+;;* # end of pm-lint.sh
+;;
+;; Highlighting
+;;
+;; Just couple of words about the chosen regexps for procmail code.
+;; Notice, that if you make a mistake, the dollar($) in front of
+;; identifier is not highlighted. This should help with spotting
+;; errors by eye better.
+;;
+;; $VAR = ${VAR:-"no"}
+;; |===
+;; |Error, you must not place '$' to the left here.
+;; |
+;; This dollar($) sign is not highlighted.
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+;;{{{ setup: require
+
+(require 'tinylibm)
+
+(eval-when-compile (ti::package-use-dynamic-compilation))
+
+(eval-and-compile
+ (defvar tinytab-mode nil)
+ (autoload 'tinycompile-parse-line-goto "tinycompile" "" t)
+ (autoload 'turn-on-tinytab-mode "tinytab" "" t)
+ (autoload 'turn-off-tinytab-mode "tinytab" "" t)
+ (autoload 'tinytab-mode "tinytab" "" t)
+ (ti::overlay-require-macro
+ (message "\
+ ** tinyprocmail.el: overlay-* functions missing from this Emacs.")))
+
+(ti::package-defgroup-tiny TinyProcmail tinyprocmail-: extensions
+ "Procmail log minor mode
+ Overview of features
+
+o Minor mode for writing Procmail recipes (use tab for
+ indenting)
+o Linting procmail code: From batch command line or
+ interactively. In interactive mode yuser can auto-correct code
+ on the fly. Linting erformance is about 160 recipes in 15 seconds.
+o Font-lock supported.
+o files that have extension .rc or name .procmailrc trigger
+ turning on `tinyprocmail-mode' (By using `auto-mode-alist'). Please
+ check that the first line does not have anything that would
+ override this, like '-*- text -*-'")
+
+;;}}}
+;;{{{ setup: public
+
+;;; ......................................................... &v-hooks ...
+
+(defcustom tinyprocmail-:load-hook nil
+ "*Hook run when file has been loaded."
+ :type 'hook
+ :group 'TinyProcmail)
+
+(defcustom tinyprocmail-:lint-before-hook nil
+ "*Hook run before `tinyprocmail-lint-forward'."
+ :type 'hook
+ :group 'TinyProcmail)
+
+(defcustom tinyprocmail-:lint-do-hook
+ '(tinyprocmail-lint-recipe-start
+ tinyprocmail-lint-condition-lines)
+ "List of lint functions to check the recipe at point.
+
+Call arguments:
+
+ FLAGS Read flags
+ STD-FLAGS Standardized flag sequence.
+
+Function should offer fixing recipe if `tinyprocmail-:lint-fix-mode' is activated
+and it should write log if `tinyprocmail-:lint' is nil."
+ :type '(repeat function)
+ :group 'TinyProcmail)
+
+(defcustom tinyprocmail-:lint-after-hook nil
+ "*Hook run after `tinyprocmail-lint-forward'."
+ :type 'hook
+ :group 'TinyProcmail)
+
+(defcustom tinyprocmail-:lint-after-hook nil
+ "Hook run when `tinyprocmail-lint-forward' is about to finish."
+ :type 'hook
+ :group 'TinyProcmail)
+
+;;; ..................................................... &v-functions ...
+
+(defcustom tinyprocmail-:flag-format-function
+ 'tinyprocmail-flag-format-default
+ "Function to format given flags.
+This function standardizes the flag order by calling
+`tinyprocmail-flag-standardize'.
+
+It must also respect the value of `tinyprocmail-:flag-and-recipe-start-style':
+e.g. if given 'Afbwic' the standard function adds one
+leading space so that the recipe looks like ':0 Afbwic'"
+ :type 'function
+ :group 'TinyProcmail)
+
+;;; .......................................................... &public ...
+
+(defcustom tinyprocmail-:pipe-w-warning-ignore-regexp
+ ".*|[ \t]*\\(echo\\|.*vacation\\)"
+ "When checking pipe recipe and missing w flags, ignore matching regexp.
+Say you have the following recipe:
+
+ :0 hi:
+ | echo \"status info\" > file
+
+Then the \"w\" is not essential at all. The default rexgexp ignores all
+these `echo' pipes and doesn't complaint about missing 'w'. Be carefull,
+if you set this regexp, so that you don't miss important `w' warnings."
+ :type 'string
+ :group 'TinyProcmail)
+
+(defcustom tinyprocmail-:flag-and-recipe-start-style nil
+ "What is the receipe start style used.
+If 'flags-together, then the receipe start llike looks like
+
+ :0flags:
+
+If any other value, then receipe start looks like
+
+ :0 flags:"
+ :type '(choice
+ (const flags-together)
+ (const nil))
+ :group 'TinyProcmail)
+
+(eval-and-compile
+ (defun tinyprocmail-procmail-version ()
+ "Call `procmail -v' to find out the version number.
+procmail v3.22 2001/09/10
+procmail v3.11pre7 1997/04/28 written and created by Stephen R. van den Berg
+procmail v3.11pre4 1995/10/29 written and created by Stephen R. van den Berg"
+ (let* ((prg (executable-find "procmail")))
+ (if (null prg)
+ (message "\
+ ** tinyprocmail.el: Warning, couldn't auto-set `tinyprocmail-:procmail-version'.")
+ (ti::string-match "^procmail[ \t]+v?\\([0-9]+[^ \t\n]+\\)"
+ 1 (shell-command-to-string "procmail -v"))))))
+
+(defcustom tinyprocmail-:procmail-version (tinyprocmail-procmail-version)
+ "The version number returned by `procmail -v'."
+ :type 'string
+ :group 'TinyProcmail)
+
+(defcustom tinyprocmail-:font-lock-keywords
+ (list
+ ;; Seeing embedded tabs in procmail is crucial because
+ ;; procmail doesn't know [ \t]. This regexp highlights bracketed
+ ;; regexp if it contains tab
+ ;;
+ ;; [ \n]
+ ;; ^ ^^^highlighted.
+ '("\\[[^]\n]*\t[^]\n]*\\]" . font-lock-keyword-face)
+
+ '("#.*" . font-lock-comment-face)
+ ;; Recipe start :0
+ ;; The regexp says: Start with `:0' or `:' followed by spaces
+ ;; and characters, but you MUST ent with non-space. This matches
+ ;; `spaced' flags:
+ ;;
+ ;; :0 B fh wi
+ ;;
+ ;; But also `tight' flags
+ ;;
+ ;; :0Bfhwi
+ '("^[\t ]*\\(:0? *[ a-zA-Z]+[^ #\n]+\\)" 1 font-lock-type-face)
+ '("^[\t ]*\\(:0\\)" 1 font-lock-type-face)
+ ;; Special condiion line
+ ;;
+ ;; * ! BH ?? regexp
+ '("^[ \t]*\\*.*\\<\\(HB\\|BH\\)\\>.*[?][?]" 1 font-lock-reference-face)
+ '("^[ \t]*\\*.*\\<\\([BH]\\)\\>.*[?][?]" 1 font-lock-reference-face)
+ ;; Special variable assignments
+ (list
+ (concat
+ "[^_a-zA-Z0-9]"
+ "\\("
+ "VERBOSE"
+ "\\|DELIVERED"
+ "\\|COMSAT"
+ "\\|LOG"
+ "\\|EXITCODE"
+ "\\|LOGFILE"
+ "\\|LOGABSTRACT"
+ "\\|MAILDIR"
+ "\\|HOST"
+ "\\|FROM_DAEMON"
+ "\\|FROM_MAILER"
+ "\\|TO_?"
+ "\\|FORMAIL"
+ "\\|SENDMAIL"
+ "\\)"
+ "[^_a-zA-Z0-9]")
+ 1 'font-lock-reference-face)
+ ;; variable expansion condition or variable extrapolation
+ ;;
+ ;; * $
+ ;;
+ ;; ${var}
+ ;;
+ '("\\* *\\([$]\\)" 1 font-lock-reference-face)
+ '("\\(\\$\\){" 1 font-lock-reference-face)
+ '("\\<\\(\\$\\)[A-Za-z]" 1 font-lock-reference-face)
+ ;; Left hand variable assignments
+ ;; $VAR = "value"
+ ;; LOG = "value"
+ '("\\([A-Z_][A-Z0-9_]+\\)[\t ]*=" 1 font-lock-keyword-face)
+ ;; Lonely right hand variables
+ ;; $VAR = $RIGHT_HAND
+ '("\\${?\\([A-Z0-9_]+\\)}?\\>" 1 font-lock-keyword-face)
+ ;; Standard programs called
+ (list
+ (concat
+ "[^_a-zA-Z0-9]\\(" ;; Do not put \\< here
+ "test"
+ "\\|awk"
+ "\\|cat"
+ "\\|cut"
+ "\\|echo"
+ "\\|formail"
+ "\\|[ezba]*?grep"
+ "\\|head"
+ "\\|perl"
+ "\\|python"
+ "\\|sed"
+ "\\|sendmail"
+ "\\|tail"
+ "\\)[^_a-zA-Z0-9]")
+ 1 'font-lock-reference-face)
+ ;; External shell calls with backquote
+ '("`\\([^' \t\n]+\\)'" 1 font-lock-reference-face t))
+ "*Font lock keywords."
+ :type 'sexp
+ :group 'TinyProcmail)
+
+(defcustom tinyprocmail-:lint-font-lock-keywords
+ (list
+ '("`\\([^' \t\n]+\\)'" 1 font-lock-reference-face)
+ '("Error," 0 font-lock-keyword-face)
+ '("Warning," 0 font-lock-reference-face)
+ ;; No there is no mistake here. The "i" is in lowercase because
+ ;; when the errors are sorted, the order of the sort must be like this.
+ ;;
+ ;; Error
+ ;; Pedantic
+ ;; Warning
+ ;; info
+ '("info," 0 font-lock-comment-face))
+ "*Font lock keywords."
+ :type 'sexp
+ :group 'TinyProcmail)
+
+(defcustom tinyprocmail-:auto-mode-alist
+ '(("\\.rc\\'\\|^rc\\.\\|procmailrc" . turn-on-tinyprocmail-mode))
+ "Items to add to `auto-mode-alist' to call `turn-on-tinyprocmail-mode'."
+ :type '(repeat
+ (list
+ (regexp :tag "Regexp to match filename")
+ (const 'tinyprocmail-mode)))
+ :group 'TinyMbx)
+
+(defcustom tinyprocmail-:lint-fix-mode 'semi
+ "*The mode of fixing code.
+'auto Automatic fixing.
+'semi Ask permission to fix.
+nil no fixing."
+ :type '(choice
+ (const nil)
+ (const auto)
+ (const semi))
+ :group 'TinyProcmail)
+
+(defcustom tinyprocmail-:lint-log-verbose 'pedantic
+ "If nil, then do not log new features available only in latest procmail.
+If 'pedantic, warn about all possible things that may not work in older
+procmail releases."
+ :type '(choice
+ (const nil)
+ (const pedantic))
+ :group 'TinyProcmail)
+
+(defcustom tinyprocmail-:lint-log nil
+ "*If non-nil receord lint check to `tinyprocmail-:lint-output-buffer'."
+ :type 'boolean
+ :group 'TinyProcmail)
+
+;;}}}
+;;{{{ setup: private
+
+;;; ......................................................... &private ...
+
+(defvar tinyprocmail-:overlay nil
+ "Overlay used.")
+
+(defvar tinyprocmail-:overlay-second nil
+ "Overlay used.")
+
+(defvar tinyprocmail-:lint-output-buffer "*Procmail Lint*"
+ "Log buffer for Lint.")
+
+(defvar tinyprocmail-:lint-output-file "~/pm-lint.out"
+ "Where `tinyprocmail-lint-buffer-batch' should save the results.")
+
+(defvar tinyprocmail-:mode-output-map nil
+ "Map useed in `tinyprocmail-:lint-output-buffer'.")
+
+(defvar tinyprocmail-:mode-output-easymenu nil
+ "Ooutput mode menu.")
+
+(eval-and-compile
+ (ti::macrof-version-bug-report
+ "tinyprocmail.el"
+ "tiprocmail"
+ tinyprocmail-:version-id
+ "$Id: tinyprocmail.el,v 2.51 2007/05/01 17:20:53 jaalto Exp $"
+ '(tinyprocmail-:version-id)))
+
+;;}}}
+
+;;; ############################################################ &mode ###
+
+;;{{{ mode
+
+;;;###autoload (autoload 'tinyprocmail-mode "tinyprocmail" "" t)
+;;;###autoload (autoload 'turn-on-tinyprocmail-mode "tinyprocmail" "" t)
+;;;###autoload (autoload 'turn-off-tinyprocmail-mode "tinyprocmail" "" t)
+;;;###autoload (autoload 'tinyprocmail-commentary "tinyprocmail" "" t)
+;;;###autoload (autoload 'tinyprocmail-version "tinyprocmail" "" t)
+
+(eval-and-compile
+
+ (ti::macrof-minor-mode-wizard
+ "tinyprocmail-" " PM" "\C-c'" "PM" 'TinyProcmail "tinyprocmail-:"
+ "Procmail coding minor mode.
+
+Code writing: `tinytab-mode' on \\[tinytab-mode]
+
+Mode description (main mode)
+\\{tinyprocmail-:mode-prefix-map}"
+
+ "Procmail recipe coding"
+
+ (progn ;Some mode specific things? No?
+ (cond
+ (tinyprocmail-mode
+ (setq comment-start "#"
+ comment-start-skip "#+[ \t]*"
+ comment-end ""
+ indent-tabs-mode nil)
+ ;; Should we turn on the font-lock me too?
+ ;; global-font-lock-mode is available in new emacs versions.
+ ;;
+ ;; Font-lock must be turned on FIRST, then set
+ ;; `font-lock-keywords'
+ (font-lock-mode-maybe 1)
+ (tinyprocmail-font-lock-keywords
+ tinyprocmail-:font-lock-keywords 'mode-font-lock)
+ (put 'tinyprocmail-mode 'tit tinytab-mode) ;Save previous
+ (unless tinytab-mode
+ (turn-on-tinytab-mode)))
+ (t
+ (tinyprocmail-font-lock-keywords
+ tinyprocmail-:font-lock-keywords 'mode-font-lock 'restore)
+ (if (and tinytab-mode (get 'tinyprocmail-mode 'tit))
+ (turn-off-tinytab-mode))
+ (tinyprocmail-overlay-hide))))
+
+ "Procmail mode"
+ (list ;arg 10
+ tinyprocmail-:mode-easymenu-name
+ ["Forward" tinyprocmail-forward t]
+ ["Backward" tinyprocmail-backward t]
+ ["Forward strict" tinyprocmail-forward-strict t]
+ ["Backward strict" tinyprocmail-backward-strict t]
+ "----"
+ ["Lint forward" tinyprocmail-lint-forward t]
+ ["Lint buffer" tinyprocmail-lint-buffer t]
+ ["Lint buffer and save output" tinyprocmail-lint-buffer-batch t]
+ ["Lint output, buffer display" tinyprocmail-output-display t]
+ ["Lint output, buffer clear" tinyprocmail-output-clear t]
+ ["Lint output, kill file" tinyprocmail-output-file-kill t]
+ "----"
+ (list
+ "Comment Hiding"
+ ["Hide region" tinyprocmail-hide-comment-text-region t]
+ ["Show region" tinyprocmail-show-comment-text-region t]
+ ["Hide recipe" tinyprocmail-hide-comment-text-recipe t]
+ ["Show recipe" tinyprocmail-show-comment-text-recipe t])
+ (list
+ "Misc"
+ ["Return key toggle" tinytab-return-key-mode t]
+ ["Fix backslashes at point" tinyprocmail-fix-backslashes-paragraph t]
+ ["Package version" tinyprocmail-version t]
+ ["Package commentary" tinyprocmail-commentary t])
+ "----"
+ ["Mode off" turn-off-tinyprocmail-mode t])
+ (progn
+ (define-key map "\\" 'tinyprocmail-fix-backslashes-paragraph)
+ (define-key map "?" 'tinyprocmail-mode-help)
+ (define-key map "Hm" 'tinyprocmail-mode-help)
+ (define-key map "Hc" 'tinyprocmail-commentary)
+ (define-key map "Hv" 'tinyprocmail-version)
+ (define-key root-map "\C-n" 'tinyprocmail-forward)
+ (define-key root-map "\C-p" 'tinyprocmail-backward)
+ (define-key root-map [(end)] 'tinyprocmail-forward)
+ (define-key root-map [(home)] 'tinyprocmail-backward)
+ (define-key root-map [(control end)] 'tinyprocmail-forward-strict)
+ (define-key root-map [(control home)] 'tinyprocmail-backward-strict)
+ (define-key map "_" 'tinyprocmail-hide-comment-text-region)
+ (define-key map "-" 'tinyprocmail-show-comment-text-region)
+ (define-key map ":" 'tinyprocmail-hide-comment-text-recipe)
+ (define-key map "." 'tinyprocmail-show-comment-text-recipe)
+ (define-key map "l" 'tinyprocmail-lint-forward)
+ (define-key map "L" 'tinyprocmail-lint-buffer)
+ (define-key map "r" 'tinyprocmail-standardize-recipe-start)
+ (define-key map "\C-m" 'tinytab-return-key-mode)
+ ;; Uppercase to prevent from errors.
+ (define-key map "B" 'tinyprocmail-lint-buffer-batch)
+ (define-key map "K" 'tinyprocmail-output-file-kill)
+ (define-key map "d" 'tinyprocmail-output-display)
+ (define-key map "c" 'tinyprocmail-output-clear)
+ (define-key map "o" 'tinyprocmail-overlay-hide)
+ (define-key map "?" 'tinyprocmail-describe-mode))))
+
+;;;###autoload (autoload 'tinyprocmail-output-mode "tinyprocmail" "" t)
+;;;###autoload (autoload 'turn-on-tinyprocmail-output-mode "tinyprocmail" "" t)
+;;;###autoload (autoload 'turn-off-tinyprocmail-output-mode "tinyprocmail" "" t)
+
+(eval-and-compile
+
+ (ti::macrof-minor-mode-wizard
+ "tinyprocmail-output-" " PM-Lint" "\C-c'" "PM-Lint"
+ 'TinyProcmail "tinyprocmail-output-:"
+
+ "Browsing Procmail lint output. See \\[tinyprocmail-lint]
+
+Mode description
+
+\\{tinyprocmail-output-:mode-prefix-map}"
+ "tinyprocmail"
+ (progn
+ (when (and (interactive-p) ;On when user calls us directly
+ ;; Mode is Now turned on, check Lint buffer and confirm
+ tinyprocmail-output-mode
+ (null (ti::re-search-check (concat "^" (regexp-quote "*** "))))
+ (null (y-or-n-p
+ "No Prcomail Lint output found. Are you sure? ")))
+ (setq tinyprocmail-output-mode nil)
+ (error "Aborted."))
+ (tinyprocmail-font-lock-keywords
+ tinyprocmail-:lint-font-lock-keywords 'lint-font-lock))
+ "Procmail Lint output mode"
+ (list ;arg 10
+ tinyprocmail-output-:mode-easymenu-name
+ ["Find error" tinycompile-parse-line-goto t]
+ ["Beginning of output" tinyprocmail-output-start t]
+ ["End of output" tinyprocmail-output-end t]
+ ["Save output" tinyprocmail-output-file-save t]
+ ["Clear output" tinyprocmail-output-clear t]
+ "----"
+ ["Sort by line number" tinyprocmail-output-sort-by-line t]
+ ["Sort by error" tinyprocmail-output-sort-by-error t]
+ "----"
+ ["Mode on for all pm buffers" turn-on-tinyprocmail-mode-all-buffers t]
+ ["Mode off for all pm buffers" turn-off-tinyprocmail-mode-all-buffers t]
+ ["Mode help" tinyprocmail-output-mode-help t]
+ ["Mode off" tinyprocmail-output-mode t])
+ (progn
+ (if (ti::emacs-p)
+ (define-key root-map [mouse-2] 'tinycompile-parse-line-goto)
+ (define-key root-map [(button2)] 'tinycompile-parse-line-goto))
+ ;; Define keys like in Compile
+ (define-key map "\C-c\C-c" 'tinycompile-parse-line-goto)
+ (define-key map "\C-m" 'tinycompile-parse-line-goto)
+ (define-key map "b" 'tinyprocmail-output-start)
+ (define-key map "e" 'tinyprocmail-output-end)
+ (define-key map "sl" 'tinyprocmail-output-sort-by-line)
+ (define-key map "se" 'tinyprocmail-output-sort-by-error)
+ (define-key map "S" 'tinyprocmail-output-file-save)
+ (define-key map "C" 'tinyprocmail-output-clear)
+ (define-key map "?" 'tinyprocmail-output-mode-help))))
+
+;;; ......................................................... &install ...
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload (autoload 'tinyprocmail-install-files "tinyprocmail" t t)
+(ti::macrof-install-pgp-tar tinyprocmail-install-files "tinyprocmail.el")
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun turn-off-tinyprocmail-mode-all-buffers (&optional verb)
+ "Call `turn-on-tinyprocmail-mode-all-buffers' with parameter `off'. VERB."
+ (interactive)
+ (ti::verb)
+ (turn-on-tinyprocmail-mode-all-buffers 'on verb))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun turn-on-tinyprocmail-mode-all-buffers (&optional off verb)
+ "Turn on or OFF function `tinyprocmail-mode' for all procmail buffers. VERB.
+Procmail files start with `rc.' or end to `.rc' and file content
+must match `^:0'."
+ (interactive "P")
+ (ti::verb)
+ (dolist (buffer (buffer-list))
+ (with-current-buffer buffer
+ (when (and (if off tinyprocmail-mode (null tinyprocmail-mode))
+ buffer-file-name
+ (string-match
+ "^rc\\.\\|\\.rc$\\|procmailrc"
+ buffer-file-name)
+ (ti::re-search-check "^:0"))
+ (if verb (message "TinyProcmail: Mode turned %s in %s"
+ (if off "off" "on") (buffer-name)))
+ (if off
+ (turn-off-tinyprocmail-mode)
+ (turn-on-tinyprocmail-mode))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-install-auto-mode-alist (&optional uninstall)
+ "Update `auto-mode-alist' to know about procmail *.rc files."
+ (cond
+ (uninstall
+ (ti::assoc-replace-maybe-add
+ 'auto-mode-alist
+ tinyprocmail-:auto-mode-alist
+ 'remove))
+ (t
+ (ti::assoc-replace-maybe-add
+ 'auto-mode-alist
+ tinyprocmail-:auto-mode-alist)
+ (if (interactive-p)
+ (message "TinyProcmail: uninstalled")))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-install (&optional uninstall verb)
+ "Install package, or optionally UNINSTALL. VERB."
+ (interactive "P")
+ (ti::verb)
+ ;; It is crucial that these two hooks are in this order
+ ;; First runs `tinyprocmail-lint-malformed-start-recipe' and only after
+ ;; that the receipes can be found.
+ (ti::add-hooks 'tinyprocmail-:lint-before-hook
+ '(tinyprocmail-standardize-recipe-start
+ tinyprocmail-lint-malformed-start-recipe)
+ uninstall)
+ (ti::add-hooks 'tinyprocmail-:lint-after-hook
+ '(tinyprocmail-lint-malformed-var-defs
+ tinyprocmail-lint-malformed-misc
+ tinyprocmail-lint-malformed-brace
+ tinyprocmail-lint-find-wrong-escape-codes
+ tinyprocmail-lint-find-2spaces
+ tinyprocmail-lint-list-lint-directives)
+ uninstall)
+ (tinyprocmail-install-auto-mode-alist uninstall)
+ (turn-on-tinyprocmail-mode-all-buffers uninstall verb))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-find-file-hook ()
+ "Turn on tipm mode if you're viewing log file."
+ (when (and (not tinyprocmail-mode)
+ (ti::re-search-check "^:0$")) ;It's procmail ok
+ (tinyprocmail-mode 1)))
+
+;;}}}
+
+;;; ########################################################### ¯o ###
+
+;;{{{ macro
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro tinyprocmail-o (&rest body)
+ "Move overlay to point and protect BODY. Overlay is hiddedn after body."
+ (`
+ (unwind-protect
+ (progn
+ (tinyprocmail-overlay (point))
+ (,@ body))
+ (tinyprocmail-overlay-hide))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro tinyprocmail-output-macro (&rest body)
+ "Go to `tinyprocmail-:lint-output-buffer' and do BODY.
+If buffer does not exist, do nothing."
+ (`
+ (let ((buffer (get-buffer tinyprocmail-:lint-output-buffer)))
+ (when buffer
+ (with-current-buffer buffer
+ (,@ body))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinyprocmail-fix-macro 'lisp-indent-function 1)
+(defmacro tinyprocmail-fix-macro (message &rest body)
+ "Fix. Display MESSAGE and do BODY."
+ (`
+ (when (or (eq tinyprocmail-:lint-fix-mode 'auto)
+ (and (eq tinyprocmail-:lint-fix-mode 'semi)
+ (tinyprocmail-o (y-or-n-p (, message)))))
+ (,@ body))))
+
+;;; ----------------------------------------------------------------------
+;; fmacro = function create macro
+;;;
+(defmacro tinyprocmail-fmacro-move (back method)
+ "Make move function using BACK and METHOD."
+ (let* ((sym (intern
+ (format "tinyprocmail-%s-%s"
+ (if back
+ "backward"
+ "forward")
+ (symbol-name (` (, method)))))))
+ (`
+ (defun (, sym) ()
+ (interactive)
+ (tinyprocmail-forward (quote (, back)) (quote (, method)))))))
+
+;;}}}
+;;{{{ misc
+
+;;; ............................................................. misc ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinyprocmail-comment-line-p ()
+ "Check if this ine is full comment line. Use `save-excursion'."
+ (save-excursion
+ (beginning-of-line)
+ (looking-at "^[ \t]*#")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinyprocmail-comment-line-pp ()
+ "Check if this ine is full comment line at current point forward."
+ (looking-at "^[ \t]*#"))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinyprocmail-string-valid-p (string &optional type)
+ "Check is STRING is valid variable. Find any supicious character.
+Input:
+ STRING variable or read filename.
+ TYPE if 'path; then check as path."
+ (cond
+ ((eq type 'path)
+ (string-match "^[-_a-zA-Z0-9.$\\/@]+$" string))
+ (t
+ (string-match "^[_a-zA-Z0-9]+$" string))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-supported-p (feature)
+ "Check if FEATURE is supported by `tinyprocmail-:procmail-version'."
+ (let* ((v (or tinyprocmail-:procmail-version "")))
+ (cond
+ ((eq feature 'condition-middle-comment)
+ (string-match "3.11pre7" v))
+ ((error "Invalid feature %s" feature)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-lint-directive-1 (&optional start-point)
+ "Search Lint directive line backward from current point or START-POINT.
+# Ignore checking of mising -w flag in this case
+# Lint: -w
+:0 fh
+| doSomething
+
+Return:
+
+ str directive flags."
+ (save-excursion
+ (if start-point (goto-char start-point))
+ (end-of-line)
+ (when (and (re-search-backward "^[ \t]*:0" nil t)
+ (forward-line -1)
+ (looking-at "^[ \t]*#[ \t]*Lint:\\(.*\\)"))
+ (match-string 1))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinyprocmail-lint-directive-p (directive directive-flags)
+ "Search Lint DIRECTIVE from DIRECTIVE-FLAGS."
+ (when (stringp directive-flags)
+ (string-match (concat " " (regexp-quote directive)) directive-flags)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-overlay (point)
+ "Move overlay to POINT."
+ (when (and (fboundp 'make-overlay)
+ (fboundp 'move-overlay)
+ (fboundp 'overlay-put))
+ (or tinyprocmail-:overlay
+ (setq tinyprocmail-:overlay (make-overlay 1 1)))
+ (or tinyprocmail-:overlay-second
+ (setq tinyprocmail-:overlay-second (make-overlay 1 1)))
+ (dolist (elt '((owner tipm)
+ (priority 1)
+ (face highlight)
+ (before-string ">")))
+ (multiple-value-bind (property value) elt
+ (overlay-put tinyprocmail-:overlay property value)
+ (if (eq property 'before-string)
+ (overlay-put tinyprocmail-:overlay-second
+ 'after-string " <<"))))
+ (save-excursion
+ (goto-char point)
+ (move-overlay tinyprocmail-:overlay
+ (line-beginning-position)
+ (line-end-position)
+ (current-buffer))
+ (goto-char (line-end-position))
+ (move-overlay tinyprocmail-:overlay
+ (line-beginning-position)
+ (line-end-position)
+ (current-buffer)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-overlay-hide ()
+ "Move overlay out of sight."
+ (interactive)
+ (when (fboundp 'move-overlay)
+ (dolist (ov '(tinyprocmail-:overlay tinyprocmail-:overlay-second))
+ (when (and (boundp ov)
+ (setq ov (symbol-value ov)))
+ (move-overlay ov 1 1)
+ (overlay-put ov 'before-string "")
+ (overlay-put ov 'after-string "")))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-font-lock-keywords (keywords property &optional restore)
+ "Use font-lock KEYWORDS and store original to PROPERTY. RESTORE original."
+ (let ((sym 'font-lock-keywords))
+ (when (boundp sym)
+ (if restore
+ (set sym (get 'tinyprocmail-mode property))
+ (put 'tinyprocmail-mode property (symbol-value sym))
+ (set sym keywords)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-log (point string &optional point-min)
+ "Log POINT and STRING to lint buffer if `tinyprocmail-:lint' is non-nil.
+
+Input:
+
+ POINT The current error point
+ POINT-MIN Where is the logical `point-min' which we use to count
+ the line numbers. Defualts to (point-min) but in case
+ you're using narrow, this should be `point-min' before
+ narrowing to check the recipe condition."
+ (when tinyprocmail-:lint-log
+ ;; Some safety measures
+ (when (and point (not (integerp point)))
+ (error "arg POINT is not integer"))
+ (when (and string (not (stringp string)))
+ (error "arg STRING is not stringp"))
+ (let* ((buffer (get-buffer-create tinyprocmail-:lint-output-buffer))
+ (name (buffer-name))
+ (LINE (if point
+ (save-excursion
+ (goto-char point)
+ (count-lines
+ (or point-min (point-min))
+ (if (bolp)
+ (1+ (point))
+ (point)))))))
+;;; (if (eq point 4266) (ti::d! LINE point point-min (bolp) ))
+ (with-current-buffer buffer
+ (ti::pmax)
+ (if (and point string)
+ (insert
+ (format
+ "%s:%03d: %s\n"
+ name
+ LINE
+ string))
+ (insert string))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-log-start ()
+ "Start log by adding header into list log buffer."
+ (tinyprocmail-log
+ nil
+ (format
+ (concat
+ "\n\n"
+ "*** %s (%s) %s tinyprocmail.el %s\n%s")
+ (ti::date-standard-date 'minutes)
+ (buffer-name)
+ (or tinyprocmail-:procmail-version "")
+ (ti::string-match "[0-9][0-9.]+" 0 tinyprocmail-:version-id)
+
+ (if (buffer-file-name)
+ (concat "cd " (file-name-directory (buffer-file-name)) "\n")
+ ""))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinyprocmail-recipe-start-p (&optional line)
+ "Check if current LINE is recipe start line."
+ (if line
+ (string-match "^[ \t]*:0" line)
+ (save-excursion
+ (beginning-of-line)
+ (looking-at "^[ \t]*:0"))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-condition-line-p (&optional line)
+ "Check if current LINE is condition line."
+ (if line
+ (string-match "^[ \t]*\\*" line)
+ (save-excursion
+ (beginning-of-line)
+ (or (looking-at "^[ \t]*\\*")
+ (progn
+ ;; Peek previous line
+ ;; * condition \
+ ;; line \
+ ;; line-end << suppose point is here
+ (forward-line -1)
+ (looking-at "^[ \t*]+.*[\\]"))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-assignment-line-p (&optional line)
+ "Check if current LINE has assignment."
+ (if line
+ (string-match "^[^=]+=" line)
+ (save-excursion
+ (beginning-of-line)
+ (or (looking-at "^[^=]+=")
+ (progn
+ ;; Peek previous line
+ ;; * condition \
+ ;; line \
+ ;; line-end << suppose point is here
+ (forward-line -1)
+ (or (looking-at "^[^=]+=.*[\\][ \t]*$")
+ (progn
+ (tinyprocmail-skip-continuation-backward)
+ (forward-line 1)
+ (looking-at "^[^=]+="))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro tinyprocmail-flag-string ()
+ "Return base flag string."
+ (` "aAeEHBDfhbwWirc:"))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinyprocmail-flag-p (char-string)
+ "Check if one CHAR-STRING is valid flag."
+ (ti::string-match-case char-string (tinyprocmail-flag-string)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinyprocmail-recipe-start-require ()
+ "Flag error if not at recipe start."
+ (unless (tinyprocmail-recipe-start-p)
+ (error "Not recipe start line")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-brace-p (&optional line)
+ "Check if cursor is under brace or in brace LINE. Return 'beg, 'end or nil."
+ (interactive)
+ (cond
+ (line
+ (save-excursion
+ (cond
+ ((looking-at "[ \t]*{")
+ 'beg)
+ ((looking-at "[ \t]*}")
+ 'beg))))
+ (t
+ (or (if (char= (following-char) ?{) 'beg)
+ (if (char= (following-char) ?}) 'end)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-action-line-ok-p ()
+ "Point must be at the end of conditions.
+This checks if the actions line is ok."
+ (interactive)
+ (let* ((opoint (point))
+ (point opoint))
+ ;; Suppose there is no action line at all
+ ;;
+ ;; :0
+ ;; * test
+ ;;
+ ;; # comment
+ ;; :0[*] point is somewhere here, previous condition end.
+ (beginning-of-line)
+ ;; - Eat all newlines and comments backward
+ (setq point (point))
+ (if (tinyprocmail-recipe-start-p)
+ (backward-line 1))
+ (when (tinyprocmail-skip-comments-backward)
+ (if (tinyprocmail-condition-line-p)
+ (forward-line 1))
+ (setq point (point)))
+ (goto-char point)
+ (skip-chars-forward " \t")
+ ;;
+ ;; :0 :0 :0 :0 :0 :0
+ ;; ! | { mbox /dev/null $mbox
+
+ (when (not (looking-at "[|!/][^#\n]+\\|[$]?[A-Z]\\|{"))
+ (point))))
+
+;;}}}
+;;{{{ move: primitives
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-next-empty-line ()
+ "Return point of next empty code line."
+ (let* ((list (ti::re-search-point-list
+ '("^[ \t]*$" "^[ \t]*#")
+ 'beginning-of-line)))
+ (if list
+ (apply 'min list))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-skip-regexp (regexp &optional backward)
+ "Skip all lines that match `looking-at' REGEXP. Optionally BACKWARD."
+ (let* (done)
+ (while (and (not (eobp))
+ (looking-at regexp))
+ (setq done t)
+ (if backward
+ (backward-line 1)
+ (forward-line 1)))
+ (when done
+ (if backward
+ (skip-chars-backward " \t")
+ ;; Go to first char in the line
+ (skip-chars-forward " \t")))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-skip-comments-forward ()
+ "Skip all comments and whitespace lines."
+ (tinyprocmail-skip-regexp "[ \t]*#\\|[ \t]*$"))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-skip-comments-backward ()
+ "Skip all comments and whitespace lines."
+ (tinyprocmail-skip-regexp "[ \t]*#\\|[ \t]*$" 'back))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-skip-continuation-forward ()
+ "Skip lines that end to backslash."
+ (tinyprocmail-skip-regexp ".*[\\][ \t]*$"))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-skip-continuation-backward ()
+ "Skip lines that end to backslash."
+ (tinyprocmail-skip-regexp ".*[\\][ \t]*$" 'back))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-move-to-next-condition-line ()
+ "Move to next line in condition.
+Return:
+ t Sitting on condition line after move.
+ nil Not a condition line after move"
+ (let* ((cont-p (looking-at ".*[\\][ \t]*$")))
+ (if (or (looking-at ":0")
+ (save-excursion
+ (beginning-of-line)
+ ;; :0
+ (looking-at "^[ \t]*:")))
+ (forward-line 1)
+ (forward-line 1)
+ (when (and (not (looking-at "[ \t]*\\*")) ;; Beginning of recipe
+ cont-p)
+ (forward-line -1) ;Start from original line
+ (inline (tinyprocmail-skip-continuation-forward))
+ (forward-line 1))
+ ;; * condition
+ ;; # comment inside condition
+ ;; * another condition.
+ (when (looking-at "[ \t]*#")
+ (inline (tinyprocmail-skip-comments-forward))))
+ (skip-chars-forward " \t")
+ (looking-at "[ \t]*\\*")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-move-to-condition-end ()
+ "Go to condition end. Point must inside condition or recipe start."
+ (let* ()
+ (cond
+ ((tinyprocmail-brace-p)
+ nil)
+ ((and (tinyprocmail-recipe-start-p)
+ (save-excursion
+ (forward-line 1)
+ (not (looking-at "^[ \t]*\\*"))))
+ ;; Handle special case
+ ;;
+ ;; :0 c:
+ ;; mailbox
+ (forward-line 1)
+ (skip-chars-forward " \t"))
+ (t
+ (while (and (not (eobp))
+ (or (tinyprocmail-move-to-next-condition-line)
+ ;; - count empty lines too. This is usually users
+ ;; mistake and error in procmail, but
+ ;; we must find condition end.
+ ;; - We accept only _1_ empty line between conditions
+ ;; Other than that must be real big error.
+ ;;
+ ;; :0
+ ;; * condition
+ ;;
+ ;; *condition
+ ;; mbox
+
+ (and (looking-at "^[ \t]*$")
+ (save-excursion
+ (forward-line 1)
+ ;; Must be condition line
+ (looking-at "[ \t]*\\*")))))
+ (skip-chars-forward " \t"))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-move-to-macthing-brace (&optional no-adjust)
+ "Go to { or } brace when sitting on } or {.
+Input:
+ NO-ADJUST If non-nil, when goind to ending brace, do not
+ put cursor on brace, but to next line."
+ (unless (get 'tinyprocmail-:mode-name 'syntax-table)
+ (let* ((otable (syntax-table))
+ (table otable))
+ (modify-syntax-entry ?{ "(" table)
+ (modify-syntax-entry ?} ")" table)
+ (put 'tinyprocmail-:mode-name 'syntax-table table)))
+
+ (let* ((otable (syntax-table)))
+ (set-syntax-table (get 'tinyprocmail-:mode-name 'syntax-table))
+ (prog1
+ (cond
+ ((char= (following-char) ?{)
+ (forward-list 1)
+ (if no-adjust
+ (forward-line 1)
+ (backward-char 1)))
+ (t
+ (forward-char 1)
+ (backward-list 1)))
+ (set-syntax-table otable))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-move-to-recipe-end ()
+ "Go to recipe block end. Return recipe bound: (beg . end) ."
+ (let* (beg)
+ (if (not (tinyprocmail-recipe-start-p))
+ (tinyprocmail-backward-strict))
+ (setq beg (point))
+
+ (tinyprocmail-move-to-condition-end)
+ (if (tinyprocmail-brace-p)
+ (tinyprocmail-move-to-macthing-brace 'no-adjust)
+ (or (re-search-forward "^[ \t]*$" nil t)
+ (error "TinyProcmail: Can't find recipe end.")))
+ (cons beg (point))))
+
+;;}}}
+;;{{{ move: interactive
+
+;;; ............................................................ &move ...
+
+(tinyprocmail-fmacro-move nil strict)
+(tinyprocmail-fmacro-move back strict)
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-fix-backslashes-paragraph ()
+ "Fix backslashes at point"
+ (interactive)
+ (ti::buffer-backslash-fix-paragraph))
+
+;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-backward (&optional method verb)
+ "Find previous procmail recipe. See METHOD in `tinyprocmail-forward'. VERB."
+ (interactive)
+ (ti::verb)
+ (tinyprocmail-forward 'back method verb))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-forward (&optional back method verb)
+ "Find next procmail recipe.
+
+Input:
+
+ BACK Search backward
+ METHOD if 'any then search commented recipe too.
+ if 'strict then only left flushed recipes.
+ nil searches ^WHITESPACE:
+ VERB Be verbose
+
+Return:
+
+ nil or non-nil if moved."
+ (interactive)
+ (let* ((opoint (point))
+ (re (cond
+ ((eq method 'strict)
+ "^:")
+ ((eq method 'any)
+ "^[# \t]*\\(:\\)")
+ (t
+ "^[ \t]*\\(:\\)"))))
+ (ti::verb)
+ (cond
+ (back
+ (beginning-of-line)
+ (if (re-search-backward re nil t)
+ (goto-char (match-beginning 1))
+ (if verb
+ (message "TinyProcmail: No more recipes backward."))
+ (goto-char opoint)
+ nil))
+ (t
+ (end-of-line)
+ (if (re-search-forward re nil t)
+ (goto-char (match-beginning 1))
+ (if verb
+ (message "TinyProcmail: No more recipes forward."))
+ (goto-char opoint)
+ nil)))))
+
+;;}}}
+;;{{{ hide
+
+;;; ............................................................ &hide ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-hide-comment-text-region (beg end &optional show)
+ "In region BEG END, hide or SHOW comment text ."
+ (interactive "r\nP")
+ (ti::narrow-safe beg end
+ (goto-char (min beg end))
+ (setq show (not show))
+ (with-buffer-modified
+ (while (re-search-forward "#.*" nil t)
+ (add-text-properties
+ (1+ (match-beginning 0)) (match-end 0)
+ (list 'invisible show))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-show-comment-text-recipe ()
+ "See `tinyprocmail-hide-comment-text-recipe'."
+ (interactive)
+ (tinyprocmail-hide-comment-text-recipe 'show))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-hide-comment-text-recipe (&optional show)
+ "Hide or SHOW comment text in current recipe. point must be in recipe."
+ (interactive "P")
+ (let* ((region (save-excursion (tinyprocmail-move-to-recipe-end))))
+ (tinyprocmail-hide-comment-text-region
+ (car region) (cdr region) show)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-show-comment-text-region (beg end)
+ "See `tinyprocmail-hide-comment-text-region'. Use Region BEG END."
+ (interactive "r")
+ (tinyprocmail-hide-comment-text-region beg end 'show))
+
+;;}}}
+;;{{{ output mode:
+
+;;; .......................................................... &output ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-output-end ()
+ "Go to endline of output block."
+ (interactive)
+ (if (looking-at "^[ \t]*$")
+ (skip-chars-forward " \t\n"))
+ (re-search-forward "^[ \t]*$"))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-output-start ()
+ "Go to start line of output block."
+ (interactive)
+ (unless (re-search-backward "^\\*\\*")
+ (error "Invalid buffer format, No ** found.")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-output-line-start ()
+ "Go to start of first code line."
+ (tinyprocmail-output-start)
+ (forward-line 1)
+ (if (looking-at "cd \\([^ \t\n]+\\)")
+ (forward-line 1))
+ (point))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-output-region ()
+ "Return output region block '(beg . end)."
+ (save-excursion
+ (let* ((beg (tinyprocmail-output-line-start)))
+ (tinyprocmail-output-end)
+ (cons beg (point)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-output-sort-by-error (&optional reverse)
+ "Sort block by error. Optionally REVERSE."
+ (interactive "P")
+ (let* ((region (tinyprocmail-output-region)))
+ (ti::save-line-column-macro nil nil
+ (sort-regexp-fields
+ (if reverse -1)
+ "^[^:]+:[^:]+:\\([^,]+\\).*$" "\\1"
+ (car region)
+ (cdr region)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-output-sort-by-line (&optional reverse)
+ "Sort block by line number. Optionally REVERSE."
+ (interactive "P")
+ (let* ((region (tinyprocmail-output-region)))
+ (ti::save-line-column-macro nil nil
+ (sort-lines reverse (car region) (cdr region)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-output-file-save (&optional file)
+ "Write `tinyprocmail-:lint-output-buffer' to `tinyprocmail-:lint-file' using FILE."
+ (interactive)
+ (save-excursion
+ (if (null (ti::set-buffer-safe tinyprocmail-:lint-output-buffer))
+ (error "No `%s' buffer found." tinyprocmail-:lint-output-buffer)
+ (write-region (point-min) (point-max)
+ (or file tinyprocmail-:lint-output-file)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-output-file-kill ()
+ "Kill `tinyprocmail-:lint-file' if it exists."
+ (interactive)
+ (if (file-exists-p tinyprocmail-:lint-output-file)
+ (delete-file tinyprocmail-:lint-output-file)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-output-clear (&optional verb)
+ "Clear `tinyprocmail-:lint-output-buffer' buffer if it exists. VERB."
+ (interactive)
+ (ti::verb)
+ (save-excursion
+ (cond
+ ((ti::set-buffer-safe tinyprocmail-:lint-output-buffer)
+ (erase-buffer)
+ (if verb
+ (message "TinyProcmail: %s cleared"
+ tinyprocmail-:lint-output-buffer))))))
+
+;;}}}
+
+;;{{{ Lint: Flag functions
+
+;;; ............................................................ &flag ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-flag-read (string)
+ "Read flags; including lock char, from STRING. If no flags read, return nil."
+ ;;
+ ;; We have to count space, beacuse
+ ;;
+ ;; :0 E fh c: is valid recipe.
+ ;;
+ (setq string (replace-regexp-in-string "[ \t]+" "" string))
+ (when (or (string-match "^[ \t]*:0?\\([^0#\n:]*:\\)" string)
+ (string-match "^[ \t]*:0?\\([^0#\n]+\\)" string))
+ (match-string 1 string)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-flag-standardize (string)
+ "Standardize flag order.
+The STRING must not contain anything else but flags.
+Call `tinyprocmail-flag-read' first.
+
+Return:
+
+ string Standardized order.
+ symbol Standardized order, flags, ok, but flags were uniqueied:
+ e.g. 'fhih' --> 'fhi'
+ 1 Error, The input string had invalid flags.
+ 2 Error, flag conflict, aAeE used simultaneously"
+ (let* ((flags (tinyprocmail-flag-string))
+ (hash (make-vector (length flags) nil))
+ (len (length string))
+ (ret "")
+ (ret-len 0)
+ (conflict1 0)
+ (conflict2 0)
+ case-fold-search
+ ch
+ pos)
+ (ti::dotimes counter 0 (1- (length string))
+ (setq ch (substring string counter (1+ counter)))
+ (when (string-match ch flags) ;This is case sensitive match
+ ;; Get the hash position
+ ;;
+ ;; aAeEf
+ ;; |
+ ;; pos = 2 if the ch was 'f'
+ (setq pos (match-beginning 0))
+ ;; Increment the logical length: The character was valid
+ (incf ret-len) ;OK
+ ;; filter duplicates: If the hash doen't have this character already
+ ;; then add it to new string.
+ (when (null (elt hash pos))
+ ;; Mark the flas as used in hash table
+ (aset hash pos t)
+ (if (string-match ch "aAeE")
+ (incf conflict1))
+ (if (string-match ch "wW")
+ (incf conflict2)))))
+ ;; Map the hash and see what flags it set
+ (ti::dotimes counter 0 (1- (length hash))
+ (if (elt hash counter)
+ (setq ret (concat ret (substring flags counter (1+ counter))))))
+ (cond
+ ((or (> conflict1 1)
+ (> conflict2 1))
+ ;; There can be only one: aAeE
+ 2)
+ ((eq len (length ret))
+ ;; All flags checked and they were valid
+ ret)
+ ((eq len ret-len)
+ ;; All flags ok, but there were duplicates, which were
+ ;; removed.
+ (make-symbol ret))
+ (t
+ ;; Error: invalid flags
+ 1))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-flag-format-default (flags)
+ "Default FLAGS format: ' STANDARDIZED-ORDER'. FLAGS must not have spaces."
+ (let* (new)
+ (setq new (tinyprocmail-flag-standardize flags))
+ (if (or (stringp new)
+ (and (symbolp new)
+ (setq new (symbol-name new))))
+ (if (not (eq tinyprocmail-:flag-and-recipe-start-style
+ 'flags-together))
+ (concat " " new)
+ new)
+ (error "Invalid flags %s --> %s " flags new))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-flag-kill (&optional replace)
+ "Kill flags in the line and optionally REPLACE and STANDARDIZE with SPACE."
+ (let* ((eol (line-end-position))
+ beg
+ end
+ list)
+ (when (and replace tinyprocmail-:flag-format-function)
+ (setq replace (funcall tinyprocmail-:flag-format-function replace)))
+ (beginning-of-line)
+ (when (re-search-forward ":0" eol t)
+ (setq beg (point))
+ (setq list (inline (ti::re-search-point-list '(":" "#") nil eol))
+ end (if list (apply 'min list) eol))
+ (delete-region beg end)
+ (goto-char beg)
+ (if replace
+ (insert replace)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-flag-order-lint ()
+ "Lint flag order at point. Return (FLAGS . STD-FLAGS) or nil."
+ (let* ((line (ti::remove-properties (ti::read-current-line)))
+ (pedantic (eq tinyprocmail-:lint-log-verbose 'pedantic))
+ flags1
+ flags2
+ str)
+ (when (prog1 (setq flags1 (tinyprocmail-flag-read line))
+ (unless flags1 ;No flags in this recipe
+ (setq flags1 "" flags2 "")))
+ ;; User can write this, which we just ignore if the first
+ ;; character is $
+ ;;
+ ;; :0 $FLAGS
+ ;;
+ (if (string-match "^[$]" flags1)
+ (progn
+ (tinyprocmail-log
+ (point)
+ (format
+ "info, flag variable `%s' was not checked." flags1))
+ nil) ;RET VAL
+ (setq flags2 (tinyprocmail-flag-standardize flags1))
+ ;; How would the standardization go?
+ (cond
+ ((symbolp flags2)
+ (setq str (format "Warning, duplicate flags found: `%s'" flags1))
+ (tinyprocmail-log (point) str)
+ (setq flags2 (symbol-name flags2))
+ (tinyprocmail-fix-macro (concat str " Correct ")
+ (tinyprocmail-flag-kill flags2)))
+ ((eq 1 flags2)
+ (setq str (format "Error, invalid or extra flags: `%s'" flags1))
+ (tinyprocmail-log (point) str)
+ (tinyprocmail-fix-macro (concat str "(C-g to quit)"))
+ (setq flags2 nil))
+ ((eq 2 flags2)
+ (setq str "Error, flag conflict; some simultaneous 'aAeEwW'")
+ (tinyprocmail-log (point) str)
+ (tinyprocmail-fix-macro (concat str "(C-g to quit)"))
+ (setq flags2 nil))
+ ((and (not (string= flags1 flags2)) pedantic)
+ (setq
+ str
+ (format
+ "Pedantic, flag order style is not standard `%s', was `%s'"
+ flags2 flags1))
+ (tinyprocmail-log (point) str)
+ (tinyprocmail-fix-macro (concat str " Correct ")
+ (tinyprocmail-flag-kill flags2))))))
+ (if (and flags1 flags2)
+ (cons flags1 flags2))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-conition-comment-move-up ()
+ "Move comment upward and kill it."
+ (let* (str
+ col)
+ (save-excursion
+ (beginning-of-line)
+ (cond
+ ((looking-at "^[ \t]*\\(#.*\\)")
+ (goto-char (match-beginning 1))
+ (setq str (match-string 1)
+ col (current-column))
+ (ti::buffer-kill-line))
+ ((looking-at ".*\\(#.*\\)")
+ (setq str (match-string 1))
+ (ti::replace-match 1)
+ (if (looking-at "^[ \t]+")
+ (setq col (length (match-string 0))))))
+ (when str
+ (if (null (re-search-backward "^[ \t#]*$" nil t))
+ (ti::pmin)
+ (end-of-line))
+ ;; COL is the indentation of the code.
+ (insert (if col (make-string col ?\ ) "") str "\n")
+ t))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-condition-comment-embedded (&optional point point-min)
+ "Handle embedded comment inside condition line. Point must be on comment.
+POINT is used for lint log. POINT-MIN is (point-min) by default."
+ (let* ((supp (tinyprocmail-supported-p 'condition-middle-comment))
+ (col (current-column))
+ (opoint (point))
+ (tab " ")
+ no-move)
+ (or point (setq point opoint))
+ (or point-min (setq point-min (point-min)))
+ (cond
+ ((save-excursion
+ (beginning-of-line)
+ (looking-at "^[ \t]*\\*.*#"))
+ (tinyprocmail-log
+ point
+ "Error, comments not allowed in condition line."
+ point-min)
+ (tinyprocmail-fix-macro
+ "Comments not allowed in condition, Move upwards "
+ (setq no-move
+ (tinyprocmail-conition-comment-move-up))))
+ ((null supp)
+ (tinyprocmail-log
+ point
+ "Error, embedded comment. Not supported by your procmail."
+ point-min)
+ (tinyprocmail-fix-macro "Error, embedded comment. Move upward "
+ (tinyprocmail-conition-comment-move-up)))
+ (t ;supported by this procmail
+ (forward-line -1) ;Peek previous line
+ (move-to-column col t)
+ (cond
+ ((looking-at "\\*")
+ (tinyprocmail-log
+ point
+ "\
+info, embedded comment, please indent it by 4 spaces (readability)."
+ point-min)
+ (save-excursion
+ (forward-line 1) (move-to-column col t)
+ (tinyprocmail-fix-macro "[recommendation] Indent comment "
+ (insert tab))))
+ ((looking-at "\\([ \t]+\\)#")
+ ;;
+ ;; # comment
+ ;; # comment << here
+ (tinyprocmail-log point "info, embedded comment does not line up."
+ point-min)
+ (save-excursion
+ (forward-line 1) (move-to-column col 'force)
+ (tinyprocmail-fix-macro "Line up comment "
+ (insert (match-string 1))))))
+ ;; Back to normal line
+ (forward-line 1)))
+ (if (null no-move) ;The comment line was killed.
+ (end-of-line))))
+
+;;; --------------------------------------------------------- &comment ---
+;;;
+(defun tinyprocmail-lint-condition-comments (&optional point-min)
+ "Check condition area and comments.
+Buffer must be narrowed to condition lines.
+
+:0 --> :0
+* condition * condition
+# comment # comment
+* condition * condition
+
+Input:
+
+ POINT-MIN This is the value of logical `point-min' before calling
+ the function. If aller narrowed to recipe, it must pass
+ this variable, otherwise narrowed region's `point-min'
+ is used to report error lines.
+
+Return:
+
+ nil
+ non-nil there are embedded comments"
+ (ti::pmin)
+ (while (re-search-forward "#" nil t)
+ (backward-char 1)
+ (tinyprocmail-condition-comment-embedded (point) point-min)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-lint-recipe-start (flags std-flags)
+ "Lint recipe start: flags and lockfile. Use FLAGS and STD-FLAGS."
+ (let* ((lock-p (string-match ":" (or flags "")))
+ (pedantic (eq tinyprocmail-:lint-log-verbose 'pedantic))
+ (pipe-w-re tinyprocmail-:pipe-w-warning-ignore-regexp)
+ (opoint (point))
+ (point-min (point-min))
+ (bol (line-beginning-position))
+ (direc (tinyprocmail-lint-directive-1))
+ (dw (tinyprocmail-lint-directive-p "-w" direc))
+ (di (tinyprocmail-lint-directive-p "-i" direc))
+ (dc (tinyprocmail-lint-directive-p "-c" direc))
+ str
+ str2
+ point
+ lock-file
+ file
+ cond-end
+ fix-line fix list
+ dev-null-p
+ formail-p
+ formail-d-p
+ paren-p
+ sendmail-p
+ condition-p
+ brace-p
+ pipe-p
+;;; var-or-literal-p
+ mbox-many-p
+ mbox-p
+ assignment-p
+ forward-p
+ redirection-p
+ invalid-action-p
+ fwd-invalid-p
+ size-test-p)
+ (catch 'end
+ (tinyprocmail-move-to-condition-end)
+ (setq cond-end (point)
+ flags (or flags "")
+ pipe-p (looking-at "[ \t]*|")
+ brace-p (tinyprocmail-brace-p)
+;;; var-or-literal-p (looking-at "[$a-z]")
+ forward-p (if (looking-at "!") (point))
+ fwd-invalid-p (if (looking-at "!.*,") (point))
+ ;; Illegal construct
+ ;; :0
+ ;; mailbox1 mailbox2
+ mbox-many-p (if (looking-at "[^|!{:\n]+[ \t]+[^ \t\n]") (point))
+ mbox-p (if (looking-at "[^|!{:\n]+[ \t]*$") (point))
+ dev-null-p (if (looking-at "/dev/null") (point))
+ ;; The actions line must be one of the following
+ ;;
+ ;; ! forward
+ ;; | pipe
+ ;; $MBOX
+ ;; MBOX
+ ;;
+ ;; This Moves point
+ invalid-action-p (if (tinyprocmail-action-line-ok-p) cond-end)
+ ;; VAR=| formail -zX'Subject:'
+ assignment-p (if (looking-at ".*=|")
+ (point)))
+;;; (ti::d! mbox-p dev-null-p (ti::read-current-line))
+ ;; ....................................................... mailbox ...
+ (when (eobp)
+ (setq str "Error, prematuere end of buffer.")
+ (tinyprocmail-log (point) str)
+ (tinyprocmail-fix-macro (concat "[cannont-fix] " str)))
+ (when (and mbox-many-p
+ (null assignment-p))
+ (setq str "Error, Multiple mailboxes not allowed.")
+ (tinyprocmail-log cond-end str)
+ (tinyprocmail-fix-macro (concat "[cannot-fix] " str)))
+ (when invalid-action-p
+ (save-excursion
+ (goto-char invalid-action-p)
+ (skip-chars-forward " \t\n")
+ (cond
+ ((looking-at "{")
+ (setq str "Error, empty lines before brace are not allowed.")
+ (tinyprocmail-log invalid-action-p str)
+ (tinyprocmail-fix-macro (concat str " Delete ")
+ (beginning-of-line)
+ (delete-region
+ (point)
+ (progn
+ (skip-chars-backward " \t\n")
+ (forward-line 1)
+ (point)))))
+ (t
+ (setq str "Error, Invalid action line; no |!$A-Z or brace found.")
+ (tinyprocmail-log invalid-action-p str)
+ (save-excursion
+ (goto-char invalid-action-p)
+ (tinyprocmail-fix-macro (concat "[cannot-fix] " str)))))))
+ ;; ....................................................... forward ...
+ (when fwd-invalid-p
+ (setq str "Error, invalid forward line. Maybe extra colons.")
+ (tinyprocmail-log fwd-invalid-p str)
+ (tinyprocmail-fix-macro (concat str " Remove ")
+ (beginning-of-line)
+ (while (re-search-forward "," (line-end-position) t)
+ (ti::replace-match 0))))
+ (when forward-p
+ (save-excursion
+ (goto-char forward-p)
+ (when (looking-at ".*!.*\\(\\<-t\\> *\\)")
+ (setq str "Warning, forward does not need -t switch")
+ (tinyprocmail-fix-macro (concat str " Remove ")
+ (ti::replace-match 1)))
+ (when (looking-at ".*!.*\\(\\<-oi\\> *\\)")
+ (setq str "\
+info, ! -oi, may be unnecessary. It's default in New prcomail.")
+ (tinyprocmail-fix-macro (concat str " Remove ")
+ (ti::replace-match 1)))))
+ ;; ............./........................................ check >> ...
+ ;; Narrowed to condition region
+ ;;
+ ;; :0
+ ;; * condition * condition
+ ;; # comment | pipe actions. \\
+ ;; * more actions \\
+ ;; { end
+ ;;
+ (goto-char cond-end)
+;;;; (ti::d! (point) brace-p (ti::read-current-line))
+ (cond
+ ((tinyprocmail-recipe-start-p)
+ (backward-line 1))
+ ((null brace-p)
+ ;; | recipe \\
+ ;; continues
+ (tinyprocmail-skip-continuation-forward)
+ (forward-line 1)))
+ (skip-chars-backward " \t\n") ;The end of narrow point
+;;; (ti::d! "skip" (point))
+ ;; ################################################## Narrow-begin ###
+ (ti::narrow-safe bol (point)
+ (when (setq formail-p (ti::re-search-check "formail"))
+ (setq formail-d-p (ti::re-search-check " -[^ ]*D "))) ;; perhaps -rD
+ ;; | (formail -rA "Header: val" \
+ ;; .. rest
+ ;; ) | $SENDMAIL
+ (setq paren-p (ti::re-search-check "("))
+ (setq sendmail-p (ti::re-search-check "sendmail")
+ ;; Is there any condition lines?
+ condition-p (ti::re-search-check "^[ \t]*\\*")
+ size-test-p (ti::re-search-check "^[ \t]*\\*[ !$]*[<>]"))
+;;; (ti::d! cond-end "pm-narrow: formail, sendmail" formail-p condition-p)
+ ;; \> is procmail word boundary.
+ (when (save-excursion
+ (goto-char cond-end)
+ ;; If line continues:
+ ;;
+ ;; | foo \
+ ;; this > mbox
+ ;;
+ ;; Accept "out >>FILE" and "OUT >>$FILE", but single
+ ;; token must have leading space
+ ;;
+ ;; If the > token is directly in the cond-end line
+ ;;
+ ;; | cat > junk
+ (or (looking-at ".*>") ;; on the same line
+ (re-search-forward "[^\\]> " nil t) ;; maybe continued
+ (re-search-forward ">>" nil t)))
+ (setq redirection-p (point))
+;;; (ti::d! (progn (goto-char redirection-p) (ti::read-current-line)))
+ nil)
+ ;; ................................................. empty-lines ...
+ (ti::pmin)
+ (while (and (not (eobp))
+ (re-search-forward "^[ \t]*$" nil t))
+ (setq point nil)
+ (tinyprocmail-log
+ (point) "Error, no empty lines allowed inside condition block"
+ point-min)
+ (tinyprocmail-fix-macro
+ "Error, empty line not allowed inside condition. Remove "
+ (setq point t)
+ (ti::buffer-kill-line))
+ (if (null point)
+ (forward-line 1)))
+ ;; .................................................... comments ...
+ (ti::pmin)
+ (when (and pedantic
+ (setq point
+ (tinyprocmail-lint-condition-comments point-min)))
+ (tinyprocmail-log
+ point "Pedantic, Condition lines have embedded comments."
+ point-min)))
+ ;; #################################################### Narrow-end ###
+ (goto-char opoint)
+ ;; ............................................. no-condition-line ...
+ (unless condition-p
+ (setq fix nil str "" str2 flags)
+ (dolist (ch '("H" "B" "D"))
+ (when (ti::string-match-case ch str2)
+ (setq fix t
+ str (concat str ch)
+ str2 (ti::replace-match 0 nil str2))))
+ (when fix
+ (setq str
+ (format "Warning, no condition line, but flags `%s' found."
+ str))
+ (tinyprocmail-log opoint str)
+ (tinyprocmail-fix-macro (concat str " Remove ")
+ (setq fix-line t
+ flags str2))))
+ ;; ......................................... nested {} block start ...
+ ;; Most of the flags don't make sense in the outer block level
+ ;;
+ ;; H, B, A, a, E, e, and D affect the conditions and thus are
+ ;; meaningful when the action is to open a brace. H, B, and D would be
+ ;; meaningless, of course, on any unconditional recipe, but they should
+ ;; not cause error messages.
+ (when brace-p
+ (setq fix nil str "" str2 flags)
+ ;; Exclude all. Base is aAeEfhbHBDwWirc:
+ (setq list '("f" "h" "b" "i" "r" "w" "W" ":"))
+ ;; if you are using c to launch a clone, then w, W, and a
+ ;; local lockfile can be meaningful.
+ (setq
+ list
+ (cond
+ ((string-match "c" flags)
+ '("f" "h" "b" "i" "r"))
+ (t
+ '("f" "h" "b" "i" "r" "w" "W"))))
+ (setq str2 flags)
+ (dolist (ch list)
+ (when (ti::string-match-case ch str2)
+ (setq fix t
+ str (concat str ch)
+ str2 (ti::replace-match 0 nil str2))))
+ (when fix
+ (setq str
+ (format "Warning, start of {} block has unnecessary flags `%s'"
+ str))
+ (tinyprocmail-log opoint str)
+ (tinyprocmail-fix-macro (concat str " Remove ")
+ (setq fix-line t
+ flags str2)))
+ (when (and lock-p
+ (not (string-match "c" flags)))
+ (setq str "Error, start of {} block has lockfile, but no `c' flag.")
+ (tinyprocmail-log opoint str)
+ (tinyprocmail-fix-macro (concat "[cannot-fix]" str))))
+ ;; ...................................................... size[<>] ...
+ (when size-test-p
+ (let* (case-fold-search)
+ (when (string-match "H" flags)
+ (setq str "Error, size test doesn't use `H' flag. (use H ?? <)")
+ (tinyprocmail-log size-test-p str)
+ (tinyprocmail-fix-macro (concat str " Remove ")
+ (setq fix-line t
+ flags (replace-regexp-in-string "H" "" flags))))
+ (when (string-match "B" flags)
+ (setq str "Error, size test doesn't use `B' flag. (use B ?? <)")
+ (tinyprocmail-log size-test-p str)
+ (tinyprocmail-fix-macro (concat str " Remove ")
+ (setq fix-line t
+ flags (replace-regexp-in-string "B" "" flags))))))
+ ;; .................................................... assignment ...
+ ;; VAR=| cat something
+ (when assignment-p
+ (when (and (string-match "c" flags)
+ (null dc))
+ (setq str "Warning, flag `c' is useless in assignment =|")
+ (tinyprocmail-log opoint str)
+ (tinyprocmail-fix-macro (concat str " Remove ")
+ (setq fix-line t
+ flags (replace-regexp-in-string "c" "" flags))))
+ (when (and (string-match "i" flags)
+ (null di))
+ (setq str "Warning, flag `i' is not recommended in assignment =|")
+ (tinyprocmail-log opoint str)
+ (tinyprocmail-fix-macro (concat str " Remove ")
+ (setq fix-line t
+ flags (replace-regexp-in-string "i" "" flags))))
+ (when lock-p
+ (setq str "Warning, lockfile \":\" is useless in assignment =|")
+ (tinyprocmail-log opoint str)
+ (tinyprocmail-fix-macro (concat str " Remove ")
+ (setq fix-line t
+ flags (replace-regexp-in-string ":" "" flags))))
+ (save-excursion
+ (goto-char assignment-p)
+ (when (looking-at ".*`")
+ (setq str "Error, backquotes mess things up in assignment =|")
+ (tinyprocmail-log (point) str)
+ (tinyprocmail-fix-macro (concat "[cannot-fix] " str )))))
+ ;; ..................................................... formail-D ...
+ (when (and formail-p
+ formail-d-p
+ (null assignment-p)
+ (null brace-p))
+ (when (string-match "f" flags)
+ (tinyprocmail-log
+ opoint "Error, formail -D used. Flag `f' is a mistake.")
+ (tinyprocmail-fix-macro "Formail -D used, remove `f' flag? "
+ (setq fix-line t
+ flags (replace-regexp-in-string "f" "" flags))))
+ (when (not (string-match "W" flags))
+ (tinyprocmail-log
+ opoint "Warning, formail -D used but no `W' flag found.")
+ (tinyprocmail-fix-macro "Formail -D found, add `W' flag? "
+ (setq fix-line t flags (concat "W" flags))))
+ (when (not (ti::string-match-case "h" flags))
+ (tinyprocmail-log opoint "Error, formail -D used. No flag `h' found.")
+ (tinyprocmail-fix-macro "Formail -D found, Add `h' flag? "
+ (setq fix-line t flags (concat "h" flags))))
+ (when (ti::string-match-case "b" flags)
+ (tinyprocmail-log
+ opoint "Error, formail -D used. SHould not have `b'.")
+ (tinyprocmail-fix-macro "Formail -D found, remove `b' flag? "
+ (setq fix-line t flags (ti::string-regexp-delete "b" flags))))
+ (when (not lock-p)
+ (setq str "Warning, formail -D used but no lockfile.")
+ (tinyprocmail-log opoint str)
+ (tinyprocmail-fix-macro (concat str " Add. ")
+ (setq fix-line t flags (concat ":" flags)))))
+ ;; ............................................ Check f and h or b ...
+ (setq fix nil)
+ (when (and (ti::string-match-case "f" flags)
+ (null (or (ti::string-match-case "b" flags)
+ (ti::string-match-case "h" flags))))
+ (tinyprocmail-log
+ (point)
+ "Warning, `f', but no h;b;hb found. What's up here? (readability) ")
+ (when (eq tinyprocmail-:lint-fix-mode 'semi)
+ (if (tinyprocmail-o
+ (y-or-n-p "Flag `f' requires `h' or `b' (yes=h, no=b) "))
+ (setq flags (concat "h" flags))
+ (setq flags (concat "b" flags)))
+ (setq fix t)))
+ ;; ......................................................... :0 fc ...
+ (when (and (ti::string-match-case "f" flags)
+ (ti::string-match-case "c" flags))
+ (setq str "info, Redundant `c' in `f' recipe.")
+ (tinyprocmail-log (point) str)
+ (tinyprocmail-fix-macro (concat str " Correct ")
+ (setq fix t)
+ (setq flags (replace-regexp-in-string "c" "" flags))))
+ (when fix (tinyprocmail-flag-kill flags))
+ ;; ..................................................... "|" and w ...
+ ;; Every "|" action should have "w" flag
+ (when (and pipe-p
+ (null brace-p)
+ (null assignment-p)
+ (null (string-match "w" flags))
+ (null dw)
+ (or (null pipe-w-re)
+ (save-excursion
+ (goto-char cond-end)
+ (not (looking-at pipe-w-re)))))
+ (setq str "\
+Warning, recipe with \"|\" may need `w' flag. (recommended) ")
+ (tinyprocmail-log opoint str)
+ (tinyprocmail-fix-macro (concat str " Add ")
+ (setq fix-line t
+ flags (concat "w" flags))))
+ ;; ................................................. check formail ...
+ (when (and formail-p
+ (null formail-d-p)
+ (null paren-p) ;; If this, then "f" is not needed
+ (null assignment-p)
+ (null brace-p)
+ ;; Don't require "f" flag in this case
+ ;;
+ ;; | $FORMAIL -A "header" >> mbox
+ ;;
+ (null redirection-p)
+ (not (string-match "f" flags)))
+ (setq str "Warning, Formail used but no `f' flag found.")
+ (tinyprocmail-log opoint str)
+ (tinyprocmail-fix-macro (concat str " Add ")
+ (setq fix-line t flags (concat "f" flags))))
+ ;; .............................................. f and no-formail ...
+ ;; If there was MH "rcvstore" Then "i" should not be there.
+ (when (and (null redirection-p)
+ pipe-p
+ (null formail-p)
+ (null sendmail-p)
+ (not (ti::string-match-case "f" flags))
+ (not (ti::string-match-case "i" flags))
+ (null di))
+ (setq str "Warning, recipe with \"|\", but no \">\" may need `i' flag.")
+ (tinyprocmail-log opoint str)
+ (tinyprocmail-fix-macro (concat str " Add ")
+ (setq fix-line t
+ flags (concat "i" flags))))
+ ;; i is meaningless if nested condition follows
+ ;; :0 i
+ ;; { }
+ (when (and brace-p
+ (ti::string-match-case "i" flags)
+ (null di))
+ (setq str "info, flag `i' is meaningless on top of nested block.")
+ (tinyprocmail-log opoint str)
+ (tinyprocmail-fix-macro (concat str " Remove ")
+ (setq fix-line t
+ flags (replace-regexp-in-string "i" "" flags))))
+ (when (and (null redirection-p)
+ pipe-p
+ (not (ti::string-match-case "f" flags))
+ (not (ti::string-match-case "c" flags))
+ (ti::string-match-case "i" flags)
+ (null dc))
+ (setq str
+ "\
+Warning, no \">\" in \"|\" recipe 'i' kills message. May need `c'.")
+ (tinyprocmail-log opoint str)
+ (tinyprocmail-fix-macro (concat str " Add ")
+ (setq fix-line t flags (concat "c" flags))))
+ (goto-char opoint)
+ ;; ............................................. check H without B ...
+ (let (case-fold-search)
+ (when (and (string-match "H" flags)
+ (null (ti::string-match-case "B" flags)))
+ (setq str "info, flag `H' is useless, because it is default.")
+ (tinyprocmail-log opoint str)
+ (tinyprocmail-fix-macro (concat str " Remove ")
+ (setq fix-line t
+ flags (replace-regexp-in-string "H" "" flags)))))
+ ;; ....................................................... check W ...
+ ;; :0 c: somefile is same as :0 Wc: somefile but ONLY on nesting
+ ;; block
+ (when (and flags
+ brace-p lock-p
+ (ti::string-match-case "W" flags)
+ (ti::string-match-case "c" flags))
+ (setq str
+ "info, redundant `Wc:', `c:' already implies W in {} block.")
+ (tinyprocmail-log opoint str)
+ (tinyprocmail-fix-macro (concat str " Correct")
+ (setq fix-line t
+ flags (replace-regexp-in-string "W" "" flags))))
+ ;; ................................................. need lockfile ...
+ (when (and redirection-p
+ (not brace-p)
+ (not formail-p)
+ (not forward-p)
+ (not lock-p))
+ (setq str "Warning, recipe seems to store to folder, may need lock.")
+ (tinyprocmail-log opoint str)
+ (tinyprocmail-fix-macro (concat str " Add ")
+ (setq fix-line t
+ flags (concat flags ":"))))
+ ;; Missing lockfile, but not if /dev/null
+ ;; :0 :0
+ ;; mbox /dev/null
+ (when (and mbox-p
+ (not dev-null-p)
+ (not redirection-p)
+ (not brace-p)
+ (not formail-p)
+ (not forward-p)
+ (not lock-p))
+ (setq str "Warning, message dropped to folder, it may need a lock.")
+ (tinyprocmail-log mbox-p str)
+ (save-excursion
+ (goto-char mbox-p)
+ (tinyprocmail-fix-macro (concat str " Add ")
+ (setq fix-line t
+ flags (concat flags ":")))))
+ ;; .......................................................... MBOX ...
+ (when mbox-p
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... dev/null . .
+ (when dev-null-p
+ (when lock-p
+ (setq str "Warning, /dev/null doesn't need lock")
+ (tinyprocmail-log mbox-p str)
+ (save-excursion
+ (goto-char mbox-p)
+ (tinyprocmail-fix-macro (concat str " Remove ")
+ (setq fix-line t
+ flags (replace-regexp-in-string ":" "" flags)))))
+ (unless (ti::string-match-case "h" flags)
+ (setq str "Info, /dev/null may be more efficient with `h' flag")
+ (tinyprocmail-log mbox-p str)
+ (save-excursion
+ (goto-char mbox-p)
+ (tinyprocmail-fix-macro (concat str " Add ")
+ (setq fix-line t
+ flags (concat flags "h"))))))
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... mbox name . .
+ ;; Check MBOX name
+ (save-excursion
+ (goto-char mbox-p)
+ (when (looking-at ".*LOGFILE\\|MAILDIR\\|FORMAIL\\|SENDMAIL")
+ (setq str (ti::read-current-line (point)))
+ (setq str (format "Warning, suspicious mbox filename `%s'" str))
+ (tinyprocmail-log mbox-p str)
+ (tinyprocmail-fix-macro (concat "[cannot-fix] " str))))
+ (when (and flags (string-match "i" flags))
+ (setq str "Warning, flag `i' is dangerous when dropping to folder.")
+ (tinyprocmail-log opoint str)
+ (tinyprocmail-fix-macro (concat str " Remove ")
+ (setq fix-line t
+ flags (replace-regexp-in-string "i" "" flags))))
+ (when (and flags (ti::string-match-case "hb\\|bh" flags))
+ (setq str "\
+Warning, flag combo `hb' is useless when dropping to folder.")
+ (tinyprocmail-log opoint str)
+ (tinyprocmail-fix-macro (concat str " Remove ")
+ (setq fix-line t
+ flags (replace-regexp-in-string "hb\\|bh" "" flags)))))
+ ;; .................................................... check lock ...
+ (goto-char opoint)
+ (beginning-of-line)
+ (skip-chars-forward "[ \t]")
+ (when (looking-at "[ \t]*:0[^:\n]*\\(:\\)\\( [a-z]\\)[a-z]?[ \t\n#]+")
+ (setq str (save-match-data (ti::string-remove-whitespace
+ (match-string 2))))
+ ;; change :0 HB: c to :0 HBc:
+ (tinyprocmail-log
+ (point)
+ (format "Possibly Flag used as lock `%s'" (ti::read-current-line)))
+ (cond
+ ((tinyprocmail-flag-p str)
+ (tinyprocmail-fix-macro
+ (format "Only One char `%s' lockfile, Move to flag section? " str)
+ (ti::replace-match 2)
+ (setq flags (concat str flags)
+ fix-line t)))
+ (t
+ (tinyprocmail-fix-macro
+ (format "[cannot-fix] Odd one char `%s' lockfile, C-g to quit."
+ str)))))
+ ;; ................................................. lockfile name ...
+ (when (looking-at "[ \t]*:0[^#:\n]*\\(:\\)\\([ \t]*\\)\\([^ \t\n#]+\\)")
+ (setq lock-file (match-string 3))
+;;; (ti::d! "LOCK-FILE" lock-file)
+ (when (save-match-data
+ ;; \ = dos styled path
+ ;; / = unix styled path
+
+ (and
+ ;; If lock file has variable expansion, then we won't
+ ;; check it.
+ (not (string-match "[$]" lock-file))
+ (not (tinyprocmail-string-valid-p lock-file 'path))))
+ (tinyprocmail-log
+ (point)
+ (format "Unusual characters in lockfile name `%s'" lock-file))
+ (tinyprocmail-fix-macro
+ "[cannot-fix] Lockfile has unusual characters. C-g to quit"))
+ ;; :0: $FILE --> can't know if it has .lock
+ (cond
+ ((and (not (save-match-data (string-match "\\." lock-file)))
+ (not (string-match "[$]LOCKEXT" lock-file))
+ (save-match-data (string-match "^[$]" lock-file)))
+ (tinyprocmail-log
+ (point)
+ (format
+ "info, could't check extention .lock in lockfile `%s'"
+ lock-file)))
+ ((save-match-data
+ (and (not (string-match "\\." lock-file))
+ (not (string-match "[$]LOCKEXT" lock-file))))
+ (setq str (format "no $LOCKEXT extension in lockfile `%s'" lock-file))
+ (tinyprocmail-log (point) str)
+ (tinyprocmail-fix-macro (concat str " Add ")
+ (goto-char (match-end 0))
+ (insert "$LOCKEXT")))
+ ((save-match-data
+ (and
+ (when (string-match "\\(.*\\)\\." lock-file)
+ (setq file (match-string 1 lock-file)))
+ (not (string-match "\\.lock\\|\\.lck\\|[$]LOCKEXT" lock-file))))
+ (tinyprocmail-log
+ (point)
+ (format
+ "Non-standard lockfile extension. (use $LOCKEXT) `%s'" lock-file))
+ (tinyprocmail-fix-macro
+ (format "Non-standard lockfile extension. Change to $LOCKEXT ")
+ (setq lock-file (concat file "$LOCKEXT"))
+ (ti::replace-match 3 lock-file))))) ;; When end
+ (goto-char opoint)
+ (when fix-line (tinyprocmail-flag-kill flags)))))
+
+;;}}}
+;;{{{ lint: other
+
+;;; ........................................................... &other ...
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-lint-malformed-brace ()
+ "Check braces."
+ (while (re-search-forward "^[ \t]*{" nil t)
+ (when (and (char= ?\{ (preceding-char)) ; {} or {var
+ (not (looking-at "[ \t\n]")))
+ (tinyprocmail-log (point) "Error, no space after `{' .")
+ (tinyprocmail-fix-macro "No space after { Add one?"
+ (insert " ")
+ (backward-char 1)))
+ (when (and (looking-at ".*\\(}\\)")
+ (save-match-data
+ (not (looking-at ".*[ \t\n]+\\(}\\)"))))
+ (tinyprocmail-log (point) "Error, no space before `}' .")
+ (tinyprocmail-fix-macro "No space before } Add one?"
+ (ti::replace-match 1 " }")))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-lint-malformed-misc ()
+ "Check varaious other things."
+ (let* (;;; (pedantic (eq tinyprocmail-:lint-log-verbose 'pedantic))
+ (opoint (point))
+ (re "echo\\|cat\\|tail\\|head\\|sed\\|perl\\|awk\\|perl\\|[-]")
+ str)
+ ;; Detect "dummy `echo`", missing "=" or ";"
+ ;;
+ ;; But following is valid.
+ ;;
+ ;; LOG = "text start
+ ;; and-newline "
+ (while (re-search-forward
+ "^[ \t]*\\([^!|#\n=;]+\\)\\([ \t]+\\)[\"`]" nil t)
+ (setq str (match-string 0))
+ (when (save-match-data
+ (and
+ (not (string-match re (match-string 1)))
+ (not (string-match "\"[ \t]*$\\|\"[ \t]*#" str))
+ (not (tinyprocmail-condition-line-p))))
+ (setq
+ str
+ (format "Warning, After `%s', there is no \"=\" or \";\""
+ (match-string 1)))
+ (tinyprocmail-log (point) str)
+ (tinyprocmail-fix-macro (concat str " Add = ")
+ (ti::replace-match 2 " = "))))
+ (goto-char opoint)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-lint-malformed-var-defs ()
+ "Check variable definitions and assignments."
+ (let* (
+;;; (pedantic (eq tinyprocmail-:lint-log-verbose 'pedantic))
+;;; cont-p
+ var1
+ var2
+ str
+ op)
+ (while (re-search-forward "^[ \t]*[^#\n].*=" nil t)
+ (beginning-of-line)
+ (unless (tinyprocmail-comment-line-pp)
+ ;; Backslash at the end (continuation)
+ ;;
+;;; (setq cont-p (looking-at ".*[\\][ \t]*$"))
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... .. date ...
+ ;; It's slow to call `date' and there is already 10x faster
+ ;; ways to derive the message date: See pm-jadate.rc
+ ;;
+ ;; MONTHNAME = `date +%y-%m`
+ (when (looking-at ".*=`.*date")
+ (setq str
+ (concat
+ "Info, calling `date' is 10x slower"
+ " than reading From_ hdr."))
+ (tinyprocmail-log (point) str)
+ (tinyprocmail-fix-macro str))
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... perl-var . .
+ ;; $perl-styled-var = "value"
+ (when (looking-at "^[ \t]*\\([$]\\).*=")
+ (tinyprocmail-log (point) "Error, perl styled variable assignment.")
+ (tinyprocmail-fix-macro "Remove extra Perl styled assignment to `$' "
+ (ti::replace-match 1)))
+ ;; ... ... ... ... ... ... ... ... ... ... ... illegal-var-name . .
+ ;; VAR-1 = 1
+ (when (and (looking-at "^[ \t]*\\([^ \t\n]+\\)[ \t]*=")
+ (setq str (match-string 1))
+
+ ;; Must start with alpha otherwise reject
+ (string-match "^[A-Z]" str)
+ (not (tinyprocmail-comment-line-p))
+ (not (tinyprocmail-string-valid-p str)))
+ ;; This will unfortunately misclassify line,
+ ;; which includes '=', like
+ ;;
+ ;; SPAM_REGEXP_FILE ="\
+ ;; filename.*=.*\.(pif|rar|zoo|arj|exe|bat)"
+ (setq str
+ (format
+ "Warning, odd characters in variable `%s'." str))
+ (tinyprocmail-log (point) str)
+ (tinyprocmail-fix-macro str))
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... . literal . .
+ ;; VAR = abc
+ ;; VER = 1.4a
+ (when (looking-at "^[^=\n]+=[ \t]*\\([a-z]\\|[0-9]+[-.a-z]\\)")
+ (tinyprocmail-log
+ (point)
+ "Warning, no right hand variable found. ([$\"`'] .. missing)")
+ (tinyprocmail-fix-macro "Add missing `$' to right hand variable? "
+ (ti::replace-match 1 (concat "$" (match-string 1))) ))
+ ;; ............................................. odd name(right) ...
+ ;; var = $odd%&_name nok
+ ;; var = var-var ok
+ ;; var = $var-$var ok
+ (when (looking-at
+ "^[ \t]*[a-z].*=[ \t]*[$]\\([a-z]+[^-/_a-z0-9$ \t\n#]+\\)")
+ (setq str
+ (format
+ "Error, Odd variable name to the right `%s'."
+ (match-string 1)))
+ (tinyprocmail-log (point) str)
+ (tinyprocmail-fix-macro str))
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... tilde(~) . .
+ (when (looking-at "^.*=.*\\(~\\)/")
+ (tinyprocmail-log (point)
+ "Error, csh's tilde(~) is not supported, Use $HOME.")
+ (tinyprocmail-fix-macro "Non-supported: Substitute ~ with $HOME "
+ (ti::replace-match 1 "$HOME")))
+ ;; ... ... ... ... ... ... ... ... ... ... ... mismatch(` -- ') . .
+ (when (or (looking-at "^.*=[ \t]*`.*\\('\\)[ \t]*#.*$") ;; comment
+ ;; no comment
+ (looking-at "^.*=[ \t]*`.*\\('\\)[ \t]*$"))
+ (setq
+ str
+ "Error, assignent, starting backtick, but ends to single quote.")
+ (tinyprocmail-log (point) str)
+ (tinyprocmail-fix-macro (concat str " Kill ' ")
+ (ti::replace-match 1 "`")))
+ ;; ...................................................... var-init ...
+ ;; D = ${D: ...
+ ;;
+ ;; Note that the colon in this case is ok.
+ ;; D = {D}:/directory/file.txt
+ (when (looking-at
+ (concat
+ "[ \t]*\\([^ \t{]+\\)[ \t]*"
+ "=.*$\\({\\)[ \t]*\\([^ \t}:]*\\)\\([ \t]*\\):\\(.\\)"))
+ (setq var1 (match-string 1)
+ var2 (match-string 3)
+ str (match-string 4)
+ op (match-string 5))
+ (when (save-match-data (not (string= "" str)))
+ (tinyprocmail-log (point) "Error, space before init operator.")
+ (tinyprocmail-fix-macro "Kill Space before init operator."
+ (ti::replace-match 4)))
+ (when (save-match-data (ti::nil-p var2))
+ (tinyprocmail-log (point)
+ "Error, no right hand init variable found.")
+ (tinyprocmail-fix-macro
+ (format "Error, no right hand `%s'. Add " var1 )
+ (goto-char (1+ (match-beginning 2)))
+ (insert var1)
+ (setq var2 var1)))
+ ;; Writing VAR = ${$VAR is a mistake. Notice 2nd $
+ (when (save-match-data (and var2 (string-match "^[$]" var2)))
+ (tinyprocmail-log
+ (point)
+ (format
+ "Error, in init sequence, `%s' has extra $ ." var2))
+ (tinyprocmail-fix-macro
+ (format "`%s' contains extra $. Correct " var2)
+ (save-match-data (setq
+ var2
+ (replace-regexp-in-string "^[$]" "" var2)))
+ (ti::replace-match 3 var2)))
+ (when (save-match-data
+ (or (and var1 (not (tinyprocmail-string-valid-p var1)))
+ (and var2 (not (tinyprocmail-string-valid-p var2)))))
+ (setq
+ str
+ (format
+ "Warning, in init sequence `%s' or `%s' has illegal characters."
+ (or var1 "<?>") (or var2 "<?>")))
+ (tinyprocmail-log (point) str)
+ (tinyprocmail-fix-macro str))
+ ;; 1998-04 I used to believe this calls shell, but it doesn't.
+ ;; D = ${D:-`date`} So the following recipe is *commented out*
+ (when nil
+ (when (and (save-match-data (looking-at ".*[-+][ \t]*`"))
+ pedantic)
+ (tinyprocmail-log
+ (point)
+ (concat
+ "Pedantic, `` is not a recommended initialize "
+ "practise (uses shell)."))))
+ (when (save-match-data (not (string= var1 var2)))
+ (tinyprocmail-log (point)
+ "Warning, variables don't match in init sequence.")
+ (tinyprocmail-fix-macro
+ "[cannot-fix] Left var1 and right var2 don't match."))
+ (when (save-match-data (not (string-match "[-+]" op)))
+ (tinyprocmail-log
+ (point)
+ (format "Error, invalid init operator `%s'. Not [-+] " op))
+ (tinyprocmail-fix-macro
+ (format "[cannot-fix] Invalid init operator `%s' "
+ op )))))
+ (forward-line 1))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-lint-malformed-start-recipe ()
+ "Check ': ' or '0:' recipes."
+ (let* ((space (if (eq 'flags-together
+ tinyprocmail-:flag-and-recipe-start-style)
+ "" " "))
+ list
+ str)
+ (while (setq list (ti::re-search-point-list '("^[ \t]*0:" "^[ \t]*:[^0]")
+ 'beginning-of-line))
+ (goto-char (apply 'min list))
+ (cond
+ ((looking-at "^[ \t]*\\(0:\\)")
+ (tinyprocmail-log (point)
+ "Error, recipe start is invalid, should be `:0'.")
+ (tinyprocmail-fix-macro "recipe error, fix to `:0' "
+ (ti::replace-match 1 ":0")))
+ (t
+ ;; The :[^0] matches \n, and that's why we use looking-at.
+ (if (looking-at "[ \t]*:")
+ (goto-char (match-end 0))
+ (backward-char 1)) ;There was newline
+ (cond
+ ((looking-at "\\([ \t]*[1-9]\\|[ \t]+0\\)") ; ': 0' or
+ (setq str "Warning, Suspicious recipe start, use standard `:0'.")
+ (tinyprocmail-log (point) str)
+ (tinyprocmail-fix-macro (concat str " Correct ")
+ (ti::replace-match 1 "0")))
+ (t ; ':'
+ (setq str "Warning, Suspicious recipe start, use standard `:0'.")
+ (tinyprocmail-log (point) str)
+ (tinyprocmail-fix-macro str
+ (delete-horizontal-space)
+ (insert "0" space)
+ (if (not (looking-at " "))
+ (insert " ")))))))
+ (end-of-line))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-lint-condition-line-1 ()
+ "Check one condition line. Point must be over start(*)."
+ (let* ((point (point))
+ (var-test-p (looking-at ".*[?][?]"))
+ (shell-test-p (looking-at "\\*[! \t]+[?]"))
+ tmp
+ str
+ match-p
+ end)
+ (catch 'done
+ ;; ....................................................... empty ...
+ (when (looking-at "\\*[ \t]*$")
+ (setq str "Error, Nothing in condition line.")
+ (tinyprocmail-log (point) str)
+ (tinyprocmail-fix-macro (concat "[Cannot-fix] " str))
+ (throw 'done 'nothing))
+ ;; ............................................ missing caret(^) ...
+ ;; * ! Headr-field:
+ ;; * ! FROM_DAEMON
+;;; (ti::d! (buffer-substring (point) (line-end-position)))
+ (when (or (looking-at "\\*[ \t!]*\\([-A-Z]+\\):")
+ (let (case-fold-search) ;be case sensitive
+ (looking-at
+ (concat
+ "\\*[ \t!]*\\(FROM_DAEMON\\|FROM_MAILER\\|TO_?\\)"
+ "[ \t]*$"))))
+ (setq
+ str
+ (format
+ "Warning, `%s' does not have (^) in condition line."
+ (match-string 1)))
+ (tinyprocmail-log (point) str)
+ (tinyprocmail-fix-macro (concat str " Add ")
+ (goto-char (match-beginning 1))
+ (insert "^")))
+ ;; .......................................................... TO ...
+ ;; * ^TOregexp is a mistake, should use ^TOregexp\> or something
+ ;; Skip ^TO$REGEXP
+ (when (let (case-fold-search)
+ (and (looking-at ".*\\(TO[^([\n]+\\)")
+ (save-match-data
+ (and (not (looking-at ".*[\\]>[ \t]*$"))
+ (not (looking-at ".*[$]"))
+
+ ;; Next line must not a condition
+ ;; line
+ ;;
+ ;; * ^TOadmin
+ ;; * more-restrictive-condition
+ ;;
+ (not (save-excursion
+ (forward-line 1)
+ (looking-at "[ \t]*\\*")))))
+ ;; Try to find similar contruct from buffer.
+ ;; If found then user needs swap the order of
+ ;; these two.
+ ;;
+ ;; 1) TOaddr and later) TOadd-another
+ ;;
+ (save-excursion
+ (end-of-line)
+ (re-search-forward
+ (regexp-quote (match-string 1)) nil t))))
+ (setq
+ str
+ (format
+ "Warning, `%s' is not unique, another similar TO found."
+ (match-string 1)))
+ (tinyprocmail-log (point) str)
+ (tinyprocmail-fix-macro (concat "[cannot-fix]" str)))
+ ;; ....................................................... extra ...
+ ;; * regexp|regexp\
+ ;; * |regexp|regexp << Ooops, extra (*)
+ (when (and (looking-at "\\*[ \t]*|")
+ (save-excursion ;Peek previous
+ (forward-line -1)
+ (looking-at "[\\][ \t]*$")))
+ (setq str "Warning, extra \"*\" before fist regexp \"|\".")
+ (tinyprocmail-log (point) str)
+ (tinyprocmail-fix-macro (concat str " Remove `*' ")
+ (delete-char 1)
+ (throw 'done 'extra))) ;Nothing more to check
+ ;; ........................................... expansion missing ...
+ ;; Very common mistake, you forgot the beginning $
+ ;;
+ ;; * ! $REGEXP
+ ;;
+ ;; * $$REGEXP is ok
+ ;; * $!$REGEXP is ok
+ ;; * $(^TO$REGEXP) is ok
+ ;; * $-${VAR}^0 is ok
+ (when (and (not (looking-at "\\*[ \t]*[$][-$!^(]"))
+ (looking-at "\\*[ \t!]*[$]\\([^ \t\n]+\\)[^$\n]*$")
+ (not var-test-p))
+ (setq
+ str
+ (format "Error, No eval($) in condition found. (%s)"
+ (match-string 1)))
+ (tinyprocmail-log (point) str)
+ (tinyprocmail-fix-macro (concat str " Add `$' ")
+ (save-excursion
+ (forward-char 1)
+ (insert "$" ))))
+ ;; A bit more complex
+ ;; * !^(To|Cc|Bcc):.*$LOGNAME
+ ;;
+ ;; But this is ok
+ ;;
+ ;; * ? echo "$ARG"
+ ;;
+ ;; And $HOME variable is accepted without eval
+ (when (and (not var-test-p)
+ (not shell-test-p)
+ (looking-at
+ "\\*[^$\n]+\\(.\\)[$]\\([A-Z][^ \t\n]+\\)+[^$\n]$")
+ (save-match-data
+ (not (string-match "[\"]" (match-string 1))))
+ (save-match-data
+ (not (string-match "[$]HOME" (match-string 2)))))
+ (setq
+ str
+ (format "Error, No eval($) in complex condition found. (%s)"
+ (match-string 2)))
+ (tinyprocmail-log point str)
+ (tinyprocmail-fix-macro (concat str " Add `$' ")
+ (save-excursion
+ (forward-char 1)
+ (insert "$" ))))
+ ;; ............................................. missing eval($) ...
+ ;; User forgot the interpolation in the line
+ ;;
+ ;; * ! VAR ?? $eval-this-var
+ ;;
+ ;; --> * ! VAR ?? $ $eval-this-var
+ ;;
+ ;; It's impossible to catch this however
+ ;;
+ ;; * ! VAR ?? $eval-this $eval-second
+ ;;
+ ;;
+ ;; But these are ok
+ ;;
+ ;; * FROM??^foo@bar$
+ ;; * TO??^$
+ (when (and (looking-at "\\*\\(.*\\)[?]\\([?]\\)[^$\n]+[$][^$]+$")
+ (save-match-data ;; has $
+ (not (string-match "[$]" (match-string 1))))
+ (save-match-data ;; but must not ne at the end
+ (not (string-match "[$]$" (match-string 1))))
+ (save-match-data ;; literal newline in prenthesis ($)
+ (not (string-match "($)" (match-string 1)))))
+ (setq tmp (match-beginning 2))
+ (setq str "Warning, missing eval($) operator in variable context.")
+ (tinyprocmail-log (point) str)
+ (tinyprocmail-fix-macro (concat str " Add ")
+ (goto-char (1+ tmp))
+ (insert " $ ")
+ (goto-char point)))
+ ;; Warn about: *$ $VAR ?? test
+ ;; Not Warn about: *$ $VAR ?? $test
+ ;;
+ ;; But this is ok: *$ $SUPREME^0 ^From:(some match)
+ (when (and (not (looking-at "^.+[^][0-9] "))
+ (looking-at "^.+\\([$]\\).*[$].*[?][?]"))
+ (setq str "Warning, Possible $ misuse (doubled) to the left of ??")
+ (tinyprocmail-log (point) str)
+ (tinyprocmail-fix-macro (concat "cannot-fix]" str)))
+ ;; * VAR ?? test is legal in procmail, don't require
+ ;; *$ VAR ?? test
+ ;;
+;;; (when (and (looking-at "[^$\n]+[?][?]") ;; * VAR ?? test
+;;; (not (looking-at ".*[HB][! \t]+[?]")) ;; * HB ?? regexp
+;;; )
+;;; (tinyprocmail-log
+;;; (point)
+;;; "Possibly missing left hand $ in ?? variable test.")
+;;; (ti::d! (ti::read-current-line))
+;;; (tinyprocmail-fix-macro "Maybe missing left hand $. C-g to quit."
+;;; (forward-char 1)
+;;; (insert "$")
+;;; ))
+ ;; .................................................... empty ?? ...
+ (when (looking-at ".*[?][?][ \t\n]*$")
+ (tinyprocmail-log (point) "Error, Nothing follows ?? ")
+ ;; Can't autofix this one.
+ ;;
+ (tinyprocmail-fix-macro
+ "[cannot-fix] Error, Nothing follows ??, C-g to quit. "))
+ ;; ............................................... suspicious ?? ...
+ ;; VAR ?? . is not right
+ (when (looking-at ".*[?][?][ \t]*\\(\\.\\)[ \t]*$")
+ (tinyprocmail-log
+ (point)
+ "Warning, '?? .' will fail on null variable. Prefer '(.|$)'")
+ (tinyprocmail-fix-macro
+ "'?? .' is not preferred, use '(.|$)' instead "
+ (ti::replace-match 1 "(.|$)")))
+ ;; ............................................... trailing star ...
+ ;; * regexp.* but * \/regexp.* is okay.
+ (save-excursion
+ ;; Skip continuation
+ (while (and (not (eobp))
+ (looking-at ".*\\[ \t]*"))
+ (forward-line 1))
+ (save-excursion
+ (setq end (line-end-position))
+ (goto-char point)
+ (if (re-search-forward "\/" end t)
+ (setq match-p t)))
+ (when (and (null match-p) (looking-at "^[^ \t\]+\\*[ \t]*$"))
+ (tinyprocmail-log
+ (point)
+ "info, maybe useless regexp `*' at the end condition.")
+ (tinyprocmail-fix-macro "[cannot-fix] Useless `*' at the end."))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-lint-condition-lines (&rest args)
+ "Check all condition lines. Ignore ARGS. Point must be inside condition."
+ (while (and (not (eobp)) (tinyprocmail-move-to-next-condition-line))
+ (tinyprocmail-lint-condition-line-1)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-standardize-recipe-start ()
+ "Check whole buffer and change recipe start to ':0 FLAGS'.
+Refrences:
+ `tinyprocmail-:flag-and-recipe-start-style'"
+ (interactive)
+ (let* ((style tinyprocmail-:flag-and-recipe-start-style)
+ (i 0)
+ (found 0))
+ (save-excursion
+ (ti::pmin)
+ (while (tinyprocmail-forward)
+ (incf found)
+ ;; We're sitting on : go to 2 char forward
+ (forward-char 2)
+ (cond
+ ((eq style 'flags-together)
+ (when (looking-at "\\([ \t]\\)[^#]")
+ (ti::replace-match 1)
+ (incf i)))
+ (t
+ (unless (looking-at "[ \t\n]")
+ (insert " ")
+ (incf i))))
+ (end-of-line)))
+
+ (unless (zerop i)
+ (message
+ "TinyProcmail: standardized %d recipe start line(s). Style: %s"
+ i
+ (if style
+ (symbol-name style)
+ "Flags separated from :0")))
+
+ (when (zerop found)
+ (message "TinyProcmail: Can't find any recipes from buffer."))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-lint-list-lint-directives ()
+ "Find all recipes that have Lint directives.
+This function puts the results to `tinyprocmail-:lint-output-buffer'.
+Function activates only of `tinyprocmail-:lint-log-verbose' is 'pedantic."
+ (let* (options
+ flags
+ point)
+ (when (eq tinyprocmail-:lint-log-verbose 'pedantic)
+ (while (re-search-forward "^[ \t]*#[ \t]*Lint:[ \t]*\\(.*\\)" nil t)
+ (setq options (match-string 1) point (match-beginning 1))
+ (forward-line 1)
+ (setq flags (tinyprocmail-flag-read (ti::read-current-line)))
+ (tinyprocmail-log
+ point
+ (format "info, Lint options `%s'. recipe flags `%s'."
+ options flags))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-lint-find-wrong-escape-codes ()
+ "Find misused \\t and \\n characters."
+ (let* (str
+ val)
+ ;; (re-search-forward "\\[[^]\n\\]+\\([\\]t\\)" nil t)
+ (while (re-search-forward "\\([\\][tn]\\)" nil t)
+ (unless (save-match-data (tinyprocmail-comment-line-p))
+ (setq val (match-string 1))
+ (setq
+ str
+ (format "Error, escape code `%s' is not known to procmail." val))
+ (tinyprocmail-log (point) str)
+ (cond
+ ((save-match-data (string-match "t" val))
+ (tinyprocmail-fix-macro (concat str " Correct ")
+ (ti::replace-match 1 "\t")))
+ (t
+ (tinyprocmail-fix-macro (concat "[cannot-fix] " str))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-lint-find-2spaces ()
+ "Find misused [ ] contructs. User meant space and TAB."
+ (let* (str
+ set
+ done
+ not-comment
+ not-backtics)
+ (while (re-search-forward "\\[\\([^]\n]+\\)\\]" nil t)
+ (setq set (match-string 1)
+ not-comment (save-match-data
+ (not (tinyprocmail-comment-line-p)))
+ not-backtics (save-excursion
+ (beginning-of-line)
+ (save-match-data (not (looking-at ".*`")))))
+ ;; Skip lines like: dummy = `echo "[this value here]" > file`
+ (when (and not-comment not-backtics)
+ (save-match-data
+ (when (string-match " \\( +\\)" set)
+ (setq
+ str
+ "Warning, two spaces inside regexp [], maybe you mean TAB.")
+ (tinyprocmail-log (point) str)
+ (tinyprocmail-fix-macro "Warning, two spaces, change to TAB "
+ (setq done t)
+ (setq set (ti::replace-match 1 "\t" set)))))
+ (when done
+ (ti::replace-match 1 set))
+ (when (and (or (tinyprocmail-condition-line-p)
+ (tinyprocmail-assignment-line-p))
+ ;; like " asd "
+ (string-match " [^ ]+ " set))
+ (setq str "Warning, two spaces inside regexp [].")
+ (tinyprocmail-fix-macro (concat "[cannot-fix] " str)))))))
+
+;;}}}
+;;{{{ Lint: main
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-output-display ()
+ "Show `tinyprocmail-:lint-output-buffer' buffer."
+ (interactive)
+ (cond
+ ((null (get-buffer tinyprocmail-:lint-output-buffer))
+ (error "No `tinyprocmail-:lint-output-buffer'"))
+ (t
+ (ti::save-excursion-macro
+ (display-buffer tinyprocmail-:lint-output-buffer)
+ (select-window (get-buffer-window tinyprocmail-:lint-output-buffer))
+ (ti::pmax)
+ (re-search-backward "^\\*\\*" nil t) ;; start of lint section
+ (unless (eq major-mode 'tinyprocmail-output-mode)
+ (turn-on-tinyprocmail-output-mode))
+ (font-lock-mode-maybe 1)
+ (ti::string-syntax-kill-double-quote)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-lint-forward (&optional mode verb)
+ "Lint the code forward.
+Input:
+ MODE If nil, step through recipes and correct them interactively.
+ If non-nil then Write log _with_ pedantic messages.
+ If 2 x \\[universal-argument] then Write log without pedantic.
+ VERB Verbose messages."
+ (interactive "P")
+ (let* ((check-list tinyprocmail-:lint-do-hook)
+ (tinyprocmail-:lint-fix-mode tinyprocmail-:lint-fix-mode)
+ (tinyprocmail-:lint-log tinyprocmail-:lint-log)
+ (tinyprocmail-:lint-log-verbose tinyprocmail-:lint-log-verbose)
+ (opoint (point))
+ (time (current-time))
+ (count 0)
+ point
+ secs
+ ret)
+ (ti::verb)
+ (when mode
+ (setq tinyprocmail-:lint-fix-mode nil)
+ (if (equal mode '(16))
+ ;; suppess 'pedantic
+ (setq tinyprocmail-:lint-log-verbose nil)))
+ (setq tinyprocmail-:lint-log (if mode t nil))
+ (tinyprocmail-log-start)
+ (beginning-of-line)
+ (run-hooks 'tinyprocmail-:lint-before-hook)
+ (goto-char opoint)
+ (while (tinyprocmail-forward)
+ (setq point (point))
+ (incf count)
+ (when (and verb mode)
+ (message "TinyProcmail: Linting %d %s" count (ti::read-current-line)))
+ ;; There is no point of checking the recipe if the Flags are
+ ;; not all right. The functions usually modify flags,
+ ;; and that is imposible without proper flags.
+ (setq ret (tinyprocmail-flag-order-lint))
+ (when ret
+ (dolist (func check-list)
+ (goto-char point)
+ (funcall func (car ret) (cdr ret) )))
+ (goto-char point)
+ (forward-line 1))
+ (dolist (func tinyprocmail-:lint-after-hook)
+ (goto-char opoint)
+ (funcall func))
+ (tinyprocmail-overlay-hide)
+ ;; Sort the output buffer. The results are in random order, because
+ ;; many different list function have been run one after another.
+ (when tinyprocmail-:lint-log
+ (tinyprocmail-output-macro (tinyprocmail-output-sort-by-line)))
+ (setq secs (ti::date-time-difference (current-time) time)
+ time (/ secs 60))
+ (message "TinyProcmail: Lint done. recipe Count = %d time: %02d:%02d "
+ count time (- secs (* time 60)))
+ (when mode (tinyprocmail-output-display))
+ (goto-char opoint)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-lint-buffer (&optional mode verb)
+ "Lint whole buffer. See MODE and VERB from `tinyprocmail-lint-forward'."
+ (interactive "P")
+ (ti::verb)
+ (save-excursion
+ (ti::pmin)
+ (tinyprocmail-lint-forward mode verb)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyprocmail-lint-buffer-batch (&optional clear file)
+ "Batch Lint buffer and write results to `tinyprocmail-:lint-output-file'.
+Input:
+
+ CLEAR If non-nil, clear output buffer
+ FILE Save results to this file"
+ (interactive "P")
+ (if clear
+ (tinyprocmail-output-clear))
+ ;; Delete empty lines from the beginning to get line numbers
+ ;; sensible
+ (ti::pmin) (skip-chars-forward " \t\n")
+ (unless (eq (point) (point-min))
+ (delete-region (point-min) (point)))
+ (tinyprocmail-lint-buffer '(4))
+ (tinyprocmail-output-file-save file))
+
+;;}}}
+;;{{{ Examples or other files
+;;; ........................................................ &Examples ...
+;; Here is example file for the Lint. It also demonstrated what kind of
+;; errors can be trapped.
+
+;; file pkg.tar:
+;; r--r--r-- 240/222 14764 Jun 22 15:05 1998 pm-lint.rc 1.26
+;;
+;; -----BEGIN PGP MESSAGE-----
+;; Version: 2.6.3ia
+;; Comment: Base64 signed. File: pkg.tar uncompresses to approx. 20K
+;;
+;; owHtWUtvW0ty9kUwCMQs80A2AVo0rVdEWpIfuSOP7UiyfKXElgxbvp47lmw1z2mS
+;; PToP5jxE8V57l0UGyCIIMFkEmMkmCDCL/IGs8sKsB5gECJAJ5gcMsggQZBckVdV9
+;; +jx4DmmS9y6CXMKwyHO6v66urq76qup7117+0jeu3fn5f/zR3/7Nv//zJ7/2W3c+
+;; +ujjP/7ofz57/6c/XfzJwQ/j/nf+5Wc//NEPfvar3/vPv2/+99/96Kd/de/7//hP
+;; P/mNv/zB/V/84Y+b//oPv/zxX9z4vePv//zln/3Xj/+t+4s/v/Gbv358/Cd//exX
+;; 2t8II1t61+DTd5uO9KJWYF37yj4b8Ll9+zb9vXV3Q/29dZf+wrfbd+/AO/jvFgza
+;; un0Lnm/CsN+5tvHViZR+4jDiASz5Xc6dyK8e57uWy73q92ozG+bv/5HPdfa7K9dX
+;; WWoGrNlkL7jbdwTbd7kVshPpDZ+5LeGwlWeBD0qQzirDwSwSYcQ60hE1jdI4tLcz
+;; UOuXbLO1dZdtfvObH9/cuHtza4ttbm1v3Nm+c4cpdbP9qz5r1K4DAGOPRGgFsh9J
+;; 38MnCyc9GTL4Z5ZhHT/QQvW5dcG7IhWuxZ743GYRzIGpNBqE8Jmg4dyzmcUdhz1t
+;; XrFIgoiubwt6/IR20hPM8r1IeBFOH8iox/aaMQ0/p/G4pWY77nREsNxiO04kAo9H
+;; 8lI4w3U29GOAB6kXQiFYzx8QIOkojLtdkF+J4PILEcJCQSAs3GbIcCWYVr6O1ste
+;; j3uw1Sd+l614vidWazV6nujn6PiE9fXJKD2RPH7s2CyIvRYMRNU5jj+QXpeBvUfC
+;; hZ0SSFvAY3YhHSckoUEy2Qfdua6wJQx0hkx2CDAKhgwU2hEiUTNMhwfJ0tuMHUbL
+;; NrNjt497BKuoHRy/OGH32VtxJaO3Gcy3uIPWbB+2dMkDydsOqBJ+1mogBvt05/kC
+;; LFT3L+oLC/jgOvMv1tkfxD5YT3bEZva1F7ttEWRfwyG4YjkzpA2GFknrIqyphRow
+;; MAuzHwR+sM6eicABzQ4dUA4PQ9n1SMMZZEeCyXBHTxNqmofKVEIysO3GHGpRemlK
+;; T0Yjaml8AV+2m6e1Ohq59GJh19+nilBjnxx/ghqMxFXEsh8aAdbb9MQArFPUpxzO
+;; Cp/rrO/EeAtcVBHcUrImvC2iVSsT+9wGmzl/T1Nf8cADI15nYU/AdY5DYbfYyxCu
+;; cnoj2YAPi/tvENLmeyMDnBudwP5VFHDWQDG24IYmpsU87ooRWRhC5A8+BE8k4BaB
+;; a0KPA8r3+3DOkR+M7oSNzJbeJXekbeaw7TqrlyxbPTOzJPrNkqm//YFT83O3m7ww
+;; zfNRO1sjS3x7dCiM2ySHhxOY7XvLEfi+yOqVHO8irxAvvUbrLPYuPH/gpXpa1Eg3
+;; 8rcR3Jjocqf8GJubk4fSWPBg7hCdgbB6/vKIFmgn6EnPM6Np7Hl+rCthC1535f6q
+;; tmvwmHsclWGLCCIAOlww3Q+94AXhTpOd6DtNp8i4CmYClO936FLV1C6S0QUB4OaR
+;; L2qxo9zOMovdbxwcP92/SeEle8lz4jQ4X7qRu+WD5Koe2xB8ezzgFlzREG9aovM8
+;; wv2in0D/+2Lv+Pk+THBiUZvHOyZO8v475R31eewd7O/9/nbqVjoO7zILoyq4Fogw
+;; KnZsbzArsSIAsLimPWNRJKJ4foQhlXydLewETU6D5vjWhSI0I1JtfwCONkYTyJgL
+;; AHjyXhfw+iVQ5wnU+VwaZ0uwc4FswhivESp5g+Q7UhZIAzaUGG7bv5o8A24YsHfU
+;; CWxA7SMze5bpO9UAWo1wS5TL5x2wZrh7Dl465FbJ6eb3UAriAzMjspAXq8WepgKB
+;; 6QzUZLq4n4lwXV3XARG7NvBL8l9wnRIGBocco6MFZpt4N3iLBFdJtlWp3Aly6Y1t
+;; sZx+ZjUNxon8ItUtM41iGKDB5MnYivaoq9po6c8aJQgfDEIu/N1iA/nWTvM7JUj4
+;; tb7YqM9p/MAIwAXa1TsE30DOVlHzkC2yZIotLIdnIvqofIvlkGSOyutom2xVAUB0
+;; ugBlfNevdjyx54EZhCEH5t+MKoGaEWF9GArRgqYvx6HBa42Yh4SYUzWrM7A38b+t
+;; eYMEW2oHeL2Lp8bU4yxvJz+QleiL97Xp59j+bLPYLNOYWm3MRHKJ4FwivyuASASU
+;; oRr/uFHTOO/nwVCnB7TFlinzVJjzBXi2hJ6p+sa5sQNJNrg3HCYompqQnHq2Us+d
+;; Jh5x2JeW9CGFocGGYRqMBqRGjw+f7BchTD3D9zH7ATmuMH9WVKylChEDcNysi0lM
+;; hzuhSEiUBnohMNEJfQoEarHrCbEEOv109xjIeOPo5ZMnb/H7+1pBMD3ipi0ub3qx
+;; 47xPJDS7M6/AUkSITJEsKaEgBUAzOsE59Dp+FsTlQzQEF5Mj0emA3gRtEszhvLdM
+;; PKmWtYoM4NymEMrPRRnXo+dUU0q2iAH3/ECJ02Ir+POAPXzIvpXEGXagbfZbbHNj
+;; YyO11w8B3s0B7+aBdyuA5+VdXXHVD0suAlU9MDqAcxCWBIYw8IPCHVhjncB339pc
+;; uDr+jL0QjuA2hjGLByJaebOapD1F0EX2+Pnx07ePdvafHh9VEZEZUA9gpAiaHSkc
+;; u5LgSDJMzZ6Z0s/K2mohXTIuSSVOhaXUrLWqJVC16O2Ip5/eVMlUvhqQATu9qeBa
+;; WbzpDz056yb5+mbE2yWHbpRqxIsGmsYCnewJT78Iewm1DHnfUuVRQDQehj6JF/M9
+;; ZwhpnbAuBJYSJujuNWNnJlyPNScj2mTQ05qWqQR9AniYR18xdTFaaHXMSuGEjRzB
+;; 7UrVEkpbJKUuPc4IW5j4aVKI4KEMM/VDo3m+CkoXqSbMi/YqS+UHYwjAxhPqaAZZ
+;; qyr8EZEuDNqB9BvFqplfesOlD+GTflMjZs8FEvs1llsauJPGA3lWcmBYD2Kn0aid
+;; nUZna6HvCuLWa/h7Z3fvbELiU4mPWcKpUtKrw5P9F8929vax7AmvTr36dGBeibBe
+;; QVhvnLDGjPN2TDam1Mhen7VGV6G0MbtQpfGiD5NdD8P16zNlxlj+T2sHHT9GVxng
+;; U7pBqWXnqmasDoZB65ITIQHq5+YGJMVf6svo72e1+arfpkwy6gB17EhpjFJRlZ4z
+;; FK8wA5Jgq2qWuIqEh1fKLIdhtATB/CqLUzpvT8FAy2ZnK2hMkJJ7NmSJq3nEVuT2
+;; ESjxz2ZS9oymXVEvsd1APosrXJ+AllZJUjxOyWgZLLHkCiRFJamLtaw9qsIkh91C
+;; qEpJK+072axRTo69kx5vLN0k8CzGjGaJzs2Wutc3pggGtAQ5iRm6nkRiJIyJqLlE
+;; /h2jS0Zk8wFLmfmXDV2GvTAD9vWFhd040ikOtQM6MvELGNPawuI4C7nYA7TeMIr1
+;; EcDUfB5JqNTTfICOCGSkfLPHIWkKY7A/8FAmZVpYUG6yeotTbLDFXpHsbaH8YBXo
+;; lJiY8k2EHHcQPR6y+oO6Kv+ZonNmCdJ7eCH7VPcNS2pCpw/moqHa3oXbj4ZEUMpy
+;; D8/PDdAFqjwRa5url4lg5vVmrfhkq/Yl3FO6qtqxlQku3LawbWFCVbhZkFAPT8Zt
+;; trT3Sgk1WDtM1NWGdOTWhJFrLNsY084rTycTqFsaagakrawOJ2x9q2zrhe2P2bja
+;; LXHQuA+3HB3AaEiZg05iqt2ElBa8xehBPhM2h/hhrZsgqlo1ND7ZWK+jL1/HD4jG
+;; NYOoIlu5B6Sn70iLR4KAwhSj02m3273eYDKWPhPVefK9DuAZWst3yuZPMV3slwpw
+;; b0r9siW4sXCKTbqfTdrrmD7aPXZEw9V1Jv+UrQKnqkqyE0iaBDmIfMJH/BCeLlu6
+;; VpTsq9NrH+w+Gkh1aKOlmFnl0IKYPNmqWNbSnMt4q/lFGI+fLZea9Wa8JmzpULVF
+;; qs+x0D7JSdm5Gn4+2arVRVeNULj/Qd93uCIJXpogt3LK/8yPWSiEYgXYpORdocoM
+;; HTaEd0EM8YGKKjQ9P/kQF8E2D7AACncm+Qojv8/wQPUE+v/xk51PXmAit9uT9WRn
+;; DXr6wbdfb+9cLrNBD8mkHfj9PhL/yMemDviUhwm0rO4JFnrPPoxh5732cqbdq4o0
+;; sJEgh56At3s59HkKp2bbrdHwLYQNCaASEy9mG+lXL09YclqbIxxrnKZdZp1Kkl72
+;; bhaXf8Q2tz5mjYPjp/s3LQ720nLDrrSLSI9xLx1GaWqmC41W3vtgyLn0rQJWZ4wz
+;; XUcRgM9xm7elIyO8Djq+EudlvXvte71Cle6FdPtwcaLhkAyyk1TiOSanEb8wnJ8l
+;; 0c72S0umwCOBlkLUBF9ox4KML9WRlZk8X9uN1HBQYnbKkdBBHWSuxLrJGSRxXswc
+;; bNHhsWOiX1K0z3vOL+GSaGkHlZdkUGKaWH1p9oGu1yZP0eQqM8lkeYXJA30dsSkU
+;; xt0uxZr0fLZnvBdYB4IcnhypcrbsRdynmiGEsnpW5HqhR4Vztllz8AFb+RLOQJac
+;; gVQ6AYsHg0dRM4HmsGNS46RJw/t9wQM07EEgI7SnMKWHfhz1Y6xTDQcYQhIYdH9Y
+;; AUtbPXQVwYko/7jOBiI5D1aX9dzhDnIaCfxuwN1W2CvsYsIZtIdMJ3iXkA0/PWCB
+;; dYkBgjJMs199GLK4dDK4eO6UVi9DQLNB8MAfmjiMa6vdcJv6MkDJjAsZyKodOTNv
+;; Kb8B6/Bo78nLR/vP99j9yavmFzVuVDLiFRx/UVQFlullyFlhSRO65yZcqc2S/Vd5
+;; DTmL1yBLzBG0yvs2I1sk7GbSLmyVVLGSCPEKaGuz+YBZ24nuXumvX6g572vzzZ1y
+;; B6nnb4Kami63Al/RXasi0hriz4E5YsXp5JgBb4UvkppkLFPS0pGW6q1qDMQf6ans
+;; pQ7XJGhqFHCRFK49cQmjqC9YJL5UwgoHklqGlL36HVwQa2IDP8tcTdnmzckxLpJP
+;; P4pvExEqkhS8kJnam9o7UW6sytUTvdRPjlV/oX4PKHWeaZh36W5BfHkJGikWmt4k
+;; Q1NpZrDJzKlijthslLa58ys3Gs/3P9n/9rMMAygfb2pOjcU3jwPf3W6tTTt1jpmg
+;; oBU9afXDZ61kp00xr9n44tOd5+/fZPsgFYngU93RaIyoafwWJ01fnBOgwRbfrJz4
+;; 7/asd7uWtVqq86lNjGqBfUdcNdNqRJmJKRplGAB6ZLYPCXPe9BbZQ5byr8+vyDbQ
+;; QXcD0YfQzID8Kz7Wwjah14S7GISZmDOqD5cdkfeHxVYaq9jM5Z7p5U638NPPHh0+
+;; r1p5zmgHmnz4sLK6gJ6EupGYzDr+IITBI6fLGmChyYuy5FlD2X7cdkD9jQbyOHTU
+;; juhElXAs44aqjS6Q3R4SO4iwlzyQvO0oOhkWrZhp1MYI7OzCwtsqWStiF+oaSJHj
+;; sA6ceAtLWch1qbiaUuAF/J+9BH8P41/z5udnJAQyO0VosUIFRgypHmSdpmXMhBOK
+;; VqWMrWqvQ0GVCYBEW8VMbWTP5i6zXVIjgFbZ/xR4YP60LTTzHOIkQB6pJ56dxzs5
+;; foulqcYYJEjPRQAsyRMDql8Kz3L8UDU5AD2PhyM24Sn+3cpdO1ga4z91KPsuhrmo
+;; FQBn+QrO/9rXn68/X3/+335UaVlx/7RrF/K+pbovES9UFinfSbIEXcfP93DRnxUj
+;; xWvGztAbTw5jkO6wsM8tMRn0tKZlKkGfAB7m0VfgayS9GLaCC62OWSmcsJGjtL0B
+;; a4TSFoWGrRG2MPHThGPwUIZdLzNDf/gqZWVGE+ZFe5Wl8gNXwHpKQgfNIGuVubET
+;; SRWX8oN22H0Sq2Z+6Q2XPoRP+k2NmKNhq5NHsLMxjahngW8RjzVdHWSs7DQatbPT
+;; 6GzN0JY1/L2zu3c2gepV4iMJOlVKenV4sv/i2c7ePraN4NWpV58OzCsR1isI640T
+;; 1phx3o7JxpQa2euz1ugq1FDLLlRpvMhhZNfDMuLrM2XGSAvb3LqIpHURAlePkZsE
+;; RBa9nGXbsesOQTfnwur5rA6GQeuSEyEB6ufmBuh59DL5fjZXxsGWsIRHjKk1kqu5
+;; On1MhmR5WImewzjsS0v6cVicwbaZVTVLXEWC0jCzXAcyrhIE86sEBOib6AKBTMFA
+;; y2ZnK6qfqWrTq3nEVuT2ESjxz2ZS9oymXVEvsd14fPhkH1e4PgFNX4EjP4MHfJoD
+;; Ky2BRdQqJNX3sTAiLWuPqjBVPo5QlZJW2neyWaMcj7uFk7mxdLNlqsHzNYvQuemK
+;; dmkJIelEQN4dsszQ9SQSY1kuETVXS3vH6JJRfpOUd78K6DLshRmwry8s7MaRKvwP
+;; fKyWdGTiFzCmZWqQsB+JDZg4KcgvLER+V1A1diCjnjJ2alQ8QEcEMlLxlBowYQz2
+;; Bx7KtKMWFpSbrN7iFBtssVckOxAk8oNVoFNiYso2EXLcQWDKXn9QX2ftmHqhHmV+
+;; mSVI7+GF7Iek8kJZFvFPH2TsfeZgLtx+NCSCEpZ1OfzcAI5VnyJ3TBsxmQhmXm/W
+;; ik+2al/CPW3pmh86tjLBhdsWNqTQiSsNNwsS6uHJuM2W9l4poQZrh4m6NZuO3Jow
+;; co1Ga6eaOK88nUygbmmoGZC2sjqcsPWtsq0Xtj9m42q3xEHjPtxydACjIWUOOkld
+;; YdVBGT3IZwJ7TdJaTxu81Cqm8cnGeh19+UztNIgqspV7QHr6jrR4JHItOMDodNrt
+;; dq83mIylz4QEAbvuAJ6htXynbP4U08V+qQD3ptQvW1KN0ibdzybttYyuG70cZfqq
+;; 5J9izwNvFYY8GGZUlWQnkDQJchD5hI/4ITxdtpazvVHGO732we6jgazqa80qhxbE
+;; tMKsimUtzbmMt5pfhPH4GZeXrjdrR3fp0LvkjrTxHP8X
+;; =D/Dv
+;; -----END PGP MESSAGE-----
+
+;;}}}
+
+(add-hook 'tinyprocmail-:mode-define-keys-hook
+ 'tinyprocmail-mode-define-keys)
+
+(add-hook 'tinyprocmail-output-:mode-define-keys-hook
+ 'tinyprocmail-output-mode-define-keys)
+
+(provide 'tinyprocmail)
+(run-hooks 'tinyprocmail-:load-hook)
+
+;;; tinyprocmail.el ends here
--- /dev/null
+;;; tinyreplace.el --- Handy query-replace, area, case preserve, words
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 1995-2007 Jari Aalto
+;; Keywords: tools
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program, call M-x tinyreplace-version.
+;; Look at the code with folding.el.
+
+;; COPYRIGHT NOTICE
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;; ....................................................... &t-install ...
+;; Put this file on your Emacs-Lisp load path, add following into your
+;; ~/.emacs startup file
+;;
+;; (require 'tinyreplace)
+;;
+;; Or you can use autoload (preferred) and your emacs starts up faster
+;;
+;; (autoload 'tinyreplace-replace-forward "tinyreplace" "" t)
+;; (autoload 'tinyreplace-replace-region "tinyreplace" "" t)
+;; (autoload 'tinyreplace-replace-over-files "tinyreplace" "" t)
+;; (autoload 'tinyreplace-define-keys-compile-map "tinyreplace" "" t)
+;; (autoload 'tinyreplace-replace-over-files-compile-buffer "tinyreplace" "" t)
+;; (add-hook 'compilation-mode-hook 'tinyreplace-define-keys-compile-map)
+;;
+;; For easy access to replace functions, bind function `tinyreplace-menu'
+;; to a free key. The default install uses M-&, which is next to
+;; standard M-% replace key.
+;;
+;; M-x tinyreplace-install ;; C-u to uninstall
+;;
+;; Check that you have colors on, otherwise the replaced region may
+;; not be visible.
+;;
+;; (set-face-background 'highlight "blue")
+;;
+;; If you have any questions, contact maintainer with function
+;;
+;; M-x tinyreplace-submit-bug-report
+
+;;}}}
+;;{{{ Documentation
+
+;; .................................................... &t-commentary ...
+;;; Commentary:
+
+;; Preface 1995
+;;
+;; There was post in gnu.emacs.help where Brian Paul asked for
+;; help to replace his C variables: "Suppose I want to replace
+;; all occurances of the variable i in my C program with j." The
+;; normal emacs function query-replace wasn't suitable for this
+;; task because it offered too many false hits. Guess how many i
+;; characters are used in non-variable context.
+;;
+;; Well later I rembered that one could have used \bi\b to search
+;; words. But the nature of "word" is very different here as it
+;; would have been with \b, which relies on syntax table which you
+;; seldom want to change, whilst the "word definition " here can be
+;; changed on the fly. (Remember that \bi\b still matches entries
+;; like "i.here" where you would want to match only plain "i")
+;;
+;; Things are not that simple always, in fact, the first
+;; implementation of this package had to do with the latex math
+;; equation replace, so that program would automatically skip over
+;; normal text and perform replace within the blocks only.
+;; I decided to pull out the v1.0 and make it a complete package,
+;; so here it is folks.
+;;
+;; Overview of features
+;;
+;; o Companion to emacs's query-replace. Simple interface.
+;; o Text beeing replaced is highlighted AND terminals that cannot see
+;; the highlight will see "=>" string marking the line beeing
+;; processed
+;; o Preserve case while replacing "FoO" --> "BaR" (symmetry)
+;; o Toggle case sensitivity and symmetry during the replace.
+;; o Word match mode on/off during replace: 'matchTHIS or THIS '
+;; o "Narrow to function", go to "beginning of file" when you start
+;; replacing. You're put back to position where you were when
+;; you quit.
+;; o Can replace over many files. (Reads compile buffer output)
+;; Checks Out files from RCS when needed (if they are not locked)
+;; o Variable `tinyreplace-exlude-line-regexp' can be use
+;; to ignore lines
+;;
+;; How to use
+;;
+;; If you know lisp, you can go and take straight advantage of the
+;; engine function:
+;;
+;; tinyreplace-replace-region-1
+;;
+;; Normally functions work within area defined by you, but
+;; there is 'applications' section which offers several ready to run
+;; functions for various needs:
+;;
+;; o `tinyreplace-replace-region', like query replace but in selected area
+;; o `tinyreplace-replace-forward', start from current point.
+;; o `tinyreplace-latex-blk-replace', replace text surrounded
+;; by latex BLOCKS
+;; o `tinyreplace-latex-math-replace', replace text within latex
+;; math equations only.
+;;
+;; What commands do I have while replacing interactively?
+;;
+;; There are some handy commands that normal emacs replace lacks:
+;;
+;; o toggle case sensitivity during replace
+;; o toggle symmetry during replace (character by character conversion)
+;; o Go to start of buffer _now_ (return back when you exit replace)
+;; o search backward
+;; o Narrow to current function, so that you can replace local variables
+;; o Flash function name where you're (only for some programming
+;; languages.)
+;;
+;; See function `tinyreplace-replace-region-1' for command
+;; explanation. To abort the search, you just press Ctrl-g or 'Q'
+;; and you'll be returned to the starting point of search.
+;;
+;; Command line prompt explanation
+;;
+;; The command line prompt will look like this
+;;
+;; Replace 'xx' with 'yy' (a,bvuBFNU? [+CSX] !ynqQ)
+;;
+;; Where the flag settings active are displayed between brackets.
+;; The '+' means that you have used (N)arrow command, C indicates
+;; case sensitivity, S tells that symmetry is activated and X
+;; means that line exclude is in effect. For full explanation of
+;; the commands, please press help key (?) Which will print the
+;; command summary.
+;;
+;; Special commands in command line
+;;
+;; When you edit the seach string or destination string, there are
+;; some keys that you can use:
+;;
+;; C-l Yank the text under point to current prompt
+;; C-o Yank previous SRING1
+;;
+;; The Yank command is `C-l' not `C-y', because if you edit and
+;; kill inside the prompt line, you can use regular `C-y' to yank
+;; text back. The `C-l' command reads a space separated text from
+;; the buffer and pastes it into the prompt for editing.
+;;
+;; The `C-o' command yanks the SEARCH string to the prompt. It
+;; comes handy if you used `C-l' to yank the initial search
+;; string, edited yanked text and wanted to share it in the next
+;; prompt. This way you don't have to do the editing again, but
+;; only modify the previous string. To pick right word (Yank
+;; `C-l') from the buffer, when you don't have have mouse, you
+;; can use following keys. Text to the left shows you briefly
+;; where the point currenly is.
+;;
+;; < Moves buffer's point backward
+;; > Moves buffer's point forward
+;;
+;; This feature propably is at its best in a compile buffer where you
+;; have grep results and you draw region around the the files where
+;; you want the replace to happen. Move a little with [<>] and you
+;; will be soon in a line that has the grep word, then yank it to the
+;; replace prompt.
+;;
+;; Note about the arrow pointer
+;;
+;; Terminals that do not have highlight capability to see which
+;; portion of text will be replaced will appreciate the arrow at
+;; the beginning of line to show where the text is located.
+;;
+;; The option "a" that refreshes the arrow marker is *forced* to
+;; ask a minibuffer question in order to change the state of
+;; arrow (hide or show). There was no other way to do this and I
+;; think it's a bug in 19.28 emacs, because the state is not
+;; immediately shown in buffer.
+;;
+;; Note about commands
+;;
+;; The commands are hard wired in this module and you cannot add
+;; new ones as you can in replace.el which is minor-mode based.
+;; This package is meant to be companion to replace.el, and for
+;; that reason the interface has been designed to be as simple as
+;; possible without any additional modes.
+;;
+;; There is no plan to convert this module to minor mode.
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+;;{{{ require
+
+;;; ......................................................... &require ...
+
+(require 'tinylibm)
+
+(eval-and-compile
+ (autoload 'vc-registered "vc"))
+
+(eval-when-compile (ti::package-use-dynamic-compilation))
+
+(ti::package-defgroup-tiny TinyReplace tinyreplace-: tools
+ "Overview of features
+
+ o Companion to emacs's query-replace. Simple interface.
+ o Text beeing replaced is highlighted AND terminals that cannot see
+ the highlight will see '=>' string marking the line beeing
+ processed
+ o Preserve case while replacing FoO --> BaR (symmetry)
+ o Toggle case sensitivity and symmetry during the replace.
+ o Word match mode on/off during replace: matchTHIS or THIS
+ o 'Narrow to function', go to 'beg of file' when you start
+ replacing. You're put back to position where you were when
+ you quit.
+ o Can replace over many files. (Reads compile buffer output)
+ ChecksOut files from RCS when needed (if they are not locked)
+ o You can define `tinyreplace-exlude-line-regexp' that skips any line
+ matching looking-at regexp at the beginning of line.")
+
+;;}}}
+
+;;{{{ setup: hooks
+
+(defcustom tinyreplace-load-hook nil
+ "*Hook run when file has been loaded."
+ :type 'hook
+ :group 'TinyReplace)
+
+(defcustom tinyreplace-:args-keymap-hook nil
+ "*Hook which can define additional key bindings to `tinyreplace-:args-keymap'."
+ :type 'hook
+ :group 'TinyReplace)
+
+(defcustom tinyreplace-:pre-replace-hook nil
+ "*Hook to run just before replacing start in a buffer."
+ :type 'hook
+ :group 'TinyReplace)
+
+;;}}}
+;;{{{ setup: public, User configurable
+
+(defcustom tinyreplace-:goto-region-beginning t
+ "If non-nil go to beginning of region before replace starts."
+ :type 'boolean
+ :group 'TinyReplace)
+
+(defcustom tinyreplace-:exclude-line nil
+ "*When search stops to found position, this variable is consulted.
+
+It can be:
+
+ nil do nothing special. Proceed replace.
+ regexp line which matches `looking-at' REGEXP at the beginning
+ of line is skipped.
+ function if it returns t, then the line is skipped and search continues.
+ Function takes no arguments and it can move point, since
+ it is run under `save-excursion'. Point is at replace point when
+ the function is called.
+
+Example:
+
+ (setq tinyreplace-:exclude-line 'my-tinyreplace-exclude)
+ (defun my-tinyreplace-exclude ()
+ ;; Exclude comment lines
+ (cond
+ ((eq major-mode 'c++-mode)
+ (beginning-of-line)
+ (looking-at \"^[ \t]*//\"))))"
+ :type '(string :tag "Regexp")
+ :group 'TinyReplace)
+
+(defcustom tinyreplace-:arrow "=>"
+ "*Line marker where the replace takes effect.
+Especially useful, when term cannot display colours to show the
+replacement place."
+ :type '(string :tag "Arrow string")
+ :group 'TinyReplace)
+
+(defcustom tinyreplace-:arrow-initial-state 'show
+ "*When replacing interactively, this is the default arrow state.
+If your terminal supports highlighting you may want to set this to 'hide.
+
+The only valid values are 'show and 'hide."
+ :type '(choice
+ (const show)
+ (const hide))
+ :group 'TinyReplace)
+
+(defcustom tinyreplace-:face 'highlight
+ "*The match area overlay face."
+ :type 'face
+ :group 'TinyReplace)
+
+(defcustom tinyreplace-:word-boundary "[^a-zA-Z0-9_]"
+ "*This is complement set of characters forming a word.
+For example if you want to replace 'i' with 'j' , you don't want to match
+
+ \"Ignore ThIs match, but replace i with j\"
+ ^^^
+The complement makes sure the word is full word."
+ :type '(string :tag "Word complement charset")
+ :group 'TinyReplace)
+
+(defcustom tinyreplace-:symmetry nil
+ "*Non-nil perform replacement using same symmetry.
+When replacing text, it may be desirable to have the same symmetry,
+the case of the characters, to be preserved while replace takes effect.
+Suppose you have text
+
+ FOO Foo fooUx foo
+
+And you want to preserve the symmetry when doing \"foo\" --> \"bar\".
+This is what you get:
+
+ BAR Bar barUx bar
+
+If the symmetry is nil, then the normal replace would have given:
+
+ bar bar barUx bar"
+ :type 'boolean
+ :group 'TinyReplace)
+
+(defcustom tinyreplace-:symmetry-rest nil
+ "*If non-nil then rest of the characters follow previous symmetry."
+ :type 'boolean
+ :group 'TinyReplace)
+
+;; Not in defcustom; advanced feature and expert knows what to to with this.
+;;
+(defvar tinyreplace-:read-args-function 'tinyreplace-read-args
+ "*Function to ask two arguments ARG1 and ARG2 for replace.
+Input:
+
+ String
+
+Output:
+
+ '(\"arg1\" \"arg2\")
+
+Function must terminate with error if it cannot return list of
+two strings.")
+
+(defcustom tinyreplace-:user-function 'ti::buffer-outline-widen
+ "*User function fun from command prompt key 'U'."
+ :type 'function
+ :group 'TinyReplace)
+
+;;}}}
+;;{{{ setup: private
+
+(defvar tinyreplace-:replace-region-overlay nil
+ "Overlay used to show the replaced region.")
+
+(defvar tinyreplace-:transient-mark-mode nil
+ "Transient mark mode state (Emacs).")
+
+(defvar tinyreplace-:arrow-state nil
+ "Arrow display state.")
+
+(defvar tinyreplace-:narrow-state nil
+ "Narrowed to function state.")
+
+(defvar tinyreplace-:args-history nil
+ "History of replace strings.")
+
+(defvar tinyreplace-:args-keymap nil
+ "Keymap for reading arguments.")
+
+(defvar tinyreplace-:replace-buffer nil
+ "Buffer where to replace.")
+
+(defvar tinyreplace-:tmp-buffer "*tinyreplace-temp*"
+ "Temp buffer.")
+
+(defvar tinyreplace-:err-buffer "*tinyreplace-error*"
+ "Error message buffer.")
+
+(defvar tinyreplace-:read-point nil
+ "This variable is used in interactive word reading.
+It tells where the current point is.")
+
+(defvar tinyreplace-:o-exclude nil
+ "Private. Temporary variable to keep state when calling another function.")
+
+(defvar tinyreplace-:string1 nil
+ "Private. The asked string1. Set in `tinyreplace-read-args'.")
+
+(defvar tinyreplace-:word-match-mode nil
+ "Not a user variable. Hold value t if user switch to exact word matching.
+Property 're will have the original regexp.")
+
+;;; ............................................................ &menu ...
+
+;; You propably want to copy this to your ~/.emacs and define your
+;; own key combinations. See tinylibmenu.el how to use the menu variable
+
+(defvar tinyreplace-:menu
+ '("\
+replace: (f)wd (r)eg (w)ord (c)ompile buffer files (f)iles (lL)atex (?)help "
+ (
+ ;; If `tinyreplace-menu' is bound to M-%, then the "5" key makes
+ ;; sense, because "%" is shift-5.
+ (?f . ( (call-interactively 'tinyreplace-replace-forward)))
+ (?5 . ( (call-interactively 'tinyreplace-replace-forward)))
+ (?% . ( (call-interactively 'tinyreplace-replace-forward)))
+ (?w . ( (call-interactively 'tinyreplace-word-replace)))
+ (?r . ( (call-interactively 'tinyreplace-replace-region)))
+ (?c . ( (call-interactively
+ 'tinyreplace-replace-over-files-compile-buffer)))
+ (?F . ( (call-interactively 'tinyreplace-replace-over-files)))
+ (?l . ( (call-interactively 'tinyreplace-latex-blk-replace)))
+ (?L . ( (call-interactively 'tinyreplace-latex-math-replace)))))
+ "Help menu for the commands. Press 'q' to return to menu.
+
+Standard replace commands:
+
+ f calls function `tinyreplace-replace-forward'
+ % calls function `tinyreplace-replace-forward' (like M-%)
+ 5 calls function `tinyreplace-replace-forward' (Like M-%)
+
+ w calls function `tinyreplace-word-replace'
+ r calls function `tinyreplace-replace-region'
+
+The following keys can be used in compile-like buffers, where each line
+contains standard grep-like output. If you mark a region, the selected
+files are searched and matches replaced.
+
+ FILE:LINE-NUMBER:output
+ FILE:LINE-NUMBER:output
+ FILE:LINE-NUMBER:output
+
+ c calls function `tinyreplace-replace-over-files-compile-buffer'
+ F calls function `tinyreplace-replace-over-files'
+
+Special commands:
+
+ l calls function `tinyreplace-latex-blk-replace'
+ L calls function `tinyreplace-latex-math-replace'")
+
+;;}}}
+;;{{{ version and install
+
+;;; ----------------------------------------------------------------------
+;;;
+(eval-and-compile
+ (ti::macrof-version-bug-report
+ "tinyreplace.el"
+ "tinyreplace"
+ tinyreplace-:version-id
+ "$Id: tinyreplace.el,v 2.59 2007/05/07 10:50:13 jaalto Exp $"
+ '(tinyreplace-:version-id
+ tinyreplace-:arrow-state
+ tinyreplace-:narrow-state
+ tinyreplace-:arrow-initial-state
+ tinyreplace-:face
+ tinyreplace-:word-boundary
+ tinyreplace-:symmetry
+ tinyreplace-:symmetry-rest)))
+
+;;; ----------------------------------------------------------------------
+;;;###autoload
+(defun tinyreplace-install-default-keybings (&optional uninstall)
+ "Install or UNINSTALL M-& default keybing to run `tinyreplace-menu'."
+ (interactive)
+ (let* ((key "\M-&")
+ (def (lookup-key global-map key)))
+ (when (featurep 'compile)
+ (tinyreplace-define-keys-compile-map))
+ (cond
+ (uninstall
+ (when (setq def (ti::keymap-bind-control 'global-map 'get 'tinymy key))
+ (global-set-key key def)))
+ (t
+ (ti::keymap-bind-control 'global-map 'set 'tinymy key)
+ (global-set-key key 'tinyreplace-menu)))))
+
+;;; ----------------------------------------------------------------------
+;;;###autoload
+(defun tinyreplace-install (&optional uninstall)
+ "Call `tinyreplace-install-default-keybings' with optional UNINSTALL."
+ (interactive "p")
+ (tinyreplace-install-default-keybings uninstall))
+
+;;}}}
+;;{{{ misc
+
+;;; ----------------------------------------------------------------------
+;;;###autoload
+(defun tinyreplace-menu ()
+ "Run `tinyreplace-:menu'."
+ (interactive)
+ (if buffer-read-only
+ (message "My: Cannot start replace, buffer is read-only.")
+ (ti::menu-menu 'tinyreplace-:menu)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinyreplace-with-keymap 'lisp-indent-function 1)
+(defmacro tinyreplace-with-keymap (sym &rest body)
+ "If keymap SYM exists, run BODY. Variable `map' is set to keymap."
+ `(let (map)
+ (when (and (boundp ,sym)
+ (setq map (symbol-value ,sym))
+ (keymapp map))
+ ,@body)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyreplace-define-keys-compile-map ()
+ "Define key bindings."
+ (interactive)
+ (tinyreplace-with-keymap 'compilation-mode-map
+ (define-key map "%" 'tinyreplace-replace-over-files-compile-buffer))
+ (tinyreplace-with-keymap 'compilation-minor-mode-map
+ (define-key map "%" 'tinyreplace-replace-over-files-compile-buffer))
+ (tinyreplace-with-keymap 'grep-mode-map
+ (define-key map "%" 'tinyreplace-replace-over-files-compile-buffer)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro tinyreplace-interactive-region-args (string)
+ "Construct interactive tag for functions that need region.
+STRING is argument to `tinyreplace-:read-args-function'.
+
+Return:
+ '(BEG END ARG1-STRING ARG2-STRING)"
+ (`
+ (if buffer-read-only
+ (barf-if-buffer-read-only)
+ (if (region-active-p)
+ (ti::list-merge-elements
+ (region-beginning)
+ (region-end)
+ (funcall tinyreplace-:read-args-function (, string)))
+ (error "TinyReplace: Region is not active. Please select one.")))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyreplace-make-word-regexp (string)
+ "See `tinyreplace-:word-boundary'. Make regexp from STRING."
+ (concat tinyreplace-:word-boundary
+ "\\(" (regexp-quote string) "\\)"
+ tinyreplace-:word-boundary))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyreplace-read-args (&optional prompt)
+ "Read two arguments with PROMPT. Return '(ARG1 ARG2)."
+ (let* ((opoint (point))
+ arg1
+ arg2)
+ ;; Disable electric file minor mode, which defines specilal
+ ;; characters.
+ (setq tinyreplace-:replace-buffer (current-buffer)
+ tinyreplace-:read-point (point)
+ tinyreplace-:string1 nil)
+ (tinyreplace-args-keymap-create)
+ (setq arg1
+ (ti::remove-properties
+ (read-from-minibuffer
+ (concat (or prompt "") " Search: ") nil
+ tinyreplace-:args-keymap nil tinyreplace-:args-history)))
+ (setq tinyreplace-:string1 arg1) ;Now available
+ (setq arg2
+ (ti::remove-properties
+ (read-from-minibuffer
+ "Replace with: " nil
+ tinyreplace-:args-keymap nil tinyreplace-:args-history)))
+ (goto-char opoint) ;restore
+ (list arg1 arg2)))
+
+;;; ----------------------------------------------------------------------
+;;; - This is for user friendliness
+;;;
+;;;###autoload
+(defun tinyreplace-symmetry-toggle (&optional arg verb)
+ "Toggle variable` tinyreplace-:symmetry' with ARG. VERB."
+ (interactive "P")
+ (ti::verb)
+ (ti::bool-toggle tinyreplace-:symmetry arg)
+ (put 'tinyreplace-replace-1 'tinyreplace-:symmetry tinyreplace-:symmetry)
+ (if verb
+ (message "TinyReplace: Symmetry is now %s"
+ (if tinyreplace-:symmetry
+ "on"
+ "off"))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyreplace-transient-mark-mode (mode)
+ "Record function `transient-mark-mode' status.
+This is done only if function exists. MODE can be 'write or 'read."
+ (when (and (ti::emacs-p) ;#todo: zmacs-region-stays
+ (boundp 'transient-mark-mode)) ;XEmacs doesn't have this
+ (cond
+ ((eq mode 'write)
+ (setq tinyreplace-:transient-mark-mode
+ (let* ((var 'transient-mark-mode)) ;XEmacs 19.14 byteComp silencer
+ (symbol-value var))))
+ ((eq mode 'read)
+ tinyreplace-:transient-mark-mode))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyreplace-arrow-control (buffer mode &optional str)
+ "Handles showing the arrow.
+
+Input:
+
+ BUFFER buffer pointer
+ MODE symbol 'show, 'hide, 'toggle, 'maybe or 'move.
+ STR Used for restoring the original contents when mode is 'hide
+
+Sets global:
+
+ `tinyreplace-:arrow-state'
+
+Returns:
+
+ mode current state"
+
+ (cond
+ ((eq mode 'toggle)
+ (if (or (null overlay-arrow-position) ;doesn't exist
+ (not (equal (marker-buffer overlay-arrow-position)
+ (current-buffer))))
+ (setq mode 'show)
+ (setq mode 'hide)))
+
+ ((eq mode 'maybe)
+ (cond
+ ((null tinyreplace-:arrow-state)
+ (setq mode 'show))
+ (t
+ ;; follow the mode which is active
+ (setq mode tinyreplace-:arrow-state)))))
+ (cond
+ ((or (eq mode 'show)
+ (eq mode 'move))
+ (ti::buffer-arrow-control buffer mode tinyreplace-:arrow (point))
+ (setq tinyreplace-:arrow-state 'show))
+ ((eq mode 'hide)
+ (ti::buffer-arrow-control buffer 'hide str)
+ (setq tinyreplace-:arrow-state 'hide)))
+ mode)
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyreplace-replace-ask (buffer from-str to-str )
+ "Perform asking while in interactive replace mode.
+
+Input:
+
+ BUFFER FROM-STR TO-STR
+
+Note:
+
+ `tinyreplace-:o-exclude' must be set in the calling function"
+ (let* ((o-exclude tinyreplace-:o-exclude)
+ (loop t)
+ msg
+ ans)
+ (while loop
+ (setq from-str (ti::string-format-percent from-str)
+ to-str (ti::string-format-percent to-str))
+ (setq
+ msg
+ (format "Replace '%s' with '%s' (a,bvuBFNU [%s%s%s%s] ?!ynqQ) "
+ ;; Make prompt fit nicely
+ (if (> (length from-str) 18)
+ (concat (ti::string-left from-str 16) "..")
+ from-str)
+ (if (> (length from-str) 18)
+ (concat (ti::string-left to-str 16) "..")
+ to-str)
+ (if tinyreplace-:narrow-state "N " "")
+ (if tinyreplace-:symmetry "S" "")
+ (if case-fold-search "" "C")
+ (if tinyreplace-:word-match-mode "W" "")
+ (if tinyreplace-:exclude-line "X" "")))
+ (setq ans (ti::read-char-safe-until msg))
+ ;; There is purposively a dummy COND case.
+ (cond
+ ((char= ?a ans)
+ (tinyreplace-arrow-control buffer 'toggle)
+ (read-from-minibuffer
+ "Arrow refreshed. Press RET to update view."))
+ ((char= ?s ans)
+ (tinyreplace-symmetry-toggle))
+ ((char= ?w ans)
+ (ti::bool-toggle tinyreplace-:word-match-mode)
+ (put 'tinyreplace-replace-1
+ 'tinyreplace-:word-match-mode
+ tinyreplace-:word-match-mode))
+ ((char= ?c ans)
+ (ti::bool-toggle case-fold-search)
+ (put 'tinyreplace-replace-1 'case-fold-search case-fold-search))
+ ((char= ?\ ans)
+ (setq ans ?y))
+ ((char= ?x ans) ;exclude toggle
+ (if tinyreplace-:exclude-line
+ (setq tinyreplace-:exclude-line nil)
+ ;; Dynamically bound in call func
+ (setq tinyreplace-:exclude-line o-exclude)))
+ ((char= ?F ans)
+ (tinyreplace-show-function-name (point)))
+ ((char= ?N ans)
+ (setq tinyreplace-:narrow-state t)
+ (setq ans ?N))
+ ((char= ?U ans)
+ (funcall tinyreplace-:user-function)
+ (setq ans ?U))
+ ((ti::char-in-list-case ans '(?\177 ?\b ?n))
+ (setq ans ?n)))
+ (if (ti::char-in-list-case ans '(?! ?? ?y ?n ?q ?Q ?b ?v ?u ?B ?N))
+ (setq loop nil))) ;; while loop
+ ans))
+
+;;; ----------------------------------------------------------------------
+;;; Press Ctrl-g to abort replace.
+;;;
+(defun tinyreplace-show-function-name (point)
+ "Flashes function name briefly from POINT."
+ (let* ((name (ti::buffer-defun-function-name point))
+ (txt (if name
+ name
+ "<not found>")))
+ (message txt)
+ (sit-for 1)))
+
+;;; ----------------------------------------------------------------------
+;;; Press Ctrl-g to abort replace.
+;;;
+(defun tinyreplace-move-overlay (beg end)
+ "Move overlay to BEG END."
+ (ti::compat-overlay-move 'tinyreplace-:replace-region-overlay beg end nil)
+ (ti::compat-overlay-put
+ 'tinyreplace-:replace-region-overlay
+ 'face tinyreplace-:face))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyreplace-replace-1 (beg end str)
+ "Replace region BEG END with STR, point with after replace."
+ (when (and (integerp beg) (integerp end))
+ (delete-region beg end) (goto-char beg)
+ (insert str)))
+
+;;}}}
+;;{{{ key
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyreplace-key-clear-input ()
+ "Clear the line."
+ (interactive)
+ (delete-region (line-beginning-position) (line-end-position)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyreplace-key-forward-word (&optional count)
+ "Forward word. COUNT is argument to `forward-word', and defaults to 1.
+
+This function is meant to position you to to right word which you can
+then insert into the replace prompt with \\[tinyreplace-key-yank-word]. When"
+ (interactive)
+ (let* ((obuffer (current-buffer)))
+ (select-window (get-buffer-window tinyreplace-:replace-buffer))
+ (forward-word (or count 1))
+ (setq tinyreplace-:read-point (point))
+ (message "TinyReplace: reading point %d:%s..."
+ (point)
+ (ti::string-left
+ (or (buffer-substring-no-properties (point) (line-end-position))
+ "")
+ 40))
+ (select-window (get-buffer-window obuffer))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyreplace-key-backward-word ()
+ "See `tinyreplace-key-forward-word'."
+ (interactive)
+ (tinyreplace-key-forward-word -1))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyreplace-key-yank-string1 ()
+ "Yank previous string (search string)."
+ (interactive)
+ (if tinyreplace-:string1
+ (insert tinyreplace-:string1)
+ (message "TinyReplace: Sorry, there is no STRING1 to yank yet ")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyreplace-key-yank-word ()
+ "Yank word from buffer. `tinyreplace-:replace-buffer' must be set."
+ (interactive)
+ (let* (word)
+ (with-current-buffer tinyreplace-:replace-buffer
+ (goto-char tinyreplace-:read-point)
+ ;; This is just because of the space-word-command
+ ;;
+ ;; Word-here
+ ;; * << advance this cursor one char
+ (if (ti::char-in-list-case (preceding-char) '(?\ ?\t ?\n ))
+ (forward-char 1))
+ (setq word (ti::remove-properties (ti::buffer-read-space-word))))
+ (when word
+ (setq word (ti::remove-properties word))
+ (insert word))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyreplace-args-keymap-create ()
+ "Create keymap."
+ (setq tinyreplace-:args-keymap (copy-keymap minibuffer-local-map))
+ (define-key tinyreplace-:args-keymap "\C-l" 'tinyreplace-key-yank-word)
+ (define-key tinyreplace-:args-keymap "\C-o" 'tinyreplace-key-yank-string1)
+ (define-key tinyreplace-:args-keymap "\C-p" 'tinyreplace-key-clear-input)
+ (define-key tinyreplace-:args-keymap "\C-b" 'tinyreplace-key-backward-word)
+ (define-key tinyreplace-:args-keymap "\C-f" 'tinyreplace-key-forward-word)
+ (run-hooks 'tinyreplace-:args-keymap-hook))
+
+;;}}}
+;;{{{ main
+
+;;; ----------------------------------------------------------------------
+;;; - The "v" has been chosen because it's close to "b". I first
+;;; used "B" for backward REPLACEMENT, but it was too much
+;;; trouble to reach extra shift key.
+;;;
+;;; Eg. If I want to replace backward (to undo some changes),
+;;; you just press "v" and "u". Much more awkward would have
+;;; been "B" and "u". The shift-modifier is not good in this case.
+;;;
+;;; - The "undo" feature here is hand coded, because I couldn't find
+;;; any emacs command that would undo last change...one at a time.
+;;;
+(defun tinyreplace-replace-region-1 (beg end re str &optional level ask func)
+ "Perform replace.
+
+Input:
+
+ BEG END region
+ RE regexp to search
+ STR replace string
+ LEVEL subexpression level to match in RE. Default is 0, whole match.
+ ASK interactive
+ FUNC Call function
+
+Commands while ASK is non-nil: (simple undo backward is = 'v u' )
+
+ y or SPACE replace
+ n or BACKSPACE skip
+ ! replace rest
+ q quit
+ Q quit at current point.
+
+Search modes
+
+ s Mode: toggle symmetry.
+ When mode is on, he written case is preserved.
+ c Mode: toggle case sensitivity in search.
+ w Mode: toggle word only search.
+ a Mode: toggle arrow display.
+ x Mode: toggle `tinyreplace-:exclude-line' variable on/off.
+
+Search control forward/backward
+
+ b search backward for MATCH
+ v search backward for REPLACEMENT
+ u undo -- This is very limited undo and works
+ only when replacing ordinary strings, not
+ regexps. The symmetry must not be used.
+
+Moving point of search
+
+ B go to beginning of search.
+ Beginning or end point depending of search direction
+
+ F flash function name
+
+ N narrow to function.
+ You can't cancel this if you use it. The
+ 'N' is indicated in the command line,
+
+ U Run user function `tinyreplace-:user-function'
+
+References:
+
+ `tinyreplace-:exclude-line'
+
+Return:
+
+ number last replace area position. This is not same as the END
+ parameter, because replacing text modifies the buffer's points."
+ (let* (case-fold-search
+ (arrow-orig overlay-arrow-string)
+ (arrow-init tinyreplace-:arrow-initial-state)
+ (symm-rest tinyreplace-:symmetry-rest)
+ (tinyreplace-:exclude-line tinyreplace-:exclude-line) ;Make local copy
+ (o-exclude tinyreplace-:exclude-line) ;original value
+ (level (or level 0)) ;default value
+ (buffer (current-buffer))
+ (func (or func 're-search-forward))
+ (MARK (point-marker)) ;record user position
+ PREV-ME
+ MARK-MAXP ;marker for the last point of search
+ minp maxp ;logical point min, point-max
+ c-exclude ;Current exclude value
+ str-to
+ do-ask
+ quit-point
+ read-string
+;;; undo-string
+ fmin fmax
+ pos
+ mb me ;match area, beg end
+ replace
+ bypass) ;This is flag to skip searching in loop
+ ;; Se same defaults as previous time
+ (when ask
+ (setq tinyreplace-:word-match-mode
+ (get 'tinyreplace-replace-1 'tinyreplace-:word-match-mode))
+ (setq tinyreplace-:symmetry
+ (get 'tinyreplace-replace-1 'tinyreplace-:symmetry))
+ (setq case-fold-search
+ (get 'tinyreplace-replace-1 'case-fold-search)))
+ (put 'tinyreplace-:word-match-mode 're re)
+ (put 'tinyreplace-:word-match-mode 'word (tinyreplace-make-word-regexp re))
+ (setq tinyreplace-:o-exclude o-exclude)
+ (tinyreplace-transient-mark-mode 'write)
+ (transient-mark-mode 0) ;turn this off for now..
+ (setq tinyreplace-:arrow-state arrow-init) ;<< set global, see 'maybe
+ (tinyreplace-arrow-control buffer 'maybe)
+ (setq tinyreplace-:narrow-state nil) ;reset
+ (cond
+ ((eq func 're-search-forward)
+ (setq minp (min beg end) ;logical min and max
+ maxp (max beg end)))
+ (t
+ (setq minp (max beg end)
+ maxp (min beg end))))
+ (save-excursion
+ (goto-char maxp)
+ (setq MARK-MAXP (point-marker)))
+ (goto-char minp)
+ (save-excursion
+ (unwind-protect
+ (catch 'cancel
+ (run-hooks 'tinyreplace-:pre-replace-hook)
+ ;; Peek a little before we start
+ ;;
+ (cond
+ ((and (not (eq (point)
+ (point-min))) ;Already ti::pmin ?
+ (save-excursion
+ (if (null (funcall func re nil t))
+ (y-or-n-p "\
+There is no matches forward. Go to beginning of buffer? "))))
+ (ti::pmin))
+ ((and (region-active-p)
+ (or tinyreplace-:goto-region-beginning
+ (y-or-n-p "\
+Region is active. Go to beginning of region? "))
+ (if (eq func 're-search-forward)
+ (goto-char (region-beginning))
+ (goto-char (region-end))))))
+ ;; SEARCH
+ (while (or bypass
+ (and (funcall func re nil t)
+ (<= (point)
+ (marker-position MARK-MAXP))))
+ (or bypass ;; Not moved, do not calculate positions
+ (setq mb (match-beginning level)
+ me (match-end level)))
+ (setq bypass nil)
+ ;; .. .. .. .. .. .. .. .. .. .. .. .. .. exclude line ..
+ (setq c-exclude tinyreplace-:exclude-line)
+ (save-excursion
+ (cond
+ ((null c-exclude) ;; No exclude patterns
+ t) ;; flag "ok"
+ ((and (symbolp c-exclude)
+ (fboundp c-exclude))
+ (if (funcall c-exclude)
+ (setq mb nil)))
+ ((stringp c-exclude)
+ (beginning-of-line)
+ (if (looking-at c-exclude)
+ ;; Force forgetting this point
+ (setq mb nil)))))
+ ;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ HANDLE it ^^^
+ (if (null mb)
+ nil ;submatch error
+ (tinyreplace-move-overlay mb me)
+ ;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ask user ^^^
+;;; (ti::d! ask)
+ (setq read-string
+ (buffer-substring-no-properties mb me))
+ (setq str-to str)
+ (if (null ask)
+ (setq replace t) ;automatic
+
+ (tinyreplace-arrow-control buffer 'maybe)
+;;; (ti::d! tinyreplace-:arrow-state )
+
+ (setq do-ask t)
+ (setq read-string
+ (buffer-substring-no-properties mb me))
+ (setq str-to str)
+ (while do-ask
+ (setq replace (tinyreplace-replace-ask
+ buffer
+ read-string
+ str))
+ (setq do-ask nil)
+ (cond
+ (tinyreplace-:word-match-mode
+ (setq re (get 'tinyreplace-:word-match-mode 'word))
+ (setq level 1))
+ (t
+ (setq re (get 'tinyreplace-:word-match-mode 're))
+ (setq level 0)))
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ...
+ (cond
+ ;; .......................... beginning of buffer ...
+ ((char= ?B replace)
+ (if (eq func 're-search-forward)
+ (progn
+ (ti::pmin)
+ (setq minp (point)))
+ (ti::pmax)
+ (setq maxp (point)))
+ (redraw-display)
+ (setq replace nil))
+ ;; ... ... ... ... ... ... ... ... ... ... . help ..
+ ((char= ?? replace)
+ (ti::menu-help 'tinyreplace-replace-region-1)
+ (setq bypass t)
+ (setq replace nil))
+ ;; ... ... ... ... ... ... ... ... ... ... narrow ..
+ ((char= ?N replace)
+ (cond
+ ((eq func 're-search-forward)
+ ;; The other call isn't executed if first fails
+ ;;
+ (and (setq fmin (ti::beginning-of-defun-point))
+ (setq fmax (ti::beginning-of-defun-point 'end)))
+ (cond
+ ((and fmin fmax (not (eq fmin fmax)))
+ (setq minp fmin maxp fmax)
+ (goto-char maxp)
+ (setq MARK-MAXP (point-marker))
+ (goto-char minp))
+ (t
+ (setq tinyreplace-:narrow-state nil)
+ (message "TinyReplace: Can't find narrow bounds.")
+ (sit-for 1))))
+ (t
+ (and (setq fmin (ti::beginning-of-defun-point))
+ (setq fmax (ti::beginning-of-defun-point 'end)))
+ (cond
+ ((and fmin fmax (not (eq fmin fmax)))
+ (setq minp fmax maxp fmin)
+ (goto-char maxp)
+ (setq MARK-MAXP (point-marker))
+ (goto-char minp))
+ (t
+ (setq tinyreplace-:narrow-state nil)
+ (message "TinyReplace: Can't find narrow bounds.")
+ (sit-for 1)))))
+ (setq replace nil))
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ..
+ ((char= ?b replace)
+ (save-excursion
+ (goto-char mb)
+ (setq mb nil me nil)
+ (when (re-search-backward re minp t)
+ (setq mb (match-beginning level)
+ me (match-end level))))
+ (if (null mb)
+ (progn
+ (message "TinyReplace: No more hits.")
+ (setq replace nil))
+ (goto-char me)
+;;; (setq undo-string (buffer-substring mb me))
+ (tinyreplace-move-overlay mb me))
+ (setq replace nil
+ do-ask t))
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ..
+ ((char= ?v replace)
+ (save-excursion
+ (if PREV-ME
+ (goto-char PREV-ME))
+ (setq mb nil me nil)
+;;; (setq P (point) R (regexp-quote str) M minp)
+ (when (re-search-backward (regexp-quote str) minp t)
+ (setq mb (match-beginning level)
+ me (match-end level))))
+ (if (null mb)
+ (progn
+ (message "TinyReplace: No previous hit.")
+ (setq replace nil))
+ (goto-char me)
+;;; (setq undo-string (buffer-substring mb me))
+ (tinyreplace-move-overlay mb me))
+ (setq replace nil do-ask t))
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ..
+ ((char= ?u replace)
+ (tinyreplace-replace-1
+ mb me
+ (ti::string-case-replace str read-string
+ tinyreplace-:symmetry symm-rest))
+ (tinyreplace-move-overlay mb me)
+ (setq replace nil do-ask t))
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ..
+ ((char= ?! replace)
+ (setq ask nil replace t))
+ ((char= ?n replace)
+ (setq replace nil))
+ ((char= ?q replace)
+ (throw 'cancel t))
+ ((char= ?Q replace)
+ (setq quit-point mb)
+ (throw 'cancel t))
+ (t
+ (setq replace t)))))
+ ;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ do it ^^^
+ (when replace
+ (setq PREV-ME me)
+
+ (tinyreplace-replace-1
+ mb me
+ (ti::string-case-replace
+ read-string str-to
+ tinyreplace-:symmetry symm-rest)))))) ;; cancel - while
+ ;; ............................ condition
+ ;; - Clean up if Ctrl-g pressed
+ ;; - We're done, dehilit and restore possible transient mode
+ (if (and tinyreplace-:replace-region-overlay
+ (ti::overlay-supported-p))
+ (ti::funcall
+ 'overlay-put tinyreplace-:replace-region-overlay 'face nil))
+ (setq pos maxp) ;update return value
+ (tinyreplace-arrow-control buffer 'hide arrow-orig) ;remove it
+ (if (tinyreplace-transient-mark-mode 'read) ;if it were on previously
+ (transient-mark-mode 1))))
+ (if quit-point ;only when interactive "Q"
+ (goto-char quit-point) ;handy if you made mistake...
+ (goto-char (marker-position MARK)))
+ (message "")
+ (setq MARK nil MARK-MAXP nil) ;kill markers
+ pos))
+
+;;}}}
+;;{{{ applications
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyreplace-read-compile-buffer-filename ()
+ "Read filename on line."
+ (let ((re "^\\(\\(.:\\)?[^\n:]+\\):") ;; allow DOS drive at front d:/file/
+ dir
+ file)
+ (save-excursion
+ (beginning-of-line)
+ (when (setq file (ti::remove-properties (ti::buffer-match re 1)))
+ (save-excursion
+ (if (re-search-backward "^cd[ \t]+\\([^\t\n]+\\)" nil t)
+ (setq dir (ti::remove-properties (match-string 1)))))
+
+ (when (and dir
+ (not (string-match "^\\(.:\\)?/" file)))
+ (setq file (concat dir file)))
+ (setq file (ti::file-name-for-correct-system file 'emacs))))
+ file))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyreplace-replace-over-files-compile-buffer
+ (beg end str1 str2 &optional func verb)
+ "Read all files forward in buffer that is in compile buffer format.
+Perform replace over the found files. Checks Out files that are
+RCS controlled if necessary.
+
+Line format:
+
+ /DIR/DIR/FILE: matched text
+
+Input:
+
+ See function `tinyreplace-replace-1'
+ BEG END STR1 STR2 &OPTIONAL FUNC VERB"
+
+ (interactive
+ (ti::list-merge-elements
+ (tinyreplace-interactive-region-args "compile")
+ nil
+ t))
+ ;; ................................................. interactive end ...
+ (let ((o-frame (selected-frame))
+ (w-frame (ti::non-dedicated-frame))
+
+ (func (or func 'tinyreplace-replace-forward))
+ (err-buffer (ti::temp-buffer tinyreplace-:err-buffer 'clear))
+ (read-only 0)
+ no-confirm
+ buffer
+ cache
+ ro-cache ;read only file list
+ file
+ ch)
+ (ti::verb)
+ (save-excursion
+ (ti::keep-lower-order beg end)
+ (goto-char end)
+ (end-of-line)
+ (setq end (point))
+ (goto-char beg)
+ (catch 'exit
+ (while (and (not (eobp))
+ (< (point) end))
+ (setq file (tinyreplace-read-compile-buffer-filename))
+ ;; See that the file is loaded only once.
+ ;; /users/jaalto/elisp/test.el:;; @(#) ...
+ ;; /users/jaalto/elisp/test.el:;; $Id: ...
+ (cond
+ ((and file (not (file-exists-p file)))
+ (ti::read-char-safe-until
+ (format "TinyReplace: [press] invalid filename %s" file)))
+
+ ((and file (not (member file cache)))
+ (raise-frame (select-frame w-frame))
+ (push file cache) ;Now we have dealt with it
+
+ ;; If it's under RCS and not locked, ask if we should
+ ;; CheckOut it.
+ (when (and (vc-registered file)
+ (eq 'RCS (vc-backend file))
+ (not (file-writable-p file))
+ (y-or-n-p (format "Co rcs file: %s" file)))
+ (unless (call-process
+ "co"
+ nil
+ err-buffer
+ nil
+ "-l"
+ (expand-file-name file))
+ (pop-to-buffer err-buffer)))
+ (cond
+ ((not (file-writable-p file))
+ (incf read-only)
+ (push file ro-cache))
+ (t
+ (save-excursion
+ ;; Also jumps to buffer if it's already in Emacs
+
+ (setq buffer (find-file file))
+
+ ;; Open outline/folding before doing anything
+ (ti::buffer-outline-widen)
+ (ti::pmin)
+ (cond
+ (no-confirm
+ ;; Automatic replace
+ (message "TinyReplace: Processing %s" file)
+ (replace-string str1 str2)
+ (with-current-buffer buffer
+ (save-buffer)))
+ (t
+ (funcall func str1 str2)
+ ;; What to do after replace
+ (if (and
+ verb
+ (null no-confirm)
+ (buffer-modified-p)
+ (ti::char-in-list-case
+ (setq
+ ch
+ (ti::read-char-safe-until
+ (format
+ "\
+%s: SPC s)ave n)ext k)save and kill C)ontinue all Q)uit-exit"
+ (file-name-nondirectory file))))
+ '(?s ?S ?n ?N ?\b ?\ ?C ?Q )))
+ (cond
+ ((ti::char-in-list-case ch '(?\ ?s ?S))
+ (with-current-buffer buffer (save-buffer)))
+ ((ti::char-in-list-case ch '(?n ?N))
+ nil)
+ ((ti::char-in-list-case ch '(?Q))
+ (throw 'exit t))
+ ((ti::char-in-list-case ch '(?C))
+ (with-current-buffer buffer (save-buffer))
+ (setq no-confirm t))
+ ((ti::char-in-list-case ch '(?k ?K))
+ ;; Why with-current-buffer? Well I have automatic
+ ;; select-buffer programmed to my my mouse movement,
+ ;; so if I point some other frame, that buffer
+ ;; gets activated.
+ ;;
+ ;; In here we want to be sure that the right buffer
+ ;; "the replace buffer" is touched.
+ ;;
+ ;;
+ (with-current-buffer buffer (save-buffer))
+ (kill-buffer buffer)))))))))))
+ (select-frame o-frame)
+ (forward-line 1))))
+ (raise-frame (select-frame o-frame))
+ (when verb
+ (message
+ "TinyReplace: Handled %s files, %s read-only: %s"
+ (length cache) read-only
+ (mapconcat 'concat ro-cache " ")))
+ nil))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyreplace-replace-region (beg end str1 str2)
+ "In region BEG END, find STR1 and replace with STR2."
+ (interactive (tinyreplace-interactive-region-args "region"))
+ (tinyreplace-replace-region-1
+ beg end (regexp-quote str1) str2 0 t))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyreplace-replace-forward (str1 str2)
+ "Find STR1 and replace with STR2 from current point forward.
+See C-h f `tinyreplace-args-keymap-create' what key bindings
+you can use. Normally C - l yanks, and \"\\\" key deletes line."
+ (interactive (funcall tinyreplace-:read-args-function))
+ (tinyreplace-replace-region-1
+ (point)
+ (point-max)
+ (regexp-quote str1) str2 0 t))
+
+;;; ----------------------------------------------------------------------
+;;; ** Not gurranteed to work interactively.
+;;;
+;;;###autoload
+(defun tinyreplace-latex-blk-replace (str1 str2 blk &optional beg-re end-re)
+ "Select latex block areas for replace.
+
+Input:
+
+ STR1 STR2 Find and replace with.
+ BLK Block delimiter to find
+ BEG-RE END-RE Region bound regexps."
+ (interactive "sLatex equation Search: \nsReplace with: \nsBlock names: ")
+ (let* ((cp (point)) ;current point
+ (block-re (concat "\\(" blk "\\)"))
+ (beg-re (or beg-re (concat "begin{" block-re "}")))
+ (end-re (or end-re (concat "end{" block-re "}")))
+ MARK
+ beg end
+ area-end
+ move)
+ (save-excursion
+ (goto-char (point-max)) (setq MARK (point-marker))
+ (goto-char cp) ;start from current point
+ (while (and (if (null (re-search-forward beg-re nil t))
+ nil
+ (setq beg (point)))
+ (save-excursion
+ (if (null (re-search-forward end-re nil t))
+ nil
+ (goto-char (match-beginning 0))
+ (setq end (point))))
+ (< (point) (marker-position MARK)))
+ (setq area-end ;leave the block end
+ (tinyreplace-replace-region-1
+ beg end (regexp-quote str1) str2 0 t)
+ move
+ (+ 2 area-end))
+ (if (< move (point-max))
+ (goto-char move)
+ (goto-char (point-max)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyreplace-latex-math-replace (str1 str2)
+ "Find STR1 and replace with STR2 inside latex math blocks."
+ (interactive "sLatex equation Search: \nsReplace with:")
+ (let ((math-blocks "equation"))
+ ;; first $ .. $ blocks
+ (save-excursion
+ (goto-char (point-min))
+ ;; first $ .. $ blocks
+ (tinyreplace-latex-blk-replace str1 str2 nil "[^\\][$]" "[^\\][$]")
+ ;; then the rest
+ (tinyreplace-latex-blk-replace str1 str2 math-blocks))))
+
+;;}}}
+
+(add-hook 'compilation-mode-hook 'tinyreplace-define-keys-compile-map)
+
+(provide 'tinyreplace)
+(run-hooks 'tinyreplace-load-hook)
+
+;;; tinyreplace.el ends here
--- /dev/null
+;;; tinyrmail.el --- RMAIL add-ons, pgp, mime labels, Spam complaint.
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 1996-2007 Jari Aalto
+;; Keywords: mail
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program, call M-x tinyrmail-version.
+;; Look at the code with folding.el.
+
+;; COPYRIGHT NOTICE
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;; ....................................................... &t-install ...
+;;
+;; ** NOTE: 1998-01 This file is no longer maintained. Plese see Gnus.
+;;
+;; Put this file on your Emacs-Lisp load path, add following into your
+;; ~/.emacs startup file. Rip code with with tinylib.el/ti::package-rip-magic
+;;
+;; (require 'tinyrmail)
+;;
+;; or prefer this; your .emacs loads up much quicker
+;;
+;; (autoload 'tinyrmail-rmail-summary-by-labels-and "tinyrmail" "" t)
+;; (autoload 'tinyrmail-install "tinyrmail" "" t)
+;; (add-hook 'rmail-mode-hook 'tinyrmail-install)
+;;
+;; If you have any questions, use this function
+;;
+;; M-x tinyrmail-submit-bug-report ,send bug report
+
+;;}}}
+
+;;{{{ Documentation
+
+;; ..................................................... &t-commentary ...
+;;; Commentary:
+
+;; Preface, overview of features
+;;
+;; 1998-01: This file is no longer supported. Prefer to use Gnus
+;; instead. There is module *tinygnus.el* which provides additional
+;; utilies for Gnus.
+;;
+;; o Detect PGP, MIME mail and label incoming messages accordingly.
+;; User can add more checking functions and labels to incoming email
+;; messages
+;; o New label summary cmd with AND e.g. finding {pgp,v} verified pgp
+;; o Flag incoming mail as deleted by regexp.
+;; o "S" command for Spam message reply.
+;; o Commands to fix your RMAIL messages.
+;; o advice: "n" and "p" do not to auto display msg in Summary buffer
+;; o advice: mouse click in Summary does not automatically update msg
+;; o advice: `rmail-ignored-headers' now reformats old messages too.
+;;
+;; Description
+;;
+;; This little package offers some autmatic detection of PGP
+;; MIME mails: It attaches labels to your incoming mails.
+;; There is also new summary function, which enables you to
+;; make a query by ANDing the labels in your RMAIL.
+;;
+;; This means, that you can now classify your message, like this:
+;;
+;; BASE
+;; SUBSET-IDENTIFIER
+;; MINOR-IDENTIFIER
+;; NOTE-IDENTIFIER
+;;
+;; Eg. For PGP mails I have
+;;
+;; {pgp}
+;; {pgp,v} -- verified signature
+;; {pgp,u} -- not verified
+;; {pgp,v,e} -- verified and encrypted
+;;
+;; The normail rmail's summary function gives you the OR summary, which
+;; would mean, that if you wanted symmary by {pgp,v}, it would give
+;; you all mail that has either {v} or {pgp} somewhere. Well, this
+;; summary is not suitable if you use one CHAR to denote attributes
+;; of your base-identifiers (multichar)
+;;
+;; Automatic deletion of incoming mail
+;;
+;; There is default function to mark messages as deleted according
+;; to regexp. Please configure this variable to suit your needs:
+;;
+;; tinyrmail-:delete-regexp
+;;
+;; If you want more personal control whether the mail
+;; should be deleted or not, please remove the default delete function
+;; and add your own:
+;;
+;; (add-hook 'tinyrmail-:load-hook 'my-tinyrmail-:load-hook)
+;;
+;; (defun my-tinyrmail-:load-hook ()
+;; "Cancel some default settings and modify parameters."
+;; (remove-hook 'tinyrmail-:get-new-mail-hook
+;; 'tinyrmail-delete-function)
+;; (add-hook 'tinyrmail-:get-new-mail-hook
+;; 'my-rmail-delete-function))
+;;
+;;
+;; (defun my-rmail-delete-function ()
+;; ...)
+;;
+;; New commands in RMAIL
+;;
+;; Refer to function tinyrmail-define-default-keys for exact setup.
+;; Currently the only new command added is
+;;
+;; "L" tinyrmail-rmail-summary-by-labels-and
+;;
+;; Fixing RMAIL format
+;;
+;; Sometimes you may get following error after you have hit "g"
+;; to get new mail: "Cannot convert to babyl". The reason for
+;; this behavior is still not quite clear to me, but the cause
+;; is in the incoming message that does not have
+;;
+;; From
+;;
+;; Field at the beginning of message. I have seen even some garbage
+;; Prepended to field so that it looked like
+;;
+;; m?From
+;;
+;; What have to start editing the RMAIL file directly to fix its
+;; format. Change the mode to text-mode, run M-x widen and search the
+;; last message that rmail was not able to read. You will easily find the
+;; point where "**** EOOH" markers do not appear any more.
+;;
+;; Now starts the fixing part to make rmail happy again:
+;;
+;; o Make sure From line is left flushed. Edit if needed and put
+;; lines in their right places.
+;; o Select all individual message's headers at a time.
+;; o Call function tinyrmail-fix-make-rmail-message-header
+;; which you should propably bound to some convenient key.
+;; The ESC-z combination is propably free for temporary use.
+;; (local-set-key "\ez" 'tinyrmail-fix-make-rmail-message-header)
+;;
+;; After you have converted all headers to rmail format, you can
+;; start rmail again with command
+;;
+;; M-x rmail-mode
+;;
+;; If you made any mistakes, rmail will let you know and you have to
+;; repeat the header fixing again. (possibly removing the prevous
+;; EOOOH markers and reconverting them). We aren't quite finished
+;; yet. You see, on error, rmail leaves the read mail into your home
+;; directory. Please check that
+;;
+;; ~/.newmail-USERNAME
+;;
+;; file doesn't contain any new message that aren't already in your RMAIL
+;; buffer. If there is only old message, delete that file. Now we
+;; have finished and you can again use "g" to get new mail.
+;;
+;; Standard Rmail distribution changes
+;;
+;; This package changes the standard Rmail distribution sligtly and here
+;; summary. If you want to disable these features or only use some of
+;; them, you have to put separate configuration to your .emacs.
+;; To disable forms:
+;;
+;; (setq tinyrmail-:load-hook '(tinyrmail-install))
+;;
+;; To disable advices, you do
+;;
+;; (setq tinyrmail-:load-hook '(tinyrmail-install my-tinyrmail-install))
+;;
+;; (defun my-tinyrmail-install ()
+;; (ti::advice-control
+;; '(rmail-show-message
+;; rmail-summary-enable
+;; rmail-summary-next-msg
+;; )
+;; "^tinyrmail"
+;; 'disable
+;; ))
+;;
+;;
+;; `tinyrmail-:forms-rmail'
+;;
+;; o Every time RMAIL package is loaded these forms are executed.
+;; o These define some keybindings to summary buffer
+;; that I have found appropriate. Mouse-2 selects message
+;; (and does not yank as the original). RET key also selects message.
+;; o The post command hook is cleared so that you can search regexp
+;; in summary buffer. Normally moving a cursor would move the
+;; current message too.
+;; o The "q" quit key is too easily pressed and I have removed it
+;; alltogether. If I really want to quit RMAIL, I usually
+;; quit Emacs too.
+;;
+;; Advices:
+;;
+;; *rmail-show-message* active
+;;
+;; The message's headers are now always reformatted. If you change
+;; variable `rmail-ignored-headers', the old messages are not affected
+;; until you "t"oggle headers. This advice does it for you
+;; automatically every time you select message. This advice slows
+;; message displaying a bit, but for me, it isn't very noticeable.
+;; You can very well turn this off if you dont' change content of
+;; `rmail-ignored-headers'.
+;;
+;; *rmail-summary-enable* active
+;;
+;; This replaces whole function. The original function did automatic
+;; message update whenever you moved around summary buffer. Now you
+;; can keep summary buffer search separated from the current
+;; message displayed.
+;;
+;; *rmail-summary-next-msg* active
+;;
+;; Same as above.
+;;
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+;;{{{ setup: libraries
+
+(require 'rmail) ;Uses macros from there
+(require 'tinylibm)
+
+(eval-and-compile
+ (autoload 'rmail-new-summary "rmailsum"))
+
+(eval-when-compile (ti::package-use-dynamic-compilation))
+
+(ti::package-defgroup-tiny TinyRmail tinyrmail-: mail
+ "Additional features to RMAIL.
+Overview of features
+
+ o Detect PGP, MIME mail and label incoming messages accordingly.
+ User can add more checking functions and labels to incoming email
+ messages
+ o New label summary cmd with AND, e.g. {pgp,v} for verified pgp mails.")
+
+;;}}}
+;;{{{ setup: hooks
+
+(defcustom tinyrmail-:load-hook '(tinyrmail-install tinyrmail-install-forms)
+ "*Hook that is run when package is loaded."
+ :type 'hook
+ :group 'TinyRmail)
+
+(defcustom tinyrmail-:rmail-get-new-mail-before-hook nil
+ "*Additional hook added by advice in package tinyrmail.el.
+Hook run just before new mail is fetched.
+Contain default function `tinyrmail-rmail-get-new-mail-before-function',
+which saves the Rmail message pointers before getting new mail."
+ :type 'hook
+ :group 'TinyRmail)
+
+(defcustom tinyrmail-:get-new-mail-hook nil
+ "*Hook run inside each _new_ mail message.
+The default function `tinyrmail-delete-function' reads variable
+`tinyrmail-:delete-regexp' and marks buffer as deleted if the regexp
+matches message contents."
+ :type 'hook
+ :group 'TinyRmail)
+
+;;}}}
+;;{{{ setup: public, user configurable
+
+(defcustom tinyrmail-:delete-regexp
+ (concat
+ "make.*money"
+ "\\|this is your chance.*money")
+ "*Mark messge deleted if this regexp match.
+If this regexp is nil, no mail is marked as deleted.
+This variable is efective only if `tinyrmail-delete-function' is
+installed into `tinyrmail-:get-new-mail-hook'."
+ :type '(string :tag "Regexp")
+ :group 'TinyRmail)
+
+(defcustom tinyrmail-:label-table
+ '((ti::mail-pgp-p "pgp")
+ (ti::mail-mime-p "mime"))
+ "*Labels to attach to new RMAIL messages.
+Format is
+
+ '((CHECK-FUNCTION STRING-OR-SYMBOL) (F S) ..).
+
+The STRING-OR-SYMBOL may be either \"string\" or variable name
+'lisp-var, where its `symbol-value' is used.
+
+The CHECK-FUNCTION is run without arguments inside every new
+message and it should return. This can also be a lisp form if
+the elt is not function symbol.
+
+ nil ,if no action should be taken
+ t ,if the STRING-OR-SYMBOL should be used for labelling
+ string ,that string is used for labelling."
+ :type '(repeat
+ (list
+ (function :tag "Check function")
+ (choice
+ :inline t
+ (string :tag "String Label")
+ (symbol :tag "Var Symbol"))))
+ :group 'TinyRmail)
+
+;;}}}
+;;{{{ setup: private
+
+(defvar tinyrmail-:rmail-info-list nil
+ "Values of saved message counters before we get new mail.")
+
+(defconst tinyrmail-:forms-rmail
+ '(progn
+ (when (boundp 'rmail-summary-mode-map)
+ (cond
+ ((ti::emacs-p)
+ ;; mouse-2 is paste, move it to select a buffer.
+ ;; See the rmail advices.
+ (define-key rmail-summary-mode-map [down-mouse-2]
+ 'rmail-summary-goto-msg)
+ (define-key rmail-summary-mode-map [mouse-2]
+ 'rmail-summary-goto-msg))
+ (t
+ (define-key rmail-summary-mode-map [(button2up)]
+ 'rmail-summary-goto-msg)
+ (define-key rmail-summary-mode-map [(button2)]
+ 'rmail-summary-goto-msg)))
+ ;; Enter selects a message too
+ (define-key rmail-summary-mode-map "\C-m" 'rmail-summary-goto-msg)
+ ;; rmailsum.el makes this buffer local, loop all rmail summary
+ ;; buffers and remove function from post-command-hook.
+ (ti::dolist-buffer-list
+ (eq major-mode 'rmail-summary-mode)
+ (not 'temp-buffers)
+ (not 'exclude)
+ (progn
+ (remove-hook 'post-command-hook 'rmail-summary-rmail-update)))
+ ;; disable "quit", it's too risky. I want to be in RMAIL,
+ ;; and only there hit the "q" key.
+ ;;
+ (define-key rmail-summary-mode-map "q" 'ignore))
+ (when (boundp 'rmail-mode-map)
+ (define-key rmail-mode-map "q"
+ '(lambda ()
+ "Confirm quit."
+ (interactive)
+ (if (y-or-n-p "Really quit RMAIL ")
+ (rmail-quit))))))
+ "Additional forms to `after-load-alist'.
+Set this variable to '(progn) if you want to disable these features.")
+
+;;}}}
+;;{{{ version
+
+;;;###autoload (autoload 'tinyrmail-version "tinyrmail" "Display commentary." t)
+
+(eval-and-compile
+ (ti::macrof-version-bug-report
+ "tinyrmail.el"
+ "tinyrmail"
+ tinyrmail-:version-id
+ "$Id: tinyrmail.el,v 2.44 2007/05/01 17:20:59 jaalto Exp $"
+ '(tinyrmail-:version-id
+ tinyrmail-:rmail-info-list
+ tinyrmail-:load-hook
+ tinyrmail-:rmail-get-new-mail-before-hook
+ tinyrmail-:get-new-mail-hook
+ tinyrmail-:delete-regexp
+ tinyrmail-:label-table)))
+
+;;}}}
+;;{{{ Installation
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload (autoload 'tinyrmail-install-files "tinyrmail" t t)
+(ti::macrof-install-pgp-tar tinyrmail-install-files "tinyrmail.el")
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyrmail-install-forms ()
+ "Some other things to do to get all installed.
+See source code for
+better explanation."
+ (interactive)
+ (when (boundp 'rmail-summary-mode-map)
+ (eval tinyrmail-:forms-rmail)) ;run it immediately
+ (cond
+ ((not (fboundp 'eval-after-load))
+ (load "rmailsum")
+ (load "rmail")
+ (eval tinyrmail-:forms-rmail))
+ ((fboundp 'eval-after-load)
+ ;; Quiet XEmacs 19.14 compiler who says this function doesn't exist
+ (ti::funcall 'eval-after-load "rmailsum" tinyrmail-:forms-rmail)
+ (ti::funcall 'eval-after-load "rmail" tinyrmail-:forms-rmail))))
+
+;;; ----------------------------------------------------------------------
+;;; - If more commnds are added, I make this a separate minor mode...
+;;;
+(defun tinyrmail-define-default-keys ()
+ "Define keys to various maps."
+ (interactive)
+ ;; Making summaries by ANDING labels.
+ (when (boundp 'rmail-mode-map)
+ (define-key rmail-mode-map "L" 'tinyrmail-rmail-summary-by-labels-and))
+ ;; This is not loaded, that's why symbol-value to shut up byte
+ ;; compiler.
+ (when (boundp 'rmail-summary-mode-map)
+ (define-key
+ (symbol-value 'rmail-summary-mode-map)
+ "L"
+ 'tinyrmail-rmail-summary-by-labels-and)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyrmail-install-advices (&optional remove verb)
+ "Install advices. Optionally REMOVE advices. VERB."
+ (interactive "P")
+ (ti::advice-control
+ '(rmail-get-new-mail)
+ "^tinyrmail-"
+ remove
+ (or verb
+ (interactive-p))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyrmail-install (&optional remove)
+ "Install package hooks. Optionally REMOVE installation.
+Can't restore changes to keymaps."
+ (interactive "P")
+ (let* ((f (if remove 'remove-hook 'add-hook)))
+ ;; Set up RMAIL for PGP
+ (funcall f 'rmail-get-new-mail-hook 'tinyrmail-rmail-get-new-mail-function)
+ (funcall f 'tinyrmail-:rmail-get-new-mail-before-hook
+ 'tinyrmail-rmail-get-new-mail-before-function)
+ ;; New commands
+ (funcall f 'rmail-mode-hook 'tinyrmail-define-default-keys)
+ (funcall f 'rmail-summary-mode-hook 'tinyrmail-define-default-keys)
+ (funcall f 'gnus-article-mode-hook 'tinyrmail-define-default-keys)
+ (tinyrmail-define-default-keys) ;Install immediately too
+ (tinyrmail-install-advices remove)))
+
+;;}}}
+;;{{{ rmail, labels
+
+;;; ----------------------------------------------------------------------
+;;; see rmailsum.el
+;;;
+;;;###autoload
+(defun tinyrmail-rmail-summary-by-labels-and (labels)
+ "Display a summary of all messages with one or more LABELS.
+LABELS should be a string containing the desired labels, separated by commas.
+This summary is prduced by _ANDING_ the labels."
+ (interactive "s(AND) Labels to summarize by: ")
+ (if (string= labels "")
+ (setq labels (or rmail-last-multi-labels
+ (error "No label specified"))))
+ (setq rmail-last-multi-labels labels)
+ (rmail-new-summary (concat "labels " labels)
+ (list 'rmail-summary-by-labels labels)
+ 'tinyrmail-rmail-message-labels-and-p
+ ;; convert to list of label string
+ ;;
+ (split-string labels "[ ,]+")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyrmail-rmail-message-labels-and-p (msg labels)
+ "Check and condition in MSG nbr with LABELS LIST."
+ (let* ((copy labels) ;since labels list vanishes in loop
+ (i 0))
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char (rmail-msgbeg msg))
+ (forward-char 3)
+ (dolist (elt labels)
+ ;; May look like this:
+ ;;
+ ;; 1,, pgp, v,
+ (if (looking-at (concat ".* " elt ","))
+ (incf i)))))
+ ;; Must have as many hits as labels passed to function
+ (eq (length copy) i)))
+
+;;}}}
+;;{{{ rmail, new message
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyrmail-delete-function ()
+ "Mark messages as deleted if it find regexp `tinyrmail-:delete-regexp'.
+This function is in `tinyrmail-:get-new-mail-hook'."
+ (ti::pmin)
+ (if (and (stringp tinyrmail-:delete-regexp)
+ (re-search-forward tinyrmail-:delete-regexp nil t))
+ (rmail-delete-message)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinyrmail-rmail-new-message-ptr ()
+ "Return first new message NBR.
+Function must be called only after the \"g\" key, in `rmail-get-new-mail'."
+ (if (and tinyrmail-:rmail-info-list
+ (not (eq (car tinyrmail-:rmail-info-list)
+ rmail-total-messages))
+ (integerp (car tinyrmail-:rmail-info-list)))
+ (1+ (car tinyrmail-:rmail-info-list))
+ ;; Whan you first hit M-x RMAIL, this tells you the first message
+ (rmail-first-unseen-message)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyrmail-rmail-get-new-mail-function ()
+ "Loop over every incoming mail message and do labelling."
+ (let* ((table tinyrmail-:label-table)
+ (rmail-current-message rmail-current-message)
+ nbr
+ list
+ func
+ label
+ stat)
+ ;; Is there new mail, maybe some of them are not read yet?
+ (setq nbr (tinyrmail-rmail-new-message-ptr))
+ (when nbr
+ (while (< nbr (1+ rmail-total-messages))
+ (ti::mail-rmail-do-message-macro nbr nil
+ (setq rmail-current-message nbr)
+ (setq list table)
+ (dolist (elt list)
+ (setq func (nth 0 elt)
+ label (nth 1 elt)
+ stat (if (symbolp func)
+ (funcall func)
+ (eval func)))
+ (if (symbolp label)
+ (setq label (symbol-value label)))
+ (cond
+ ((stringp stat)
+ (rmail-add-label stat))
+ ((and stat (stringp label))
+ (rmail-add-label label))
+ ((and stat (not (stringp label)))
+ (error "Label is not a string %s %s" label table))))
+ (run-hooks 'tinyrmail-:get-new-mail-hook))
+ (incf nbr)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyrmail-rmail-get-new-mail-before-function ()
+ "Reset some values before getting mail."
+ (setq
+ tinyrmail-:rmail-info-list
+ (list
+ rmail-total-messages
+ rmail-current-message
+ rmail-message-vector
+ rmail-deleted-vector
+ rmail-summary-vector)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defadvice rmail-get-new-mail (before tinyrmail-hook act)
+ "Run hook 'tinyrmail-:rmail-get-new-mail-before-hook'."
+ (run-hooks 'tinyrmail-:rmail-get-new-mail-before-hook))
+
+;;}}}
+;;{{{ Advice
+
+;;; ----------------------------------------------------------------------
+;;; (ad-unadvise 'rmail-show-message)
+;;;
+(defadvice rmail-show-message (before tirm act)
+ "Reformat message.
+If you change the `rmail-ignored-headers' it won't affect the current
+messages unless you hit 't' to toggle headers. This advice reformats
+message every time the message is shown."
+ ;; We do}t want expunge to call use, only direct
+ ;; show message command.
+ (when (interactive-p)
+ (ti::widen-safe
+ (rmail-maybe-set-message-counters)
+ (narrow-to-region (rmail-msgbeg (ad-get-arg 0)) (point-max))
+ (let ((buffer-read-only nil))
+ (goto-char (point-min))
+ (forward-line 1)
+ ;; Convert 1 --> 0, otherwise format command barfs.
+ (delete-char 1)
+ (insert "0")
+ (forward-line 1)
+ (let ((case-fold-search t))
+ (while (looking-at "Summary-Line:\\|Mail-From:")
+ (forward-line 1)))
+ (insert "*** EOOH ***\n")
+ (forward-char -1)
+ (search-forward "\n*** EOOH ***\n")
+ (forward-line -1)
+ (let ((temp (point)))
+ (and (search-forward "\n\n" nil t)
+ (delete-region temp (point))))
+ (goto-char (point-min))
+ (search-forward "\n*** EOOH ***\n")
+ (rmail-reformat-message (point-min) (point-max))))))
+
+;;; ----------------------------------------------------------------------
+;;; - Copy from rmailsum.el
+;;; - This would normally cause automatic update by mouse click, disable it
+;;; - I want to select message with RETURN or mouse-2. This way I can
+;;; move around the buffer and leave the message in RMAIL untouched.
+;;;
+(defadvice rmail-summary-enable (around tirm act)
+ "Replace function.
+Disable automatic update when mouse - 1 is pressed or cursor is moved.
+You can browse the summary buffer more freely and keep the
+selected message in RMAIL."
+ (use-local-map rmail-summary-mode-map)
+ ;; (add-hook 'post-command-hook 'rmail-summary-rmail-update)
+ (setq revert-buffer-function 'rmail-update-summary))
+
+;;; ----------------------------------------------------------------------
+;;; - Copy from rmailsum.el.
+;;; - I hate when I can't browse forward without getting
+;;; the Summary. Grr...
+;;;
+(defadvice rmail-summary-next-msg (around tirm act)
+ "Replace function. Disbale automatic showing of summary buffer."
+ (forward-line 0)
+ (and (> number 0) (end-of-line))
+ (let ((count (if (< number 0) (- number) number))
+ (search (if (> number 0) 're-search-forward 're-search-backward))
+ (non-del-msg-found nil))
+ (while (and (> count 0) (setq non-del-msg-found
+ (or (funcall search "^....[^D]" nil t)
+ non-del-msg-found)))
+ (setq count (1- count))))
+ (beginning-of-line)
+;;; this does automatic update, "p", "n" and mouse click
+;;; (display-buffer rmail-buffer)
+ nil)
+
+;;}}}
+;;{{{ Fixing RMAIL messages
+
+;;; ----------------------------------------------------------------------
+;;; - When you run RMAIL over FCC'd file, and afterwards add more to that
+;;; FCC mail, the file may become corrupt so that RMAIL can't read all
+;;; messages in it.
+;;; - This little function, when header region is selected, converts
+;;; the headers to Rmail, so that summary can be used.
+;;; - I don't understand why my 'From ' field goes totally wrong...
+;;;
+;;;
+(defun tinyrmail-fix-make-rmail-message-header (beg end)
+ "Fix RMAIL header in BEG END.
+To use this function you must do this.
+
+1. Be in RMAIL buffer
+2. Change mode to text with \\[text-mode]
+3. run \\[widen]
+4. Select message's full headers
+5. Call this function
+
+After the call, the appropriate RMAIL message format for headers has been
+created."
+ (interactive "r")
+ (let* ( ;; START and END headers strings
+ (s-h (concat (char-to-string ?\037) "\f\n1,,\n")) ;start header
+ (e-h "*** EOOH ***\n")
+ blk line
+ from date
+ rmail-lines)
+ (ti::keep-lower-order beg end)
+ ;; These lines are show in the real rmail message, rest are hidden.
+ (setq rmail-lines
+ (ti::buffer-grep-lines
+ "^To:\\|^From:\\|^date:\\|^Subject:" beg end))
+ (setq blk (buffer-substring beg end))
+ (kill-region beg end)
+ (goto-char beg)
+ (insert s-h blk "\n" e-h)
+ (goto-char beg) (forward-line 2)
+ (if (null ;; Is this corrupted From line ?
+ (looking-at "From\\( [a-zA-Z]+ \\)\\([FSMTWS].*\\)"))
+ nil
+ (setq from (buffer-substring (match-beginning 1) (match-end 1)))
+ (setq date (buffer-substring (match-beginning 2) (match-end 2)))
+ (kill-line)
+ (setq line (concat "Date: " date "\n" "From:" from))
+ (insert line)
+ (if (null (re-search-forward (regexp-quote "***")))
+ (message "Not found [***]")
+ (forward-line 1)
+ (setq beg (point))
+ (insert blk)
+ (goto-char beg)
+ (kill-line)
+ (insert line)
+ (re-search-forward "^Subject")
+ (forward-line)))
+ ;; If there is no babyl at all we may want to insert the RMAIL headers
+ ;;
+ (when (y-or-n-p "insert Rmail headers too?")
+ (if (null (re-search-forward (regexp-quote "***")))
+ (message "Can't find ***")
+ (forward-line 1)
+ (insert (mapconcat 'concat rmail-lines "\n") "\n")))))
+
+;;}}}
+
+(add-hook 'tinyrmail-:get-new-mail-hook
+ 'tinyrmail-delete-function)
+
+(provide 'tinyrmail)
+(run-hooks 'tinyrmail-:load-hook)
+
+;;; tinyrmail.el ends here
--- /dev/null
+;;; tinyscroll.el --- Enable or disable auto-scroll for any buffer.
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 1996-2007 Jari Aalto
+;; Keywords: extensions
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program, call M-x tinyscroll-version.
+;; Look at the code with folding.el.
+
+;; COPYRIGHT NOTICE
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;; ....................................................... &t-install ...
+;; Put this file on your Emacs-Lisp load path, add following into your
+;; ~/.emacs startup file.
+;;
+;; (require 'tinyscroll)
+;;
+;; or use autoload; your .emacs loads up a bit quicker. In this package
+;; however the above method is preferred, since it automatically
+;; marks *compilation* buffer for auto-scrolling. Using the autoload
+;; puts the scroll in effect only when you add entry to scroll list
+;; with M-x tinyscroll-control.
+;;
+;; (autoload 'tinyscroll-control "tinyscroll" "" t)
+;; (autoload 'tinyscroll-list "tinyscroll" "" t)
+;; (autoload 'tinyscroll-timer-process-control "tinyscroll" "" t)
+;; (eval-after-load "compile" '(require 'tinyscroll))
+;;
+;; To activate/deactivate scrolling for a buffer or to check list, call
+;;
+;; M-x tinyscroll-control
+;; M-x tinyscroll-list
+;;
+;; To set default buffers to scroll, change this variable
+;;
+;; tinyscroll-:list
+;;
+;; If you have any questions, use these functions
+;;
+;; M-x tinyscroll-debug-toggle to toggle the package debug.
+;; M-x tinyscroll-submit-bug-report to send bug report
+
+;;}}}
+
+;;{{{ Documentation
+
+;; ..................................................... &t-commentary ...
+;;; Commentary:
+
+;; Preface, May 1996
+;;
+;; I was in the middle of testing one of my new packages which didn't
+;; quite work as I wanted, I was loading all the lisp files to see if
+;; it breaks. I watched the *Message* buffer to fill with statements
+;;
+;; Loading abbrev...
+;; Loading abbrev...done
+;; ...
+;; Loading rmail...
+;; loading rmail done...
+;; ...
+;;
+;; But suddendly the emacs died. It kicked me off to the shell and I
+;; had no idea what package was the last one that got loaded.
+;;
+;; You see, the *Message* buffer keeps growing, but you have to tap
+;; the pgDown key to get to the end, all the time. Instead I decided
+;; to pull out some lisp to do general auto-scrolling for any buffer,
+;; so that I can just sit back and watch the buffer move. No more
+;; guessing in *Message* buffer what was the last message before Emacs
+;; sunk :-)
+;;
+;; Overview of features
+;;
+;; o Select buffer, and hit auto scroll on/off. You can scroll any
+;; buffer.
+;; o All windows for the buffer are scrolled in all frames.
+;; If frame is miimized and contains window to sroll, frame will
+;; be maximized ("popped up")
+;; o If buffer's point-max doesn't move, scroll is ignored.
+;; o Default scroll activated for: *Compilation* *Grep* and *Messages*
+;;
+;; How to use this package
+;;
+;; The scroling here is based on timers, where the lowest interval can
+;; be one 1 second. This means that you don't get smooth and
+;; continuous scrolling, but regular update of the buffer, which may
+;; in rare cases seem jerky. However, using timers is the only
+;; possibility if we want to have general scroll utility for *any* buffer.
+;;
+;; To enable/disable auto-scroll for current buffer, use these:
+;;
+;; M-x tinyscroll-control ;to activate scroll
+;; C-u M-x tinyscroll-control ;to deactivate scroll
+;;
+;; Lowest window of the same buffer always scrolls
+;;
+;; It is an interesting problem, when you have SAME buffer in multiple
+;; windows, to decide which window to scroll. I didn't want to scroll
+;; all windows, since otherwise I wouldn't have used two/or more
+;; windows for the same buffer.
+;;
+;; I decided that the lowest window for the buffer always scrolls. You
+;; can't change that. This was a design decision and I won't support
+;; scrolling middle/upper buffers. Just arrange your windows so that
+;; the scrolling one goes to the bottom.
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+;;{{{ setup: libraries
+
+(require 'tinylibm)
+
+(eval-and-compile
+ (ti::package-package-require-timer))
+
+(eval-when-compile (ti::package-use-dynamic-compilation))
+
+(ti::package-defgroup-tiny TinyScroll tinyscroll-: extensions
+ "Enable or Disable autos-croll for any buffer.
+ Overview of features
+
+ o Select buffer, and hit auto scroll on/off. You can scroll any
+ buffer.
+ o If there are multiple windows for the same buffer, scroll only the
+ bottom one. --> you can have \"permanent\" look window, while
+ the buffer scrolls in other window.
+ o Smart scrolling: if buffer's point-max doesn't move, it ignores
+ scrolling. This way you can browse buffer after there is
+ no more output to window.
+ ")
+
+;;}}}
+;;{{{ setuo: public, user configurable
+
+(defcustom tinyscroll-:load-hook nil
+ "*Hook that is run when package is loaded."
+ :type 'boolean
+ :group 'TinyScroll)
+
+(defcustom tinyscroll-:interval 3
+ "*Interval in seconds when scrolling process activates.
+Must be bigger that 1."
+ :type 'integer
+ :group 'TinyScroll)
+
+;; Initalize this in tinyscroll-:load-hook if you want to have some
+;; other default buffers at startup.
+(defcustom tinyscroll-:list
+ '(
+ ("*compilation*" . 1) ;set this to auto scroll
+ ("*grep*" . 1)
+ ("*igrep*" . 1)
+ ("*Messages*" . 1))
+ "*List of buffers that have auto scroll active.
+Format: '((buffer-name-string . max-point) (BN . POINT) ..)"
+ :type '(repeat
+ (string :tag "buffer")
+ (integer :tag "point"))
+ :group 'TinyScroll)
+
+;;}}}
+;;{{{ setup: private
+
+(defvar tinyscroll-:tmp-buffer "*auto-scroll*"
+ "Temporary buffer to display the active auto-scroll buffers.")
+
+(defvar tinyscroll-:timer-elt nil
+ "Timer process.")
+
+;;}}}
+;;{{{ version
+
+;;;###autoload (autoload 'tinyscroll-version "tinyscroll" "Commentary." t)
+(eval-and-compile
+ (ti::macrof-version-bug-report
+ "tinyscroll.el"
+ "tinyscroll"
+ tinyscroll-:version-id
+ "$Id: tinyscroll.el,v 2.41 2007/05/01 17:21:00 jaalto Exp $"
+ '(tinyscroll-:version-id
+ tinyscroll-:debug
+ tinyscroll-:load-hook
+ tinyscroll-:interval
+ tinyscroll-:list
+ tinyscroll-:tmp-buffer
+ tinyscroll-:timer-elt)
+ '(tinyscroll-:debug-buffer)))
+
+;;}}}
+;;{{{ code: misc
+
+;;;### (autoload 'tinyscroll-debug-toggle "tinyscroll" "" t)
+
+(eval-and-compile (ti::macrof-debug-standard "tinyscroll" "-:"))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinyscroll-active-buffer-p (buffer-name)
+ "Check is BUFFER-NAME name is in `tinyscroll-:list'."
+ (assoc buffer-name tinyscroll-:list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinyscroll-add-1 (buffer-name position)
+ "Add BUFFER-NAME and last POSITION to scroll list."
+ (push (cons buffer-name position) tinyscroll-:list ))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinyscroll-remove-1 (buffer-name)
+ "Remove BUFFER-NAME from scroll list."
+ (setq tinyscroll-:list (adelete 'tinyscroll-:list buffer-name)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinyscroll-point-max-moved-p (buffer-name max)
+ "Find BUFFER-NAME; return t if MAX is not stored `point-max' for BUFFER-NAME.
+Also updates new `point-max' if MAX is different.
+If buffer does not exist, do nothing and return nil."
+ (let* ((elt (tinyscroll-active-buffer-p buffer-name)))
+ (tinyscroll-debug "Max-p check" elt buffer-name max "\n")
+ (when (and elt (not (eq (cdr elt) max)))
+ (setcdr elt max)
+ max )))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinyscroll-buffers ()
+ "Return list of buffer that have auto scroll on."
+ (mapcar 'car tinyscroll-:list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinyscroll-ti::temp-buffer ()
+ "Set up temporary buffer and displays it."
+ (ti::temp-buffer tinyscroll-:tmp-buffer 'clear)
+ (pop-to-buffer tinyscroll-:tmp-buffer) )
+
+;;; ----------------------------------------------------------------------
+;;; if easier to trap "t" error condition.
+;;;
+(defun tinyscroll-:list-add (buffer-name position &optional remove)
+ "Check is BUFFER-NAME name is in 'tisc:-list'.
+
+Input:
+
+ BUFFER-NAME buffer name string
+ POSITION `point-max' in the buffer
+ REMOVE flag, remove buffer from list
+
+Return:
+
+ nil Yes, buffer is in list
+ t action not done"
+ (let* ((exist (tinyscroll-active-buffer-p buffer-name))
+ ret)
+ (cond
+ ((or (and remove (null exist))
+ (and (null remove) exist))
+ (setq ret t))
+ (remove
+ (tinyscroll-remove-1 buffer-name))
+ (t
+ (tinyscroll-add-1 buffer-name position)))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinyscroll-window-list ()
+ "Return windows that have auto scroll enabled.
+Return:
+ window list or nil"
+ (let* (win
+ win-list)
+ (dolist (frame (frame-list))
+ (dolist (buffer (tinyscroll-buffers))
+ (if (setq win (get-buffer-window buffer frame))
+ (push win win-list))))
+ win-list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyscroll-process ()
+ "Scroll all window buffers in `tinyscroll-:list'.
+Activate This process activates itself only when the window, which
+should be scrolled, is visible"
+ (let ((list (tinyscroll-window-list))
+ (oframe (selected-frame)))
+ (when list ;if we bother to do anything?
+ (dolist (win list)
+ (ti::save-excursion-macro
+ (set-buffer (window-buffer win))
+ (tinyscroll-debug "tinyscroll-process: " (window-buffer win)
+ (buffer-name) (point-max) "\n")
+
+ ;; Scrolling in fact means that, the point-max is
+ ;; always visible
+ (select-window win)
+ (when (tinyscroll-point-max-moved-p (buffer-name) (point-max))
+ (ti::pmax) )))
+ (select-frame oframe))
+ nil))
+
+;;}}}
+;;{{{ code: interactive
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyscroll-timer-process-control (&optional delete verb)
+ "Keep the auto scroll process and timer process alive.
+Optionally DELETE auto scroll process. VERB."
+ (interactive "P")
+ (setq tinyscroll-:timer-elt
+ (ti::compat-timer-control "1 sec"
+ tinyscroll-:interval
+ 'tinyscroll-process
+ delete
+ verb)))
+
+;;; ---------------------------------------------------7-------------------
+;;;
+;;;###autoload
+(defun tinyscroll-list (&optional print)
+ "Show list of active auto scroll buffers.
+Buffers are listed inecho-area if they fit there, otherwise in separate buffer.
+
+If optional PRINT flag is non-nil, always generate report to temporary buffer.
+If list if empty, do nothing.
+
+Return:
+
+ t report generated to temporary buffer
+ nil no report"
+ (interactive)
+ (let* ((str (ti::list-to-string (mapcar 'car tinyscroll-:list)))
+ (verb (interactive-p))
+ ret)
+ (if (and (string= str "") verb)
+ (message "TinyScroll: no entries in `tinyscroll-:list'.")
+ (setq ret t)
+ (cond
+ ((and (null print)
+ (< (length str) 80))
+ (message str))
+ (t
+ (tinyscroll-ti::temp-buffer)
+ (insert (ti::list-to-string tinyscroll-:list "\n"))
+ (setq buffer-read-only t)
+ (shrink-window-if-larger-than-buffer))))
+ ret))
+
+;;}}}
+;;{{{ code: main
+
+;;; ----------------------------------------------------------------------
+;;; - It's a bit slow to create buffer comletions this way.
+;;; Anybody has a better suggestion to amulate "bBuffer"
+;;; interactive tag? Mail me if you know...
+;;;
+;;; But I couldn't get the on/off information to the prompt
+;;; otherwise.
+;;;
+;;;###autoload
+(defun tinyscroll-control (buffer-or-pointer &optional off verb)
+ "Turn on auto scroll on/off for current buffer.
+If this command is called from `tinyscroll-:tmp-buffer' then the current
+word in the line is read and offered for default buffer name.
+
+Input:
+
+ BUFFER-OR-POINTER buffer to scroll
+ OFF flag, prefix arg; is non-nil turn scrolling off
+ VERB flag, allow verbose messages."
+ (interactive
+ (list
+ (completing-read
+ (format "Scroll [%s] buffer: " (if current-prefix-arg "off" "on"))
+ (ti::list-to-assoc-menu
+ (ti::dolist-buffer-list (string-match "." (buffer-name))))
+ nil
+ nil
+ ;; Default buffer ...
+ (if (string= (buffer-name) tinyscroll-:tmp-buffer)
+ (ti::read-current-line)
+ (buffer-name))) ;; completing-read
+ current-prefix-arg))
+ (let* ((bufferp (if (bufferp buffer-or-pointer)
+ buffer-or-pointer
+ (get-buffer buffer-or-pointer)))
+ buffern
+ msg)
+ (ti::verb)
+ ;; Check non-interactive errors
+ (if (or (null bufferp)
+ (not (buffer-live-p (get-buffer bufferp))))
+ (error "Invalid arg, buffer %s" bufferp))
+ (setq buffern (buffer-name bufferp))
+ (if off
+ (if (tinyscroll-:list-add buffern 0 'remove)
+ (setq msg "TinyScroll: buffer already removed."))
+ ;; Keep the process alive all the time
+ (tinyscroll-timer-process-control)
+ (save-excursion
+ ;; We have to record the point-max
+ (set-buffer buffern)
+ (if (tinyscroll-:list-add buffern (point-max))
+ (setq msg "TinyScroll: Already in list.")) ))
+ (if verb
+ (message msg))))
+
+;;}}}
+
+(tinyscroll-timer-process-control) ;; wake it up !
+(provide 'tinyscroll)
+(run-hooks 'tinyscroll-:load-hook)
+
+;;; tinyscroll.el ends here
--- /dev/null
+;;; tinysearch.el --- Grab and search word under cursor
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 1994-2007 Jari Aalto
+;; Keywords: tools
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program, call M-x tinysearch-version.
+;; Look at the code with folding.el.
+
+;; COPYRIGHT NOTICE
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;;; Intallation:
+;; ....................................................... &t-install ...
+;; Put this file on your Emacs-Lisp load path, add following into
+;; ~/.emacs startup file.
+;;
+;; (require 'tinysearch)
+;;
+;; or use autoload, and your ~/.emacs loads quicker
+;;
+;; (autoload 'tinysearch-search-word-forward "tinysearch" "" t)
+;; (autoload 'tinysearch-search-word-backward "tinysearch" "" t)
+;;
+;; ;; Install default keybindings: M-s (forward search), C-M-s
+;; ;; (bbackward), M-Mouse-1 (forward), C-M-Mouse-1 (backward)
+;; (add-hook 'tinysearch-:load-hook 'tinysearch-install)
+
+;;}}}
+;;{{{ Documentation
+
+;; ..................................................... &t-commentary ...
+;;; Commentary:
+
+;; Preface, 1994
+;;
+;; In 7 Nov 1994 <aep@world.std.com> (Andrew E Page) posted
+;; interesting code by article name 'Script Example: Search for next
+;; word', which was interesting. The idea of the code was good, but it
+;; didn't work as expected at all. Gradually the idea was crystallized
+;; into this package.
+;;
+;; "Why we need search word package, when in emacs I can do `C-s' to
+;; enter search mode: C-w C-w C-w to grap words immediately after
+;; point and finally C-s to start searching...?"
+;;
+;; Well, people tend to forget, that life was out there when 19.xx
+;; wan't in hands of developers. This package was originally made for
+;; 18. The advantage of this package is the variable
+;;
+;; tinysearch-:word-boundary-set
+;;
+;; which you can easily change whenever you need (e.g. thru
+;; functions). To do the same in emacs, you have to go and modify the
+;; syntax entries involved...then come back again when you're done. I
+;; never do that, I seldom touch the syntax entries. Besides all
+;; mode-xxx go crazy if I would do so. Now you see the advantage?
+;;
+;; And of course I feel more comfortable to do just one keypress,
+;; like like `M-s' to search forward instead of cubersome C-s C-w C-w
+;; C-w [n times] and finally C-s
+;;
+;; Description
+;;
+;; Grab word under oint and searches fwd/back. The word is inserted
+;; into Emacs's search ring, so that you can later continue with `C-s'
+;; or with `C-r' call.
+;;
+;; Why doesn't it find my C++ function class::InitClass() ??
+;;
+;; User pressed the search function over the call:
+;;
+;; InitClass(); << Here
+;; i = i +1;
+;;
+;; Why isn't the function found? Remember that this searches
+;; 'true' words, not parts of them. A word is surrounded by at
+;; least one whitespace, since it's not a word if it is concatenated
+;; together with something else.
+;;
+;; The problem is, that if is you define ':' to belong to a
+;; character set in C++, [because you propably want to grab
+;; variables easily. including the scope operator
+;; 'clss::variable' or '::global'], this package expects to
+;; find word a boundary:
+;;
+;; nonWordWORDnonWord
+;; ======= =======
+;;
+;; And as you can see, the if ':' belongs to word, it can't
+;; simultaneously belong to NonWord ! Summa summarum: Revert to
+;; emacs C-s for a moment, since the word is automatically added
+;; to the search buffer.
+;;
+;; Word accept function note:
+;;
+;; There is variable `tinysearch-:accept-word-function', which has
+;; default function
+;;
+;; tinysearch-accept-word
+;;
+;; The function's purpose is to check if the searched word is
+;; accepted and that search should be terminated. Currently there it
+;; contains some programming logic for C/C++ languages, so that
+;; certain hits are ignored. Consider following case:
+;;
+;; struct *foo; - 1
+;; foo->x; - 2
+;; x->foo - 3
+;;
+;; int foo, x; - 4
+;; foo = x; - 5 * start of 'foo' and 'x' search backward
+;;
+;; C/C++ mode, searching for 'foo' finds 4,2,1 -- Not 3
+;; C/C++ mode, searching for 'x' finds 5,4,3 -- Not 2
+;; But in text-mode, you would find all occurrances.
+;;
+;; The added logic to C++ ignores the struct's MEMBER matches so that
+;; you really can find the "main" variables. If you don't like
+;; this added feature, you can alwasy go to
+;;
+;; M-x text-mode
+;;
+;; For a while, or if want to permanently switch this feature off,
+;; you set the variable `tinysearch-:accept-word-function' to nil, which
+;; causes all hits to be accepted.
+;;
+;; Needless to say, that you can use put your own checking
+;; function in that variable to control the accurrances better.
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+;;{{{ setup: require
+
+(require 'tinylibm)
+
+(eval-when-compile (ti::package-use-dynamic-compilation))
+
+(ti::package-defgroup-tiny TinySearch tinysearch-: extensions
+ "search word under cursor: backward, forward.")
+
+;;}}}
+;;{{{ hooks
+
+;;; ......................................................... &v-hooks ...
+
+(defcustom tinysearch-:before-hook nil
+ "*Hook that is run at the BEG of search function.
+You can set this to point to function that alters the value of
+`tinysearch-:word-boundary-set' e.g. by looking at the file type."
+ :type 'hook
+ :group 'TinySearch)
+
+(defcustom tinysearch-:final-hook nil
+ "*Hook that is _always_ run at the END of search function.
+It doesn't care about word grabbings or search failures."
+ :type 'hook
+ :group 'TinySearch)
+
+(defcustom tinysearch-:load-hook nil
+ "*Run when package has been loaded.
+A good candidate could be `tinysearch-install-default-keybindings'."
+ :type 'hook
+ :group 'TinySearch)
+
+;;}}}
+;;{{{ variables
+
+;;; ....................................................... &v-private ...
+
+(defvar tinysearch-:direction nil
+ "Tell direction of search. nil = forward.")
+
+(defvar tinysearch-:search-status nil
+ "Status of word search. t = successful.")
+
+(defvar tinysearch-:overlay nil
+ "Overlay used for highlighting.
+Created and killed during program execution.")
+
+;;; ........................................................ &v-public ...
+;;; User configurable
+
+(defcustom tinysearch-:word-boundary-set "-A-Za-z0-9_"
+ "*Character set to conform a single word.
+You might want to set this to something else before doing search."
+ :type 'hook
+ :group 'TinySearch)
+
+(defcustom tinysearch-:wrap-flag nil
+ "*Non-nil means wrap buffer if there is no more match."
+ :type 'boolean
+ :group 'TinySearch)
+
+(defcustom tinysearch-:accept-word-function 'tinysearch-accept-word
+ "*Function run after the search for word has been successful.
+If this variable contains non-existing function (like nil), the
+content of the variable is ignored.
+
+Default function:
+
+ 'tinysearch-accept-word'
+
+Passed args to function:
+
+ string word being searched
+
+Return values of function:
+
+ t accept search
+ nil do not accept search, continue searching next word."
+ :type 'function
+ :group 'TinySearch)
+
+;;; ....................................................... &v-version ...
+
+(eval-and-compile
+ (ti::macrof-version-bug-report
+ "tinysearch.el"
+ "tinysearch"
+ tinysearch-:version-id
+ "$Id: tinysearch.el,v 2.49 2007/05/07 10:50:14 jaalto Exp $"
+ '(tinysearch-:version-id
+ tinysearch-:before-hook
+ tinysearch-:final-hook
+ tinysearch-:load-hook
+ tinysearch-:direction
+ tinysearch-:search-status
+ tinysearch-:overlay
+ tinysearch-:word-boundary-set
+ tinysearch-:wrap-flag)))
+
+;;}}}
+
+;;; ########################################################### &Funcs ###
+
+;;{{{ 19.xx isearch add
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinysearch-add-to-isearch-search-ring (isearch-string)
+ "Add search pattern to ISEARCH-STRING in Emacs.
+This code is directly taken from function `isearch-done' By Daniel LaLiberte."
+ (if (> (length isearch-string) 0)
+ ;; Update the ring data.
+ (if isearch-regexp
+ (if (or (null regexp-search-ring)
+ (not (string= isearch-string (car regexp-search-ring))))
+ (progn
+ (setq regexp-search-ring
+ (cons isearch-string regexp-search-ring))
+ (if (> (length regexp-search-ring) regexp-search-ring-max)
+ (setcdr (nthcdr (1- search-ring-max) regexp-search-ring)
+ nil))))
+ (if (or (null search-ring)
+ (not (string= isearch-string (car search-ring))))
+ (progn
+ (setq search-ring (cons isearch-string search-ring))
+ (if (> (length search-ring) search-ring-max)
+ (setcdr (nthcdr (1- search-ring-max) search-ring) nil)))))))
+
+;;}}}
+;;{{{ main
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinysearch-accept-word (word)
+ "Determine if we accept searched WORD."
+ (let* ((type (symbol-name major-mode))
+ (ret t) ;default, accept search
+ space-word)
+ (cond
+ ((string-match "^c-\\|^cc-\\|c[+]+" type)
+ ;; Check C/C++ dependent variables, where rg. 'a' is
+ ;; searched
+ ;; a = 1 , begin search with 'a'
+ ;; a = a + 1 , accepted hit
+ ;; struct->a , not accepted hit, continue search
+ (setq space-word
+ (save-excursion
+ (or (ti::buffer-read-space-word)
+ "")))
+ (if (string-match (concat "\\(->\\|[.]\\)" (regexp-quote word))
+ space-word)
+ ;; discard this one.
+ (setq ret nil))))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinysearch-grab-word (&optional charset beg end )
+ "Gets word under cursor limited by CHARSET string.
+Optional BEG and END gives maximum search limits.
+Default boundary is line limit."
+ (let* (re-word-boundary
+ re-word
+ ;; We accept ':' and '-' , beasuse they are used in c++ and lisp
+ (charset (or charset "-:A-Za-z0-9_"))
+ (beg (or beg (line-beginning-position)))
+ (end (or end (line-end-position)))
+ pb
+ pe
+ p
+ re
+ ret)
+ (setq re-word-boundary (concat "[^" charset "]"))
+ (setq re-word (concat "[" charset "]")) ;considered single word
+ ;; Note: the first search goes backwards to find the start of the
+ ;; word, which is one character in front of the character
+ ;; found by the search. Then we go forward to the end of
+ ;; word which is one character behind the character found by the
+ ;; search.
+ (save-excursion ;conceive original (point)
+ (if (re-search-backward re-word-boundary beg t)
+ (setq pb (1+ (point))))
+ (if pb nil ;already found
+ (setq p (point))
+ (beginning-of-line)
+ (if (eq p (point)) ;we were at the BEG
+ (setq re re-word)
+ (setq re (concat re-word "+"))) ;skip chars
+ (if (re-search-forward re (1+ p) t) ; word at the BEG
+ (setq pb beg))))
+ ;; Then search end point
+ (save-excursion
+ (if (re-search-forward re-word-boundary end t)
+ (setq pe (1- (point))))
+ (if pe nil ;already found
+ (if (looking-at (concat re-word "+$")) ; handle word at the END of ln
+ (setq pe end))))
+ (if (and pb pe)
+ (setq ret (buffer-substring pb pe)))
+ ;; easier to debug this way
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;; - There is lot of re-search-backward/fwd commands and it is intentional,
+;;; so that the code is totally emacs version independent. Newer emacs
+;;; has nice functions that shrink this code to 10 lines :->
+;;; - Never grab word function is already coded in tinylib.el
+;;;
+(defun tinysearch-search-word-main (&optional backward set)
+ "Gets word under cursor and search next occurrence.
+If BACKWARD is non-nil, the search will be headed backward, the SET
+corresponds to `tinysearch-:word-boundary-set'.
+
+Before searching is done the tinysearch-hooks is thrown. This is useful
+is you want someone to dynamically change the search-word's idea of
+the chars belonging to word. By setting `tinysearch-:word-boundary-set' you
+can set different sets for text and Lisp. [In Lisp the '-' is part of
+word while in text it normally isn't].
+
+NOTE:
+
+ You cannot search 1 char words with this due to internal
+ behaviour of search method and cursor positioning."
+ (interactive "P")
+ (let ((wrap tinysearch-:wrap-flag)
+ (loop 0)
+ (accept t)
+ charset
+ re-charset
+ word found
+ re-word-boundary re-word
+ prev-point
+ no-msg
+ mb
+ me)
+ (or tinysearch-:overlay
+ (setq tinysearch-:overlay (ti::compat-overlay-some)))
+ ;; ................................................... set charset ...
+ (setq tinysearch-:direction backward ;inform possible hook func
+ charset (or set tinysearch-:word-boundary-set)
+ re-word-boundary (concat "[^" charset "]")
+ re-word (concat "[" charset "]") ;considered single word
+ re-charset re-word)
+ ;; Let the user set the word criteria
+ (if tinysearch-:before-hook
+ (run-hooks 'tinysearch-:before-hook))
+ ;; ...................................................... set word ...
+ (setq word (tinysearch-grab-word charset))
+ (if (null word)
+ (message "TinySearch: Word not grabbed.")
+ ;; enable C-s and C-r to use the word, look isearch.el
+ ;; NOTE: this doesn't put the WORD regexp there...
+ (tinysearch-add-to-isearch-search-ring word)
+ ;; post a message saying what we're looking for
+ (message "searching for \`%s\`" word)
+ (setq no-msg (concat "TinySearch: No more words [" word "]" ))
+ (setq re-word
+ (concat
+ "\\(^" word "\\|"
+ re-word-boundary word "\\)" re-word-boundary))
+ ;; ................................................... do search ...
+ (while loop
+ ;; Record the point only if the word is accepted.
+ (if accept
+ (setq prev-point (point)))
+ (if backward ;choose backward
+ (progn
+ (setq found (re-search-backward re-word nil t))
+ (if (null found)
+ (message no-msg)
+ (save-match-data ;highlight needs orig region
+ (unless (looking-at re-charset)
+ (re-search-forward re-charset) ;Goto first char
+ (backward-char 1)))))
+ ;; - This a little hard to explain: the search
+ ;; does not succeed, if the variable 'a' is at
+ ;; the beginning of line due to backward-char 2 correction
+ (if (eq (current-column) 0)
+ (ignore-errors (forward-char 1)))
+ (setq found (re-search-forward re-word nil t))
+ (if found
+ (backward-char 2)))
+ (if found
+ ;; - So that NEXT word will be grabbed, that's why 1 char words
+ ;; can't be found
+ (setq mb (match-beginning 0) me (match-end 0) )
+ (message no-msg))
+ ;; ........................................................ done ...
+ (setq tinysearch-:search-status found) ;save status
+ ;; Should we continue searching ?
+ (cond
+ ((and (null found)
+ wrap)
+ (if (> loop 0)
+ (setq loop nil) ;No hits at all
+ (if backward ;start a new round
+ (ti::pmax)
+ (ti::pmin))))
+ ((and (null found)
+ (> loop 0))
+ ;; Word accept function caused loop to run again, but
+ ;; there were no more hits. Back to prev position
+ (goto-char prev-point)
+ (setq loop nil))
+ ((or (null found)
+ (not (fboundp tinysearch-:accept-word-function)))
+ (setq loop nil))
+ ((and found
+ ;; Is this found word accepted in the context
+ ;; surrounding the text ?
+ (setq accept (funcall tinysearch-:accept-word-function word)))
+ ;; Restore previous search point
+ (setq loop nil)))
+ ;; .................................................... do hilit ...
+ (if (and tinysearch-:overlay found (null loop))
+ (ti::compat-overlay-move tinysearch-:overlay mb me nil 'highlight))
+ (when tinysearch-:overlay ;Hide overlay
+ (sit-for 1)
+ (ti::compat-overlay-move tinysearch-:overlay 1 1))
+ (if loop
+ (incf loop))))
+ ;; ---------------------- grabbed
+ (if tinysearch-:final-hook
+ (run-hooks 'tinysearch-:final-hook))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinysearch-charset-control ()
+ "Dynamic character set change according to mode. This is example function."
+ (let* ((type (symbol-name major-mode))
+ set)
+ (cond
+ ((string-match "^c-\\|^cc-\\|c[+]+" type)
+ (setq set "A-Za-z0-9_"))
+ ((string-match "lisp" type)
+ ;; Add ':' , which I use in variable names.
+ (setq set "-:A-Za-z0-9_"))
+ ((string-match "text\\|shell\\|perl" type)
+ (setq set "A-Za-z0-9_")))
+ set))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinysearch-search-word-forward ()
+ "Search word at point forward."
+ (interactive)
+ (tinysearch-search-word-main nil (tinysearch-charset-control)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinysearch-search-word-backward ()
+ "Search word at point backward."
+ (interactive)
+ (tinysearch-search-word-main 'back (tinysearch-charset-control)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinysearch-install-default-keybindings (&optional uninstall)
+ "Install default keybindings; M-s C-M-s, M-Mouse-1, C-M-Mouse-1."
+ (interactive)
+ (global-set-key [(meta ?s)] 'tinysearch-search-word-forward)
+ (global-set-key [(control meta ?s)] 'tinysearch-search-word-backward)
+ ;; For mouse (under windowed system)
+ (global-set-key [(meta control mouse-1)]
+ 'tinysearch-search-word-forward)
+ (global-set-key [(meta control shift mouse-1)]
+ 'tinysearch-search-word-backward))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinysearch-install (&optional arg)
+ "Call `tinysearch-install-default-keybindings' with ARG."
+ (interactive)
+ (tinysearch-install-default-keybindings arg))
+
+;;}}}
+
+(provide 'tinysearch)
+(run-hooks 'tinysearch-:load-hook)
+
+;;; tinysearch.el ends here
--- /dev/null
+;;; tinytab.el --- Programmers TAB minor mode. Very flexible.
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 1995-2007 Jari Aalto
+;; Keywords: tools
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program, call M-x tinytab-version.
+;; Look at the code with folding.el.
+
+;; COPYIGHT NOTICE
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;; ....................................................... &t-install ...
+;; Put this file on your Emacs-Lisp load path, add following into your
+;; ~/.emacs startup file.
+;;
+;; (require 'tinytab)
+;;
+;; or use this; your .emacs loads up a bit quicker
+;;
+;; (autoload 'tinytab-mode "tinytab" "" t)
+;; (autoload 'tinytab-return-key-mode "tinytab" "" t)
+;;
+;; Suggested keybindings
+;;
+;; (global-set-key "\C-cT" 'tinytab-mode)
+;; (global-set-key [(shift tab)] 'tinytab-tab-del-key)
+;; (global-set-key "\C-c\C-m" 'tinytab-return-key-mode)
+;;
+;; For more customisation, do this:
+;;
+;; (add-hook 'tinytab-mode-define-keys-hook 'my-tinytab-keys)
+;;
+;; (defun my-tinytab-keys ()
+;; "My tinytab key additions, override settings."
+;; ... code here ...)
+
+;;}}}
+
+;;{{{ Documentation
+
+;; ..................................................... &t-commentary ...
+
+;;; Commentary:
+
+;; Preface, oct 1995
+;;
+;; There was a post in gnu.emacs.sources (what an source of
+;; inspiration), where someone asked:
+;;
+;; "Is there anyway to reset the number of spaces that TAB does?
+;; Like, I want to make it jump four spaces instead of the
+;; usual whatever.How can I set the tabs to 4?"
+;;
+;; and the typical answer was:
+;;
+;; "In .emacs, set the variable tab-stop-list, like so:
+;; (setq tab-stop-list (list 4 8 12 ...))"
+;;
+;; Well, A regular user does not want to touch the original
+;; `tab-stop-list', because the 8 spaces per tab is the norm. But for
+;; programming the 4 tabs is norm, like for shell programming or for
+;; simple memos and text documents. The goal was to write a minor
+;; mode, which you can turn on and off, which handles _only_ tab key.
+;; This mode was supposed to be plain rigid. The tab goes where you
+;; want it, and you can control the amount of movement to either
+;; direction, back or forward.
+;;
+;; Overview of features
+;;
+;; o Programmable TAB. If you set the count to to 4,
+;; you can virtually program "blindly" without any other modes.
+;; o Selectable: 2, 4, 8 .. space indent.
+;; o moving commands: tab-forward, tab-backward
+;; o indent commands: tab indent forward, tab indent backward
+;; o Simple positioning of braces { } with TAB key.
+;;
+;; Extras
+;;
+;; o Special auto-indent function offered for return key.
+;; Switch it on, and you can continue your shell, awk, SQL, C++,
+;; Perl comments and more.
+;; o C-c TAB enters interactive indentation mode where
+;; keys "qw" "as" abd "zx" control the amount of indentation.
+;;
+;; What this package does?
+;;
+;; Mimic `tab-stop-list' with minor mode if some analogy can be
+;; drawn. You only set one variable, that controls the amount of
+;; movement, whereas you would have to put many values inside
+;; `tab-stop-list'. The variable to control tab widths is:
+;;
+;; tinytab-:width-table
+;;
+;; When the mode is off, the tab key behaves as the mode thinks
+;; it should behave. The tab step forward and backward keys
+;; respect `tinytab-:width'. Normally the current position
+;; in the line is advanced, but if you select a region, all the
+;; lines are indented:
+;;
+;; This text here
+;; More text Here
+;; And so on.
+;;
+;; -- Supposing all of the above text was selected and TAB was pressed
+;;
+;; This text here
+;; More text Here
+;; And so on.
+;;
+;; -- Select all lines and press ESC-tab (or Shift-Tab) and lines
+;; -- are unintended
+;;
+;; This text here
+;; More text Here
+;; And so on.
+;;
+;; -- If you have to "shoot" carefully how much indentation is needed,
+;; -- select region and call C-c TAB
+;;
+;; This text here Use keys q - w (un/indent by 1)
+;; More text Here a - s (un/indent by 2)
+;; And so on. z - x (un/indent by 4)
+;;
+;; To change permanently current tab division, use function
+;; `tinytab-change-tab-width' which steps through list
+;; `tinytab-:width-table'; tab factors 2, 4, and 8.
+;;
+;; Major modes and this minor mode
+;;
+;; When you use some programming mode, say C++ mode, it usually
+;; provides function to indent the line right with tab key.
+;; If you then turn on this mode, you loose the mode specific
+;; indenting, because turning on minor mode overrides the underlying
+;; major mode bindings. However this package co-operates with
+;; major modes so that it preserves the original indenting style in some
+;; extent. In variable `tinytab-:tab-insert-hook' there is function
+;; `tinytab-tab-mode-control' which looks at variable
+;;
+;; tinytab-:mode-table
+;;
+;; If the mode is listed in the table _and_ current point is at the
+;; *beginning* of line, then the line is handled by original major mode
+;; and not by this minor mode.
+;;
+;; However, this minor mode is normally meant to be used as turn
+;; on/off basis in such programming modes that indent lines when you
+;; pressing tab key. Current compatibility function
+;; `tinytab-tab-mode-control' only allows you to get some flexibility
+;; when this mode is temporarily on. Bind this mode to some fast key
+;; which you can use to toggle this mode on/off when you need tab for
+;; a moment in programming modes.
+;;
+;; (global-set-key "\C-cT" 'tinytab-mode)
+;;
+;; If you don't want any support to major modes, put following
+;; into your $HOME/.emacs
+;;
+;; (setq tinytab-:mode-table nil)
+;;
+;; Return key addition
+;;
+;; This package also includes a little function
+;; `tinytab-return-key-mode' which will keep the line's indentation.
+;; You can bind it to key C-c RET:
+;;
+;; (global-set-key "\C-c\C-m" 'tinytab-return-key-mode)
+;;
+;; When the function is active, you can continue indenting from
+;; the current position, like this:
+;;
+;; // Comment here. Call C-c C-m...and press RET
+;; // And it automatically indents here.
+;;
+;; See variable
+;;
+;; tinytab-:auto-indent-regexp
+;;
+;; what line prefixes are "copied" along with the indented spaces.
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+;;{{{ setup: require
+
+;; (require 'tinylibm)
+
+;;}}}
+;;{{{ version
+
+(defvar tinytab-:version-id
+ "$Id: tinytab.el,v 2.61 2007/05/06 23:15:20 jaalto Exp $")
+
+;;}}}
+;;{{{ setup: mode
+
+;;;###autoload (autoload 'tinytab-mode "tinytab" "" t)
+;;;###autoload (autoload 'turn-on-tinytab-mode "tinytab" "" t)
+;;;###autoload (autoload 'turn-off-tinytab-mode "tinytab" "" t)
+;;;###autoload (autoload 'tinytab-commentary "tinytab" "" t)
+;;;###autoload (autoload 'tinytab-version "tinytab" "" t)
+
+(eval-and-compile
+
+ (ti::macrof-minor-mode-wizard
+ "tinytab-"
+ " " ;; This used to be " +" to indicate "Plussed tab"
+ nil
+ "Tab"
+ 'TinyTab
+ "tinytab-:" ;parameters 1-6
+
+ "Tab movement minor mode. Adjustable movement step.
+If you're running non/windowed version, Try to figure out which key
+combinations work there best, In X, you have more flexible bindings.
+
+If region is active, the indentation (backward or forward) is
+applied to whole region.
+
+References:
+
+ tinytab-:width
+
+Mode description:
+
+\\{tinytab-:mode-map}
+
+"
+ "Tab indent mode"
+ (progn
+ (if tinytab-mode
+ (tinytab-set-mode-name)))
+ "Tab indent mode"
+ (list ;arg 10
+ tinytab-:mode-easymenu-name
+ ["Insert" tinytab-tab-key t]
+ ["Delete" tinytab-tab-del-key t]
+ ["Indent region forward" tinytab-indent-by-tab-width t]
+ ["Indent region backward" tinytab-indent-by-tab-width-back t]
+ ["Indent region dynamically" tinytab-indent-region-dynamically t]
+ ["Forward" tinytab-tab-forward t]
+ ["Backward" tinytab-tab-backward t]
+ ["Change step factor" tinytab-change-tab-width t]
+ ["Return-key indent mode" tinytab-return-key-mode t]
+ "----"
+ ["Package version" tinytab-version t]
+ ["Package commentary" tinytab-commentary t]
+ ["Mode help" tinytab-mode-help t]
+ ["Mode off" turn-off-tinytab-mode t])
+ (progn
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... non-X keys . .
+ (define-key root-map "\t" 'tinytab-tab-key)
+ (define-key root-map "\e\t" 'tinytab-tab-del-key)
+ (define-key root-map "\C-c\t" 'tinytab-indent-region-dynamically)
+ (define-key root-map "\C-c\C-m" 'tinytab-return-key-mode)
+ ;; ........................................................ X-keys ...
+ ;; Standard key
+ (define-key root-map (kbd "<S-tab>") 'tinytab-tab-del-key)
+ ;; Other keyboards
+ (define-key root-map [(shift backtab)] 'tinytab-tab-del-key)
+ (define-key root-map [(shift hpBackTab)] 'tinytab-tab-del-key) ;; XEmacs
+ (define-key root-map [(shift kp-tab)] 'tinytab-tab-del-key)
+ (define-key root-map [(shift iso-lefttab)] 'tinytab-tab-del-key))))
+
+;;}}}
+;;{{{ setup: hooks
+
+(defcustom tinytab-:load-hook nil
+ "*Hook that is run when package is loaded."
+ :type 'hook
+ :group 'TinyTab)
+
+(add-hook 'tinytab-:load-hook 'tinytab-install-mode)
+
+(defcustom tinytab-:tab-insert-hook
+ '(tinytab-tab-mode-control
+ tinytab-tab-brace-control
+ tinytab-tab-forward-insert
+ tab-to-tab-stop)
+ "*List of functions to call for inserting logical TAB.
+If any of these functions return non-nil, it is assumed,
+that the tab key was handled."
+ :type 'hook
+ :group 'TinyTab)
+
+(defcustom tinytab-:tab-delete-hook
+ '(tinytab-tab-backward-del
+ tinytab-bol-forward-del)
+ "*List of functions to delete a logical TAB backward.
+If any of these functions return non-nil, it is assumed,
+that the tab handling was performed."
+ :type 'hook
+ :group 'TinyTab)
+
+;;}}}
+;;{{{ setup: public, user configurable
+
+;; Simple name is enough. Think this as "Tab +" or "extended tab" -mode
+;;
+(defcustom tinytab-:mode-name-base " +"
+ "*Minor mode's base name. Default value is ` +'."
+ :type 'string
+ :group 'TinyTab)
+
+;; If I accidentally press key I didn't meant to, I want to know
+;; about it. Like in empty line, where is no visual aids
+;;
+(defcustom tinytab-:verbose nil
+ "*Enable verbose messages."
+ :type 'boolean
+ :group 'TinyTab)
+
+(defcustom tinytab-:width-table '(2 4 8)
+ "*After call to \\[tinytab-change-tab-width], cycle through list of tab positions.
+Default values are '(2 4 8)"
+ :type '(repeat integer)
+ :group 'TinyTab)
+
+(defcustom tinytab-:mode-table
+ '(c++-mode cc-mode c-mode perl-mode cperl-mode java-mode)
+ "*List of mode name symbols where the TAB key calls mode's TAB function.
+But, only if the point is at the beginning of line."
+ :type '(repeat (symbol
+ :tag "Mode name symbols"))
+ :group 'TinyTab)
+
+(defcustom tinytab-:indent-region-key-message
+ "Dynamic Indent <>: [qw]=1 [as]=2 [zx]=4 [Esc]=exit"
+ "*Message displayed while in dynamic indent mode.
+If you change this, see also `tinytab-:indent-region-key-list'."
+ :type 'string
+ :group 'TinyTab)
+
+(defcustom tinytab-:indent-region-key-list
+ '(?q ?w
+ ?a ?s
+ ?z ?x
+ ?\e)
+ "*List of keys to control dynamic indenting. Not case sensitive.
+The first 6 keys go in pairs.
+
+elt 0 1 left and right by 1
+elt 2 3 left and right by 2
+elt 4 5 left and right by 4
+elt 6 exit key
+
+If you chnage this variable, change also
+`tinytab-:indent-region-key-message'."
+ :type '(list
+ character character
+ character character
+ character character
+ character)
+ :group 'TinyTab)
+
+(defcustom tinytab-:auto-indent-regexp "[#!;*/]\\|REM\\|//"
+ "*If previous line match this regexp, it is copied when you hit RET.
+This allows e.g. continuing C++'s // comments.
+See function `tinytab-return-key-mode' to turn on this auto-indent feature."
+ :type 'string
+ :group 'TinyTab)
+
+;;}}}
+;;{{{ setup: private
+
+(defvar tinytab-:width 4
+ "Current tab division.")
+
+;;}}}
+;;{{{ extra functions
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinytab-activate-region (beg end)
+ "Activate region which was previously selected.")
+ ;; #todo:
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro tinytab-message (&rest body)
+ "Run BODY if `tinytab-:verbose' is non nil."
+ (`
+ (when tinytab-:verbose
+ (message (,@ body)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinytab-region-bounds (&optional beg end)
+ "Set variables BEG and END if region is active.
+Otherwise use current line's end points."
+ (if (and beg
+ end)
+ (list beg end)
+ (if (and (region-active-p)
+ ;; Must be active too, otherwise may cause suprises to indent
+ ;; many lines in the buffer
+ transient-mark-mode)
+ (list (region-beginning)
+ (region-end))
+ ;; Interactive call. Single line
+ nil)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinytab-width ()
+ "Return TAB advance."
+ (if (not (integerp tinytab-:width))
+ (setq tinytab-:width 4))
+ tinytab-:width)
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytab-indent-by-tab-width (&optional beg end back)
+ "Indent region BEG END by current tab division.
+Optional BACK indents backward. If BEG is nil and region is active,
+determine BEG and END."
+ ;; (interactive "*r")
+ (let* ((width (tinytab-width))
+ (div (if back
+ (- 0 width)
+ width)))
+ (multiple-value-bind (b e)
+ (tinytab-region-bounds beg end)
+ (if (eq b e)
+ (tinytab-tab-forward-insert)
+ ;; This deactivates region, keep it on
+ (indent-rigidly b e div)
+ (tinytab-activate-region b e)))))
+
+;;; ----------------------------------------------------------------------
+;;; - So that you can bind this to fast key
+;;;
+(defun tinytab-indent-by-tab-width-back (&optional beg end)
+ "Just shortcut to `tinytab-indent-by-tab-width'. Indent BEG END backward.
+If BEG and END are nil, indent current line. (interactive call on current line)
+If region is active, use that. (interactive + region selected)."
+ (interactive)
+ (multiple-value-bind (b e)
+ (tinytab-region-bounds beg end)
+ (tinytab-indent-by-tab-width b e 'back)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytab-bol-forward-del ()
+ "If at beginning of line, delete `tinytab-:width' spaces to the right."
+ (interactive)
+ (when (bolp)
+ ;; They may be \t, so convert all to spaces first and
+ ;; then we know if we can delete enough spcaes.
+ (let* ((line (buffer-substring (line-beginning-position)
+ (line-end-position)))
+ (width (tinytab-width))
+ (str (and width
+ (with-temp-buffer
+ (insert line)
+ ;; Only convert from the start, not whole line
+ (untabify (point-min) (min
+ (+ (point-min) width)
+ (point-max)))
+ (goto-char (point-min))
+ (when (looking-at
+ (concat
+ "^"
+ (make-string width ?\ )))
+ (forward-char 4)
+ (buffer-substring (point) (point-max)))))))
+ (cond
+ (str
+ (delete-region (point) (line-end-position))
+ (save-excursion
+ (insert str)))
+ (tinytab-:verbose
+ (message "TinyTab: Cannot delete %d spaces" width))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytab-tab-mode-control ()
+ "If `mode-name' in in the list `tinytab-:mode-table', call mode's tab key.
+But only if
+o point is at the beginning of line.
+o the line is empty
+
+This way you can partly mix e.g. C++ mode and this minor mode."
+ (interactive)
+ (let* ((sym (intern (format "%s-map" (symbol-name major-mode))))
+ (point (point))
+ map
+ func)
+ ;; If we're at the beginnning of line, see if there is keymap for
+ ;; this current mode. Then try to find function for "\t" key
+ ;; and call it
+ ;;
+ (when (and (or (bolp)
+ (save-excursion
+ (beginning-of-line)
+ (looking-at "^[ \t]+$")))
+ (memq major-mode tinytab-:mode-table)
+ (boundp sym)
+ (keymapp (setq map (eval sym)))
+ (setq func (lookup-key map "\t")))
+ (call-interactively func)
+ (if (eq (point) point)
+ ;; Not moved? Then continue calling other functions.
+ nil
+ t))))
+
+;;; ----------------------------------------------------------------------
+;;; - For a little more smarter TAB key to line up { } braces
+;;; in variaous programming modes I made this. It's simple,
+;;; but suffices for most common needs.
+;;; - I don't know how the C-mode or cc-mode does this, but, hey,
+;;; this is one way :-)
+;;;
+;;;
+(defun tinytab-tab-brace-control ()
+ "When hitting TAB, line up {} braces, otherwise do nothing special.
+Remember that opening brace, the {, follows previous line's indentation
+and } follows the \"{\".
+
+Return:
+
+ t ,if TAB handled in this function.
+ nil ,nothing done."
+ (interactive)
+ (let* (line
+ rest
+ indent
+ pindent ;previous
+ col
+ ret ;flag
+ handle
+ equal)
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... check brace ...
+ (save-excursion
+ (beginning-of-line)
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... ... ... { . .
+ (cond
+ ((looking-at "^\\([ \t]*\\)\\({.*\\)")
+ (setq indent (or (match-string 1) "")
+ rest (match-string 2)
+ handle '{ )
+ (save-excursion
+ (forward-line -1) ; peek previous line indent
+ (let ((line (buffer-substring (line-beginning-position)
+ (line-end-position))))
+ (setq pindent (if (string-match "^[ \t]+" line)
+ (match-string 1 line)
+ "")))))
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... ... .. } ..
+ ((looking-at "^\\([ \t]*\\)\\(}.*\\)")
+ (setq indent (or (match-string 1) "")
+ rest (match-string 2)
+ handle '{)
+ (save-excursion
+ (cond
+ ((re-search-backward "^\\([ \t]*\\){" nil t)
+ (setq pindent (or (match-string 1) ""))))))))
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... .. adjust brace ...
+ (setq equal (and indent pindent (string= indent pindent))
+ col (and indent (length (subst-char-with-string indent))))
+ (cond
+ ((and indent
+ pindent
+ equal
+ (memq handle '({ }))
+ (< (current-column) col))
+ ;; Pressing TAB, before the {, puts cursor to brace.
+ (move-to-column col)
+ (setq ret t))
+ ((and indent
+ pindent
+ (not (string= indent pindent)))
+ ;; This is reindent case: { and } didn't line up.
+ (setq line (concat pindent rest)
+ col (current-column)
+ ret t)
+ (setq col (current-column))
+ (delete-region (line-beginning-position) (line-end-position))
+ (insert line)
+ ;; If user is in the LEFT side of brace, put cursor to brace
+ ;; If user if in the RIGHT side, then move-to-column will
+ ;; preserve position.
+ ;;
+ (move-to-column col)
+ (when (< col (length (subst-char-with-string pindent)))
+ (re-search-forward "{\\|}")
+ (forward-char -1))))
+ ret))
+
+;;}}}
+;;{{{ code: return key
+
+;;; ----------------------------------------------------------------------
+;;; Replaces the RET key
+;;; The arg is just due to: (newline &optional ARG1)
+;;;
+(defun tinytab-auto-indent (&optional arg)
+ "Automatically indent according to previous line.
+If optional ARG is given, behave exactly like 'newline' function."
+ (interactive "P")
+ ;; The RE matches few common comments and empty whitespaces
+ ;; # = shell
+ ;; ; = lisp comments
+ ;; * = C comments
+ ;; ! = .Xdefaults comments
+ ;; // = C++ comments
+ ;; REM = oracle SQL comments
+ ;;
+ (let ((re (concat "^[ \t]*\\(" tinytab-:auto-indent-regexp "\\)*[ \t]*"))
+ str)
+ (cond
+ (arg ;; We do not do anything special if user has given arg.
+ (newline arg))
+ ((not (eolp)) ;; Now let's see if user wanted fresh line
+ ;; User wanted to divide a line.
+ ;; Read the line up till cursor point
+ (if (> (current-column) 0)
+ (setq str (buffer-substring (line-beginning-position) (point))))
+ ;; Ignore portion match --> nothing important matched
+ (if (or (null str)
+ (not (and (string-match re str)
+ (equal (length str)
+ ;; The position (column in string)
+ (match-end 0)))))
+ (newline) ;something else than re, break line
+ (let ((left-margin 0)) ;Can't add string right otherwise
+ (newline)
+ (insert str))))
+ (t
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... .. else ...
+ ;; Let's peek current line
+ (if (> (current-column) 0)
+ (save-excursion
+ (beginning-of-line)
+ (setq str (if (looking-at re)
+ (match-string 0)))))
+ (if (null str) ;Nothing important here
+ (newline)
+ (let ((left-margin 0))
+ (newline)
+ (insert str)))))))
+
+;;}}}
+;;{{{ code: tab
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytab-set-mode-name ()
+ "Set mode name according to tab count in effect."
+ (interactive)
+ (let* ((base tinytab-:mode-name-base)
+ (val (tinytab-width)))
+ (setq tinytab-:mode-name (format "%s%d" (or base "") val))
+ (if (fboundp 'force-mode-line-update)
+ (force-mode-line-update))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytab-change-tab-width ()
+ "Toggle tab width according to `tinytab-:width-table'."
+ (interactive)
+ (let* ((verb (interactive-p))
+ (val (tinytab-width))
+ (table tinytab-:width-table)
+ elt)
+ (cond
+ ((not (integerp val))
+ (setq val (car table))) ;default value
+ ((setq elt (memq val table))
+ (if (eq 1 (length elt)) ;it's last item
+ (setq val (car table)) ;pick first value
+ (setq val (nth 1 elt)))) ;get next in the list
+
+ (t ;can't find value from table ?
+ (setq val (car table)))) ;get first then.
+ (setq tinytab-:width val) ;update
+ (tinytab-set-mode-name)
+ (if verb ;this does no harm....
+ (message "TinyTab: Tab factor is now %d" val))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytab-tab-backward-del ()
+ "Move Tab backward.
+Delete whitespace if all characters preceding the point are white spaces
+_and_ the final position is in divide-able by current div-factor.
+
+Eg. If you factor is 4, and there is 2 spaces before your cursor \"*\",
+ This function will not delete the extra spaces, because it can't reach
+ position 8.
+
+ bar Geezy *
+ 12345678901234
+ ^ ^ ^
+
+In this case, calling the function is no-op.
+
+References:
+
+ `tinytab-:tab-delete-hook'
+ `tinytab-:width'"
+ (interactive "*")
+ (let* ((div (tinytab-width))
+ (col (current-column))
+ (dest (- col (% col div)))
+ MARK
+ str
+ eob ;flag
+ p ;points
+ p2)
+ (setq MARK (save-excursion
+ (if (eobp)
+ (setq eob t)
+ (forward-char 1)) ;push marker one forward
+ (point-marker)))
+ (if (= col dest ) ; would be exact
+ (setq dest (- col div )))
+ (if (< dest 0)
+ (setq dest 0))
+ (if (= col 0) ;beg of line
+ nil
+ (move-to-column dest t) ;converts tabs to spaces.
+ ;; consider following:
+ ;; actual seen
+ ;; 12345678 123456789
+ ;; ----------------------------------
+ ;; #\thello "# hello" ,suppose cursor is in "h"
+ ;; | |
+ ;; | point 3
+ ;; point 1
+ ;;
+ ;; Now you indent back by 4, this is what happens
+ ;; 12345678 12345678
+ ;; # hello "# hello"
+ ;; | |
+ ;; | point 5 , Geez!
+ ;; point 1
+ ;;
+ ;; The tab is converted and it caused all point to be altered.
+ ;; That's why we have to use the marker, because it stays
+ ;; releative to text, in this case just _behind_ the letter "h"
+ ;;
+ (setq p (if eob
+ (marker-position MARK)
+ (1- (marker-position MARK))))
+ (setq p2 (point))
+ (setq str (buffer-substring p2 p))
+ (if (not (string-match "^[ \t]+$" str))
+ (progn
+ (tinytab-message "TinyTab: Can't reach previous tab position")
+ (goto-char p)) ;do not move. Stay put.
+ (delete-region p2 p)
+ (tinytab-message "Tinytab: Deleted")))
+ (setq MARK nil))) ;kill the marker
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytab-tab-backward ()
+ "Logical tab movement backward, until reach beginning of line."
+ (interactive)
+ (let* ((div (tinytab-width))
+ (dest (- (current-column) div)))
+ (if (< dest 0)
+ (setq dest 0))
+ (move-to-column dest t)
+ (if (looking-at "[ \t]+$")
+ (tinytab-message "TinyTab: Moved."))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytab-tab-forward-insert ()
+ "Move tab forward, insert spaces or tabs, see variable `indent-tabs-mode'.
+
+References:
+
+ `tinytab-:width'"
+ (interactive "*")
+ (let* ((col (current-column))
+ (div (tinytab-width))
+ (nbr (- div (% col div)))
+ div
+ eob ;flag
+ MARK ;marker
+ str)
+ (if (= 0 nbr)
+ (setq str (make-string div ?\ ))
+ (setq str (make-string nbr ?\ )))
+ (insert str)
+ (when indent-tabs-mode
+ ;; - When we insert non-tabs, like in mode "tab 4", what happens is
+ ;; that we insert " " + " " ie. 4 + 4 spaces.
+ ;; - but, we really like them to be like one "\t" code in text,
+ ;; So, let's fix the line every time something is inserted.
+ ;; - We have to use markers again due to tabify.
+ ;; - The EOB is special case
+ ;;
+ (setq MARK (save-excursion
+ (if (eobp)
+ (setq eob t)
+ (forward-char 1))
+ (point-marker)))
+ (tabify (line-beginning-position) (point))
+ (goto-char (if eob
+ (line-end-position)
+ (1- (marker-position MARK))))
+
+ (setq MARK nil)) ;kill it
+ t)) ;we handled this
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytab-tab-forward ()
+ "Step logical tab forward. Does not insert anything. Stops at EOL.
+Tabs are converted to spaces when needed; because you can't step inside
+'\t' character in the line otherwise.."
+ (interactive)
+ (let* ((div (tinytab-width))
+ (col (current-column))
+ (nbr (- div (% col div)))
+ (ecol (save-excursion (end-of-line) (current-column)))
+ (dest (+ col nbr)))
+ (cond
+ ((> dest ecol)
+ (end-of-line)
+ (tinytab-message "End of line."))
+ (t
+ (move-to-column dest t)
+ (if (looking-at "[ \t]+$")
+ (tinytab-message "Tinytab: Moved."))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytab-tab-key-insert ()
+ "Run all functions in `tinytab-:tab-insert-hook' until success."
+ ;; We could use this instead:
+ ;;
+ ;; (run-hook-with-args-until-success 'tinytab-:tab-insert-hook)
+ ;;
+ ;; But then it would not be possible to debug which function gets
+ ;; called.
+ (dolist (function tinytab-:tab-insert-hook)
+ (when (funcall function)
+ (tinytab-message "TinyTab: %s" (symbol-name function))
+ (return))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinytab-tab-key (&optional beg end)
+ "Run list of function to handle TAB key. See variable `tinytab-:tab-insert-hook'.
+If region is active and BEG and END are nil, then call function
+`tinytab-indent-by-tab-width'."
+ (interactive)
+ (cond
+ ((and (null beg)
+ (region-active-p))
+ (tinytab-indent-by-tab-width))
+ (t
+ ;; Integrate this function with tinymail.el tab-key.
+ (let* ((sym 'tinymail-:complete-key-hook)
+ (tinymail-:complete-key-hook (if (boundp sym)
+ (symbol-value sym))))
+ ;; No-op: byte compiler silencer
+ (if (null tinymail-:complete-key-hook)
+ (setq tinymail-:complete-key-hook nil))
+ (remove-hook sym 'tinymail-complete-guest-packages)
+ ;; keep this at the end
+ (when (memq 'tab-to-tab-stop tinytab-:tab-insert-hook)
+ (remove-hook 'tinytab-:tab-insert-hook 'tab-to-tab-stop)
+ (add-hook 'tinytab-:tab-insert-hook 'tab-to-tab-stop 'append))
+ (tinytab-tab-key-insert)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinytab-tab-del-key (&optional beg end)
+ "Remove indentation. See variable `tinytab-:tab-delete-hook'.
+If region is active, indent all lines backward."
+ (interactive)
+ (cond
+ ((and (region-active-p)
+ transient-mark-mode)
+ (tinytab-indent-by-tab-width-back)
+ (tinytab-activate-region beg end))
+ (t
+ (run-hook-with-args-until-success 'tinytab-:tab-delete-hook))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun turn-on-tinytab-return-key-mode ()
+ "Turn on auto indent after RET key."
+ (tinytab-return-key-mode 1 (interactive-p)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun turn-off-tinytab-return-key-mode ()
+ "Turn on auto indent after RET key."
+ (tinytab-return-key-mode 1 (interactive-p)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinytab-return-key-mode (&optional mode verb)
+ "Toggle auto indent MODE / regular newline mode. VERB."
+ (interactive)
+ (let* ((func 'tinytab-auto-indent)
+ (now
+ (or (and
+ ;; e.g. in fundamental-map this value is nil and
+ ;; nil cannot be used as an keymap for lookup-key
+ ;;
+ (current-local-map)
+ (lookup-key (current-local-map) "\C-m"))
+ (lookup-key (current-global-map) "\C-m")))
+ to)
+ ;; If we redefine return key here, user will nver get out.
+ ;; C-m is exit-minibuffer.
+
+ (if (string-match "minibuf" (buffer-name))
+ (error "TinyTab: Return key-mode not allowed in minibuffer."))
+ (setq verb (interactive-p))
+ (cond
+ ((or (null mode) (not (integerp mode)))
+ (setq to (if (eq now 'tinytab-auto-indent)
+ 'newline
+ func)))
+ ((< mode 1)
+ (setq to 'newline))
+ (t
+ (setq to func)))
+ (local-set-key "\C-m" to)
+ (if verb
+ (message "TinyTab Return key auto indent %s"
+ (if (eq to func)
+ "on"
+ "off")))
+ to))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytab-indent-region-dynamically (beg end)
+ "Move region BEG END until exit key is pressed.
+For ey setup, see `tinytab-:indent-region-key-list'. The default keys are:
+
+LEFT RIGHT
+ q w by 1
+ a s by 2
+ z x by 4"
+ (interactive "*r")
+ (let* ((i 1)
+ (k tinytab-:indent-region-key-list)
+ (msg tinytab-:indent-region-key-message)
+ ch
+ EXIT)
+ (if (not (eq (length k) 7))
+ (error "Not enough members in tinytab-:indent-region-key-list."))
+ (setq EXIT (nth 6 k))
+ (while (not (eq EXIT (setq ch
+ (downcase
+ (read-char-exclusive msg)))))
+ (setq i nil)
+ (cond
+ ((eq ch (nth 0 k))
+ (setq i -1))
+ ((eq ch (nth 1 k))
+ (setq i 1))
+ ((eq ch (nth 2 k))
+ (setq i -2))
+ ((eq ch (nth 3 k))
+ (setq i 2))
+ ((eq ch (nth 4 k))
+ (setq i -4))
+ ((eq ch (nth 5 k))
+ (setq i 4)))
+ (if i
+ (indent-rigidly (region-beginning) (region-end) i)))))
+
+;;}}}
+
+(add-hook 'tinytab-:mode-define-keys-hook 'tinytab-mode-define-keys)
+
+(provide 'tinytab)
+(run-hooks 'tinytab-:load-hook)
+
+;;; tinytab.el ends here
--- /dev/null
+;;; tinytag.el --- Grep tags: show C++/Java/etc. syntax call while coding
+
+;; This file is not part of Emacs.
+
+;;{{{ Id
+
+;; Copyright (C) 1996-2007 Jari Aalto
+;; Keywords: tools
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program, call M-x tinytag-version.
+;; Look at the code with folding.el.
+
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;; ....................................................... &t-install ...
+;; Put this file on your Emacs-Lisp load path, add following into your
+;; ~/.emacs startup file. Rip code with with tinylib.el/ti::package-rip-magic
+;;
+;; (setq tinytag-:database-dir "~/elisp/config")
+;; (require 'tinytag)
+;;
+;; You can also use the autoload feature, which speeds up loading
+;; the ~/.emacs
+;;
+;; (autoload 'tinytag-install "tinytag" "" t)
+;; (autoload 'tinytag-main "tinytag" "" t)
+;; (autoload 'tinytag-main-mouse "tinytag" "" t)
+;;
+;; You do not have to install `tinytag-install' function to every known
+;; programming language, because the mode will be global once it
+;; is called. Here, if you program mostly with Java and C,
+;; then either one will activate tinytag for all buffers.
+;;
+;; (add-hook 'c++-mode-hook 'tinytag-install)
+;; (add-hook 'c-mode-hook 'tinytag-install)
+;; (add-hook 'java-mode-hook 'tinytag-install)
+;;
+;; ********************************************************************
+;;
+;; YOU MAY NEED TO CHANGE VARIABLE tinytag-:database-setup-table
+;; BEFORE YOU USE THIS PACKAGE.
+;;
+;; It gives the instructions where are the databases located
+;; that offer the code help in echo are. Without that variable
+;; this package does nothing.
+;;
+;; Read section "Installing support for your programming languages"
+;;
+;; ********************************************************************
+;;
+;; When you use this package for the first time, an example C/C++
+;; database is extracted fromt he end of this file. See the attached
+;; perl script if you want to generate the database from your
+;; system's manual pages by hand.
+;;
+;; M-x load-library RET tinytag RET
+;; M-x tinytag-install-sample-databases
+;;
+;; Keybinding suggestion (HP-UX)
+;;
+;; (global-set-key [(alt control mouse-2)] 'tinytag-main-mouse)
+;; (global-set-key "\C-c\C-z" 'tinytag-main)
+;;
+;; If you have any questions, use these function
+;;
+;; M-x tinytag-submit-bug-report
+;;
+;; Pleace, send any other programming language database that you may use,
+;; even an different C prototypes in different platform. Let's share the
+;; information with others!
+;;
+;; C/C++ database help
+;;
+;; Peter Simons <simons@petium.rhein.de> to get
+;; NetBSD/Linux C database
+;;
+;; Java database help
+;;
+;; Jari Aalto
+;; SUN Java databases (1.2.2 - 1.4)
+
+;;}}}
+;;{{{ Documentation
+
+;; ..................................................... &t-commentary ...
+;;; Commentary:
+
+;; Preface, overview of features
+;;
+;; o Simple database searching, some analogue to emacs TAGS package.
+;; Databaseses are simple text files that are searched for matches.
+;; o Flips databases easily to show the right data.
+;; o The Language's function call syntax is shown in the echo area
+;; when cursor is over an identifiable item.
+;; o Limitations: The function help info can only be 80 characters
+;; or as long as your minibuffer is wide. But you can keep the
+;; *tinytag-output* buffer visible in another buffer to show all
+;; the information.
+;; o Unlimited extendability to any programming or other "lookup"
+;; languages.
+;;
+;; Ready-to-use databases currently available:
+;;
+;; o HP-UX/Netbsd C/C++ function database is included in this file
+;; and perl script to rip the function definitions from Unix manual
+;; pages.
+;; o Perl script to generate databases from any
+;; Javadoc compliant pages (E.g full database from all
+;; JDK 1.2.2 pages) The Java database is not distributed
+;; because it takes over a Meg and generating one straight
+;; from SUN Java /docs tree is trivial.
+;;
+;; Story behind this package
+;;
+;; The word "tag" refers to famous tags package in emacs that allows
+;; you to browse your C/C++ code easily.
+;;
+;; Someone may be in the middle of c++ project at work and notice
+;; that he frequently consults the manual pages to find correct
+;; syntax for calling stdio.h functions. It's hard to remember
+;; them right every time. Time spent for reading manual pages may
+;; be considerable just to figure out what #include statements
+;; each function might require, and what type of parameters they
+;; need.
+;;
+;; No more. There must be a way out of this...
+;;
+;; If you have programmed in lisp, you propably know package called
+;; eldoc.el (get it fast if you haven't) by Noah Friedman
+;; <friedman@prep.ai.mit.edu>. It shows you the lisp function call
+;; arguments when your cursor is right over some function.
+;;
+;; What a cool tool! You never have to go to elisp info pages
+;; just to check what the function takes, and you don't have to
+;; pop up extra buffer with c-h f <func>. It's a real time saver.
+;; Similar keyword lookup feature culd be built for any
+;; programing. Since eldoc looked the lisp args from memory
+;; (emacs obarray, symbol storage), the other programming
+;; languages must use external reference files: databases.
+;;
+;; First, all C/C++ function syntaxes were extracted out of the
+;; man pages with small perl program. The final output after
+;; ripping all the 3C man pages loooked like this. The output
+;; is put under database 'c++-functions'
+;;
+;; <dirent.h> dir *opendir(const char *dirname);
+;; <dirent.h> int closedir(dir *dirp);
+;; <dirent.h> int readdir_r(dir *dirp, struct dirent *result);
+;; <dirent.h> long int telldir(dir *dirp);
+;; <dirent.h> struct dirent *readdir(dir *dirp);
+;; ...
+;; <string.h><strings.h> char *index(const char *s, int c);
+;; <string.h><strings.h> char *rindex(const char *s, int c);
+;;
+;; Notice how perl stuck the '#define' statements at the
+;; beginning of each function. After this 'function' database was
+;; ready, the only thing needed was lisp code to handle database
+;; lookups for the keyword under the cursor. Similar approach can
+;; be user for any programming language. Just set up the
+;; database, entries to search; one per line. that's it.
+;;
+;; Word about installation -- performance problems [19.29 or lower]
+;;
+;; Skip this part if you have 19.30+
+;;
+;; When you load this package, it immediately installs an _example_
+;; post-command function. It assumes that you're using the "Having a
+;; test drive" C++ database and stored it as explained. You propably
+;; want to remove that default post-command function and use your own
+;; definition. Here is how you remove it.
+;;
+;; Doing this is also recommended if you don't want post command
+;; actions, but want to use the tinytag-main[-mouse] functions
+;; directly. Call them only when you need them.
+;;
+;; o before any load command say: (setq tinytag-:load-hook nil)
+;; o If package is already loaded, say: C-u M-x tinytag-install.
+;;
+;; If your databases are big, or if you're afraid of the overall emacs
+;; performance I STRONGLY ADVICE THAT YOU REMOVE THAT post-command
+;; with methods (2) or (1) You can always call the database with the
+;; supplied keyboard or mouse commands when you need the information.
+;;
+;; Having a test run
+;;
+;; There is sample C++ database from HP-UX 10 man 3C pages, which
+;; is unfortunately incomplete. You may consider using the BSD
+;; C-database instaed. The BSD is installed by default when you
+;; call `M-x' `tinytag-install-sample-database-c'. Rememeber that
+;; you really should replace those definitions with your own
+;; systems equivalents, because not all functions are found in
+;; all systems. Vendors are different.
+;;
+;; This is how you test this package.
+;;
+;; o Go to empty buffer
+;; o Add statement "strcat(a,b)" to the buffer
+;; o Turn on C++ mode
+;; o Be sure to have tinytag on (M-x load-library tinytag.el)
+;; o Move your cursor over the word "strcat" and wait few seconds.
+;; <For very old Emacs, below 19.30: wave your cursor
+;; back and forth about 5 times.>
+;;
+;; You should see the "strcat"'s function's definition displayed in
+;; the echo area. Next, you can start writing your own databases to
+;; languages you use.
+;;
+;; Installing support for your programming languages
+;;
+;; While you may have installed the default database for C/C++, you
+;; have to configure the variable `tinytag-:database-setup-table' to
+;; include all languages where you have databases available. It is
+;; recommended that you keep all emacs related configuration,
+;; including databases, in one place, e.g.
+;;
+;; ~/elisp/config/
+;;
+;; First you need databases which you must write yourself.
+;; e.g. emacs-tinytag-python-function.el where you describe the
+;; function, packages and call syntax. The only thing after creating the
+;; database is to tell where it can be found. E.g for php you would
+;; add couple of you own variables:
+;;
+;; (defconst my-tinytag-:db-map-php
+;; '((func "emacs-config-tinytag-php.txt"))
+;; "Java database.")
+;;
+;; (defconst my-tinytag-:db-re-php
+;; '(("." (func))) ;; See name FUNC in prev. variable
+;; "PHP database.")
+;;
+;; And tell tinytag.el that the Java is now known:
+;;
+;; (defconst tinytag-:database-setup-table
+;; (list
+;; (list
+;; "code-php\\|php"
+;; '(my-tinytag-:db-map-php
+;; my-tinytag-:db-re-php))
+;; (list
+;; "c-mode....."
+;; '(..
+;; ))))
+;;
+;; C/C++ database
+;;
+;; Run c-function-list.pl that comes with Tiny Tools Distribution to
+;; generate function database.
+;;
+;; Alternatively copy the database from the end of this file or
+;; use M-x tinytag-install-sample-databases
+;;
+;; Java database
+;;
+;; Run script `java-function-list.pl' that comes with Tiny Tools
+;; distribution to generate function database from the Sun JDK's javadoc
+;; html pages. See the manual page of the script how to run it (--help
+;; option)
+;;
+;; NOTE: In SUN documentation, there is no System.out.print() or
+;; System.out.println() functions that could be extracted. Please add
+;; Those functions by hand to the database.
+;;
+;; This script is also run with call tinytag-install-sample-databases,
+;; provided that you have `perl' and `java' and `java-function-list.pl'
+;; installed and located along PATH.
+;;
+;; Perl database
+;;
+;; <coming>
+;;
+;; Run perl-function-list.pl that comes with Tiny Tools Distribution to
+;; generate function database. See the manual page of the script how to
+;; run it (--help option)
+;;
+;; Database format and display
+;;
+;; There is nothing special in the database format, each entry must me
+;; in one line nad that's all. Try to find most suitable display format
+;; for your language, like the general method that is used for C/C++, Java
+;; and Perl
+;;
+;; <LIBRARY> return-value function-name(function-parameters) REST-INFO
+;;
+;; _Important_: When function `tinytag-search-db' searches the whole
+;; database, it gathers the lines that likely match and FIRST one that
+;; is found is displayed in the echo-area. So that you're aware of other
+;; matches, the count of matches is displayed
+;;
+;; 10: java.lang.System.out void println()
+;; |
+;; Count of matches
+;;
+;; If you have time, it would be sensible to move the most informational
+;; description of the function first in the list of lines, so that it
+;; get displayed. For example, you could move method this method first in
+;; the line and add [] inside function parameters to signal that the
+;; parameter is optional
+;;
+;; java.lang.System.out void print([Object obj])
+;;
+;; Alternatively, you can keep the buffer `tinytag-:output-buffer'
+;; visible e.g in separate frame, so that all the matched items are
+;; visible to you in case the one displayed in echo-are is not correct.
+;;
+;; Differencies between 19.30+ and lower
+;;
+;; The 19.30 Emacs has idle hook, which runs after you move cursor. It
+;; doesn't run if you move mouse. 19.28 on the other hand has post
+;; command hook, that runs every time you either move cursor _OR_
+;; move mouse.
+;;
+;; Now, to get display fast in 19.28, you propably want to wave
+;; your mouse fast couple of times. In 19.30 you can have immediate
+;; display with just one cursor move over the word.
+;;
+;; What to do if you don't see the definition displayed?
+;;
+;; hem most informative is the internal debug which you turn on with:
+;;
+;; M-x tinytag-debug
+;;
+;; Then call this function directly over the word whose definition
+;; you want to display (e.g. strcat in C++)
+;;
+;; ESC ESC : (tinytag-post-command-1)
+;; ========
+;; Press this key combination and enter text to the right.
+;;
+;; After that call there is buffer *tinytag-debug* that has some
+;; information about called functions and parameters. Please
+;; investigate the call chain for possible problem. Is the database
+;; selected right? if the regexp used for search right? If you don't
+;; know how to read the debug buffer's output, just send the buffer's
+;; content to me and describe what you did and what was your current
+;; major mode.
+;;
+;; Thank you
+;;
+;; Peter Simons <simons@petium.rhein.de> sent me
+;; NetBSD and Linux C databases and his perl script can help you
+;; to create your own database from the man pages.
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+;;{{{ setup: require
+
+;; Under no circumstances remove the following comment line below!
+;; $PackageInstallRe: '^;;+[*]' $
+
+(require 'tinylibm)
+
+(eval-and-compile
+ (autoload 'man "man" "" t))
+
+(eval-when-compile (ti::package-use-dynamic-compilation))
+
+(ti::package-defgroup-tiny TinyTag tinytag-: programming
+ "Grep database: example show C++ synatx call while coding.
+Overview of features
+ o simple database searching, some analogue to emacs TAGS package.
+ o you can flip databases very easily to show the right data.
+ o example: showing c++ funcall syntax in echo area while you program.
+ o installs hp-ux or netbsd c function databases automatically.")
+
+;;}}}
+;;{{{ setup: -- variables
+
+(defcustom tinytag-:load-hook nil
+ "*Hook run when file has been loaded."
+ :type 'hook
+ :group 'TinyTag)
+
+(defcustom tinytag-:post-command-try-hook
+ '(tinytag-try-function-show-cached-word
+ tinytag-try-function-search-db)
+ "*Try displaying the information.
+Run these functions, until one of them return non-nil.
+Put here only functions that does not need any user interaction."
+ :type 'hook
+ :group 'TinyTag)
+
+(defcustom tinytag-:try-hook
+ '(tinytag-try-function-show-cached-word
+ tinytag-try-function-search-db
+ tinytag-try-function-man)
+ "*Try displaying the information.
+Run these functions, until one of them return non-nil.
+This hook is primarily run upon request: M - x, keyboard command, or mouse
+command."
+ :type 'hook
+ :group 'TinyTag)
+
+(defcustom tinytag-:set-database-hook
+ '(tinytag-set-database)
+ "*Function to set the correct database for buffer.
+Run these functions, until someone return non-nil."
+ :type 'hook
+ :group 'TinyTag)
+
+(defcustom tinytag-:word-filter-hook
+ '(tinytag-filter-default-function)
+ "*Run hook until some function return non-nil.
+Every function in this hook is called with
+
+arg1: string, word picked at current point to initiate database search
+
+The function should return nil if the word should not be searched.
+many times short words are not valid 'keys' in database: e.g. in
+C/C++ code common words like 'char' 'double' 'int' can be ignored."
+ :type 'hook
+ :group 'TinyTag)
+
+(defcustom tinytag-:word-modify-hook 'tinytag-word-default-adjust
+ "*This function formats the searched word to correct search regexp.
+Regexp should match only desired hits.
+
+Call arguments:
+ string
+
+Function must return always:
+ string"
+ :type 'hook
+ :group 'TinyTag)
+
+(defcustom tinytag-:database-ok-hook nil
+ "*Run hook database was set according to current buffer.
+Called from `tinytag-set-database'.
+
+The variables `tinytag-:database-map' and `tinytag-:regexp-to-databases'
+have valid values when the hook is called."
+ :type 'hook
+ :group 'TinyTag)
+
+;;; ....................................................... &v-private ...
+
+(defvar tinytag-:last-word-lookup nil
+ "Last lookup, '(WORD . (DB-STRING DB-STRING)).")
+(make-variable-buffer-local 'tinytag-:last-word-lookup)
+
+(defvar tinytag-:noerror nil
+ "If non-nil, no error command is called.")
+
+(defvar tinytag-:post-command-hook-counter nil
+ "Counter.")
+
+(defvar tinytag-:post-command-hook-wakeup
+ ;; There is no delay in 19.30+, but for <19.30 the must be
+ ;;
+ (if (boundp 'post-command-idle-hook)
+ 0 3)
+ "Wakeup threshold.
+The more lower value, the more often post command hook is called
+and your Emacs probably slows down. The values must be 0 in 19.30+,
+because `post-command-hook' is not used there.")
+
+(defvar tinytag-:database-map nil
+ "Databases available, format '((NAME-SYMBOL FILENAME) .. )
+Do not put directory name here, use `tinytag-:database-dir' instead.")
+
+(defvar tinytag-:regexp-to-databases nil
+ "Which REGEXP on word should initiate database search?.
+Format: '((REGEXP '(database1 database2 ..)) (RE (d1 d1 ..)) ..)")
+
+(defvar tinytag-:idle-timer-elt nil
+ "If idle timer is used, this variable has the timer elt.")
+
+;;; .................................................. &private-sample ...
+;;; - These are offered as samples, see tinytag-set-database,
+;;; which uses these variable. They are not part of the tinytag.el
+;;; package (user variables). You should program your own
+;;; tinytag-set-database function to deal with different buffers.
+
+(defconst tinytag-:example-db-map-c++
+ '((func "emacs-config-tinytag-c++-functions.txt")
+ (struct "emacs-config-tinytag-c++-structs.txt")
+ (types "emacs-config-tinytag-c++-types.txt"))
+ "Sample. C++ databases.")
+
+(defconst tinytag-:example-db-re-c++
+ '(("_t" (types structs))
+ ("_s" (struct types))
+ ("." (func)))
+ "Sample. C++ word-to-database mappings.")
+
+(defconst tinytag-:example-db-map-java
+ '((func "emacs-config-tinytag-java-functions.txt"))
+ "Sample. Java databases.")
+
+(defconst tinytag-:example-db-re-java
+ '(("." (func))) ;; All words are looked from `func' database
+ "Sample. Map found word to correct Java database.")
+
+;;; You propably should program your own filter function for variaous
+;;; modes. This variable belongs to default filter only.
+;;;
+(defcustom tinytag-:filter-default-c++-words
+ (concat
+ "^char\\|^double\\|^int$\\|^float\\|^void\\|static"
+ "\\|endif\\|define\\|ifndef\\|ifdef\\|include"
+ "\\|break")
+ "*Filter out unwanted words from current point.
+This variable is used in `tinytag-filter-default-function'."
+ :type '(string "Regexp")
+ :group 'TinyTag)
+
+;;; ........................................................ &v-public ...
+;;; user configurable
+
+(defcustom tinytag-:output-buffer "*tinytag-output*"
+ "*Buffer where to display all database matches for word at point.
+Many times the word picked at point matches several functions and you
+can keep this buffer in separate frame in Window environment to see what
+is the correct match.
+If this variable is nil, no buffer is created.")
+
+(defcustom tinytag-:database-dir
+ (or
+ (file-name-as-directory
+ (file-name-directory (ti::package-config-file-prefix "tinytag.el")))
+ (error "TinyTag: Can't set default value for `tinytag-:database-dir'.
+Please define the directory of database directory to `tinytag-:database-dir'."))
+ "*Directory of database files."
+ :type 'directory
+ :group 'TinyTag)
+
+(defcustom tinytag-:filter-word-table
+ (list
+ (list
+ (concat
+ "c-mode\\|cc-mode\\|c[+]+-mode"
+ ;;See tinylibid.el
+ "\\|code-c\\|code-c[+]+")
+ '(or (< (length string) 4) ;too short word ?
+ (string-match tinytag-:filter-default-c++-words string))))
+ "*Format is:
+
+'((BUFFER-TYPE-REGEXP EVAL-STATEMENT-TO-REJECT) (B E) ..)
+
+If buffer type/mode matches REGEXP then the eval statement is evaluated
+for current word that is stored into 'string'. The statement should return
+t if word should be rejected. During the eval, any matches done are
+case sensitive."
+ :type '(repeat
+ (string :tag "buffer type regexp")
+ (sexp :tag "Form"))
+ :group 'TinyTag)
+
+(defcustom tinytag-:database-setup-table
+ (list
+ (list
+ (concat
+ ;; See tinylibid.el to detect buffer type
+ "c-mode\\|cc-mode\\|c[+]+-mode"
+ "\\|code-c\\|code-c[+]+")
+ '(tinytag-:example-db-map-c++
+ tinytag-:example-db-re-c++))
+ (list
+ "java"
+ '(tinytag-:example-db-map-java
+ tinytag-:example-db-re-java)))
+ "*If buffer type/mode match REGEXP then set database variables.
+Cariables `tinytag-:database-map' and
+`tinytag-:regexp-to-databases' are used.
+
+The BUFFER-TYPE-REGEXP corresponds the value returned by ti::id-info
+for current buffer. The function detects various progrmaming.
+
+Format:
+
+'((BUFFER-TYPE-REGEXP (DATABASE-MAP-SYM DATABASE-REGEXP-SYM))
+ ..)"
+ :type '(repeat
+ (list
+ (string :tag "mode regexp")
+ (list
+ (symbol :tag "db map sym")
+ (symbol :tag "db regexp sym"))))
+ :group 'TinyTag)
+
+(defcustom tinytag-:display-function 'tinytag-display-function
+ "*Function to display search results.
+Should accept one ARG, which is list of matched lines from databases."
+ :type 'function
+ :group 'TinyTag)
+
+;;}}}
+;;{{{ version
+
+;;;### (autoload 'tinytab-debug-toggle "tinytag" t t)
+
+(eval-and-compile (ti::macrof-debug-standard "tinytag" "-:"))
+
+(eval-and-compile
+ (ti::macrof-version-bug-report
+ "tinytag.el"
+ "tinytag"
+ tinytag-:version-id
+ "$Id: tinytag.el,v 2.53 2007/05/01 17:21:00 jaalto Exp $"
+ '(tinytag-:version-id
+ tinytag-:debug
+ tinytag-:load-hook
+ tinytag-:try-hook
+ tinytag-:set-database-hook
+ tinytag-:last-word-lookup
+ tinytag-:noerror
+ tinytag-:post-command-hook-counter
+ tinytag-:post-command-hook-wakeup
+ tinytag-:example-db-map-c++
+ tinytag-:example-db-re-c++
+ tinytag-:database-dir
+ tinytag-:database-map
+ tinytag-:regexp-to-databases
+ tinytag-:display-function
+ post-command-idle-hook
+ post-command-hook)
+ '(tinytag-:debug-buffer)))
+
+;;}}}
+;;{{{ code: install
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytag-initialize ()
+ "Start package and verify that some variables exist."
+ (interactive)
+ (let* ()
+ (if (or (not (stringp tinytag-:database-dir))
+ (not (file-exists-p tinytag-:database-dir)))
+ (error "\
+TinyTag: `tinytag-:database-dir' is not a directory. Please configure"))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinytag-install (&optional uninstall)
+ "Install package. Optionally UNINSTALL."
+ (interactive "P")
+ (let* ((hook (if (boundp 'post-command-idle-hook)
+ ;; post-command-idle-hook became obsolete in 19.34
+ 'post-command-idle-hook
+ 'post-command-hook))
+ (cmd (if uninstall
+ 'remove-hook
+ 'add-hook)))
+ (cond
+ ((ti::idle-timer-supported-p)
+ (ti::compat-timer-cancel-function 'tinytag-post-command)
+ (unless uninstall
+ (setq
+ tinytag-:idle-timer-elt
+ (ti::funcall
+ 'run-with-idle-timer
+ 2
+ 'repeat
+ 'tinytag-post-command))))
+ (t
+ ;; We use post-command-idle-hook if defined,
+ ;; otherwise put it on post-command-hook.
+ ;; The idle hook appeared in Emacs 19.30.
+ (funcall cmd hook 'tinytag-post-command)))
+ (when (interactive-p)
+ (message "TinyTag: Package %s" (if uninstall
+ "deactivated"
+ "activated")))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinytag-uninstall ()
+ "Uninstall package."
+ (tinytag-install 'uninstall))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytag-install-sample-database-java-external-process (doc-dir file)
+ "Call external process to examine DOC-DIR to build Java function calls.
+The output is written to FILE."
+ (let* ((info (ti::process-perl-version "perl"))
+ (perl (nth 2 info))
+ ;; (type (nth 1 info))
+ (bin "java-function-list.pl")
+ (prg (ti::file-get-load-path bin exec-path)))
+ (cond
+ ((null perl)
+ (message
+ (concat
+ "Tinytag: [install] Cannot find `perl' along path. "
+ "Please check your PATH or install perl. "
+ (if (ti::win32-p)
+ "http://www.activestate.com"
+ "http://www.perl.com/"))))
+ ((null prg)
+ (message
+ (concat
+ "Tinytag: [install] Cannot find " bin
+ " please check your PATH")))
+ (t
+ (unless (file-directory-p
+ (file-name-directory file))
+ (error "Tinytag: Can't find directory %s" file))
+ (with-temp-buffer
+ ;; Java 1.3-1.4 documentation size, when processes, is 1.5 Meg
+ ;; It will fit into memory.
+ (message
+ (concat
+ "Tinytag: [install] Java database... "
+ "Please wait for external process to traverse %s") doc-dir)
+ (call-process perl
+ nil
+ (current-buffer)
+ nil
+ prg
+ "--recurse"
+ doc-dir)
+ (message "Tinytag: [install] Java database...done. Size %d"
+ (buffer-size))
+ ;; perl syntax error in line NNNN
+ (when (ti::re-search-check " line [0-9]")
+ (error "Tinytag: Failed to call %s\n\ [Perl error] %s"
+ prg (buffer-string)))
+ (when (ti::buffer-empty-p)
+ (error "Tinytag: %s with %s didn't return anything."
+ prg doc-dir))
+ (write-region (point-min) (point-max) file)
+ (message "Tinytag: [install] Java database...done %s"
+ file))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinytag-install-sample-database-java ()
+ "Install Java database from Sub JDK documentation."
+ (interactive)
+ (tinytag-initialize)
+ (let* ((java-info (progn
+ (message "TinyTag: Wait, checking java...")
+ (prog1 (ti::process-java-version)
+ (message "TinyTag: Wait, checking java...done."))))
+ (case-fold-search t))
+ (cond
+ ((not java-info)
+ (message
+ (concat
+ "Tinytag: [install] Skipped. No `java' binary found along PATH."
+ " Java sample database will not be installed.")))
+ (t
+ ;; path to `java' binary could be something like
+ ;; i:/java/sun/jdk1.3_02/bin/java
+ ;;
+ ;; The Java documentation si assumed to be under
+ ;; i:/java/sun/jdk1.3_02/docs/
+ ;;
+ (let* ((java (nth 2 java-info)) ;; path
+ (dir (file-name-directory java))
+ (root (and dir (ti::directory-up dir)))
+ (doc-dir (and root (concat (file-name-as-directory root)
+ "docs")))
+ (out-dir (file-name-as-directory tinytag-:database-dir))
+ (db (concat
+ out-dir
+ (nth 1 (assq 'func tinytag-:example-db-map-java)))))
+ (cond
+ ((and (stringp doc-dir)
+ (file-directory-p doc-dir))
+ (if (file-exists-p db)
+ (message
+ "Tinytag: [install] Skipped. Database already exists %s"
+ db)
+ (tinytag-install-sample-database-java-external-process
+ doc-dir db)))
+ (t
+ (message "Tinytag: [install] Can't find java docs/ dir [%s]"
+ doc-dir))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinytag-install-sample-database-c ()
+ "Install c/C++ database from file tintytag.el."
+ (interactive)
+ (tinytag-initialize)
+ (let* ((case-fold-search t)
+ (file (locate-library "tinytag.el"))
+ (dir (file-name-as-directory tinytag-:database-dir))
+ (db (concat
+ dir
+ (nth 1 (assq 'func tinytag-:example-db-map-c++))))
+ buffer)
+ (unless (stringp file)
+ (error "Tinytag: [install] cannot find tinytag.el along load-path."))
+ (setq buffer (ti::package-install-example "tinytag.el"))
+ (with-current-buffer buffer
+ (if (not (re-search-forward "Sample.*function database" nil t))
+ (error "Tinytag: [install] Cannot find start of example section.")
+ ;; Remove all before the database.
+ (beginning-of-line)
+ (delete-region (point-min) (point))
+ (cond
+ ((string-match "hpux" (emacs-version))
+ ;; GNU Emacs 19.28.1 (hppa1.1-hp-hpux9, X toolkit)
+ ;;
+ (re-search-forward "END HP-UX")
+ (forward-line 1)
+ (delete-region (point) (point-max)))
+ (t
+ ;; GNU Emacs 19.33.1 (i386-unknown-netbsd1.1, X toolkit)
+ ;;
+ (re-search-forward "# NetBSD Sample")
+ (beginning-of-line) (delete-region (point-min) (point))
+ (re-search-forward "# END NetBSD")
+ (forward-line 1)
+ (delete-region (point) (point-max))))
+
+ (if (file-exists-p db)
+ (message
+ "Tinytag: [install] Skipped. Database already exists %s" db)
+ (message "Tinytag: [install] C/C++ database...")
+ (write-region (point-min) (point-max) db)
+ (message
+ "Tinytag: [install] C/C++ database...installed %s" db))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytag-install-sample-databases ()
+ "Install Sample databases: C/C++ and Java.
+This function sets ´tinytag-install-sample-databases'
+property 'done to non-nil value, when called."
+ (tinytag-install-sample-database-c)
+ (tinytag-install-sample-database-java)
+ ;; This is signal for other setups, that can check if functon
+ ;; has already been called (not to install databases multiple times)
+ (put 'tinytag-install-sample-databases 'done t)
+ (ti::kill-buffer-safe "*ti::pkg*"))
+
+;;}}}
+
+;;{{{ code: misc
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinytag-word-at-point ()
+ "Read word on current point."
+ (if (looking-at "[.a-z0-9_]+[ \t\n\r]*(") ;is here word ?
+ (ti::buffer-read-word "-_.A-Za-z0-9" )))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinytag-display (list)
+ "Call display function with LIST."
+ (funcall tinytag-:display-function list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytag-display-function (list)
+ "Display car of LIST and count of LIST.
+Output matched to tinytag-:output-buffer too."
+ (when (stringp tinytag-:output-buffer)
+ (with-current-buffer (get-buffer-create tinytag-:output-buffer)
+ (erase-buffer)
+ (dolist (line list)
+ (insert line "\n"))))
+ (message
+ (format
+ "%s: %s" (length list) (car list))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytag-filter-default-function (string)
+ "Default filter function. Reject STRING."
+ (let* ((fid "tinytag-filter-default-function: ")
+ (id (or (ti::id-info nil 'variable-lookup)
+ (symbol-name major-mode)))
+ (table tinytag-:filter-word-table)
+ (accept t)
+ (case-fold-search nil) ;Case is important here
+ elt)
+ (when (and (setq elt (ti::list-find table id))
+ (eval (nth 1 elt)))
+ (setq accept nil))
+ (tinytag-debug fid " ret accept" accept "elt" elt "\n")
+ accept))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytag-word-default-adjust (string)
+ "Convert STRING to suitable regexp.
+Currently supports only C/C++ and Java."
+ (let ((fid "tinytag-word-default-adjust: ")
+ (id (or (ti::id-info nil 'variable-lookup)
+ (symbol-name major-mode)))
+ (ret string))
+ (cond
+ ((string-match "c[+]+\\|code-c\\|c-mode\\|cc-mode" id)
+ ;;
+ ;; We suppose database format
+ ;; "<include.h> function(definition...)"
+ ;;
+ ;; Notice the '*' which matches functions returning a pointer
+ ;; ring.h><strings.h> char *strcat(
+ ;;
+ (setq ret (format "[ \t*]%s[ \t]*(" string)))
+ ((string-match "java" id)
+ ;;
+ ;; We suppose database format
+ ;;
+ ;; java.lang.System.out void print(boolean b)
+ ;; java.lang.System.out void print(Object obj)
+ ;;
+ ;; --> System.out.*print\\>
+ ;;
+ ;; But there is a problem with variables
+ ;;
+ ;; Runtime rt = Runtime.getRuntime();
+ ;; long free = rt.freeMemory();
+ ;; *cursor here --> grabbed "rt.freeMemory"
+ ;;
+ ;; --> Search last word after dot too.
+ ;;
+ (let (class
+ function)
+ (tinytag-debug fid "java" (string-match "^(.*\\.)(.*)$" string)
+ ret "\n")
+ (cond
+ ((string-match "\\(.+\\)\\.\\(.*\\)$" string)
+ (setq class (match-string 1 string)
+ function (match-string 2 string)
+ ret (format "%s.*%s\\>"
+ (regexp-quote class)
+ (regexp-quote function)))
+ ;; If the name is "System.something", the assume that the first word
+ ;; is pure java Class.
+ ;;
+ ;; If the name is in lowercase, assume that it is variable and
+ ;; search for plain function name as well.
+ (unless (ti::string-match-case "^[A-Z]" class)
+ (setq ret (format "%s\\| %s(" ret function))))
+ ((not (string-match "\\." string))
+ (setq ret (format "\\<%s[ \t]*("
+ (regexp-quote string))))))))
+ (tinytag-debug fid "ret" ret "\n")
+ ret))
+
+;;}}}
+;;{{{ code: search engine
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytag-search-db (re single-or-list)
+ "Search RE from databases in SINGLE-OR-LIST.
+
+References:
+
+ `tinytag-:database-map'
+ `tinytag-:database-dir'
+ `tinytag-:noerror'
+ `tinytag-:word-modify-hook'
+
+Return:
+
+ list '(line line ..) matched lines or nil."
+ (tinytag-initialize)
+ (let* ((fid "tinytag-search-db: ")
+ (table tinytag-:database-map)
+ (noerr tinytag-:noerror)
+ (dir (file-name-as-directory tinytag-:database-dir))
+ (list (ti::list-make single-or-list))
+ buffer
+ file
+ ret)
+ (tinytag-debug fid " input" re single-or-list "\n")
+ (dolist (elt list)
+ (when (setq elt (assq elt table))
+ (setq file (concat
+ (file-name-as-directory dir)
+ (nth 1 elt)))
+ (setq buffer (or (get-file-buffer file)
+ (and (file-exists-p file)
+ (find-file-noselect file))))
+ (tinytag-debug fid " buffer" buffer "file" file "\n")
+ ;; ......................................... search or no file ...
+ (cond
+ ((and
+ buffer
+ (setq re (run-hook-with-args-until-success
+ 'tinytag-:word-modify-hook re)))
+ (tinytag-debug fid " regexp" re "\n")
+ (with-current-buffer buffer
+ (ti::pmin)
+ (setq ret (ti::buffer-grep-lines re))))
+ ((null noerr)
+ (error "No database to search %s" file))))) ;; when-dolist
+ (tinytag-debug fid "RET" ret "\n")
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytag-do-search (string)
+ "Search those databases which match predefined regexp against STRING.
+
+References:
+ `tinytag-:regexp-to-databases'
+
+Return:
+ list '(db-matched-line ..) or nil"
+ (let* ((fid "tinytag-do-search: ")
+ (table tinytag-:regexp-to-databases)
+ e
+ db
+ re
+ ret)
+ (tinytag-debug fid "string" string "\n")
+ (when (run-hook-with-args-until-success
+ 'tinytag-:word-filter-hook string)
+ (dolist (elt table)
+ (setq re (car elt)
+ db (nth 1 elt))
+ (when (string-match re string)
+ (setq ret (tinytag-search-db string db))
+ (tinytag-debug fid " MATCH" "re" re "str" string "ret" ret"\n")
+ (return))))
+ ret))
+
+;;}}}
+;;{{{ code: try funcs
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytag-try-function-show-cached-word (&optional noerr)
+ "Pick word at point and show info if word was same as previously looked.
+NOERR ignores errors."
+ (interactive)
+ (let* ((word (tinytag-word-at-point))
+ (prev-word (car-safe tinytag-:last-word-lookup))
+ (prev-info (cdr-safe tinytag-:last-word-lookup))
+ (err (or noerr tinytag-:noerror))
+ (fid "tinytag-try-function-show-cached-word: "))
+ (catch 'quit
+ (tinytag-debug fid
+ "word" word
+ "previous word" prev-word
+ "previous info" prev-info
+ "error flag" err
+ "\n")
+ (when (not (stringp word))
+ (if (null err)
+ (message "tinytag: No word at point."))
+ (throw 'quit t))
+
+ (when (and (not (null prev-word))
+ (not (null prev-info))
+ (string= word prev-word))
+ (tinytag-display prev-info)
+ (throw 'quit t)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytag-try-function-search-db ()
+ "Do lookup, pick word at point and search databases.
+Show the matched word from database."
+ (interactive)
+ (let* ((fid "tinytag-try-function-search-db: ")
+ (word (tinytag-word-at-point))
+ info)
+ (tinytag-debug fid "word" word "\n")
+ (when (and (stringp word)
+ (run-hook-with-args-until-success 'tinytag-:set-database-hook)
+ (setq info (tinytag-do-search word)))
+ (setq tinytag-:last-word-lookup (cons word info))
+ (tinytag-display info)
+ t)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytag-try-function-man ()
+ "Suggest man page search for current word."
+ (interactive)
+ (let* ((word (ti::buffer-read-word))
+ ;; only in 19.30
+;;; (syntax-elt (fexec 'c-guess-basic-syntax))
+;;; (syntax (car-safe syntax-elt))
+ ans)
+ (when
+ (and word ;; (memq syntax '(statement nil))
+ (y-or-n-p (concat "Run man on " word))
+ (not
+ (ti::nil-p
+ (setq ans (read-from-minibuffer "Man cmd: " word)))))
+ (man ans)
+ t)))
+
+;;}}}
+;;{{{ main
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinytag-main ()
+ "Run `tinytag-:try-hook' until some of the functions return non-nil."
+ (interactive)
+ (run-hook-with-args-until-success 'tinytag-:try-hook))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinytag-main-mouse (&optional event)
+ "See `tinytag-main'. Function is called with mouse EVENT."
+ (interactive "e")
+ (tinytag-main))
+
+;;}}}
+;;{{{ code: example
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytag-post-command-1 ()
+ "Do lookup."
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... do action . .
+ ;;
+ (when (and
+ (run-hook-with-args-until-success 'tinytag-:set-database-hook)
+ (run-hook-with-args-until-success 'tinytag-:post-command-try-hook))
+ ;; This is needed in 19.30<, so that the
+ ;; message doesn't get wiped away.
+ ;;
+ ;; (unless (fboundp 'post-command-idle-hook)
+ ;; (sleep-for 1))
+ ;;(discard-input)
+ nil))
+
+;;; ----------------------------------------------------------------------
+;;; - The functionality is copied from Noah's <friedman@prep.ai.mit.edu>
+;;; eldoc.el: eldoc-mode-print-current-symbol-info
+;;;
+;;;###autoload
+(defun tinytag-post-command ()
+ "Activates only if `tinytag-:set-database-hook' wakes up.
+Show the database definition for the current word under point.
+
+References:
+
+ `tinytag-:noerror'
+ `tinytag-:post-command-hook-wakeup'
+ `tinytag-:set-database-hook'"
+ (let* ((tinytag-:noerror t)
+ it-is-time)
+ (when (and (not (ti::compat-executing-macro))
+ ;; Having this mode operate in the minibuffer
+ ;; makes it impossible to
+ ;; see what you're doing.
+ (not (eq (selected-window) (minibuffer-window)))
+ (symbolp this-command)
+ (sit-for 0.50)
+ ;; Is this programming language supported?
+ (run-hook-with-args-until-success
+ 'tinytag-:set-database-hook))
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... wakeup time? . .
+ ;; This is not used if we're in 19.34
+ ;;
+ (cond
+ ((fboundp 'run-with-idle-timer)
+ (setq it-is-time t))
+ (t
+ (if (null tinytag-:post-command-hook-counter)
+ (setq tinytag-:post-command-hook-counter 0))
+ ;; Don't wake up all the time.. saves Emacs processing time.
+ ;;
+ (setq
+ it-is-time
+ (or (eq 0 tinytag-:post-command-hook-wakeup)
+ (and (not (eq 0 tinytag-:post-command-hook-counter))
+ (eq 0 (% tinytag-:post-command-hook-counter
+ tinytag-:post-command-hook-wakeup)))))
+ (incf tinytag-:post-command-hook-counter)
+ (if it-is-time ;do reset
+ (setq tinytag-:post-command-hook-counter 0))))
+ ;; ... ... ... ... ... ... ... ... ... ... ... ... ... do action . .
+ ;;
+ (if it-is-time
+ (tinytag-post-command-1)))))
+
+;;; ----------------------------------------------------------------------
+;;; This is default function. Copy this and you _have_to_ write your own.
+;;;
+(defun tinytag-set-database ()
+ "Set correct database values according to buffer content.
+Return:
+ non-nil or nil was the database set according to buffer?"
+ (let* ((id (or (ti::id-info nil 'variable-lookup)
+ (symbol-name major-mode)))
+ ;; read last word, delete rest
+ ;;
+ (table tinytag-:database-setup-table)
+ elt
+ did-it)
+ (cond
+ ((and (setq elt (ti::list-find table id))
+ (setq elt (nth 1 elt))) ;Get second list
+ (setq tinytag-:database-map (eval (nth 0 elt))
+ tinytag-:regexp-to-databases (eval (nth 1 elt))
+ did-it (nth 0 elt)))
+ (t
+ ;; Disable search. We don't know database for this buffer
+ ;;
+ (setq tinytag-:database-map nil
+ tinytag-:regexp-to-databases nil)))
+
+ (if did-it
+ (run-hooks 'tinytag-:database-ok-hook))
+ did-it))
+
+;;}}}
+;;{{{ example: perl script for creating your own database
+
+;;; ..................................................... &example-c++ ...
+
+;;; Here sript which you can use to generate database lines from
+;;; manual page files. I would have included mine, but it uses my private
+;;; perl libs and it's much bigger than Peter's handy script.
+
+;;* #! /usr/local/perl5/bin/perl
+;;* #
+;;* # Peter Simons <simons@petium.rhein.de>
+;;* # (#) Script to make C++ function database for Emacs tinytag.el
+;;* _
+;;* foreach $filename (@ARGV) {
+;;* open(INFILE, $filename) || die("Can't open file $filename.");
+;;* @lines = <INFILE>;
+;;* chop(@lines);
+;;* $lines_num = @lines;
+;;* for ($isSynopsis = 0, $includes = "", $curr_line = "", $i = 0;
+;;* $i < $lines_num; $i++) {
+;;* $lines[$i] =~ s/.\b//g;
+;;* if ($lines[$i] =~ /^SYNOPSIS$/) {
+;;* $isSynopsis = 1;
+;;* next;
+;;* }
+;;* if ($lines[$i] =~ /^DESCRIPTION$/) {
+;;* $isSynopsis = 0;
+;;* $includes = "";
+;;* $curr_line = "";
+;;* last;
+;;* }
+;;* if ($isSynopsis == 1) {
+;;* if ($lines[$i] =~ /^ *#include/) {
+;;* $lines[$i] =~ s/^.*<(.*)>$/<$1>/;
+;;* $includes = $includes . $lines[$i];
+;;* }
+;;* elsif ($lines[$i] =~ /^$/) {
+;;* if ($curr_line ne "") {
+;;* $curr_line =~ s/ +/ /g;
+;;* if ($includes eq "") {
+;;* printf("<none>$curr_line\n");
+;;* }
+;;* else {
+;;* printf("$includes$curr_line\n");
+;;* }
+;;* $curr_line = "";
+;;* }
+;;* }
+;;* else {
+;;* $curr_line = $curr_line . $lines[$i];
+;;* }
+;;* }
+;;* }
+;;* }
+
+;; }}}
+;; {{{ example: HP-UX simple database
+
+;;; Rip code with with tinylib.el/ti::package-rip-magic
+;;; These databases are automatically intalled when call
+;;; M-x tinytag-install-sample-database-c
+
+;;* # HP-UX Sample C++ function database
+;;* #
+;;* # HP 10, The C/C++ function call definitions from man 3C and 2.
+;;* # Not guarrantees, that are calls are here.
+;;* #
+;;* _
+;;* <dirent.h> DIR *opendir(const char *dirname);
+;;* <dirent.h> int closedir(DIR *dirp);
+;;* <dirent.h> int readdir_r(DIR *dirp, struct dirent *result);
+;;* <dirent.h> long int telldir(DIR *dirp);
+;;* <dirent.h> struct dirent *readdir(DIR *dirp);
+;;* <dirent.h> void rewinddir(DIR *dirp);
+;;* <dirent.h> void seekdir(DIR *dirp, long int loc);
+;;* <regexp.h> extern char *loc1, *loc2, *locs;
+;;* <regexp.h> extern int circf, sed, nbra;
+;;* <regexp.h> int advance(const char *string, const char *expbuf);
+;;* <regexp.h> int step(const char *string, const char *expbuf);
+;;* <stdio.h> FILE *fdopen(int fildes, const char *type);
+;;* <stdio.h> FILE *fopen(const char *pathname, const char *type);
+;;* <stdio.h> FILE *freopen(const char *pathname, const char *type, FILE *stream);
+;;* <stdio.h> FILE *stream);
+;;* <stdio.h> int fclose(FILE *stream);
+;;* <stdio.h> int fclose_unlocked(FILE *stream);
+;;* <stdio.h> int feof(FILE *stream);
+;;* <stdio.h> int feof_unlocked(FILE *stream);
+;;* <stdio.h> int ferror(FILE *stream);
+;;* <stdio.h> int ferror_unlocked(FILE *stream);
+;;* <stdio.h> int fflush(FILE *stream);
+;;* <stdio.h> int fflush_unlocked(FILE *stream);
+;;* <stdio.h> int fscanf(FILE *stream, const char *format, /* [pointer,] */ ...);
+;;* <stdio.h> int fseek(FILE *stream, long int offset, int whence);
+;;* <stdio.h> int fseek_unlocked(FILE *stream, long int offset, int whence);
+;;* <stdio.h> int scanf(const char *format, /* [pointer,] */ ...);
+;;* <stdio.h> int sscanf(const char *s, const char *format, /* [pointer,] */ ...);
+;;* <stdio.h> long int ftell(FILE *stream);
+;;* <stdio.h> long int ftell_unlocked(FILE *stream);
+;;* <stdio.h> size_t fread(void *ptr, size_t size, size_t nitems, FILE *stream);
+;;* <stdio.h> size_t fwrite(const void *ptr, size_t size, size_t nitems, FILE *stream);
+;;* <stdio.h> void clearerr(FILE *stream);
+;;* <stdio.h> void clearerr_unlocked(FILE *stream);
+;;* <stdio.h> void rewind(FILE *stream);
+;;* <stdio.h> void rewind_unlocked(FILE *stream);
+;;* <stdlib.h> int system(const char *command);
+;;* <stdlib.h> void abort(void);
+;;* <string.h><strings.h> char *index(const char *s, int c);
+;;* <string.h><strings.h> char *rindex(const char *s, int c);
+;;* <string.h><strings.h> char *strcat(char *s1, const char *s2);
+;;* <string.h><strings.h> char *strchr(const char *s, int c);
+;;* <string.h><strings.h> char *strcpy(char *s1, const char *s2);
+;;* <string.h><strings.h> char *strdup(const char *s);
+;;* <string.h><strings.h> char *strncat(char *s1, const char *s2, size_t n);
+;;* <string.h><strings.h> char *strncpy(char *s1, const char *s2, size_t n);
+;;* <string.h><strings.h> char *strpbrk(const char *s1, const char *s2);
+;;* <string.h><strings.h> char *strrchr(const char *s, int c);
+;;* <string.h><strings.h> char *strrstr(const char *s1, const char *s2);
+;;* <string.h><strings.h> char *strstr(const char *s1, const char *s2);
+;;* <string.h><strings.h> char *strtok(char *s1, const char *s2);
+;;* <string.h><strings.h> char *strtok_r(char *s1, const char *s2, char **last);
+;;* <string.h><strings.h> int strcasecmp(const char *s1, const char *s2);
+;;* <string.h><strings.h> int strcmp(const char *s1, const char *s2);
+;;* <string.h><strings.h> int strcoll(const char *s1, const char *s2);
+;;* <string.h><strings.h> int strncasecmp(const char *s1, const char *s2, size_t n);
+;;* <string.h><strings.h> int strncmp(const char *s1, const char *s2, size_t n);
+;;* <string.h><strings.h> size_t strcspn(const char *s1, const char *s2);
+;;* <string.h><strings.h> size_t strlen(const char *s);
+;;* <string.h><strings.h> size_t strspn(const char *s1, const char *s2);
+;;* <string.h><strings.h> size_t strxfrm(char *s1, const char *s2, size_t n);
+;;* <time.h> char *asctime(const struct tm *timeptr);
+;;* <time.h> char *ctime(const time_t *timer);
+;;* <time.h> double difftime(time_t time1, time_t time0);
+;;* <time.h> extern char *tzname[2];
+;;* <time.h> extern int daylight;
+;;* <time.h> extern long timezone;
+;;* <time.h> int asctime_r(const struct tm *timeptr, char *buffer, int buflen);
+;;* <time.h> int ctime_r(const time_t *timer, char *buffer, int buflen);
+;;* <time.h> int gmtime_r(const time_t *timer, struct tm *result);
+;;* <time.h> int localtime_r(const time_t *timer, struct tm *result);
+;;* <time.h> struct tm *gmtime(const time_t *timer);
+;;* <time.h> struct tm *localtime(const time_t *timer);
+;;* <time.h> time_t mktime(struct tm *timeptr);
+;;* <time.h> void tzset(void);
+;;* <unistd.h> char *getcwd(char *buf, size_t size);
+;;* _
+;;* #
+;;* # HP 10 man 2 pages
+;;* #
+;;* <sys/stat.h> int stat(const char *path, struct stat *buf);
+;;* <sys/stat.h> int lstat(const char *path, struct stat *buf);
+;;* <sys/stat.h> int fstat(int fildes, struct stat *buf);
+;;* <stdlib.h><unistd.h> void exit(int status);
+;;* <stdlib.h><unistd.h> void _exit(int status);
+;;* <unistd.h> pid_t getpid(void);
+;;* <unistd.h> pid_t getpgrp(void);
+;;* <unistd.h> pid_t getppid(void);
+;;* <unistd.h> pid_t getpgrp2(pid_t pid);
+;;* <unistd.h> int link(const char *path1, const char *path2);
+;;* <time.h> time_t time(time_t *tloc);
+;;* <sys/socket.h> int send(int s, const void *msg, int len, int flags);
+;;* <sys/socket.h> int tolen);
+;;* <sys/socket.h> int sendmsg(int s, const struct msghdr msg[], int flags);
+;;* <unistd.h> extern char **environ;
+;;* <unistd.h> int execv(const char *path, char * const argv[]);
+;;* <unistd.h> int execve(const char *file, char * const argv[], char * const envp[]);
+;;* <unistd.h> int execvp(const char *file, char * const argv[]);
+;;* <unistd.h> unsigned int alarm(unsigned int sec);
+;;* <sys/times.h> clock_t times(struct tms *buffer);
+;;* <errno.h> extern int errno;
+;;* <sys/uio.h><unistd.h> ssize_t write(int fildes, const void *buf, size_t nbyte);
+;;* <sys/uio.h><unistd.h> );
+;;* <unistd.h> pid_t fork(void);
+;;* <unistd.h> int close(int fildes);
+;;* <unistd.h> int unlink(const char *path);
+;;* <unistd.h> extern char **environ;
+;;* <unistd.h> int execv(const char *path, char * const argv[]);
+;;* <unistd.h> int execve(const char *file, char * const argv[], char * const envp[]);
+;;* <unistd.h> int execvp(const char *file, char * const argv[]);
+;;* <time.h> int stime(const time_t *tp);
+;;* <ulimit.h> long ulimit(int cmd, ...);
+;;* <sys/wait.h> pid_t wait(int *stat_loc);
+;;* <sys/wait.h> pid_t waitpid(pid_t pid, int *stat_loc, int options);
+;;* <sys/wait.h> pid_t wait3(int *stat_loc, int options, int *reserved);
+;;* <time.h> int getitimer(int which, struct itimerval *value);
+;;* <unistd.h> int setuid(uid_t uid);
+;;* <unistd.h> int setgid(gid_t gid);
+;;* <unistd.h> int setresuid(uid_t ruid, uid_t euid, uid_t suid);
+;;* <unistd.h> int setresgid(gid_t rgid, gid_t egid, gid_t sgid);
+;;* <signal.h> int kill(pid_t pid, int sig);
+;;* <signal.h> int raise(int sig);
+;;* <signal.h> void (*signal(int sig, void (*action)(int)))(int);
+;;* int rmdir(const char *path);
+;;* <sys/wait.h> pid_t wait(int *stat_loc);
+;;* <sys/wait.h> pid_t waitpid(pid_t pid, int *stat_loc, int options);
+;;* <sys/wait.h> pid_t wait3(int *stat_loc, int options, int *reserved);
+;;* <unistd.h> int pause(void);
+;;* <symlink.h> int symlink(const char *name1, const char *name2);
+;;* <signal.h> int sigsuspend(const sigset_t *sigmask);
+;;* <sys/uio.h><unistd.h> size_t read(int fildes, void *buf, size_t nbyte);
+;;* <sys/uio.h><unistd.h> );
+;;* <unistd.h> extern char **environ;
+;;* <unistd.h> int execv(const char *path, char * const argv[]);
+;;* <unistd.h> int execve(const char *file, char * const argv[], char * const envp[]);
+;;* <unistd.h> int execvp(const char *file, char * const argv[]);
+;;* <unistd.h> int access(char *path, int amode);
+;;* <sys/stat.h> int mknod(const char *path, mode_t mode, dev_t dev);
+;;* <fcntl.h> int creat(const char *path, mode_t mode);
+;;* <sys/stat.h> int mkdir(const char *path, mode_t mode);
+;;* <sys/uio.h><unistd.h> size_t read(int fildes, void *buf, size_t nbyte);
+;;* <ustat.h> int ustat(dev_t dev, struct ustat *buf);
+;;* <sys/stat.h> int chmod(const char *path, mode_t mode);
+;;* <sys/stat.h> int fchmod(int fildes, mode_t mode)
+;;* _
+;;* # END HP-UX Sample C++ function database
+
+;; }}}
+;; {{{ example: NetBSD 1.2 database
+
+;;* # NetBSD Sample 1.2
+;;* # collected by Peter Simons <simons@rhein.de>
+;;* # Thu Oct 17 16:31:10 MET DST 1996
+;;* #
+;;* <assert.h> assert(expression)
+;;* <bitstring.h> bit_clear(bit_str name, int bit)
+;;* <bitstring.h> bit_decl(bit_str name, int nbits)
+;;* <bitstring.h> bit_ffc(bit_str name, int nbits, int *value)
+;;* <bitstring.h> bit_ffs(bit_str name, int nbits, int *value)
+;;* <bitstring.h> bit_nclear(bit_str name, int start, int stop)
+;;* <bitstring.h> bit_nset(bit_str name, int start, int stop)
+;;* <bitstring.h> bit_set(bit_str name, int bit)
+;;* <bitstring.h> bit_test(bit_str name, int bit)
+;;* <bitstring.h> bitstr_size(int nbits)
+;;* <bitstring.h> bitstr_t * bit_alloc(int nbits)
+;;* <ctype.h> int isalnum(int c)
+;;* <ctype.h> int isalpha(int c)
+;;* <ctype.h> int isascii(int c)
+;;* <ctype.h> int isblank(int c)
+;;* <ctype.h> int iscntrl(int c)
+;;* <ctype.h> int isdigit(int c)
+;;* <ctype.h> int isgraph(int c)
+;;* <ctype.h> int islower(int c)
+;;* <ctype.h> int isprint(int c)
+;;* <ctype.h> int ispunct(int c)
+;;* <ctype.h> int isspace(int c)
+;;* <ctype.h> int isupper(int c)
+;;* <ctype.h> int isxdigit(int c)
+;;* <ctype.h> int tolower(int c)
+;;* <ctype.h> int toupper(int c)
+;;* <dirent.h> int getdirentries(int fd, char *buf, int nbytes, long *basep)
+;;* <dlfcn.h> char * dlerror(void)
+;;* <dlfcn.h> int dlclose(void *handle)
+;;* <dlfcn.h> int dlctl(void *handle, int cmd, void *data)
+;;* <dlfcn.h> void * dlopen(char *path, int mode)
+;;* <dlfcn.h> void * dlsym(void *handle, char *symbol)
+;;* <err.h> void err(int eval, const char *fmt, ...)
+;;* <err.h> void errx(int eval, const char *fmt, ...)
+;;* <err.h> void verr(int eval, const char *fmt, va_list args)
+;;* <err.h> void verrx(int eval, const char *fmt, va_list args)
+;;* <err.h> void vwarn(const char *fmt, va_list args)
+;;* <err.h> void vwarnx(const char *fmt, va_list args)
+;;* <err.h> void warn(const char *fmt, ...)
+;;* <err.h> void warnx(const char *fmt, ...)
+;;* <fcntl.h> int fcntl(int fd, int cmd, int arg)
+;;* <fcntl.h> int open(const char *path, int flags, mode_t mode)
+;;* <fcntl.h><kvm.h> int kvm_close(kvm_t *kd)
+;;* <fcntl.h><kvm.h> kvm_t * kvm_open(const char *execfile, const char *corefile, char *swapfile, int flags, const char *errstr)
+;;* <fcntl.h><kvm.h> kvm_t * kvm_openfiles(const char *execfile, const char *corefile, char *swapfile, int flags, char *errbuf)
+;;* <fnmatch.h> int fnmatch(const char *pattern, const char *string, int flags)
+;;* <fstab.h> int setfsent(void)
+;;* <fstab.h> struct fstab * getfsent(void)
+;;* <fstab.h> struct fstab * getfsfile(const char *file)
+;;* <fstab.h> struct fstab * getfsspec(const char *spec)
+;;* <fstab.h> void endfsent(void)
+;;* <glob.h> int glob(const char *pattern, int flags, const int (*errfunc)(const char *, int), glob_t *pglob)
+;;* <glob.h> void globfree(glob_t *pglob)
+;;* <kvm.h> char * kvm_geterr(kvm_t *kd)
+;;* <kvm.h> ssize_t kvm_read(kvm_t *kd, u_long addr, void *buf, size_t nbytes)
+;;* <kvm.h> ssize_t kvm_write(kvm_t *kd, u_long addr, const void *buf, size_t nbytes)
+;;* <kvm.h><nlist.h> int kvm_nlist(kvm_t *kd, struct nlist *nl)
+;;* <kvm.h><sys/kinfo.h><sys/file.h> char * kvm_getfiles(kvm_t *kd, int op, int arg, int *cnt)
+;;* <kvm.h><sys/sysctl.h> char ** kvm_getargv(kvm_t *kd, const struct kinfo_proc *p, int nchr)
+;;* <kvm.h><sys/sysctl.h> char ** kvm_getenvv(kvm_t *kd, const struct kinfo_proc *p, int nchr)
+;;* <kvm.h><sys/sysctl.h> struct kinfo_proc * kvm_getprocs(kvm_t *kd, int op, int arg, int *cnt)
+;;* <limits.h><stdlib.h> int radixsort(u_char **base, int nmemb, u_char *table, u_int endbyte)
+;;* <limits.h><stdlib.h> int sradixsort(u_char **base, int nmemb, u_char *table, u_int endbyte)
+;;* <machine/sysarch.h> int sysarch(int number, char *args)
+;;* <math.h> double acos(double x)
+;;* <math.h> double acosh(double x)
+;;* <math.h> double asin(double x)
+;;* <math.h> double asinh(double x)
+;;* <math.h> double atan(double x)
+;;* <math.h> double atan2(double y, double x)
+;;* <math.h> double atanh(double x)
+;;* <math.h> double cabs(z)
+;;* <math.h> double cbrt(double x)
+;;* <math.h> double ceil(double x)
+;;* <math.h> double copysign(double x, double y)
+;;* <math.h> double cos(double x)
+;;* <math.h> double cosh(double x)
+;;* <math.h> double erf(double x)
+;;* <math.h> double erfc(double x)
+;;* <math.h> double exp(double x)
+;;* <math.h> double expm1(double x)
+;;* <math.h> double fabs(double x)
+;;* <math.h> double floor(double x)
+;;* <math.h> double fmod(double x, double y)
+;;* <math.h> double frexp(double value, int *exp)
+;;* <math.h> double hypot(double x, double y)
+;;* <math.h> double j0(double x)
+;;* <math.h> double j1(double x)
+;;* <math.h> double jn(int n, double x)
+;;* <math.h> double ldexp(double x, int exp)
+;;* <math.h> double lgamma(double x)
+;;* <math.h> double log(double x)
+;;* <math.h> double log10(double x)
+;;* <math.h> double log1p(double x)
+;;* <math.h> double logb(double x)
+;;* <math.h> double modf(double value, double *iptr)
+;;* <math.h> double nextafter(double x, double y)
+;;* <math.h> double pow(double x, double y)
+;;* <math.h> double remainder(double x, double y)
+;;* <math.h> double rint(double x)
+;;* <math.h> double scalb(double x, double n)
+;;* <math.h> double scalbn(double x, int n)
+;;* <math.h> double significand(double x)
+;;* <math.h> double sin(double x)
+;;* <math.h> double sinh(double x)
+;;* <math.h> double sqrt(double x)
+;;* <math.h> double tan(double x)
+;;* <math.h> double tanh(double x)
+;;* <math.h> double y0(double x)
+;;* <math.h> double y1(double x)
+;;* <math.h> double yn(int n, double x)
+;;* <math.h> erff(float x)
+;;* <math.h> extern int signgam;
+;;* <math.h> float acosf(float x)
+;;* <math.h> float acoshf(float x)
+;;* <math.h> float asinf(float x)
+;;* <math.h> float asinhf(float x)
+;;* <math.h> float atan2f(float y, float x)
+;;* <math.h> float atanf(float x)
+;;* <math.h> float atanhf(float x)
+;;* <math.h> float cbrtf(float x)
+;;* <math.h> float ceilf(float x)
+;;* <math.h> float copysignf(float x, float y)
+;;* <math.h> float cosf(float x)
+;;* <math.h> float coshf(float x)
+;;* <math.h> float erfcf(float x)
+;;* <math.h> float expf(float x)
+;;* <math.h> float expm1f(float x)
+;;* <math.h> float fabsf(float x)
+;;* <math.h> float floorf(float x)
+;;* <math.h> float fmodf(float x, float y)
+;;* <math.h> float hypotf(float x, float y)
+;;* <math.h> float j0f(float x)
+;;* <math.h> float j1f(float x)
+;;* <math.h> float jnf(int n, float x)
+;;* <math.h> float lgammaf(float x)
+;;* <math.h> float log10f(float x)
+;;* <math.h> float log1pf(float x)
+;;* <math.h> float logbf(float x)
+;;* <math.h> float logf(float x)
+;;* <math.h> float nextafterf(float x, float y)
+;;* <math.h> float powf(float x, float, y")
+;;* <math.h> float remainderf(float x, float y)
+;;* <math.h> float rintf(float x)
+;;* <math.h> float scalbf(float x, float n)
+;;* <math.h> float scalbnf(float x, int n)
+;;* <math.h> float significand(float x)
+;;* <math.h> float sinf(float x)
+;;* <math.h> float sinhf(float x)
+;;* <math.h> float sqrtf(float x)
+;;* <math.h> float tanf(float x)
+;;* <math.h> float tanhf(float x)
+;;* <math.h> float y0f(float x)
+;;* <math.h> float y1f(float x)
+;;* <math.h> float ynf(int n, float x)
+;;* <math.h> int finite(double x)
+;;* <math.h> int finitef(float x)
+;;* <math.h> int ilogb(double x)
+;;* <math.h> int ilogbf(float x)
+;;* <netdb.h> char * hstrerror(int err)
+;;* <netdb.h> endnetent()
+;;* <netdb.h> endprotoent()
+;;* <netdb.h> setnetent(int stayopen)
+;;* <netdb.h> setprotoent(int stayopen)
+;;* <netdb.h> struct hostent * gethostbyaddr(const char *addr, int len, int type)
+;;* <netdb.h> struct hostent * gethostbyname(const char *name)
+;;* <netdb.h> struct hostent * gethostent(void)
+;;* <netdb.h> struct netent * getnetbyaddr(long net, int type)
+;;* <netdb.h> struct netent * getnetbyname(char *name)
+;;* <netdb.h> struct netent * getnetent()
+;;* <netdb.h> struct protoent * getprotobyname(char *name)
+;;* <netdb.h> struct protoent * getprotobynumber(int proto)
+;;* <netdb.h> struct protoent * getprotoent()
+;;* <netdb.h> struct rpcent * getrpcbyname(char *name)
+;;* <netdb.h> struct rpcent * getrpcbynumber(int number)
+;;* <netdb.h> struct rpcent * getrpcent(void)
+;;* <netdb.h> struct servent * getservbyname(char *name, char *proto)
+;;* <netdb.h> struct servent * getservbyport(int port, proto)
+;;* <netdb.h> struct servent * getservent()
+;;* <netdb.h> void endhostent(void)
+;;* <netdb.h> void endrpcent(void)
+;;* <netdb.h> void endservent(void)
+;;* <netdb.h> void herror(char *string)
+;;* <netdb.h> void sethostent(int stayopen)
+;;* <netdb.h> void setrpcent(int stayopen)
+;;* <netdb.h> void setservent(int stayopen)
+;;* <netinet/if_ether.h> char * ether_ntoa(struct ether_addr *e)
+;;* <netinet/if_ether.h> ether_hostton(char *hostname, struct ether_addr *e)
+;;* <netinet/if_ether.h> ether_line(char *l, struct ether_addr *e, char *hostname)
+;;* <netinet/if_ether.h> ether_ntohost(char *hostname, struct ether_addr *e)
+;;* <netinet/if_ether.h> struct ether_addr * ether_aton(char *s)
+;;* <nl_types.h> char * catgets(nl_catd catd, int set_id, int msg_id, char *s)
+;;* <nl_types.h> int catclose(nl_catd catd)
+;;* <nl_types.h> nl_catd catopen(const char *name, int oflag)
+;;* <nl_types.h><langinfo.h> char * nl_langinfo(nl_item item)
+;;* <nlist.h> int nlist(const char *filename, struct nlist *nl)
+;;* <none> char * getusershell(void)
+;;* <none> char * lfind(const void *key, const void *base, size_t *nelp, size_t width, int (*compar)(void *, void *))
+;;* <none> char * lsearch(const void *key, const void *base, size_t *nelp, size_t width, int (*compar)(void *, void *))
+;;* <none> char * tgetstr(char *id, char **area)
+;;* <none> char * tgoto(char *cm, destcol, destline)
+;;* <none> char * timezone(int zone, int dst)
+;;* <none> char *crypt(const char *key, const char *setting)
+;;* <none> getloadavg(double loadavg[], int nelem)
+;;* <none> getpw(uid, char *buf)
+;;* <none> group_from_gid(gid_t gid, int nogroup)
+;;* <none> int des_cipher(const char *in, char *out, long salt, int count)
+;;* <none> int des_setkey(const char *key)
+;;* <none> int encrypt(char *block, int flag)
+;;* <none> int getnetgrent(char **host, char **user, char **domain)
+;;* <none> int getrpcport(char *host, int prognum, int versnum, int proto)
+;;* <none> int innetgr(const char *netgroup, const char *host, const char *user, )
+;;* <none> int isinf(double)
+;;* <none> int isnan(double)
+;;* <none> int profil(char *samples, size_t size, u_long offset, u_int scale)
+;;* <none> int rexec(ahost, int inport, char *user, char *passwd, char *cmd, int *fd2p)
+;;* <none> int setkey(const char *key)
+;;* <none> mode_t getmode(const void *set, mode_t mode)
+;;* <none> moncontrol(int mode)
+;;* <none> monstartup(u_long *lowpc, u_long *highpc)
+;;* <none> nice(int incr)
+;;* <none> tgetent(char *bp, char *name)
+;;* <none> tgetflag(char *id)
+;;* <none> tgetnum(char *id)
+;;* <none> user_from_uid(uid_t uid, int nouser)
+;;* <none> void * setmode(const char *mode_str)
+;;* <none> void * shutdownhook_establish(void (*fn)(void *), void *arg)
+;;* <none> void doshutdownhooks(void)
+;;* <none> void endnetgrent(void)
+;;* <none> void endusershell(void)
+;;* <none> void inittodr(time_t base)
+;;* <none> void resettodr(void)
+;;* <none> void setnetgrent(const char *netgroup)
+;;* <none> void setusershell(void)
+;;* <none> void shutdownhook_disestablish(void *cookie)
+;;* <none> void tputs(register char *cp, int affcnt, int (*outc)())
+;;* <none> void tzset()
+;;* <pwd.h><unistd.h> char * getpass(const char *prompt)
+;;* <regexp.h> int regexec(const regexp *prog, const char *string)
+;;* <regexp.h> regexp * regcomp(const char *exp)
+;;* <regexp.h> void regsub(const regexp *prog, const char *source, char *dest)
+;;* <search.h> struct qelem { struct qelem *q_forw; struct qelem *q_back; char q_data[]; }; void insque(struct qelem *elem, struct qelem *pred)
+;;* <search.h> void remque(struct qelem *elem)
+;;* <setjmp.h> int _setjmp(jmp_buf env)
+;;* <setjmp.h> int setjmp(jmp_buf env)
+;;* <setjmp.h> int sigsetjmp(sigjmp_buf env, int savemask)
+;;* <setjmp.h> void _longjmp(jmp_buf env, int val)
+;;* <setjmp.h> void longjmp(jmp_buf env, int val)
+;;* <setjmp.h> void longjmperror(void)
+;;* <setjmp.h> void siglongjmp(sigjmp_buf env, int val)
+;;* <sgtty.h> gtty(int fd, struct sgttyb *buf)
+;;* <sgtty.h> stty(int fd, struct sgttyb *buf)
+;;* <signal.h> int kill(pid_t pid, int sig)
+;;* <signal.h> int killpg(pid_t pgrp, int sig)
+;;* <signal.h> int raise(int sig)
+;;* <signal.h> int sigaction(int sig, const struct sigaction *act, struct sigaction *oact)
+;;* <signal.h> int sigaddset(sigset_t *set, int signo)
+;;* <signal.h> int sigblock(int mask)
+;;* <signal.h> int sigdelset(sigset_t *set, int signo)
+;;* <signal.h> int sigemptyset(sigset_t *set)
+;;* <signal.h> int sigfillset(sigset_t *set)
+;;* <signal.h> int siginterrupt(int sig, int flag)
+;;* <signal.h> int sigismember(sigset_t *set, int signo)
+;;* <signal.h> int sigmask(signum)
+;;* <signal.h> int sigpause(int sigmask)
+;;* <signal.h> int sigpending(sigset_t *set)
+;;* <signal.h> int sigprocmask(int how, const sigset_t *set, sigset_t *oset)
+;;* <signal.h> int sigreturn(struct sigcontext *scp)
+;;* <signal.h> int sigsetmask(int mask)
+;;* <signal.h> int sigsuspend(const sigset_t *sigmask)
+;;* <signal.h> sigmask(signum)
+;;* <signal.h> sigvec(int sig, struct sigvec *vec, struct sigvec *ovec)
+;;* <signal.h> struct sigaction { void (*sa_handler)(); sigset_t sa_mask; int sa_flags; };
+;;* <signal.h> struct sigcontext { int sc_onstack; int sc_mask; int sc_sp; int sc_fp; int sc_ap; int sc_pc; int sc_ps; };
+;;* <signal.h> struct sigvec { void (*sv_handler)(); sigset_t sv_mask; int sv_flags; };
+;;* <signal.h> void (*signal(int sig, void (*func)()))()
+;;* <stdarg.h> type va_arg(va_list ap, type)
+;;* <stdarg.h> void va_end(va_list ap)
+;;* <stdarg.h> void va_start(va_list ap, last)
+;;* <stdio.h> FILE * fdopen(int fildes, char *mode)
+;;* <stdio.h> FILE * fopen(char *path, char *mode)
+;;* <stdio.h> FILE * freopen(char *path, char *mode, FILE *stream)
+;;* <stdio.h> FILE * fropen(void *cookie, int (*readfn)(void *, char *, int))
+;;* <stdio.h> FILE * funopen(void *cookie, int (*readfn)(void *, char *, int), int (*writefn)(void *, const char *, int), fpos_t (*seekfn)(void *, fpos_t, int), int (*closefn)(void *))
+;;* <stdio.h> FILE * fwopen(void *cookie, int (*writefn)(void *, char *, int))
+;;* <stdio.h> FILE * popen(const char *command, const char *type)
+;;* <stdio.h> FILE * tmpfile(void)
+;;* <stdio.h> FILE *stdin; FILE *stdout; FILE *stderr;
+;;* <stdio.h> char * ctermid(char *buf)
+;;* <stdio.h> char * cuserid(char *buf)
+;;* <stdio.h> char * fgetln(FILE *stream, size_t *len)
+;;* <stdio.h> char * fgets(char *str, size_t size, FILE *stream)
+;;* <stdio.h> char * gets(char *str)
+;;* <stdio.h> char * tempnam(const char *tmpdir, const char *prefix)
+;;* <stdio.h> char * tmpnam(char *str)
+;;* <stdio.h> int fclose(FILE *stream)
+;;* <stdio.h> int feof(FILE *stream)
+;;* <stdio.h> int ferror(FILE *stream)
+;;* <stdio.h> int fflush(FILE *stream)
+;;* <stdio.h> int fgetc(FILE *stream)
+;;* <stdio.h> int fgetpos(FILE *stream, fpos_t *pos)
+;;* <stdio.h> int fileno(FILE *stream)
+;;* <stdio.h> int fprintf(FILE *stream, const char *format, ...)
+;;* <stdio.h> int fpurge(FILE *stream)
+;;* <stdio.h> int fputc(int c, FILE *stream)
+;;* <stdio.h> int fputs(const char *str, FILE *stream)
+;;* <stdio.h> int fscanf(FILE *stream, const char *format, ...)
+;;* <stdio.h> int fseek(FILE *stream, long offset, int whence)
+;;* <stdio.h> int fsetpos(FILE *stream, fpos_t *pos)
+;;* <stdio.h> int getc(FILE *stream)
+;;* <stdio.h> int getchar()
+;;* <stdio.h> int getsubopt(char **optionp, char * const *tokens, char **valuep)
+;;* <stdio.h> int getw(FILE *stream)
+;;* <stdio.h> int pclose(FILE *stream)
+;;* <stdio.h> int printf(const char *format, ...)
+;;* <stdio.h> int putc(int c, FILE *stream)
+;;* <stdio.h> int putchar(int c)
+;;* <stdio.h> int puts(const char *str)
+;;* <stdio.h> int putw(int w, FILE *stream)
+;;* <stdio.h> int remove(const char *path)
+;;* <stdio.h> int rename(const char *from, const char *to)
+;;* <stdio.h> int scanf(const char *format, ...)
+;;* <stdio.h> int setlinebuf(FILE *stream)
+;;* <stdio.h> int setvbuf(FILE *stream, char *buf, int mode, size_t size)
+;;* <stdio.h> int snprintf(char *str, size_t size, const char *format, ...)
+;;* <stdio.h> int sprintf(char *str, const char *format, ...)
+;;* <stdio.h> int sscanf(const char *str, const char *format, ...)
+;;* <stdio.h> int ungetc(int c, FILE *stream)
+;;* <stdio.h> long ftell(FILE *stream)
+;;* <stdio.h> size_t fread(void *ptr, size_t size, size_t nmemb, FILE *stream)
+;;* <stdio.h> size_t fwrite(const void *ptr, size_t size, size_t nmemb, FILE *stream)
+;;* <stdio.h> void clearerr(FILE *stream)
+;;* <stdio.h> void perror(const char *string)
+;;* <stdio.h> void rewind(FILE *stream)
+;;* <stdio.h> void setbuf(FILE *stream, char *buf)
+;;* <stdio.h> void setbuffer(FILE *stream, char *buf, size_t size)
+;;* <stdio.h><stdarg.h> int vfprintf(FILE *stream, const char *format, va_list ap)
+;;* <stdio.h><stdarg.h> int vfscanf(FILE *stream, const char *format, va_list ap)
+;;* <stdio.h><stdarg.h> int vprintf(const char *format, va_list ap)
+;;* <stdio.h><stdarg.h> int vscanf(const char *format, va_list ap)
+;;* <stdio.h><stdarg.h> int vsnprintf(char *str, size_t size, const char *format, va_list ap)
+;;* <stdio.h><stdarg.h> int vsprintf(char *str, char *format, va_list ap)
+;;* <stdio.h><stdarg.h> int vsscanf(const char *str, const char *format, va_list ap)
+;;* <stdlib.h> char * cgetcap(char *buf, char *cap, char type)
+;;* <stdlib.h> char * devname(dev_t dev, mode_t type)
+;;* <stdlib.h> char * getbsize(int *headerlenp, long *blocksizep)
+;;* <stdlib.h> char * getenv(const char *name)
+;;* <stdlib.h> char * initstate(unsigned seed, char *state, int n)
+;;* <stdlib.h> char * setstate(char *state)
+;;* <stdlib.h> daemon(int nochdir, int noclose)
+;;* <stdlib.h> div_t div(int num, int denom)
+;;* <stdlib.h> double atof(const char *nptr)
+;;* <stdlib.h> double drand48(void)
+;;* <stdlib.h> double erand48(unsigned short xseed[3])
+;;* <stdlib.h> double strtod(const char *nptr, char **endptr)
+;;* <stdlib.h> int abs(int j)
+;;* <stdlib.h> int atexit(void (*function)(void))
+;;* <stdlib.h> int atoi(const char *nptr)
+;;* <stdlib.h> int cgetclose(void)
+;;* <stdlib.h> int cgetent(char **buf, char **db_array, char *name)
+;;* <stdlib.h> int cgetfirst(char **buf, char **db_array)
+;;* <stdlib.h> int cgetmatch(char *buf, char *name)
+;;* <stdlib.h> int cgetnext(char **buf, char **db_array)
+;;* <stdlib.h> int cgetnum(char *buf, char *cap, long *num)
+;;* <stdlib.h> int cgetset(char *ent)
+;;* <stdlib.h> int cgetstr(char *buf, char *cap, char **str)
+;;* <stdlib.h> int cgetustr(char *buf, char *cap, char **str)
+;;* <stdlib.h> int heapsort(void *base, size_t nmemb, size_t size, int (*compar)(const void *, const void *))
+;;* <stdlib.h> int mergesort(void *base, size_t nmemb, size_t size, int (*compar)(const void *, const void *))
+;;* <stdlib.h> int putenv(const char *string)
+;;* <stdlib.h> int rand(void)
+;;* <stdlib.h> int setenv(const char *name, const char *value, int overwrite)
+;;* <stdlib.h> int system(const char *string)
+;;* <stdlib.h> ldiv_t ldiv(long num, long denom)
+;;* <stdlib.h> long atol(const char *nptr)
+;;* <stdlib.h> long jrand48(unsigned short xseed[3])
+;;* <stdlib.h> long labs(long j)
+;;* <stdlib.h> long lrand48(void)
+;;* <stdlib.h> long mrand48(void)
+;;* <stdlib.h> long nrand48(unsigned short xseed[3])
+;;* <stdlib.h> long random(void)
+;;* <stdlib.h> qdiv_t qdiv(quad_t num, quad_t denom)
+;;* <stdlib.h> quad_t qabs(quad_t j)
+;;* <stdlib.h> unsigned short * seed48(unsigned short xseed[3])
+;;* <stdlib.h> void * alloca(size_t size)
+;;* <stdlib.h> void * bsearch(const void *key, const void *base, size_t nmemb, size_t size, int (*compar) (const void *, const void *))
+;;* <stdlib.h> void * calloc(size_t nelem, size_t elsize)
+;;* <stdlib.h> void * calloc(size_t nmemb, size_t size)
+;;* <stdlib.h> void * malloc(size_t size)
+;;* <stdlib.h> void * realloc(void *ptr, size_t size)
+;;* <stdlib.h> void abort(void)
+;;* <stdlib.h> void exit(int status)
+;;* <stdlib.h> void free(void *ptr)
+;;* <stdlib.h> void lcong48(unsigned short p[7])
+;;* <stdlib.h> void qsort(void *base, size_t nmemb, size_t size, int (*compar)(const void *, const void *))
+;;* <stdlib.h> void setproctitle(const char *fmt, ...)
+;;* <stdlib.h> void srand(unsigned seed)
+;;* <stdlib.h> void srand48(long seed)
+;;* <stdlib.h> void srandom(unsigned seed)
+;;* <stdlib.h> void unsetenv(const char *name)
+;;* <stdlib.h><limits.h> long strtol(const char *nptr, char **endptr, int base)
+;;* <stdlib.h><limits.h> unsigned long strtoul(const char *nptr, char **endptr, int base)
+;;* <stdlib.h><limits.h><sys/types.h><stdlib.h><limits.h> quad_t strtoq(const char *nptr, char **endptr, int base)
+;;* <stdlib.h><limits.h><sys/types.h><stdlib.h><limits.h> u_quad_t strtouq(const char *nptr, char **endptr, int base)
+;;* <string.h> char * index(const char *s, int c)
+;;* <string.h> char * rindex(const char *s, int c)
+;;* <string.h> char * strcat(char *s, const char * append)
+;;* <string.h> char * strcat(char *s, const char *append)
+;;* <string.h> char * strchr(const char *s, int c)
+;;* <string.h> char * strcpy(char *dst, const char *src)
+;;* <string.h> char * strdup(const char *str)
+;;* <string.h> char * strerror(int errno)
+;;* <string.h> char * strerror(int errnum)
+;;* <string.h> char * strncat(char *s, const char *append, size_t count)
+;;* <string.h> char * strncpy(char *dst, const char *src, size_t count)
+;;* <string.h> char * strncpy(char *dst, const char *src, size_t len)
+;;* <string.h> char * strpbrk(const char *s, const char *charset)
+;;* <string.h> char * strrchr(const char *s, int c)
+;;* <string.h> char * strsep(char **stringp, char *delim)
+;;* <string.h> char * strsep(char **stringp, const char *delim)
+;;* <string.h> char * strsignal(int sig)
+;;* <string.h> char * strstr(const char *big, const char *little)
+;;* <string.h> char * strtok(char *s, const char *delim)
+;;* <string.h> char * strtok(char *str, const char *sep)
+;;* <string.h> int bcmp(const void *b1, const void *b2, size_t len)
+;;* <string.h> int ffs(int value)
+;;* <string.h> int memcmp(const void *b1, const void *b2, size_t len)
+;;* <string.h> int strcasecmp(const char *s1, const char *s2)
+;;* <string.h> int strcmp(const char *s1, const char *s2)
+;;* <string.h> int strcoll(const char *s1, const char *s2)
+;;* <string.h> int strncasecmp(const char *s1, const char *s2, size_t count)
+;;* <string.h> int strncasecmp(const char *s1, const char *s2, size_t len)
+;;* <string.h> int strncmp(const char *s1, const char *s2, size_t count)
+;;* <string.h> int strncmp(const char *s1, const char *s2, size_t len)
+;;* <string.h> size_t strcspn(const char *s, const char *charset)
+;;* <string.h> size_t strlen(const char *s)
+;;* <string.h> size_t strspn(const char *s, const char *charset)
+;;* <string.h> size_t strxfrm(char *dst, const char *src, size_t n)
+;;* <string.h> void * memccpy(void *dst, const void *src, int c, size_t len)
+;;* <string.h> void * memchr(const void *b, int c, size_t len)
+;;* <string.h> void * memcpy(void *dst, const void *src, size_t len)
+;;* <string.h> void * memmove(void *dst, const void *src, size_t len)
+;;* <string.h> void * memset(void *b, int c, size_t len)
+;;* <string.h> void bcopy(const void *src, void *dst, size_t len)
+;;* <string.h> void bzero(void *b, size_t len)
+;;* <string.h> void strmode(mode_t mode, char *bp)
+;;* <string.h> void swab(const void *src, void *dst, size_t len)
+;;* <sys/disklabel.h> struct disklabel * getdiskbyname(const char *name)
+;;* <sys/file.h> int flock(int fd, int operation)
+;;* <sys/ioctl.h> int ioctl(int d, unsigned long request, char *argp)
+;;* <sys/param.h> u_long htonl(u_long hostlong)
+;;* <sys/param.h> u_long ntohl(u_long netlong)
+;;* <sys/param.h> u_short htons(u_short hostshort)
+;;* <sys/param.h> u_short ntohs(u_short netshort)
+;;* <sys/param.h><stdlib.h> char * realpath(const char *pathname, char resolvedname[MAXPATHLEN])
+;;* <sys/param.h><sys/mount.h> int fstatfs(int fd, struct statfs *buf)
+;;* <sys/param.h><sys/mount.h> int mount(const char *type, const char *dir, int flags, void *data)
+;;* <sys/param.h><sys/mount.h> int statfs(const char *path, struct statfs *buf)
+;;* <sys/param.h><sys/mount.h> int unmount(const char *dir, int flags)
+;;* <sys/param.h><sys/sysctl.h> int sysctl(int *name, u_int namelen, void *oldp, size_t *oldlenp, void *newp, size_t newlen)
+;;* <sys/param.h><sys/types.h><unistd.h> int getgroups(int gidsetlen, gid_t *gidset)
+;;* <sys/param.h><sys/ucred.h><sys/mount.h> int getfsstat(struct statfs *buf, long bufsize, int flags)
+;;* <sys/param.h><sys/ucred.h><sys/mount.h> int getmntinfo(struct statfs **mntbufp, int flags)
+;;* <sys/param.h><unistd.h> int setgroups(int ngroups, const gid_t *gidset)
+;;* <sys/queue.h> CIRCLEQ_ENTRY(TYPE)
+;;* <sys/queue.h> CIRCLEQ_HEAD(HEADNAME, TYPE)
+;;* <sys/queue.h> CIRCLEQ_INIT(CIRCLEQ_HEAD *head)
+;;* <sys/queue.h> CIRCLEQ_INSERT_AFTER(CIRCLEQ_HEAD *head, TYPE *listelm, TYPE *elm, CIRCLEQ_ENTRY NAME)
+;;* <sys/queue.h> CIRCLEQ_INSERT_BEFORE(CIRCLEQ_HEAD *head, TYPE *listelm, TYPE *elm, CIRCLEQ_ENTRY NAME)
+;;* <sys/queue.h> CIRCLEQ_INSERT_HEAD(CIRCLEQ_HEAD *head, TYPE *elm, CIRCLEQ_ENTRY NAME)
+;;* <sys/queue.h> CIRCLEQ_INSERT_TAIL(CIRCLEQ_HEAD *head, TYPE *elm, CIRCLEQ_ENTRY NAME)
+;;* <sys/queue.h> CIRCLEQ_REMOVE(CIRCLEQ_HEAD *head, TYPE *elm, CIRCLEQ_ENTRY NAME)
+;;* <sys/queue.h> LIST_ENTRY(TYPE)
+;;* <sys/queue.h> LIST_HEAD(HEADNAME, TYPE)
+;;* <sys/queue.h> LIST_INIT(LIST_HEAD *head)
+;;* <sys/queue.h> LIST_INSERT_AFTER(TYPE *listelm, TYPE *elm, LIST_ENTRY NAME)
+;;* <sys/queue.h> LIST_INSERT_BEFORE(TYPE *listelm, TYPE *elm, LIST_ENTRY NAME)
+;;* <sys/queue.h> LIST_INSERT_HEAD(LIST_HEAD *head, TYPE *elm, LIST_ENTRY NAME)
+;;* <sys/queue.h> LIST_REMOVE(TYPE *elm, LIST_ENTRY NAME)
+;;* <sys/queue.h> TAILQ_ENTRY(TYPE)
+;;* <sys/queue.h> TAILQ_HEAD(HEADNAME, TYPE)
+;;* <sys/queue.h> TAILQ_INIT(TAILQ_HEAD *head)
+;;* <sys/queue.h> TAILQ_INSERT_AFTER(TAILQ_HEAD *head, TYPE *listelm, TYPE *elm, TAILQ_ENTRY NAME)
+;;* <sys/queue.h> TAILQ_INSERT_BEFORE(TYPE *listelm, TYPE *elm, TAILQ_ENTRY NAME)
+;;* <sys/queue.h> TAILQ_INSERT_HEAD(TAILQ_HEAD *head, TYPE *elm, TAILQ_ENTRY NAME)
+;;* <sys/queue.h> TAILQ_INSERT_TAIL(TAILQ_HEAD *head, TYPE *elm, TAILQ_ENTRY NAME)
+;;* <sys/queue.h> TAILQ_REMOVE(TAILQ_HEAD *head, TYPE *elm, TAILQ_ENTRY NAME)
+;;* <sys/reboot.h> void boot(int howto)
+;;* <sys/resource.h><kvm.h> int kvm_getloadavg(kvm_t *kd, double loadavg[], int nelem)
+;;* <sys/signal.h> extern char *sys_siglist[]; extern char *sys_signame[];
+;;* <sys/signal.h> void psignal(unsigned sig, const char *s)
+;;* <sys/socket.h> int getpeername(int s, struct sockaddr *name, int *namelen)
+;;* <sys/socket.h> int getsockname(int s, struct sockaddr *name, int *namelen)
+;;* <sys/socket.h> int listen(int s, int backlog)
+;;* <sys/socket.h> int shutdown(int s, int how)
+;;* <sys/socket.h><netinet/in.h><arpa/inet.h> char * inet_ntoa(struct in_addr in)
+;;* <sys/socket.h><netinet/in.h><arpa/inet.h> int inet_aton(const char *cp, struct in_addr *pin)
+;;* <sys/socket.h><netinet/in.h><arpa/inet.h> struct in_addr inet_makeaddr(int net, int lna)
+;;* <sys/socket.h><netinet/in.h><arpa/inet.h> unsigned long inet_addr(const char *cp)
+;;* <sys/socket.h><netinet/in.h><arpa/inet.h> unsigned long inet_lnaof(struct in_addr in)
+;;* <sys/socket.h><netinet/in.h><arpa/inet.h> unsigned long inet_netof(struct in_addr in)
+;;* <sys/socket.h><netinet/in.h><arpa/inet.h> unsigned long inet_network(const char *cp)
+;;* <sys/stat.h><unistd.h> int chflags(const char *path, u_long flags)
+;;* <sys/stat.h><unistd.h> int fchflags(int fd, u_long flags)
+;;* <sys/syscall.h><unistd.h> int __syscall(quad_t number, ...)
+;;* <sys/syscall.h><unistd.h> int syscall(int number, ...)
+;;* <sys/time.h> int adjtime(const struct timeval *delta, struct timeval *olddelta)
+;;* <sys/time.h> int futimes(int fd, const struct timeval *times)
+;;* <sys/time.h> int getitimer(int which, struct itimerval *value)
+;;* <sys/time.h> int gettimeofday(struct timeval *tp, struct timezone *tzp)
+;;* <sys/time.h> int setitimer(int which, const struct itimerval *value, struct itimerval *ovalue)
+;;* <sys/time.h> int settimeofday(const struct timeval *tp, const struct timezone *tzp)
+;;* <sys/time.h> int utimes(const char *file, const struct timeval *times)
+;;* <sys/time.h><sys/resource.h> int getpriority(int which, int who)
+;;* <sys/time.h><sys/resource.h> int getrusage(int who, struct rusage *rusage)
+;;* <sys/time.h><sys/resource.h> int setpriority(int which, int who, int prio)
+;;* <sys/times.h> clock_t times(struct tms *tp)
+;;* <sys/types.h> char * sbrk(int incr)
+;;* <sys/types.h> char *ctime(clock) const time_t *clock;
+;;* <sys/types.h> double difftime(time1, time0) time_t time1; time_t time0;
+;;* <sys/types.h> int bindresvport(int sd, struct sockaddr_in **sin)
+;;* <sys/types.h> int brk(const char *addr)
+;;* <sys/types.h> int setrgid(gid_t gid)
+;;* <sys/types.h> int setruid(uid_t uid)
+;;* <sys/types.h><bm.h> bm_pat * bm_comp(u_char *pattern, size_t patlen, u_char freq[256]);
+;;* <sys/types.h><bm.h> u_char * bm_exec(bm_pat *pdesc, u_char *text, size_t len);
+;;* <sys/types.h><bm.h> void bm_free(bm_pat *pdesc);
+;;* <sys/types.h><dirent.h> DIR * opendir(const char *filename)
+;;* <sys/types.h><dirent.h> int alphasort(const void *d1, const void *d2)
+;;* <sys/types.h><dirent.h> int closedir(DIR *dirp)
+;;* <sys/types.h><dirent.h> int dirfd(DIR *dirp)
+;;* <sys/types.h><dirent.h> int scandir(const char *dirname, struct dirent ***namelist, int (*select)(struct dirent *), int (*compar)(const void *, const void *))
+;;* <sys/types.h><dirent.h> long telldir(const DIR *dirp)
+;;* <sys/types.h><dirent.h> struct dirent * readdir(DIR *dirp)
+;;* <sys/types.h><dirent.h> void rewinddir(DIR *dirp)
+;;* <sys/types.h><dirent.h> void seekdir(DIR *dirp, long loc)
+;;* <sys/types.h><grp.h> int setgroupent(int stayopen)
+;;* <sys/types.h><grp.h> struct group * getgrent(void)
+;;* <sys/types.h><grp.h> struct group * getgrgid(gid_t gid)
+;;* <sys/types.h><grp.h> struct group * getgrnam(const char *name)
+;;* <sys/types.h><grp.h> void endgrent(void)
+;;* <sys/types.h><grp.h> void setgrent(void)
+;;* <sys/types.h><limits.h><db.h> DB * dbopen(const char *file, int flags, int mode, DBTYPE type, const void *openinfo);
+;;* <sys/types.h><machine/segments.h><machine/sysarch.h> int i386_get_ldt(int start_sel, union descriptor *descs, int num_sels)
+;;* <sys/types.h><machine/segments.h><machine/sysarch.h> int i386_set_ldt(int start_sel, union descriptor *descs, int num_sels)
+;;* <sys/types.h><machine/sysarch.h> int i386_get_ioperm(u_long *iomap)
+;;* <sys/types.h><machine/sysarch.h> int i386_iopl(int iopl)
+;;* <sys/types.h><machine/sysarch.h> int i386_set_ioperm(u_long *iomap)
+;;* <sys/types.h><netinet/in.h><arpa/nameser.h><resolv.h> dn_comp(char *exp_dn, char *comp_dn, int length, char **dnptrs, char **lastdnptr)
+;;* <sys/types.h><netinet/in.h><arpa/nameser.h><resolv.h> dn_expand(u_char *msg, u_char *eomorig, u_char *comp_dn, u_char *exp_dn, int length)
+;;* <sys/types.h><netinet/in.h><arpa/nameser.h><resolv.h> res_init()
+;;* <sys/types.h><netinet/in.h><arpa/nameser.h><resolv.h> res_mkquery(int op, char *dname, int class, int type, char *data, int datalen, struct rrec *newrr, char *buf, int buflen)
+;;* <sys/types.h><netinet/in.h><arpa/nameser.h><resolv.h> res_query(char *dname, int class, int type, u_char *answer, int anslen)
+;;* <sys/types.h><netinet/in.h><arpa/nameser.h><resolv.h> res_search(char *dname, int class, int type, u_char *answer, int anslen)
+;;* <sys/types.h><netinet/in.h><arpa/nameser.h><resolv.h> res_send(char *msg, int msglen, char *answer, int anslen)
+;;* <sys/types.h><netns/ns.h> char * ns_ntoa(struct ns_addr ns)
+;;* <sys/types.h><netns/ns.h> struct ns_addr ns_addr(char *cp)
+;;* <sys/types.h><pwd.h> int setpassent(int stayopen)
+;;* <sys/types.h><pwd.h> struct passwd * getpwent(void)
+;;* <sys/types.h><pwd.h> struct passwd * getpwnam(const char *login)
+;;* <sys/types.h><pwd.h> struct passwd * getpwuid(uid_t uid)
+;;* <sys/types.h><pwd.h> void endpwent(void)
+;;* <sys/types.h><pwd.h> void setpwent(void)
+;;* <sys/types.h><regex.h> int regcomp(regex_t *preg, const char *pattern, int cflags);
+;;* <sys/types.h><regex.h> int regexec(const regex_t *preg, const char *string, size_t nmatch, regmatch_t pmatch[], int eflags);
+;;* <sys/types.h><regex.h> size_t regerror(int errcode, const regex_t *preg, char *errbuf, size_t errbuf_size);
+;;* <sys/types.h><regex.h> void regfree(regex_t *preg);
+;;* <sys/types.h><rpcsvc/ypclnt.h><rpcsvc/yp_prot.h> char * yperr_string(int incode)
+;;* <sys/types.h><rpcsvc/ypclnt.h><rpcsvc/yp_prot.h> int yp_all(char *indomain, char *inmap, struct ypall_callback *incallback)
+;;* <sys/types.h><rpcsvc/ypclnt.h><rpcsvc/yp_prot.h> int yp_bind(char *dom)
+;;* <sys/types.h><rpcsvc/ypclnt.h><rpcsvc/yp_prot.h> int yp_first(char *indomain, char *inmap, char **outkey, int *outkeylen, char **outval, int *outvallen)
+;;* <sys/types.h><rpcsvc/ypclnt.h><rpcsvc/yp_prot.h> int yp_get_default_domain(char **domp)
+;;* <sys/types.h><rpcsvc/ypclnt.h><rpcsvc/yp_prot.h> int yp_master(char *indomain, char *inmap, char **outname)
+;;* <sys/types.h><rpcsvc/ypclnt.h><rpcsvc/yp_prot.h> int yp_match(char *indomain, char *inmap, const char *inkey, int inkeylen, char **outval, int *outvallen)
+;;* <sys/types.h><rpcsvc/ypclnt.h><rpcsvc/yp_prot.h> int yp_next(char *indomain, char *inmap, char *inkey, int inkeylen, char **outkey, int *outkeylen, char **outval, int *outvallen)
+;;* <sys/types.h><rpcsvc/ypclnt.h><rpcsvc/yp_prot.h> int yp_order(char *indomain, char *inmap, char *outorder)
+;;* <sys/types.h><rpcsvc/ypclnt.h><rpcsvc/yp_prot.h> int ypprot_err(unsigned int incode)
+;;* <sys/types.h><rpcsvc/ypclnt.h><rpcsvc/yp_prot.h> void yp_unbind(char *dom)
+;;* <sys/types.h><signal.h> int sigaltstack(const struct sigaltstack *ss, struct sigaltstack *oss)
+;;* <sys/types.h><signal.h><machine/segments.h><machine/sysarch.h><machine/vm86.h> int i386_vm86(struct vm86_struct *vmcp)
+;;* <sys/types.h><sys/disklabel.h><sys/disk.h> struct disk * disk_find(char *)
+;;* <sys/types.h><sys/disklabel.h><sys/disk.h> void disk_attach(struct disk *)
+;;* <sys/types.h><sys/disklabel.h><sys/disk.h> void disk_busy(struct disk *)
+;;* <sys/types.h><sys/disklabel.h><sys/disk.h> void disk_detatch(struct disk *)
+;;* <sys/types.h><sys/disklabel.h><sys/disk.h> void disk_init(void)
+;;* <sys/types.h><sys/disklabel.h><sys/disk.h> void disk_resetstat(struct disk *)
+;;* <sys/types.h><sys/disklabel.h><sys/disk.h> void disk_unbusy(struct disk *)
+;;* <sys/types.h><sys/ipc.h> key_t ftok(const char *path, char id);
+;;* <sys/types.h><sys/ipc.h><sys/msg.h> int msgctl(int msqid, int cmd, struct msqid_ds *buf)
+;;* <sys/types.h><sys/ipc.h><sys/msg.h> int msgget(key_t key, int msgflg)
+;;* <sys/types.h><sys/ipc.h><sys/msg.h> int msgrcv(int msqid, void *msgp, size_t msgsz, long msgtyp, int msgflg)
+;;* <sys/types.h><sys/ipc.h><sys/msg.h> int msgsnd(int msqid, void *msgp, size_t msgsz, int msgflg)
+;;* <sys/types.h><sys/ipc.h><sys/msg.h> int shmctl(int shmid, int cmd, struct shmid_ds *buf)
+;;* <sys/types.h><sys/ipc.h><sys/sem.h> int semctl(int semid, int semnum, int cmd, union semun arg)
+;;* <sys/types.h><sys/ipc.h><sys/sem.h> int semget(key_t key, int nsems, int semflg)
+;;* <sys/types.h><sys/ipc.h><sys/sem.h> int semop(int semid, struct sembuf *sops, int nsops)
+;;* <sys/types.h><sys/ipc.h><sys/shm.h> int shmdt(void *shmaddr)
+;;* <sys/types.h><sys/ipc.h><sys/shm.h> int shmget(key_t key, int size, int shmflg)
+;;* <sys/types.h><sys/ipc.h><sys/shm.h> void * shmat(int shmid, void *shmaddr, int shmflg)
+;;* <sys/types.h><sys/mman.h> caddr_t mmap(caddr_t addr, size_t len, int prot, int flags, int fd, off_t offset)
+;;* <sys/types.h><sys/mman.h> int madvise(caddr_t addr, size_t len, int behav)
+;;* <sys/types.h><sys/mman.h> int mincore(caddr_t addr, size_t len, char *vec)
+;;* <sys/types.h><sys/mman.h> int mlock(caddr_t addr, size_t len)
+;;* <sys/types.h><sys/mman.h> int mprotect(caddr_t addr, size_t len, int prot)
+;;* <sys/types.h><sys/mman.h> int msync(caddr_t addr, size_t len)
+;;* <sys/types.h><sys/mman.h> int munlock(caddr_t addr, size_t len)
+;;* <sys/types.h><sys/mman.h> int munmap(caddr_t addr, size_t len)
+;;* <sys/types.h><sys/mount.h> int getfh(const char *path, fhandle_t *fhp)
+;;* <sys/types.h><sys/ptrace.h> int ptrace(int request, pid_t pid, caddr_t addr, int data)
+;;* <sys/types.h><sys/socket.h> int accept(int s, struct sockaddr *addr, int *addrlen)
+;;* <sys/types.h><sys/socket.h> int bind(int s, const struct sockaddr *name, int namelen)
+;;* <sys/types.h><sys/socket.h> int connect(int s, const struct sockaddr *name, int namelen)
+;;* <sys/types.h><sys/socket.h> int getsockopt(int s, int level, int optname, void *optval, int *optlen)
+;;* <sys/types.h><sys/socket.h> int setsockopt(int s, int level, int optname, const void *optval, int optlen)
+;;* <sys/types.h><sys/socket.h> int socket(int domain, int type, int protocol)
+;;* <sys/types.h><sys/socket.h> int socketpair(int d, int type, int protocol, int *sv)
+;;* <sys/types.h><sys/socket.h> ssize_t recv(int s, void *buf, size_t len, int flags)
+;;* <sys/types.h><sys/socket.h> ssize_t recvfrom(int s, void *buf, size_t len, int flags, struct sockaddr *from, int *fromlen)
+;;* <sys/types.h><sys/socket.h> ssize_t recvmsg(int s, struct msghdr *msg, int flags)
+;;* <sys/types.h><sys/socket.h> ssize_t send(int s, const void *msg, size_t len, int flags)
+;;* <sys/types.h><sys/socket.h> ssize_t sendmsg(int s, const struct msghdr *msg, int flags)
+;;* <sys/types.h><sys/socket.h> ssize_t sendto(int s, const void *msg, size_t len, int flags, const struct sockaddr *to, int tolen)
+;;* <sys/types.h><sys/socket.h><net/if_dl.h> char * link_ntoa(const struct sockaddr_dl *sdl)
+;;* <sys/types.h><sys/socket.h><net/if_dl.h> void link_addr(const char *addr, struct sockaddr_dl *sdl)
+;;* <sys/types.h><sys/stat.h> int chmod(const char *path, mode_t mode)
+;;* <sys/types.h><sys/stat.h> int fchmod(int fd, mode_t mode)
+;;* <sys/types.h><sys/stat.h> int fstat(int fd, struct stat *sb)
+;;* <sys/types.h><sys/stat.h> int lstat(const char *path, struct stat *sb)
+;;* <sys/types.h><sys/stat.h> int mkdir(const char *path, mode_t mode)
+;;* <sys/types.h><sys/stat.h> int mkfifo(const char *path, mode_t mode)
+;;* <sys/types.h><sys/stat.h> int stat(const char *path, struct stat *sb)
+;;* <sys/types.h><sys/stat.h> mode_t umask(mode_t numask)
+;;* <sys/types.h><sys/stat.h><fcntl.h> int creat(const char *path, mode_t mode)
+;;* <sys/types.h><sys/stat.h><fts.h> FTS * fts_open(char * const *path_argv, int options, int *compar(const FTSENT **, const FTSENT **))
+;;* <sys/types.h><sys/stat.h><fts.h> FTSENT * fts_children(FTS *ftsp, int options)
+;;* <sys/types.h><sys/stat.h><fts.h> FTSENT * fts_read(FTS *ftsp)
+;;* <sys/types.h><sys/stat.h><fts.h> int fts_close(FTS *ftsp)
+;;* <sys/types.h><sys/stat.h><fts.h> int fts_set(FTS ftsp, FTSENT *f, int options)
+;;* <sys/types.h><sys/systm.h> int copyin(void *uaddr, void *kaddr, size_t len)
+;;* <sys/types.h><sys/systm.h> int copyinstr(void *uaddr, void *kaddr, size_t len, size_t *done)
+;;* <sys/types.h><sys/systm.h> int copyout(void *kaddr, void *uaddr, size_t len)
+;;* <sys/types.h><sys/systm.h> int copyoutstr(void *kaddr, void *uaddr, size_t len, size_t *done)
+;;* <sys/types.h><sys/systm.h> int copystr(void *kfaddr, void *kdaddr, size_t len, size_t *done)
+;;* <sys/types.h><sys/systm.h> int fubyte(void *base)
+;;* <sys/types.h><sys/systm.h> int fuswintr(void *base)
+;;* <sys/types.h><sys/systm.h> int fusword(void *base)
+;;* <sys/types.h><sys/systm.h> int fuword(void *base)
+;;* <sys/types.h><sys/systm.h> int subyte(void *base)
+;;* <sys/types.h><sys/systm.h> int suswintr(void *base)
+;;* <sys/types.h><sys/systm.h> int susword(void *base)
+;;* <sys/types.h><sys/systm.h> int suword(void *base)
+;;* <sys/types.h><sys/time.h><sys/resource.h> int getrlimit(int resource, struct rlimit *rlp)
+;;* <sys/types.h><sys/time.h><sys/resource.h> int setrlimit(int resource, const struct rlimit *rlp)
+;;* <sys/types.h><sys/time.h><unistd.h> FD_CLR(fd, &fdset)
+;;* <sys/types.h><sys/time.h><unistd.h> FD_ISSET(fd, &fdset)
+;;* <sys/types.h><sys/time.h><unistd.h> FD_SET(fd, &fdset)
+;;* <sys/types.h><sys/time.h><unistd.h> FD_ZERO(&fdset)
+;;* <sys/types.h><sys/time.h><unistd.h> int select(int nfds, fd_set *readfds, fd_set *writefds, fd_set *exceptfds, struct timeval *timeout)
+;;* <sys/types.h><sys/timeb.h> int ftime(struct timeb *tp)
+;;* <sys/types.h><sys/uio.h><unistd.h> ssize_t read(int d, void *buf, size_t nbytes)
+;;* <sys/types.h><sys/uio.h><unistd.h> ssize_t readv(int d, const struct iovec *iov, int iovcnt)
+;;* <sys/types.h><sys/uio.h><unistd.h> ssize_t write(int d, const void *buf, size_t nbytes)
+;;* <sys/types.h><sys/uio.h><unistd.h> ssize_t writev(int d, const struct iovec *iov, int iovcnt)
+;;* <sys/types.h><sys/wait.h> pid_t wait(int *status)
+;;* <sys/types.h><sys/wait.h> pid_t waitpid(pid_t wpid, int *status, int options)
+;;* <sys/types.h><sys/wait.h><sys/time.h><sys/resource.h> pid_t wait3(int *status, int options, struct rusage *rusage)
+;;* <sys/types.h><sys/wait.h><sys/time.h><sys/resource.h> pid_t wait4(pid_t wpid, int *status, int options, struct rusage *rusage)
+;;* <sys/types.h><time.h> char *asctime(tm) const struct tm *tm;
+;;* <sys/types.h><time.h> struct tm *gmtime(clock) const time_t *clock;
+;;* <sys/types.h><time.h> struct tm *localtime(clock) const time_t *clock;
+;;* <sys/types.h><time.h> time_t mktime(tm) struct tm *tm;
+;;* <sys/types.h><time.h> time_t posix2time(t) time_t t
+;;* <sys/types.h><time.h> time_t time2posix(t) time_t t
+;;* <sys/types.h><unistd.h> gid_t getegid(void)
+;;* <sys/types.h><unistd.h> gid_t getgid(void)
+;;* <sys/types.h><unistd.h> int chown(const char *path, uid_t owner, gid_t group)
+;;* <sys/types.h><unistd.h> int fchown(int fd, uid_t owner, gid_t group)
+;;* <sys/types.h><unistd.h> int setegid(gid_t egid)
+;;* <sys/types.h><unistd.h> int seteuid(uid_t euid)
+;;* <sys/types.h><unistd.h> int setgid(gid_t gid)
+;;* <sys/types.h><unistd.h> int setuid(uid_t uid)
+;;* <sys/types.h><unistd.h> int tcsetpgrp(int fd, pid_t pgrp_id)
+;;* <sys/types.h><unistd.h> pid_t fork(void)
+;;* <sys/types.h><unistd.h> pid_t getpid(void)
+;;* <sys/types.h><unistd.h> pid_t getppid(void)
+;;* <sys/types.h><unistd.h> pid_t setsid(void)
+;;* <sys/types.h><unistd.h> pid_t tcgetpgrp(int fd)
+;;* <sys/types.h><unistd.h> uid_t geteuid(void)
+;;* <sys/types.h><unistd.h> uid_t getuid(void)
+;;* <sys/types.h><utime.h> int utime(const char *file, const struct utimbuf *timep)
+;;* <sys/utsname.h> int uname(struct utsname *name)
+;;* <sys/vlimit.h> vlimit(resource, value)
+;;* <sys/vtimes.h> vtimes(struct vtimes *par_vm, struct vtimes *ch_vm)
+;;* <syslog.h><varargs.h> int setlogmask(int maskpri)
+;;* <syslog.h><varargs.h> void closelog(void)
+;;* <syslog.h><varargs.h> void openlog(const char *ident, int logopt, int facility)
+;;* <syslog.h><varargs.h> void syslog(int priority, const char *message, ...)
+;;* <syslog.h><varargs.h> void vsyslog(int priority, const char *message, va_list args)
+;;* <termios.h> int cfsetispeed(struct termios *t, speed_t speed)
+;;* <termios.h> int cfsetospeed(struct termios *t, speed_t speed)
+;;* <termios.h> int tcdrain(int fd)
+;;* <termios.h> int tcflow(int fd, int action)
+;;* <termios.h> int tcflush(int fd, int action)
+;;* <termios.h> int tcgetattr(int fd, struct termios *t)
+;;* <termios.h> int tcsendbreak(int fd, int len)
+;;* <termios.h> int tcsetattr(int fd, int action, const struct termios *t)
+;;* <termios.h> speed_t cfgetispeed(const struct termios *t)
+;;* <termios.h> speed_t cfgetospeed(const struct termios *t)
+;;* <termios.h> void cfmakeraw(struct termios *t)
+;;* <termios.h> void cfsetspeed(struct termios *t, speed_t speed)
+;;* <time.h> clock_t clock(void)
+;;* <time.h> size_t strftime(char *buf, size_t maxsize, const char *format, const struct tm *timeptr)
+;;* <time.h> time_t time(time_t *tloc)
+;;* <ttyent.h> int endttyent(void)
+;;* <ttyent.h> int setttyent(void)
+;;* <ttyent.h> struct ttyent * getttyent()
+;;* <ttyent.h> struct ttyent * getttynam(char *name)
+;;* <unistd.h> char * getcwd(char *buf, size_t size)
+;;* <unistd.h> char * getlogin(void)
+;;* <unistd.h> char * getwd(char *buf)
+;;* <unistd.h> char * mktemp(char *template)
+;;* <unistd.h> char * re_comp(const char *s)
+;;* <unistd.h> char * ttyname(int fd)
+;;* <unistd.h> char * valloc(unsigned size)
+;;* <unistd.h> extern char **environ;
+;;* <unistd.h> extern char *optarg; extern int optind; extern int optopt; extern int opterr; extern int optreset;
+;;* <unistd.h> int access(const char *path, int mode)
+;;* <unistd.h> int acct(const char *file)
+;;* <unistd.h> int chdir(const char *path)
+;;* <unistd.h> int chroot(const char *dirname)
+;;* <unistd.h> int close(int d)
+;;* <unistd.h> int dup(int oldd)
+;;* <unistd.h> int dup2(int oldd, int newd)
+;;* <unistd.h> int execl(const char *path, const char *arg, ...)
+;;* <unistd.h> int execle(const char *path, const char *arg, ..., char *const envp[])
+;;* <unistd.h> int execlp(const char *file, const char *arg, ...)
+;;* <unistd.h> int exect(const char *path, char *const argv[], char *const envp[])
+;;* <unistd.h> int execv(const char *path, char *const argv[])
+;;* <unistd.h> int execve(const char *path, char *const argv[], char *const envp[])
+;;* <unistd.h> int execvp(const char *file, char *const argv[])
+;;* <unistd.h> int fchdir(int fd)
+;;* <unistd.h> int fsync(int fd)
+;;* <unistd.h> int ftruncate(int fd, off_t length)
+;;* <unistd.h> int getdomainname(char *name, int namelen)
+;;* <unistd.h> int getdtablesize(void)
+;;* <unistd.h> int getgrouplist(const char *name, gid_t basegid, gid_t *groups, int *ngroups)
+;;* <unistd.h> int gethostname(char *name, int namelen)
+;;* <unistd.h> int getopt(int argc, char * const *argv, const char *optstring)
+;;* <unistd.h> int getpagesize(void)
+;;* <unistd.h> int initgroups(const char *name, gid_t basegid)
+;;* <unistd.h> int iruserok(u_int32_t raddr, int superuser, const char *ruser, const char *luser)
+;;* <unistd.h> int isatty(int fd)
+;;* <unistd.h> int link(const char *name1, const char *name2)
+;;* <unistd.h> int mknod(const char *path, mode_t mode, dev_t dev)
+;;* <unistd.h> int mkstemp(char *template)
+;;* <unistd.h> int pause(void)
+;;* <unistd.h> int pipe(int *fildes)
+;;* <unistd.h> int rcmd(char **ahost, int inport, const char *locuser, const char *remuser, const char *cmd, int *fd2p)
+;;* <unistd.h> int re_exec(const char *s)
+;;* <unistd.h> int readlink(const char *path, char *buf, int bufsiz)
+;;* <unistd.h> int revoke(const char *path)
+;;* <unistd.h> int rmdir(const char *path)
+;;* <unistd.h> int rresvport(int *port)
+;;* <unistd.h> int ruserok(const char *rhost, int superuser, const char *ruser, const char *luser)
+;;* <unistd.h> int setdomainname(const char *name, int namelen)
+;;* <unistd.h> int sethostid(long hostid)
+;;* <unistd.h> int sethostname(const char *name, int namelen)
+;;* <unistd.h> int setlogin(const char *name)
+;;* <unistd.h> int setpgid(pid_t pid, pid_t pgrp)
+;;* <unistd.h> int setpgrp(pid_t pid, pid_t pgrp)
+;;* <unistd.h> int setregid(int rgid, int egid)
+;;* <unistd.h> int setreuid(int ruid, int euid)
+;;* <unistd.h> int swapon(const char *special)
+;;* <unistd.h> int symlink(const char *name1, const char *name2)
+;;* <unistd.h> int truncate(const char *path, off_t length)
+;;* <unistd.h> int ttyslot()
+;;* <unistd.h> int unlink(const char *path)
+;;* <unistd.h> long fpathconf(int fd, int name)
+;;* <unistd.h> long gethostid(void)
+;;* <unistd.h> long pathconf(const char *path, int name)
+;;* <unistd.h> long sysconf(int name)
+;;* <unistd.h> off_t lseek(int fildes, off_t offset, int whence)
+;;* <unistd.h> pid_t getpgrp(void)
+;;* <unistd.h> pid_t vfork(void)
+;;* <unistd.h> size_t confstr(int name, char *buf, size_t len)
+;;* <unistd.h> u_int ualarm(u_int microseconds, u_int interval)
+;;* <unistd.h> unsigned int alarm(unsigned int seconds)
+;;* <unistd.h> unsigned int sleep(unsigned int seconds)
+;;* <unistd.h> void _exit(int status)
+;;* <unistd.h> void sync(void)
+;;* <unistd.h> void usleep(u_int microseconds)
+;;* <unistd.h><nfs/nfs.h> int nfssvc(int flags, void *argstructp)
+;;* <unistd.h><sys/reboot.h> int reboot(int howto)
+;;* <util.h> #indlude <pwd.h>
+;;* <util.h> int getmaxpartitions(void)
+;;* <util.h> int getrawpartition(void)
+;;* <util.h> int login_tty(int fd)
+;;* <util.h> int logout(const char *line)
+;;* <util.h> int pw_lock(int retries)
+;;* <util.h> int pw_mkdb()
+;;* <util.h> int pw_scan(char *bp, struct passwd *pw, int *flags)
+;;* <util.h> pid_t forkpty(int *amaster, char *name, struct termios *termp, struct winsize *winp)
+;;* <util.h> void login(struct utmp *ut)
+;;* <util.h> void logwtmp(const char *line, const char *name, const char *host)
+;;* <util.h> void openpty(int *amaster, int *aslave, char *name, struct termios *termp, struct winsize *winp)
+;;* <util.h> void pw_abort()
+;;* <util.h> void pw_copy(int ffd, int tfd, struct passwd *pw)
+;;* <util.h> void pw_edit(int notsetuid, const char *filename)
+;;* <util.h> void pw;;* _
+;;* # END NetBSD Sample C++ function database
+
+;;}}}
+
+(tinytag-install)
+
+(provide 'tinytag)
+(run-hooks 'tinytag-:load-hook)
+
+;;; tinytag.el ends here
--- /dev/null
+;;; tinytf.el --- Document layout tool for (T)echnical text (F)ormat
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 1997-2007 Jari Aalto
+;; Keywords: wp
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program, call M-x tinytf-version.
+;; Look at the code with folding.el.
+
+;; COPYRIGHT NOTICE
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;; ....................................................... &t-install ...
+;; Put this file on your Emacs-Lisp load path, add following into your
+;; ~/.emacs startup file.
+;;
+;; (add-hook 'tinytf-:load-hook 'turn-on-tinytf-mode-all-buffers)
+;; (setq tinytf-:mode-prefix-key "z") ;; faster than default C-c C-z
+;; (require 'tinytf)
+;;
+;; or autoload and your Emacs starts faster, preferred method:
+;;
+;; (setq tinytf-:mode-prefix-key "z")
+;; (autoload 'tinytf-mode "tinytf" "" t)
+;; (autoload 'turn-on-tinytf-mode-maybe "tinytf" "" t)
+;;
+;; To use additional function keys, add this line:
+;;
+;; (setq tinytf-:mode-define-keys-hook
+;; '(tinytf-mode-define-keys tinytf-mode-define-f-keys)))
+;;
+;; Additional hooks to detect and format buffer (optional):
+;;
+;; (add-hook 'write-file-hooks 'tinytf-untabify-buffer)
+;; (add-hook 'find-file-hooks 'turn-on-tinytf-mode-maybe)
+;;
+;; If you feel that you have to redefine some binding to suit your
+;; keyboard better, please do add similar setup to your emacs
+;;
+;; (add-hook 'tinytf-:mode-define-keys-hook 'my-tinytf-mode-define-keys)
+;;
+;; (defun my-tinytf-mode-define-keys ()
+;; (let ((map tinytf-:mode-prefix-map))
+;; (tinytf-mode-define-keys) ;; Default keys.
+;; (tinytf-mode-define-f-keys)
+;; (define-key map "]" 'tinytf-mark-word-sample)
+;; (define-key map "[" 'ignore)
+;; (define-key map "{" 'tinytf-mark-word-emp)
+;; (define-key map "}" 'tinytf-mark-word-strong)))
+;;
+;; To make HTML, you need conversion Perl script *t2html.pl* available at
+;; http://perl-text2html.sourceforge.net/
+;;
+;; It is possible to write documentation into other files as well
+;; using TF format. There is another perl program that can extract the
+;; documentation into text/plain by omitting comments:
+;;
+;; http://cpan.perl.org/modules/by-authors/id/J/JA/JARIAALTO/
+;; ripdoc.pl
+;;
+;; For example this lisp file's documentation can be converted into HTML
+;; with following command sequence:
+;;
+;; % ripdoc.pl tinytf.el | t2html.pl > tinytf.html
+;;
+;; If you have any questions use this function to contact maintainer
+;;
+;; M-x tinytf-submit-bug-report
+
+;;}}}
+
+;;{{{ Documentation
+
+;; ..................................................... &t-commentary ...
+;;; Commentary:
+
+;; Preface, Jan 1997
+;;
+;; Late in the 1996 there was a need for a better text file
+;; handling than just plan `text-mode'. I was looking for a simple
+;; tool to generate HTML pages out of text-based documents. After some
+;; researching on the web, I still couldn't find anything that would
+;; have been strictly a text-based solution. There were many "languages"
+;; from which the HTML could be generated, but really, I didn't want
+;; to learn any new language just for that. I can understand people
+;; that write their documents still using LaTeX, but Win32 Word
+;; is much suitable and more known than any of those exotic formats.
+;; The project started by creating the tool that converted text into
+;; HTML (Perl *t2html.pl* script) and then writing a Emacs package to
+;; help writing the text files. It has been proven to be really nice
+;; combination where flexibility meets cross-platform demands.
+;;
+;; Overview of features
+;;
+;; You can use `M-x' `add-change-log-entry-other-window' (C-x 4 a) to
+;; create a standard ChangeLog record for your changes under the
+;; headings.
+;;
+;; The text layout you write
+;;
+;; o You write text in rigid format called 'Technical'
+;; o There are only two heading levels, one at column 0, and
+;; another at column 4. NO OTHER SUB-HEADINGS SUPPORTED.
+;; o Text is written at column 8, at the first standard tab position.
+;; o Each column has different meaning how text is interpreted
+;; into HTML with *t2html.pl* perl script.
+;; o The full 'Technical text format' is described in the
+;; function description of `tinytf-mode'. The most recent description
+;; is always described in the perl program t2html.pl --help
+;; o The is only a handful, natural, mark up conventions for PLAIN TEXT.
+;; The whole idea was that you do not need to learn any
+;; mark up language, but just write standard looking text, which is
+;; easily managed and edited with any editor. In addition `diff(1)',
+;; `patch(1)' and `cvs(1)' are the most effective tools to keep your
+;; "text" document project in condition and encourage others to
+;; contribute fixes to your text files.
+;;
+;; This package
+;;
+;; o Can show text in outline style manner: you can open and close
+;; headings.
+;; o Provides commands to move among headings easily.
+;; o Capitalizes heading with one command.
+;; o Numbers headings with one command.
+;; o Text is untabified in regular intervals.
+;; o On-line help in 19.30+. It assist you writing the text
+;; by displaying message in echo area: how the text is interpreted by
+;; t2html.pl program, that is, how the text would look in HTML.
+;; o Offer functions to mark text with special text MARKERS that
+;; would produce <STRONG> or <EMP> and the like in the HTML.
+;;
+;; What is Technical Format?
+;;
+;; In short: it is list of text placement and formatting rules.
+;; And you're looking at it right now in this document.
+;;
+;; This package offers minor mode for text files and helps you to
+;; maintain correct layout. You can even convert file into HTML very
+;; easily with the perl script which is usually distributed in the
+;; complete Tiny Tools Kit or available separately from the CPAN
+;; under developer account JARIAALTO. You do not need to know a shred
+;; about the HTML language itself. And it is much easier to update
+;; text files, than deal with HTML itself. When you have text ready,
+;; you just feed it to the t2html.pl perl script and it gives you
+;; nicely formatted HTML page. Writing HTML *home* pages is different
+;; story, because you usually want to include some graphics,
+;; JavaScript, PHP or JSP in the page. But putting some text document
+;; available in HTML format is easily made possible with this package.
+;;
+;; In the other hand, while you may not be interested in HTML, you
+;; could still consider writing your documents in 'Technical format'
+;; -- with word *technical* I refer to the layout of the text, which
+;; is very _rigid_. In order to use facilities in this package,
+;; e.g. heading hiding/showing, the headings must be placed in
+;; columns 0 and 4 and the first word must be in *uppercase*. The
+;; actual text you write starts at column 8.
+;;
+;; If you decide write text like this, you become accustomed to the
+;; layout very quickly and it also helps keeping your documents in
+;; the same format.
+;;
+;; All in all, this package was primarily designed to help writing
+;; text documents for t2html.pl and viewing document in *outline*
+;; styled selective display. Please refer to mode description for
+;; full details of the text layout format.
+;;
+;; TF described briefly
+;;
+;; Please note, that this section may be slightly out of date.
+;; You should read up to date information from the conversion
+;; program using command `t2html.pl' `--help' available at
+;; http://perl-text2html.sourceforge.net/ and nearest Perl CPAN
+;; http://cpan.perl.org/modules/by-authors/id/J/JA/JARIAALTO/
+;;
+;; --//-- TF description start
+;;
+;; 0123456789 123456789 123456789 123456789 123456789 column numbers
+;;
+;; Table of contents
+;;
+;; <Do not write any text inside this heading. It will>
+;; <be generated by tinytf.el automatically with M-x tinytf-toc>
+;;
+;; Heading 1 starts from left
+;;
+;; emphatised text at column 1,2,3
+;;
+;;
+;; This is heading 2 at column 4, started with big letter
+;;
+;; Standard text starts at column 8, you can
+;; *emphatize* text or make it _strong_ and show
+;; variable name like =ThisVariableSample=. notice that
+;; `ThisIsAlsoVariable' and you can even _*nest*_ the mark up.
+;; more txt in this paragraph txt txt txt txt txt txt txt txt
+;; txt txt txt txt txt txt txt txt txt txt txt txt txt txt txt
+;; txt txt txt txt txt txt txt txt txt txt txt txt txt txt txt
+;;
+;; Plain but colored text at columns 5, 6
+;;
+;; EMPhatised text starts at column 7, Like heading level 3
+;;
+;; "Special STRONG EMP text in column 7 starts with double quote"
+;;
+;; txt txt txt txt txt txt txt txt txt txt txt txt
+;; txt txt txt txt txt txt txt txt txt txt txt txt
+;; txt txt txt txt txt txt txt txt txt txt txt txt
+;;
+;; strong text at columns 9 and 11
+;;
+;; Column 10 has quotation text
+;; Column 10 has quotation text
+;; Column 10 has quotation text
+;;
+;; Column 12 is reserved for code examples
+;; Column 12 is reserved for code examples
+;; All text here are surrounded by SAMP codes
+;;
+;; Heading 2, at column 4 again
+;;
+;; txt txt txt txt txt txt txt txt txt txt txt txt
+;; txt txt txt txt txt txt txt txt txt txt txt txt
+;; txt txt txt txt txt txt txt txt txt txt txt txt
+;;
+;; o Bullet 1 txt txt txt txt txt txt txt txt
+;; ,txt txt txt txt txt txt txt txt
+;;
+;; Notice that previous paragraph ends to P-comma code,
+;; it tells this paragraph to continue in bullet
+;; mode, otherwise this column at 12 would be
+;; interpreted as SAMPLE code.
+;;
+;; o Bullet 2, text starts at column 12
+;; o Bullet 3. Bullets are advised to keep together
+;; o Bullet 4. Bullets are advised to keep together
+;;
+;; . This is ordered list nbr 1, text starts at column 12
+;; . This is ordered list nbr 2
+;; . This is ordered list nbr 3
+;;
+;; .This line uses BR code, notice the DOT-code at beginning
+;; .This line uses BR code
+;; .This line uses BR code
+;;
+;; "This is emphatized text starting at column 7"
+;; .And this text is put after the previous line with BR code
+;; "This starts as separate line just below previous one, EM"
+;; .And continues again as usual with BR code
+;;
+;; See the document #URL-BASE/document.txt, where #URL-BASE
+;; tag is substituted with -base switch contents.
+;;
+;; Make this email address clickable <foo\@site.com>
+;; Do not make this email address clickable -<bar\@site.com>,
+;; because it is only an example and not a real address.
+;; Noticed the minus(-) prefix at the beginning of url?
+;;
+;; Heading level 1 again at column 0
+;;
+;; Sub heading, column 4
+;;
+;; And regular text, column 8
+;; txt txt txt txt txt txt txt txt txt txt txt txt
+;; txt txt txt txt txt txt txt txt txt txt txt txt
+;; txt txt txt txt txt txt txt txt txt txt txt txt
+;;
+;; --//-- TF description end
+;;
+;; How do you write text
+;;
+;; This package turns on two minor modes: `tinytab-mode', that handles
+;; your TAB key movements and `tinytf-mode', the Technical format
+;; minor mode. If you're uncertain about how the column will be
+;; treated in HTML output, call following function. If you have 19.30+
+;; this is not necessary, see note about post command above.
+;;
+;; Do you wonder why 'z' prefix is default? Well, I wanted a fast
+;; key that was mostly unused. You can change that if you prefer
+;; some other key. See variable `tinytf-:mode-prefix-key'
+;;
+;; z RET tinytf-column-info-display
+;;
+;; Normal text you write as usual, but if you want to mark regions
+;; as "quotations" or "code examples" there is appropriate indent
+;; commands
+;;
+;; z / tinytf-indent-region-text
+;; z ' tinytf-indent-region-quote
+;; z ; tinytf-indent-region-sample
+;; z : tinytf-indent-region-strong
+;;
+;; z t tinytf-indent-paragraph-text
+;; z a tinytf-indent-paragraph-text-as-is
+;; z l tinytf-indent-paragraph-text-and-fill
+;; z q tinytf-indent-paragraph-quote
+;; z Q tinytf-indent-paragraph-quote-and-fill
+;; z s tinytf-indent-paragraph-sample
+;; z 0 tinytf-indent-paragraph-zero
+;;
+;; The `tinytf-indent-paragraph-text-as-is' is a bit special, because
+;; it won't fill the text while it moves the paragraph to the text
+;; position. Instead it adds symbolic <BR> codes to the front of every
+;; moved line. In HTML this ensures that the lines will be shown
+;; exactly as you see them. See also BR mark commands.
+;;
+;; There is no functions for bullet creation, because you can write
+;; them easily by hand. Use `z' `b' to fill bullet text nicely.
+;; Bullets look like this
+;;
+;; o This is bullet..
+;; and cont'd line here
+;; o Yet another bullet
+;; and cont'd line here
+;;
+;; The `tinytab-mode' will advance your tab key by 4 every time, so
+;; the text in the bullets go to the right column (12). Remember also
+;; to keep the `tinytab-return-key-mode' on, because that continues
+;; lines as they were written above when you press return. See also
+;; bullet conversion command, which reformats previous text that used
+;; dashes(-) to separate bullets.
+;;
+;; z b tinytf-bullet-format
+;;
+;; BR marking commands
+;;
+;; In Html, the text would normally wrap according to the browser's
+;; page width. But sometimes you may wish to tell exactly that
+;; it shouldn't wrap the lines according to browser. For example
+;; if you want to include a quoted text "as is" from the Usenet
+;; posts to your page, you need o add symbolic BR code to the beginning
+;; of each line. Like including the following quotation
+;;
+;; >>Jim has a good point here...
+;; >>I would have expected that the system depends on..
+;; >Yeah; but you hadn't looked at the /usr/adm/today.log
+;; >
+;;
+;; In order to add this to your page "as is"; you can do this:
+;; indent it as "Sample" and it will automatically show like that.
+;; But normally you want it to show as quoted text where you refer.
+;; Then you do:
+;;
+;; z Q tinytf-indent-paragraph-quote
+;; z m b tinytf-mark-br-paragraph
+;;
+;; Which will prepend dot-code(.) to the front of every line.
+;; You can also add the *dot-code* by yourself or use following
+;; command
+;;
+;; z m B tinytf-mark-br-line
+;;
+;; Heading writing and handling
+;;
+;; You can only use 2 heading levels, which normally suffices. Sorry,
+;; there is no support for more deeper headings. You start headings
+;; with big letters or number at column 0 or 4. Here is some
+;; specialized commands for headings.
+;;
+;; This one converts first character of each heading to
+;; uppercase. This fixes mistakenly left lowercase letters.
+;;
+;; z f h tinytf-heading-fix
+;;
+;; before command:
+;; heading
+;; heading
+;;
+;; after command:
+;; Heading
+;; Heading
+;;
+;; You can (re)number heading easily with following command. If
+;; there is no number in the line, one is added to the beginning of
+;; heading. And if you have added new heading somewhere in the
+;; middle of text, just call this function and it renumbers all
+;; headings again. Running command with *prefix* *argument* removes
+;; numbering.
+;;
+;; z f 0 tinytf-heading-numbering
+;;
+;; before command:
+;; heading
+;; heading
+;; heading
+;; heading
+;;
+;; after command:
+;; 1.0 heading
+;; 1.1 heading
+;; 2.0 heading
+;; 2.1 heading
+;;
+;; One note about renumbering. Some people write heading number so
+;; that they are closed with parenthesis. This style is not
+;; recommended with technical format style and when you do renumber,
+;; those parenthesis will be removed. The parenthesis style is not
+;; supported because the plain number style is more easily parsed
+;; and detected. In addition, the plain number style in headings is
+;; more widely used in the world.
+;;
+;; before command:
+;; 1.0) heading
+;; 1.1) heading
+;;
+;; after command:
+;; 1.0 heading
+;; 1.1 heading
+;;
+;;
+;; Heading fixing
+;;
+;; z f a `tinytf-fix-all'
+;; Does lot's of things. Trim away trailing blanks
+;; from buffer. Untabify buffer.
+;; Renumber headings if needed. Delete extra whitespace
+;; around headings.
+;;
+;; z f c `tinytf-heading-fix-case'
+;; convert current heading to lowercase
+;;
+;; z f C `tinytf-heading-fix-case-all'
+;; convert all heading to lowercase
+;;
+;; About table of contents
+;;
+;; When you write text, you don't write the table of contents, but
+;; the headings. Be sure to add heading "Table of contents" somewhere
+;; in the document. To generate table of contents use commands:
+;;
+;; z T tinytf-toc, Try with C-u argument too
+;; z mouse-1 tinytf-toc-mouse
+;;
+;; Selective display
+;;
+;; The hiding and showing of the headings and their text is done by
+;; using the outline/folding style display. There is no magic in this;
+;; but there is two interesting commands that you can use in any
+;; selective display buffer.
+;;
+;; z C-p Prints selective display (what you actually see)
+;; z C-c Copy selective display
+;;
+;; Word about key definitions when mode is turned on
+;;
+;; When the minor mode is active it overrides some commonly used
+;; key bindings and moves their original function under Control key.
+;; For example:
+;;
+;; original PgUp --> Now Control-PgUp
+;; original PgDown --> Now Control-PgDown
+;;
+;; PgUp --> Moving heading backward
+;; DownUp --> Moving heading forward
+;;
+;; If you are using X environment or your emacs recognizes mouse,
+;; then there is one handy binding that opens or closes heading
+;; levels when you click over them.
+;;
+;; [mouse-3] tinytf-mouse-context-sensitive
+;;
+;; If you press this mouse button anywhere else than over the
+;; headings, it'll call original binding. This feature is similar as
+;; what is used in folding.el
+;;
+;; Technical note: about the outline layout
+;;
+;; Speed was my primary goal when I added the outline code. But that
+;; came with a price: I would have liked that the Heading-1 were
+;; separated by at least one empty space so that the buffer would
+;; look visually better.
+;;
+;; heading1-1
+;; heading1-1
+;; heading1-2
+;; << empty space here
+;; heading2-1
+;; heading2-1
+;; heading2-2
+;;
+;; But that would have required adding some extra code to do bound
+;; checking every time the block is collapsed/opened. Currently I'm
+;; not going to add that checking because it would reduce speed and
+;; the check would cause unnecessary complexity to current code
+;; flow.
+;;
+;; Technical note: about the default prefix key z
+;;
+;; The prefix key can be defined by setting `tinytf-:mode-prefix-key'
+;; The default binding is `C-c` `C-z', but if you want more comfortable
+;; editing, you can set it to "z". When the key is a single character,
+;; the key "doubles"; i.e. pressing "zz" will generate the plain "z"
+;; character.
+;;
+;; Technical note: post command
+;;
+;; This note is valid only for old Emacs releases, prior 20.x.
+;;
+;; While you type text in the buffer, the post command activates at
+;; regular intervals to untabify the buffer. The untabify is done
+;; because it makes formatting text easier and when you print the text
+;; file, you can be sure that the output is the same regardless of
+;; the tabs.
+;;
+;; If you have Emacs 19.30+ there is additional help feature available
+;; to you. When you sit still in some column position for few seconds,
+;; the column description will be shown automatically. That should
+;; help keeping you informed of the text layout.
+;;
+;; Technical note: HTML utilities
+;;
+;; Two external utilities are searched for HTML generation:
+;; t2html.pl and htmlize.el. If these utilities are found,
+;; their locations are stored to plist of variable `tinytf-menu'.
+;; See source code of function `tinytf-utility-programs-check'
+;; for more.
+;;
+;; Known bugs
+;;
+;; In Emacs 20.6 the TinyTf pull down menu contains bold titles
+;; for certain sections. This gets almost always garbled with
+;; the first pull-down. Selecting the menu second time shows
+;; correct section names with bold letters.
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+;;{{{ Libraries and compilation
+
+(require 'tinylibm)
+
+(eval-when-compile
+ (ti::package-use-dynamic-compilation)
+ ;; Need grep-regexp-alist
+ (require 'compile))
+
+(eval-and-compile
+ (defvar tinytab-mode nil)
+ (defvar tinytab-:div-factor nil)
+ ;; Just forward declarations to shut up byte compiler.
+ (defvar font-lock-keywords)
+ (defvar font-lock-mode)
+ (defvar global-font-lock-mode)
+ (defvar grep-regexp-alist)
+ (defvar add-log-current-defun-header-regexp)
+ (autoload 'compile-internal "compile")
+ (if (or (fboundp 'htmlize-buffer)
+ (locate-library "htmlize"))
+ (autoload 'htmlize-buffer "htmlize" "" t)
+ (message "\
+ ** tinytf.el: Hm, no htmlize.el found. [you can still use this package]
+ 2001-10-10 it was at http://fly.srk.fer.hr/~hniksic/emacs/htmlize.el")))
+
+(ti::package-defgroup-tiny TinyTf tinytf-: wp
+ "Minor mode for writing text in 'Technical text format'.
+
+ o You write text in rigid format called 'Technical'
+ o There are only two heading levels, one at column 0, and
+ another at column 4. NO OTHER SUB-HEADINGS SUPPORTED.
+ o Text is written in column 8
+ o Each column has different meaning how text is intepreted
+ into html.
+ o The full 'Technical text format' is described in the
+ function description of `tinytf-mode'")
+
+;;}}}
+;;{{{ setup: hooks
+
+(defcustom tinytf-:load-hook nil
+ "*Hook that is run when package is loaded."
+ :type 'hook
+ :group 'TinyTf)
+
+(defcustom tinytf-:process-compile-hook
+ '(tinytf-compile-mode-settings)
+ "*Hook that is run when compile is called (See link check)."
+ :type 'hook
+ :group 'TinyTf)
+
+(defcustom tinytf-:move-paragraph-hook nil
+ "*Hook run with arguments BEG END of region that was moved."
+ :type 'hook
+ :group 'TinyTf)
+
+(defcustom tinytf-:fix-all-hook nil
+ "*Hook run when function `tinytf-fix-all' is called."
+ :type 'hook
+ :group 'TinyTf)
+
+(defcustom tinytf-:tinytf-mode-p-function 'tinytf-text-format-file-p
+ "*Function to check if buffer is in Techical Format.
+Function must return t or nil."
+ :type 'function
+ :group 'TinyTf)
+
+(defcustom tinytf-:t2html-link-cache-file
+ (ti::package-config-file-prefix "tinytf-link-cache.txt")
+ "*File to contains cached OK links for the link check feature."
+ :type 'filename
+ :group 'TinyTf)
+
+(defcustom tinytf-:buffer-file-name-html-source-function
+ 'tinytf-convert-buffer-file-name-html-source
+ "*Return filename from where to read plain text.
+For files this should be `buffer-file-name', but for buffer
+that are not associated with file, a temporary filename shoudl be generated.
+
+Function arguments:
+
+ buffer pointer."
+ :type 'function
+ :group 'TinyTf)
+
+(defcustom tinytf-:buffer-file-name-html-destination-function
+ 'tinytf-convert-buffer-file-name-html-destination
+ "*Return filename where the HTML is stored.
+
+Function arguments:
+
+ buffer pointer."
+ :type 'function
+ :group 'TinyTf)
+
+(defcustom tinytf-:binary-t2html
+ (let ((path (ti::file-path-to-unix
+ (ti::file-get-load-path "t2html.pl" exec-path))))
+ (if path
+ (message "tinytf.el: FOUND %s" path)
+ (message
+ (concat
+ "tinytf.el: ** No t2html.pl along PATH. "
+ "Visit http://perl-text2html.sourceforge.net/")))
+ path)
+ "Path to t2html.pl perl script. Do not rename t2html.pl."
+ :type 'filename
+ :group 'TinyTf)
+
+;;}}}
+;;{{{ setup: user config
+
+(defcustom tinytf-:heading-regexp "[A-Z0-9!]"
+ "*Heading character set regexp. This charset is case sensitive.
+If there is these characters immediately after indentation, then line
+is a heading.
+
+The default regexp is [A-Z0-9!], where the ! is used as a special control
+code. The double !! signifies in the produced html
+that there should be <hr> code before heading. Like the following.
+
+ !! This heading has HR code in the html."
+ :type '(string :tag "Charset regexp")
+ :group 'TinyTf)
+
+(defcustom tinytf-:heading-regexp-no-numbering "[!]"
+ "*When numbering headings, ignore headings matching this regexp.
+at the beginning of first word."
+ :type 'string
+ :group 'TinyTf)
+
+(defcustom tinytf-:sentence-end "[.?!][]\"')}]*[ \r\n]+"
+ "*Like `sentence-end'. Used only in movement commands."
+ :type 'string
+ :group 'TinyTf)
+
+(defcustom tinytf-:paragraph-start "^[ \t]*$"
+ "*Like `paragraph-start'. Used only in movement commands."
+ :type 'string
+ :group 'TinyTf)
+
+(when (ti::emacs-p "21") ;; Variable width faces available
+
+ (defface tinytf-quote-face
+ '((((type tty pc) (class color))
+ (:foreground "lightblue" :weight bold))
+ (t (:height 1.0 :family "Georgia" )))
+ "Face for real quotes"
+ :group 'TinyTf)
+
+ (defvar tinytf-quote-face 'tinytf-quote-face)
+
+ (defface tinytf-quote2-face
+ '((((type tty pc) (class color))
+ (:foreground "lightblue" :weight bold))
+ (t (:height 1.2 :family "helv" :italic t)))
+ "Face for temporary highlight quote"
+ :group 'TinyTf)
+
+ (defvar tinytf-quote2-face 'tinytf-quote2-face)
+
+ (defface tinytf-level-1-face
+ '((((type tty pc) (class color)) (:foreground "blue" :weight bold))
+ (t (:height 1.2 :inherit tinytf-level-2-face)))
+ "Face for titles at level 1."
+ :group 'TinyTf)
+
+ (defvar tinytf-level-1-face 'tinytf-level-1-face)
+
+ (defface tinytf-level-2-face
+ '((((type tty pc) (class color)) (:foreground "lightblue" :weight bold))
+ (t (:height 1.2 :inherit tinytf-level-3-face)))
+ "Face for titles at level 2."
+ :group 'TinyTf)
+
+ (defvar tinytf-level-2-face 'tinytf-level-2-face)
+
+ (defface tinytf-level-3-face
+ '((((type tty pc) (class color)) (:foreground "black" :weight bold))
+ (t (:height 1.2 :inherit variable-pitch)))
+ "Face for titles at level 3."
+ :group 'TinyTf)
+
+ (defvar tinytf-level-3-face 'tinytf-level-3-face))
+
+;; Order of these rexeps is very important; because there are many
+;; "override" flags set to 't.
+;;
+;; 1999-11-23 `font-lock-other-type-face' doesn't exist in XEmacs 21.1.6
+;;
+;; Please COPY this variable settign to your $HOME/.emacs if you
+;; want to change the colors. substitute `defcustom' with `setq'
+;; and delete the variable comments at the end.
+
+(defcustom tinytf-:font-lock-keywords ;; &font
+ (list
+
+ ;; Bullet
+
+ (list
+ (concat (concat "^" (make-string 8 ?\ ) "[o.] "))
+ 0 'font-lock-reference-face)
+
+ ;; bullet continue comma
+
+ (list
+ (concat (concat "^" (make-string 12 ?\ ) "[,]"))
+ 0 'font-lock-reference-face)
+
+ ;; #REF and other user defined markers. See perl script
+ ;; for option --reference REF=value that lets you define
+ ;; any markers.
+
+ (list
+ (concat "^"
+ (make-string 8 ?\ )
+ "#"
+ "[^ \t\r\r\n][^ \t\r\n][^ \t\r\n]+")
+ 0 'font-lock-type-face)
+
+ ;; Column 2 small bold blue
+
+ (list
+ (concat "^ \\([^ \t].*\\)$")
+ 1 'font-lock-builtin-face)
+
+ ;; Column 3, emphasized
+
+ (list
+ (concat "^ \\([^ \t].*\\)$")
+ 1 'font-lock-constant-face)
+
+ ;; Column 5 and 6
+
+ (list
+ (concat "^ \\([^ \t].*\\)$")
+ 1
+ 'font-lock-type-face)
+
+ (list
+ (concat "^ \\([^ \t].*\\)$")
+ 1
+ (if (or (and (fboundp 'get-face) ;; XEmacs
+ (get-face 'tinytf-quote-face))
+ (facep 'tinytf-quote-face))
+ 'tinytf-quote-face
+ 'font-lock-comment-face))
+
+ ;; Colum 7, leading double quote
+
+ (list
+ (concat "^" (make-string 7 ?\ ) "\\(\"[^ \t].*\\)$")
+ 1 'font-lock-comment-face)
+
+ ;; Colum 7 and 9, Strong [Small level 3 headers]
+
+ (list
+ (concat "^" (make-string 7 ?\ ) "\\([^ \t].*\\)$")
+ 1
+ (if (or (and (fboundp 'get-face) ;; XEmacs
+ (get-face 'tinytf-level-3-face))
+ ;; Only works in Emacs. Returns nil in XEmacs
+ (facep 'tinytf-level-3-face))
+ 'tinytf-level-3-face
+ 'font-lock-comment-face)
+ t)
+
+ (list
+ (concat "^" (make-string 9 ?\ ) "\\([^ \t].*\\)$")
+ 1 'font-lock-comment-face)
+
+ ;; Colum 10, Quotation
+
+ (list
+ (concat "^" (make-string 10 ?\ ) "\\([^ \t].*\\)$")
+ 1
+ (if (or (and (fboundp 'get-face) ;; XEmacs
+ (get-face 'tinytf-quote2-face))
+ (facep 'tinytf-quote2-face))
+ 'tinytf-quote2-face
+ 'font-lock-type-face))
+
+ (list
+ (concat "^" (make-string 11 ?\ ) "\\([^ \t].*\\)$")
+ 1 'font-lock-constant-face)
+
+ ;; ..................................................... emphasisis ...
+
+ ;; _bold_ *italic* and =small=
+
+ '("_[^ \t\r\n]+_" 0 font-lock-type-face)
+
+ '("\\*[^ \t\r\n]+\\*" 0 font-lock-variable-name-face)
+
+ '(" =[^ '\t\r\n]+=" 0 font-lock-builtin-face prepend)
+
+ ;; ISO standard date YYYY-MM-DD HH:MM
+
+ (list
+ (concat
+ "\\<[0-9][0-9][0-9][0-9]-[0-9][0-9]-[0-9][0-9]")
+ 0 'font-lock-keyword-face)
+
+ ;; .................................................... references ...
+
+ ;; A long reference. There must be space somewhere otherwise
+ ;; this regexp would overlap with the shorter reference
+ ;; (font lock would do double job)
+ ;;
+ ;; [1998-08 Phil carmody pc@foo.com in vegetarian-L]
+
+ (list
+ (let* ((re "\\(\\[[^][\r\n]+ [^][\r\n]+\\]\\)"))
+ (concat
+ "^"
+ ;; At column 8
+ (make-string 8 ?\ )
+ re))
+ 1 'font-lock-keyword-face t)
+
+ (list
+ "\\(\\[[^][\r\n]+ [^][\r\n]+\\]\\)"
+ 1 'font-lock-keyword-face)
+
+ ;; When you refer to people or to document you do it like this
+ ;;
+ ;; [phil] said that [perlguts] is the document you should read..
+
+ '("\\(\\[[^ \t\r\n]+\\]\\)" 1 font-lock-type-face t)
+
+ ;; ........................................................ strings ...
+
+ ;; Big letter words
+
+ '("\\<[A-Z][-/_.A-Z0-9]+\\>" 0 font-lock-variable-name-face)
+
+ ;; `this-string'
+
+ '("`\\([^ '\t\r\n]+\\)'" 1 font-lock-reference-face prepend)
+
+ ;; ........................................................... urls ...
+
+ ;; File names or programs
+
+ '("[ \t\r\n][\\/][^ \t\r\n]+\\>" 0 font-lock-comment-face t)
+
+ ;; URL highlighting, we won't highlight Whole URL, because
+ ;; then the document would look like Xmas tree if it had
+ ;; hundreads of links. (or tens of links)
+
+ (list
+ (concat "\\(http\\|ftp\\|news\\|wais\\)://"
+ "\\|file:/"
+ "\\|[\\][\\][^ \t\r\n]+" ;; UNC \\machine\dir
+
+ ;; There is no good regexp to detect Win32 idiotic
+ ;; "space in filenames"
+
+ "\\|\\<[a-zA-Z]:[\\][^ \t\r\n]+" ;; c:\windows\file.txt
+ "\\|\\<\\([a-zA-Z]:\\)?/[^ \t\r\n]+") ;; c:/windows/file.txt
+ 0 'font-lock-reference-face t)
+ ;; <foo@site.com> Email URLs.
+ '("\\(<[^ \t\r\n]+@[^ \t\r\n]+>\\)" 1 font-lock-reference-face t)
+
+;;; (list
+;;; (concat "^" (make-string 12 ?\ ) "\\(.*\\)$")
+;;; '(1 font-lock-reference-face))
+
+;;; #todo: Hmm, font-lock doesn't allow calling functions?
+
+;;; The font-lock could also call functions that set the matched regions.
+;;; However that doesn't seem to work. The code snippet below hangs,
+;;; But if called directly via M-x tinytf-code-p, it works ok. Don't
+;;; know what is the problem,
+
+;;; '(tinytf-code-p . font-lock-reference-face)
+
+ ;; ........................................................ heading ...
+ ;; Headings 1 and 2
+
+ (list
+ "^\\([.A-Z0-9].*\\)$"
+ 1
+ (if (or (and (fboundp 'get-face) ;; XEmacs
+ (get-face 'tinytf-level-1-face))
+ ;; Only works in Emacs. Returns nil in XEmacs
+ (facep 'tinytf-level-1-face))
+ 'tinytf-level-1-face
+ 'font-lock-keyword-face)
+ t)
+
+ (list
+ "^ \\([.A-Z0-9].*\\)$"
+ 1
+ (if (or (and (fboundp 'get-face) ;; XEmacs
+ (get-face 'tinytf-level-2-face))
+ ;; Only works in Emacs. Returns nil in XEmacs
+ (facep 'tinytf-level-2-face))
+ 'tinytf-level-2-face
+ 'font-lock-keyword-face)
+ t))
+ ;; font-lock-reference-face font-lock-keyword-face
+ ;; font-lock-type-face font-lock-function-name-face
+ ;; font-lock-string-face font-lock-comment-face
+ ;; font-lock-variable-name-face
+ ;;
+ ;; font-lock-keywords
+
+ "*Font lock keywords."
+ :type 'sexp
+ :group 'TinyTf)
+
+;;}}}
+;;{{{ suetup: private variables
+
+(defvar tinytf-:process-compile-html "tinytf-compile-html"
+ "Name of the buffer/mode used for HTML compiling.")
+
+(defvar tinytf-:process-compile-link "tinytf-compile-link"
+ "Name of the buffer/mode used for HTML link check.")
+
+(defvar tinytf-:file-last-html-generated nil
+ "Filename of the last HTML generation.")
+
+(defconst tinytf-:factor 4
+ "The indent factor. DO NOT CHANGE THIS. It is hard coded to 4.")
+
+(defconst tinytf-:heading-number-level 2
+ "*Number of levels. Zero based. Allow values 0,1,2.")
+
+(defvar tinytf-:counter nil
+ "Post command counter.")
+(make-variable-buffer-local 'tinytf-:counter)
+
+(defvar tinytf-:buffer-heading "*tinytf-headings*"
+ "List of gatehered Headings from buffer.")
+
+(defvar tinytf-:buffer-html-process "*tinytf-t2html*"
+ "Output of t2html.pl run.")
+
+(eval-and-compile
+ ;; Needed in defvar
+ (defsubst tinytf-indent (&optional level)
+ "Return indent space string at LEVEL. Default is 0."
+ (cond
+ ((eq level 2)
+ (make-string (+ (* 4 1) 3) ?\ ))
+ (t
+ (make-string (* tinytf-:factor (or level 0)) ?\ )))))
+
+(defvar tinytf-:add-log-current-defun-header-regexp
+ (concat
+ ;; [text] Detect heading Levels 1 and 2 with possible numbering
+ ;;
+ ;; 1.0 Heading level one
+ ;;
+ ;; 1.1 Heading level two
+
+ "^\\( [0-9]+\\(\\.[0-9.]+\\)+[ \t]+[A-Z].*"
+ "\\|^[0-9]+\\(\\.[0-9.]+\\)+[ \t]+[A-Z].*"
+ "\\|^ [A-Z].*"
+ "\\|^[A-Z].*"
+ "\\)")
+ "*Additional ChangeLog regepx to recognize tinytf.el headings.
+This variable's locally set to `add-log-current-defun-header-regexp'
+when `tinytf-mode' is turned on.")
+
+(defvar tinytf-:heading-ignore-regexp-form
+ '(concat
+ "Table [Oo]f [Cc]ontents"
+ ;; This is special <HR> mark, see t2html.pls
+ "\\|^[ \t]*!!"
+ "\\|^[0-9.]*[ \t]*End[ \t]*$"
+ "\\|End[ \t]+of[ \t]+\\(file\\|document\\)[ \t]*$"
+ "\\|"
+ (concat "^" ;; \\(" (tinytf-indent 0) "\\|"
+ "\\(" (tinytf-indent 1) "\\)?"
+ tinytf-:heading-regexp-no-numbering))
+ "When making Table Of Contents, ignore these headings.
+This variable contains Lisp form that is evaled to get the string.
+If nil, then include all headings, dropping none.")
+
+(defconst tinytf-:column-table
+ '(
+ ;; First the most common positions.
+ (0 ((nil "Heading 0")))
+ (4 ((nil "Heading 1")))
+ (8 ((nil "Standard text")))
+ ;; Then special positions
+ (1 ((nil "Emphatised")))
+ (2 ((nil "Emphatised")))
+ (3 ((nil "Emphatised")))
+ (5 ((nil "Normal text, colored")))
+ (6 ((nil "Normal text, colored")))
+ (7 (("\"" "Emphatised")
+ (nil "Heading 3, Strong")))
+ (8 (("o "
+ "Bullet, reguler")
+ ("\. "
+ "Bullet, numbered")
+ ("\.[^ \t]"
+ "Single line, <BR> added to the end of line")
+ (",[^ \t]"
+ "Line continues in next chapter. <P> code not added")))
+ (9 ((nil "Strong")))
+ (10 ((nil "Quotation, emphatised")))
+ (11 ((nil "Normal, colored.")))
+
+ (12 ((",[^ \t]"
+ "Bullet continues in next chapter. <P> code not added")
+ (nil
+ "Sample"))))
+ "Column positions and their properties. DO NOT TOUCH THIS.
+The positions are fixed and reflect the perl program t2html.pl's HTML generation.
+
+Format:
+ '((COL ((REGEXP-OR-NIL EXPLANATION-STRING)
+ (REGEXP-OR-NIL EXPLANATION-STRING)
+ ..))
+ (COL ((RE EXPL) (RE EXPL) ..)))")
+
+(defvar tinytf-:saved-indent-tabs-mode
+ "Buffer local variable. Holds copy of original value before `tinytf-mode'.")
+
+(defvar tinytf-:saved-left-margin
+ "Buffer local variable. Holds copy of original value before `tinytf-mode'.")
+
+(defvar tinytf-:saved-tinytab-mode
+ "Buffer local variable. Holds copy of original value before `tinytf-mode'.")
+
+(defvar tinytf-:saved-font-lock-keywords
+ "Buffer local variable. Holds copy of original value before `tinytf-mode'.")
+
+(defvar tinytf-:saved-auto-fill-function
+ "Buffer local variable. Holds copy of original value before `tinytf-mode'.")
+
+(defvar tinytf-:saved-auto-fill-inhibit-regexp
+ "Buffer local variable. Holds copy of original value before `tinytf-mode'.")
+
+(defvar tinytf-:saved-comment-start
+ "Buffer local variable. Holds copy of original value before `tinytf-mode'.")
+
+(defvar tinytf-:saved-comment-end
+ "Buffer local variable. Holds copy of original value before `tinytf-mode'.")
+
+;;}}}
+;;{{{ Experimental
+
+;;; ----------------------------------------------------------------------
+;;; #todo: experimental
+(defun tinytf-code-p (&optional limit)
+ "Determine if current text is code. LIMIT parameter is passed by font-lock."
+ (let* ((re (eval-and-compile (concat "^" (make-string 12 ?\ )))))
+ (and
+ (save-excursion
+ (beginning-of-line)
+ (and (looking-at re) ;match to return to font-lock
+ (goto-char (match-end 0))
+ (looking-at "\\(.*\\)$")))
+ (save-excursion
+ (save-match-data ;Now check if it was really ok
+ (message (ti::read-current-line))
+ (backward-line 1)
+ (or (looking-at re)
+ (progn
+ ;; skip empty lines
+ (while (and (not (bobp))
+ (not (input-pending-p))
+ (looking-at "^[ \t]*$"))
+ (backward-line 1))
+ (message (ti::read-current-line))
+
+ (when (and
+ (not (input-pending-p))
+ ;; Same indentation still
+ (looking-at re) )
+ ;; Not a P-comma code in bullet?
+ (not (looking-at ".*[,o.]"))))))))))
+
+;;; ----------------------------------------------------------------------
+;;; #todo:
+;;;
+(defun tinytf-tmp-swallow-empty-backwards ()
+ (interactive)
+ (previous-line 1)
+ (while
+ (and
+ (not (bobp))
+ (looking-at "^$"))
+ (previous-line 1)))
+
+;;; ----------------------------------------------------------------------
+;;; #todo:
+;;;
+(defun tinytf-tmp-swallow-code-backwards ()
+ (interactive)
+ (let* ((re (eval-and-compile (concat "^" (make-string 12 ?\ ))))
+ (b-cont-re (eval-and-compile (concat "^" (make-string 12 ?\ ) ",")))
+ (empty (eval-and-compile (concat "^$"))))
+ ;;(message "gulp")
+ (beginning-of-line)
+ (while
+ (and
+ (not (bobp))
+ (looking-at re))
+ (previous-line 1))
+ (if (and
+ (not (bobp))
+ (looking-at empty))
+ (progn
+ (tinytf-tmp-swallow-empty-backwards)
+ (and
+ (not (looking-at b-cont-re))
+ (looking-at re)
+ (tinytf-tmp-swallow-code-backwards))))))
+
+;;; ----------------------------------------------------------------------
+;;; #todo:
+;;;
+(defun tinytf-tmp-dxc-code-p (&optional limit)
+ (interactive)
+ (let* ((bullet (eval-and-compile
+ (concat (concat "^" (make-string 8 ?\ ) "[o.] "))))
+ (re (eval-and-compile (concat "^" (make-string 12 ?\ ))))
+ (b-cont-re (eval-and-compile (concat "^" (make-string 12 ?\ ) ",")))
+ (empty (eval-and-compile (concat "^$"))))
+
+ (and
+ (save-excursion
+ (beginning-of-line)
+ (and (looking-at re)
+ (goto-char (match-end 0))
+ ;; match to return to font-lock
+ (looking-at "\\(.*\\)$"))))
+ (save-match-data
+ (save-excursion
+ (beginning-of-line)
+ (if (looking-at empty)
+ (tinytf-tmp-swallow-empty-backwards))
+ (if (not (looking-at re))
+ nil
+ (progn
+ (tinytf-tmp-swallow-code-backwards)
+ (not (or (looking-at b-cont-re)
+ (looking-at bullet)))))))))
+
+;;; ----------------------------------------------------------------------
+;;; a simple one for testing only.
+;;; #todo:
+
+(defun tinytf-tmp-dxc-2-code-p (&optional limit)
+ (interactive)
+ (let* ((re (eval-and-compile (concat "^" (make-string 12 ?\ )))))
+ (save-excursion
+ (beginning-of-line)
+ (looking-at re))))
+
+;;}}}
+;;{{{ version
+
+;;;###autoload (autoload 'tinytf-version "tinytf" "Display commentary." t)
+
+(eval-and-compile
+ (ti::macrof-version-bug-report
+ "tinytf.el"
+ "tinytf"
+ tinytf-:version-id
+ "$Id: tinytf.el,v 2.93 2007/05/07 10:50:14 jaalto Exp $"
+ '(tinytf-:version-id
+ tinytf-:load-hook
+ tinytf-:mode-define-keys-hook
+ tinytf-:mode-hook
+ tinytf-mode
+ tinytf-:mode-map
+ tinytf-:counter
+ tinytf-:mode-name
+ tinytf-:mode-prefix-key
+ tinytf-:heading-regexp
+ tinytf-:factor
+ tinytf-:column-table)))
+
+;;}}}
+;;{{{ Minor Mode definition
+
+;;; .......................................................... &v-mode ...
+;;;###autoload (autoload 'tinytf-install-mode "tinytf" "" t)
+;;;###autoload (autoload 'tinytf-mode "tinytf" "" t)
+;;;###autoload (autoload 'turn-on-tinytf-mode "tinytf" "" t)
+;;;###autoload (autoload 'turn-off-tinytf-mode "tinytf" "" t)
+;;;###autoload (autoload 'tinytf-commentary "tinytf" "" t)
+
+(eval-and-compile
+ (ti::macrof-minor-mode-wizard
+ "tinytf-" " Tf" "\C-c\C-z" "Tf" 'TinyTf "tinytf-:" ;1-6
+
+ "Minor mode for writing and editing text in technical format (TF).
+The text layout presented in this minor mode is ment to be
+feed to t2html.pls perl script which generates html out of
+plain text file.
+
+The perl code is included in source file and can be unpacked with
+command \\[tinytf-install-files]
+
+To see the complete layout description and rules,
+run command `tinytf-commentary'. However, this description
+may be a little out of synch and you should consult perl file
+t2html.pl, available at nearest Perl CPAN http://cpan.perl.org/, for
+up to date description.
+
+Mode description:
+
+\\{tinytf-:mode-prefix-map}
+"
+
+ "Technical text format"
+
+ (progn
+ ;; reinstall is done every time, because some key definitions
+ ;; are built dynamically from current/global map
+ ;; Make C-x 4 a to detect text headings for ChangeLog
+ (tinytf-install-add-log (if tinytf-mode
+ nil
+ 'remove))
+ (cond
+ (tinytf-mode
+ (tinytf-utility-programs-check)
+ (with-buffer-modified
+ (tinytf-install-mode)
+ (make-local-variable 'tinytf-:saved-indent-tabs-mode)
+ (make-local-variable 'tinytf-:saved-left-margin)
+ (make-local-variable 'tinytf-:saved-tinytab-mode)
+ (make-local-variable 'tinytf-:saved-font-lock-keywords)
+ (make-local-variable 'tinytf-:saved-comment-start)
+ (setq tinytf-:saved-indent-tabs-mode indent-tabs-mode)
+ (setq tinytf-:saved-left-margin left-margin)
+ (setq tinytf-:saved-tinytab-mode tinytab-mode)
+ ;; Emacs 21.2 newcomment.el breaks if these are not set
+ ;; properly. When auto-fill-mode is on, the call chain is:
+ ;;
+ ;; newline
+ ;; self-insert-command
+ ;; do-auto-fill
+ ;; comment-indent-new-line (newcomment.el)
+ ;; comment-normalize-vars
+ (setq tinytf-:saved-comment-start comment-start)
+ (setq tinytf-:saved-comment-end comment-end)
+ (setq comment-start "")
+ (setq comment-end "")
+ ;; When auto fill is used, do not indent lines that
+ ;; contain special tags starting with "#", which may continue
+ ;; past the right side. The tags must all be in one line, not
+ ;; broken to multiple lines:
+ ;;
+ ;; #PIC pic/this-picture.jpg # Explanation which is long ..... ###
+ ;;
+ ;; Also, do not break long headings.
+ ;;
+ ;; 2.2 This long chapter ....
+ (make-local-variable 'auto-fill-inhibit-regexp)
+ (setq tinytf-:saved-auto-fill-inhibit-regexp auto-fill-inhibit-regexp)
+ (setq auto-fill-inhibit-regexp "^[ \t]+#\\|^[ \t]+[0-9]\\.[0-9] [A-Z]")
+ (make-local-variable 'tinytf-:saved-auto-fill-function)
+ (setq tinytf-:saved-auto-fill-function auto-fill-function)
+ (turn-on-auto-fill-mode)
+ (setq selective-display t
+ selective-display-ellipses t
+ ;; left-margin 8 ;; for return key
+ indent-tabs-mode nil)
+ (unless tinytab-mode ;;Turn on this mode
+ (setq tinytf-:saved-tinytab-mode nil)
+ (turn-on-tinytab-mode))
+ (setq tinytab-:div-factor 4) ;; advance by four spaces
+ ;; Make sure RETURN key continues indent.
+ (turn-on-tinytab-return-key-mode)
+ ;; Single space ends sentence. The Emacs default is some
+ ;; old relict that nobody uses, or should use any more.
+ (make-local-variable 'sentence-end-double-space)
+ (setq sentence-end-double-space nil)
+ ;; (make-local-variable 'sentence-end)
+ ;; (setq sentence-end "[.?!][]\"')}]*\\($\\|[ \t]\\)[ \t\r\n]*"
+ ;; Use our font lock keywords this time and save original
+ (when (boundp 'font-lock-keywords)
+ (setq tinytf-:saved-font-lock-keywords font-lock-keywords)
+ (tinytf-font-lock-mode))))
+ (t
+ (with-buffer-modified
+ ;; Restore values
+ (setq indent-tabs-mode tinytf-:saved-indent-tabs-mode)
+ (setq auto-fill-function tinytf-:saved-auto-fill-function)
+ (setq auto-fill-inhibit-regexp tinytf-:saved-auto-fill-inhibit-regexp)
+ (setq comment-start tinytf-:saved-comment-start)
+ (when (integerp tinytf-:saved-left-margin)
+ (setq left-margin tinytf-:saved-left-margin))
+ (if tinytf-:saved-tinytab-mode
+ (turn-on-tinytab-mode)
+ (turn-off-tinytab-mode))
+ (setq selective-display nil)
+ (tinytf-show-buffer)
+ (when (boundp 'font-lock-keywords)
+ (setq font-lock-keywords tinytf-:saved-font-lock-keywords)
+ (when (ti::colors-supported-p)
+ (save-excursion
+ ;; force font lock to rework everything
+ (set-buffer-modified-p nil)
+ (set-text-properties (point-min) (point-max) nil)
+ (tinytf-fontify-current-buffer-window))))))))
+
+ "Technical text writing menu."
+
+ (list
+ tinytf-:mode-easymenu-name
+ "Markup"
+ ["Mark word strong" tinytf-mark-word-strong t]
+ ["Mark word sample" tinytf-mark-word-sample t]
+ ["Mark word emphatised" tinytf-mark-word-emp t]
+ ["Mark word small" tinytf-mark-word-small t]
+ ["Mark word big" tinytf-mark-word-big t]
+ ["Mark <BR> line" tinytf-mark-br-line t]
+ ["Mark <BR> paragraph" tinytf-mark-br-paragraph t]
+ ["Unmark word" tinytf-unmark-word t]
+ "Indentation"
+ ["Convert to bullet" tinytf-bullet-format t]
+ ["Indent paragraph text" tinytf-indent-paragraph-text t]
+ ["Indent paragraph text 'as is'" tinytf-indent-paragraph-text-as-is t]
+ ["Indent paragraph text and fill" tinytf-indent-paragraph-text-and-fill t]
+ ["Indent paragraph Quote" tinytf-indent-paragraph-quote t]
+ ["Indent paragraph Quote and fill" tinytf-indent-paragraph-quote-and-fill t]
+ ["Indent paragraph Sample" tinytf-indent-paragraph-sample t]
+ (list
+ "Indent by column"
+ ["Indent paragraph zero" tinytf-indent-paragraph-zero t]
+ ["Indent paragraph 2" tinytf-indent-paragraph-2 t]
+ ["Indent paragraph 3" tinytf-indent-paragraph-3 t]
+ ["Indent paragraph 5" tinytf-indent-paragraph-5 t]
+ ["Indent paragraph 6" tinytf-indent-paragraph-6 t]
+ ["Indent paragraph 11" tinytf-indent-paragraph-11 t])
+ "----"
+ (list
+ "HTML"
+ "t2html"
+ ["HTML basic" tinytf-convert-t2html-basic
+ (get 'tinytf-mode 't2html)]
+ ["HTML frames" tinytf-convert-t2html-frame
+ (get 'tinytf-mode 't2html)]
+ ["HTML as you see" tinytf-convert-t2html-as-is
+ (get 'tinytf-mode 't2html)]
+ ["Link check" tinytf-convert-t2html-link-check
+ (get 'tinytf-mode 't2html)]
+ ["Link check (with cache)" tinytf-convert-t2html-link-check-cached
+ (get 'tinytf-mode 't2html)]
+ "----"
+ "htmlize"
+ ["HTML buffer" tinytf-convert-htmlize
+ (get 'tinytf-mode 'htmlize)]
+ "----"
+ ["View HTML with browser" tinytf-convert-view-default t]
+ ["View HTML source" tinytf-convert-view-html-source t]
+ "----"
+ ["Conversion preferences" tinytf-convert-preference-set t]
+ ["Conversion menu re-evaluate" tinytf-utility-programs-check-force t])
+ (list
+ "Indent Region"
+ ["Indent region strong" tinytf-indent-region-strong t]
+ ["Indent region sample" tinytf-indent-region-sample t]
+ ["Indent region quote" tinytf-indent-region-quote t]
+ ["Indent region text" tinytf-indent-region-text t])
+ (list
+ "Headings"
+ "Heading management"
+ ["Heading 1 backward" tinytf-heading-backward-0 t]
+ ["Heading 1 forward" tinytf-heading-forward-0 t]
+ ["Heading 2 backward" tinytf-heading-backward-any t]
+ ["Heading 2 forward" tinytf-heading-forward-any t]
+ "----"
+ ["Heading numbering" tinytf-heading-numbering t]
+ ["Heading fix 1st chars" tinytf-heading-fix t]
+ ["Heading fix case" tinytf-heading-fix-case t]
+ ["Heading fix case all" tinytf-heading-fix-case-all t]
+ "----"
+ ["Paragraph forward" tinytf-forward-paragraph t]
+ ["Paragraph backward" tinytf-backward-paragraph t])
+ (list
+ "Outline"
+ ["Hide buffer" tinytf-hide-buffer t]
+ ["Show buffer" tinytf-show-buffer t]
+ ["Hide heading" tinytf-hide t]
+ ["Show heading" tinytf-show t]
+ ["Show/hide toggle" tinytf-show-toggle t])
+ (list
+ "Misc"
+ ["Toc create" tinytf-toc t]
+ ["Toc popup" tinytf-toc-mouse t]
+ ["Toc Occur" tinytf-toc-occur t]
+ "----"
+ ["Selective display copy" ti::buffer-selective-display-copy-to t]
+ ["Selective display print" ti::buffer-selective-display-print t]
+ "----"
+ ["Untabify buffer" tinytf-untabify-buffer t]
+ ["Column info" tinytf-column-info-display t])
+ "----"
+ "Package functions"
+ ["Package version" tinytf-version t]
+ ["Package commentary" tinytf-commentary t]
+ ["Mode and menu reload" tinytf-mode-reload t]
+ ["Mode help" tinytf-mode-help t]
+ ["Mode exit and cleanup" tinytf-exit t]
+ ["Mode exit" turn-off-tinytf-mode t])
+ (progn
+ (let* ()
+ (define-key map "?" 'tinytf-mode-help)
+ (define-key map "H" nil)
+ (define-key map "Hm" 'tinytf-mode-help)
+ (define-key map "Hc" 'tinytf-commentary)
+ (define-key map "Hv" 'tinytf-version)
+ (define-key map "n" 'tinytf-heading-numbering)
+ (define-key map "u" 'tinytf-untabify-buffer)
+ ;; Toc
+ ;; mouse binding "Prefix + mouse-1"
+ (define-key map "T" 'tinytf-toc)
+ (define-key map "O" 'tinytf-toc-occur)
+ (if (ti::emacs-p)
+ (define-key map [(mouse-1)] 'tinytf-toc-mouse)
+ (define-key map [(button1)] 'tinytf-toc-mouse))
+ ;;
+ ;; Marking commands in non-shift keys
+ ;; STRONG = "."; like a heavy statement that
+ ;; ends like this: "I said that. Perioti::d!"
+ ;;
+ ;; It is most likely that you "EMP" characters most of the time;
+ ;; That's why "`" is not defined as "w-". And to Undo easily
+ ;; marking, the unmark must be fast to access via " ".
+ ;;
+ (define-key map " " 'tinytf-unmark-word)
+ (define-key map "-" 'tinytf-mark-word-strong)
+ (define-key map "'" 'tinytf-mark-word-sample) ;; code
+ (define-key map "*" 'tinytf-mark-word-emp) ;; italics
+ (define-key map "+" 'tinytf-mark-word-big)
+ (define-key map "_" 'tinytf-mark-word-small)
+ (define-key map "mB" 'tinytf-mark-br-line)
+ (define-key map "mb" 'tinytf-mark-br-paragraph)
+ ;; If you're converting some document to TF format,
+ ;; therse are the commands you will use 80% of the time.
+ (define-key map "rS" 'tinytf-indent-region-strong)
+ (define-key map "rs" 'tinytf-indent-region-sample)
+ (define-key map "rq" 'tinytf-indent-region-quote)
+ (define-key map "rt" 'tinytf-indent-region-text)
+ (define-key map "c" nil)
+ (define-key map "ct" nil)
+ (define-key map "chb" 'tinytf-convert-t2html-basic)
+ (define-key map "chf" 'tinytf-convert-t2html-frame)
+ (define-key map "cha" 'tinytf-convert-t2html-as-is)
+ (define-key map "chl" 'tinytf-convert-t2html-link-check)
+ (define-key map "chL" 'tinytf-convert-t2html-link-check-cached)
+ (define-key map "chH" 'tinytf-convert-htmlize)
+ (define-key map "cr" 'tinytf-utility-programs-check-force)
+ (define-key map "cp" 'tinytf-convert-preference-set)
+ (define-key map "cvv" 'tinytf-convert-view-default)
+ (define-key map "cvf" 'tinytf-convert-view-html-source)
+ (define-key map "b" 'tinytf-bullet-format)
+ (define-key map "t" 'tinytf-indent-paragraph-text)
+ (define-key map "a" 'tinytf-indent-paragraph-text-as-is)
+ ;; l = fil(l)
+ (define-key map "l" 'tinytf-indent-paragraph-text-and-fill)
+ (define-key map "q" 'tinytf-indent-paragraph-quote-and-fill)
+ (define-key map "Q" 'tinytf-indent-paragraph-quote)
+ (define-key map "s" 'tinytf-indent-paragraph-sample)
+ (define-key map "0" 'tinytf-indent-paragraph-zero)
+ (define-key map "1" 'tinytf-indent-paragraph-11)
+ (define-key map "2" 'tinytf-indent-paragraph-2)
+ (define-key map "3" 'tinytf-indent-paragraph-3)
+ (define-key map "5" 'tinytf-indent-paragraph-5)
+ (define-key map "6" 'tinytf-indent-paragraph-6)
+ (define-key map "f" nil)
+ (define-key map "fa" 'tinytf-fix-all)
+ (define-key map "fh" 'tinytf-heading-fix)
+ (define-key map "fC" 'tinytf-heading-fix-case-all)
+ (define-key map "fc" 'tinytf-heading-fix-case)
+ (define-key map "fn" 'tinytf-heading-fix-newlines)
+ ;; Selective display
+ (define-key map "Sp" 'ti::buffer-selective-display-print)
+ (define-key map "Sc" 'ti::buffer-selective-display-copy-to)
+ ;; Hiding
+ (define-key map "\C-q" 'tinytf-show-toggle)
+ (define-key map "\C-x" 'tinytf-hide)
+ (define-key map "\C-s" 'tinytf-show)
+ (define-key map "\C-w" 'tinytf-hide-buffer)
+ (define-key map "\C-y" 'tinytf-show-buffer)
+ ;; Info
+ (define-key map "\C-m" 'tinytf-column-info-display)
+ (define-key map "xr" 'tinytf-mode-reload)
+ (define-key map "xX" 'tinytf-exit)
+ (define-key map "xx" 'turn-off-tinytf-mode)
+ ;; Original PgUp and down keys --> move under Control key
+ (ti::copy-key-definition root-map [(control prior)] [(prior)])
+ (ti::copy-key-definition root-map [(control next)] [(next)])
+ (define-key root-map [(prior)] 'tinytf-heading-backward-any)
+ (define-key root-map [(next)] 'tinytf-heading-forward-any)
+ (define-key root-map [(shift prior)] 'tinytf-heading-backward-0)
+ (define-key root-map [(shift next)] 'tinytf-heading-forward-0)
+ ;; The Shift-prior do not always show in non-window system, so define
+ ;; these:
+ (define-key map "\C-p" 'tinytf-heading-backward-0)
+ (define-key map "\C-n" 'tinytf-heading-forward-0)
+ ;; The 'home' and 'end' keys
+ (ti::copy-key-definition root-map [(control end)] [(end)])
+ (ti::copy-key-definition root-map [(control home)] [(home)])
+ (ti::copy-key-definition root-map [(control select)] [(select)])
+ (define-key root-map [(home)] 'tinytf-backward-paragraph)
+ (define-key root-map [(select)] 'tinytf-forward-paragraph)
+ (define-key root-map [(end)] 'tinytf-forward-paragraph)
+ (if (ti::emacs-p)
+ (define-key map [(mouse-3)]
+ 'tinytf-mouse-context-sensitive)
+ (define-key map [(button3)]
+ 'tinytf-mouse-context-sensitive))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinytf-mode-define-f-keys ()
+ "Define default function key to `tinytf-:mode-map'."
+ (interactive)
+ (let* ((map tinytf-:mode-map))
+ ;; more faster keys than the "w" word markup map.
+ (define-key map [(f5)] 'tinytf-mark-word-emp)
+ (define-key map [(f7)] 'tinytf-mark-word-strong)
+ (define-key map [(f8)] 'tinytf-mark-word-sample)
+ (define-key map [(f9)] 'tinytf-unmark-word)
+ (define-key map [(f10)] 'tinytf-indent-paragraph-text-and-fill)
+ (define-key map [(f11)] 'tinytf-indent-paragraph-quote-and-fill)
+ (define-key map [(f12)] 'tinytf-indent-paragraph-sample)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-mode-reload ()
+ "Reload and activate greyed menus (if new programs available).
+If you have changed `exec-path' or added htmlize.el along
+`load-path' the menus do not know when this has happened.
+
+Calling this function re-eaxamines available utilities."
+ (interactive)
+ (tinytf-utility-programs-check-force))
+
+;;}}}
+;;{{{ mode install
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload (autoload 'tinytf-install-files "tinytf" "" t)
+(ti::macrof-install-pgp-tar tinytf-install-files "tinytf.el")
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-font-lock-mode ()
+ "Install `font-lock' support. Activates only if `tinytf-mode' is on."
+ (when (and tinytf-mode
+ (boundp 'font-lock-keywords)
+ (or (and (boundp 'font-lock-mode)
+ font-lock-mode)
+ (and (boundp 'global-font-lock-mode)
+ global-font-lock-mode)))
+ (when (font-lock-mode-maybe 1)
+ (setq font-lock-keywords tinytf-:font-lock-keywords)
+ ;; if lazy-lock is in effect, it may not fontify the current window
+ ;; Do it now.
+ (tinytf-fontify-current-buffer-window))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-install-eval-after-load (&optional uninstall)
+ "Intall or UNINSTALL `eval-after-load' for add-log.el."
+ (let* ((form '(tinytf-install-add-log-all-buffers)))
+ (cond
+ (uninstall
+ (dolist (elt after-load-alist)
+ (when (and (string-match "add-log" (car elt))
+ (member form (cdr elt)))
+ (setq after-load-alist (delete elt after-load-alist)))))
+ (t
+ (eval-after-load "add-log" form)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-install-add-log (&optional uninstall)
+ "Install or UNINSTALL add-log.el support.
+Calling this function makes variable
+`add-log-current-defun-header-regexp' local in the current
+buffer. The variable includes regexp to match heading levels so that
+the ChangeLog entry is put in parentheses:
+
+ * file.txt (This Heading): <explanation>
+ ==============
+
+References:
+
+ `tinytf-:add-log-current-defun-header-regexp'."
+ (let ((sym 'add-log-current-defun-header-regexp))
+ (when (boundp sym)
+ ;; See `add-log-current-defun'
+ (if uninstall
+ (kill-local-variable sym)
+ (make-local-variable sym)
+ (set sym tinytf-:add-log-current-defun-header-regexp)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-install-add-log-all-buffers ()
+ "Install add-log.el support for all `tinytf-mode' buffers."
+ (ti::dolist-buffer-list
+ (and tinytf-mode)
+ nil
+ nil
+ (tinytf-install-add-log)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-install (&optional uninstall verb)
+ "Install hook to mode or UNINSTALL. VERB allows verbose messages."
+ (interactive "P")
+ (ti::verb)
+ (tinytf-install-eval-after-load uninstall))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-text-format-not-p ()
+ "This is backup to verify after running `tinytf-text-format-p'.
+Function `tinytf-text-format-p' may consider the file as TF format,
+but it would be good to check few things before making decisive
+conclusion."
+ (let ()
+ (or (ti::re-search-check
+ ;; Two consequent lines together, not good.
+ "^[^ \t\r\n].*\\(\r\n\\|\r\\|\n\\)[^ \t\r\n]"
+ nil nil 'read))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-text-format-ok-p-test-toc ()
+ "Check if buffer content looks like technical format.
+This is low level check. Use `tinytf-text-format-ok-p' instead."
+ (ti::re-search-check
+ ;; 1) If we see this
+ "^Table [Oo]f [Cc]ontents[ \t]*$"
+ nil nil 'read))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-text-format-ok-p-test-headings ()
+ "Check if buffer content looks like technical format.
+This is low level check. Use `tinytf-text-format-ok-p' instead."
+ ;; See if you can find two consequtive headings. The
+ ;; extra ".*" at the end of regexp is just for debugging
+ ;; purpose: what are the lines that were matched. Headings
+ ;; may be numbered.
+ ;;
+ ;; Heading one 1.0 Heading one
+ ;;
+ ;; Heading two 1.1 Heading two
+ (ti::re-search-check
+ (concat
+ "^\\(\\([0-9]\\.[0-9.]*[0-9]\\) \\)?[A-Z][^ \t\f\r\n].*"
+ "\\(\n\n\\|\r\n\r\n\\)" ;; Two newlines
+ " \\(\\([0-9]\\.[0-9.]*[0-9]\\) \\)?[A-Z][^ \t\f\r\n].*")
+ nil nil 'read))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-text-format-ok-p-test-heading-and-text ()
+ "Check if buffer content looks like technical format.
+This is low level check. Use `tinytf-text-format-ok-p' instead."
+ ;; Try to find one heading and regular text
+ ;;
+ ;; Heading one
+ ;;
+ ;; And normal text at column 8
+ ;;
+ ;; But take into account a special case, where the text starts
+ ;; at column 7, which causes it to be rendered as "small
+ ;; heading level 3"
+ ;;
+ ;; Heading one
+ ;;
+ ;; This is small heading, at column 7, offset -1
+ ;;
+ ;; And normal text at column 8
+ ;; And normal text at column 8
+ ;;
+ ;; This is small heading, at column 7, offset -1
+ (ti::re-search-check
+ (concat
+ "^\\( \\)?\\([0-9]\\.[0-9.]*[0-9] \\)?[A-Z][A-Za-z].*"
+ "\\(\n\n\\|\r\n\r\n\\)"
+ " ? ? ?[A-Z][A-Za-z].*")
+ nil nil 'read))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-text-format-ok-p ()
+ "Check if buffer content looks like technical format."
+ (interactive)
+ (let* (case-fold-search
+ ret)
+ ;; Exclude mail messages from any checks.
+ (unless (ti::mail-mail-p)
+ (setq ret
+ (or (tinytf-text-format-ok-p-test-toc)
+ (tinytf-text-format-ok-p-test-headings)
+ (tinytf-text-format-ok-p-test-heading-and-text))))
+ (if (interactive-p)
+ (if (null ret)
+ (message "Tinytf: No TF formattting found in this buffer.")
+ (message "Tinytf: Found TF format location [%s]" ret)))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-text-format-p ()
+ "Check if buffer looks like TF format."
+ (and (tinytf-text-format-ok-p)
+ (not (tinytf-text-format-not-p))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-text-format-file-p ()
+ "Test that file extension is .txt and `tinytf-text-format-p' returns t."
+ (and (string-match
+ "\\.txt"
+ (or (buffer-file-name) ""))
+ (tinytf-text-format-p)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun turn-on-tinytf-mode-maybe ()
+ "If buffer looks like technical format, turn on `tinytf-mode'.
+References:
+ `tinytf-:tinytf-mode-p-function'."
+ (when (and tinytf-:tinytf-mode-p-function
+ (funcall tinytf-:tinytf-mode-p-function))
+ (turn-on-tinytf-mode)
+ ;; Hook must return nil
+ nil))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun turn-on-tinytf-mode-all-buffers ()
+ "Call`tinytf-mode' on in all technical format buffers. Optionally OFF.
+The buffer is detected by using function strored in variable
+`tinytf-:tinytf-mode-p-function'"
+ (interactive)
+ (when tinytf-:tinytf-mode-p-function
+ (ti::dolist-buffer-list
+ (and (null tinytf-mode)
+ (string-match "text" (downcase (symbol-name major-mode)))
+ (funcall tinytf-:tinytf-mode-p-function))
+ nil
+ nil
+ (turn-on-tinytf-mode))))
+
+;;}}}
+;;{{{ macros, defsubst
+
+;;; These macros create functions
+;;;
+;;; For some unknown reason the ByteCompiler doesn't see thse
+;;; function in the followed macros unless the functions are wrapped
+;;; inside eval-and-compile FORM.
+;;;
+;;; fmacro = function create macro
+
+(eval-and-compile
+
+;;; ----------------------------------------------------------------------
+;;;
+ (defun tinytf-fmacro-indent-region-1 (func doc col msg &rest body)
+ "Use `tinytf-fmacro-indent-region' with FUNC DOC COL MSG BODY."
+ (let* ((sym (intern (symbol-name (` (, func))))))
+ (`
+ (defun (, sym) (beg end &optional verb)
+ (, doc)
+ (interactive "*r")
+ (ti::verb)
+ (let* ((reg
+ (tinytf-move-paragraph-to-column
+ beg end (, col)
+ (if verb
+ (, msg)))))
+ (,@ body))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+ (defun tinytf-fmacro-mark-word-1 (func doc char1 &optional char2)
+ "Use `tinytf-fmacro-mark-word' with FUNC DOC CHAR1 CHAR2."
+ (let* ((sym (intern (symbol-name (` (, func))))))
+ (`
+ (defun (, sym) ()
+ (, doc)
+ (interactive "*")
+ (unless (ti::space-p (preceding-char))
+ (skip-chars-backward "^ ,\t\f\r\n"))
+ (insert (char-to-string (, char1)))
+ (skip-chars-forward "^ ,\t\f\r\n")
+ (insert (char-to-string (or (, char2) (, char1))))
+ (skip-chars-forward " ,\t\f\r\n")))))
+
+;;; ----------------------------------------------------------------------
+;;;
+ (defun tinytf-paragraph-bounds ()
+ "Return (beg . end) points of paragraph."
+ (let* ((empty-line (ti::nil-p (ti::read-current-line)))
+ beg
+ end)
+ (save-excursion
+ (save-excursion
+ (if (not empty-line)
+ (or (re-search-backward "^[ \t]*$" nil t)
+ (ti::pmin)))
+ (setq beg (point)))
+ (if empty-line
+ (skip-chars-forward " \t\r\n"))
+ (or (re-search-forward "^[ \t]*$" nil t) (ti::pmax))
+ (setq end (point)))
+ (if (and beg end)
+ (cons beg end))))
+
+;;; ----------------------------------------------------------------------
+;;;
+ (defun tinytf-fmacro-indent-paragraph-1 (func doc col msg &rest body)
+ "Use `tinytf-fmacro-indent-paragraph'."
+ (let* ((sym (intern (symbol-name (` (, func))))))
+ (`
+ (defun (, sym) (&optional verb)
+ (, doc)
+ (interactive "*")
+ (let* ((region (tinytf-paragraph-bounds))
+ (beg (car-safe region))
+ (end (cdr-safe region)))
+ (ti::verb)
+ (if (null region)
+ (if verb (message "%s: Cannot find paragraph bounds."
+ tinytf-:mode-name))
+ (tinytf-move-paragraph-to-column
+ beg
+ end
+ (, col)
+ (if verb
+ (, msg))
+ 'noask)
+ (,@ body)))))))
+
+;;; --++-- --++-- --++-- --++-- --++-- --++-- --++-- --++-- - eval end --
+ ) ;; eval-end
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro tinytf-fmacro-indent-region (func doc col msg &optional body)
+ "Create indent function FUNC with DOC COL MSG BODY.
+Created function arguments: (beg end &optional verb)"
+ (` (, (tinytf-fmacro-indent-region-1
+ func
+ doc
+ col
+ msg
+ body))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro tinytf-fmacro-mark-word (func doc char1 &optional char2)
+ "Create word marking function FUNC with DOC and CHAR.
+Created function arguments: ()"
+ (` (, (tinytf-fmacro-mark-word-1
+ func doc char1 char2))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinytf-fmacro-indent-paragraph 'edebug-form-spec '(body))
+(defmacro tinytf-fmacro-indent-paragraph (func doc col msg &optional body)
+ "Create word marking function FUNC with DOC and COL, MSG and BODY.
+Created function arguments: ()"
+ (` (, (tinytf-fmacro-indent-paragraph-1
+ func doc col msg body))))
+
+;;; These are conventional macros
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinytf-paragraph-macro 'lisp-indent-function 0)
+(put 'tinytf-paragraph-macro 'edebug-form-spec '(body))
+(defmacro tinytf-paragraph-macro (&rest body)
+ "Set paragraph values locally while executing BODY."
+ (`
+ (let* ((sentence-end tinytf-:sentence-end)
+ (paragraph-start tinytf-:paragraph-start)
+ (paragraph-separate paragraph-start))
+ (,@ body))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinytf-heading-macro 'lisp-indent-function 0)
+(put 'tinytf-heading-macro 'edebug-form-spec '(body))
+(defmacro tinytf-heading-macro (&rest body)
+ "Map over every heading. The point sits at the beginning of heading text.
+The BODY must move the point so that next heading can be found."
+ (`
+ (let* ((RE-search (concat
+ (tinytf-regexp)
+ (if (> tinytf-:heading-number-level 0)
+ (concat "\\|" (tinytf-regexp 1)))
+ (if (> tinytf-:heading-number-level 1)
+ (concat "\\|" (tinytf-regexp 2)))))
+ (RE-no (or (eval tinytf-:heading-ignore-regexp-form)
+ "NothingMatchesLikeThis")))
+ (save-excursion
+ (tinytf-heading-start)
+ (while (re-search-forward RE-search nil t)
+ (unless (string-match RE-no (ti::read-current-line))
+ (,@ body)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinytf-level-macro 'lisp-indent-function 0)
+(put 'tinytf-level-macro 'edebug-form-spec '(body))
+(defmacro tinytf-level-macro (&rest body)
+ "Search begin point of current heading level or signal error.
+You can refer to variable 'level' and 'beg' and 'end' in the BODY.
+The point is at start of level."
+ (`
+ (let* ((level (tinytf-level-number))
+ beg
+ end)
+ (unless level
+ (if (tinytf-heading-backward-any)
+ (setq level (tinytf-level-number))
+ (error "Can't find begin point")))
+ (setq beg (point)
+ end (tinytf-block-end))
+ (goto-char beg)
+ (,@ body))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinytf-regexp (&optional level)
+ "Return indent regexp string at LEVEL."
+ ;; control character are not counted, like ^L page mark
+ (concat "^" (tinytf-indent level) tinytf-:heading-regexp))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinytf-level-p (&optional level)
+ "Check if line is LEVEL."
+ (let* (case-fold-search) ;case sensitive match
+ (save-excursion
+ (beginning-of-line)
+ (looking-at (tinytf-regexp level)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinytf-level-number ()
+ "Check current level on this line."
+ (cond
+ ((tinytf-level-p 0) 0)
+ ((tinytf-level-p 1) 1)
+ ((tinytf-level-p 2) 2)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinytf-block-end ()
+ "Return text block end."
+ (save-excursion
+ (if (null (tinytf-heading-forward-any))
+ (point-max)
+ (beginning-of-line)
+ (1- (point)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinytf-heading-number-regexp (&optional no-grouping)
+ "Return heading number regexp: match 'N.n ' or 'N.n) '.
+If NO-GROUPING is non-nil, the regexp will not have regexp group operator."
+ (if no-grouping
+ "[0-9]+\\.[0-9.]*[0-9])?[ \t]+"
+ "\\([0-9]+\\.[0-9.]*[0-9])?[ \t]+\\)"))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinytf-headings-numbered-p ()
+ "Check if first heading is numbered."
+ (save-excursion
+ (ti::pmin)
+ (re-search-forward (tinytf-heading-number-regexp) nil t)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinytf-heading-string (&rest levels)
+ "Return heading string. 'MAJOR.MINOR '."
+ (let ((str (number-to-string (pop levels))))
+ (dolist (nbr levels)
+ (setq str (concat str "." (number-to-string nbr))))
+ (concat str " ")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-goto-non-space ()
+ "Goto first non-whitespace of bol."
+ (beginning-of-line)
+ (if (re-search-forward "^[ \t]+" (line-end-position) t)
+ (goto-char (match-end 0))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinytf-heading-same-p (level heading-regexp)
+ "Check if heading LEVEL is identical to HEADING-REGEXP.
+After the regexp there must be non whitespace, which starts the heading
+name."
+ (save-match-data
+ (save-excursion
+ (beginning-of-line)
+ (looking-at (concat
+ "^"
+ (tinytf-indent level)
+ heading-regexp
+ ;; After the spaces there must be NON-space to start
+ ;; the heading name
+ "[^ \t]")))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-toc-goto ()
+ "Goto Table of contents and return t or to `point-min'."
+ (ti::pmin)
+ (when (re-search-forward "^Table [Oo]f [Cc]ontents[ \t]*$" nil t)
+ (beginning-of-line)
+ t))
+
+;;}}}
+;;{{{ Conversions
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-convert-preference-set ()
+ "Set HTML conversion preferences."
+ (interactive)
+ (message "tinytf-convert-preference-set is not yet implemented.")
+ (sleep-for 2))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinytf-convert-view-macro 'lisp-indent-function 0)
+(put 'tinytf-convert-view-macro 'edebug-form-spec '(body))
+(defmacro tinytf-convert-view-macro (&rest body)
+ "Check file `tinytf-:file-last-html-generated' and run BODY."
+ (`
+ (let* ((file tinytf-:file-last-html-generated))
+ (when (or (not file)
+ (not (file-exists-p file)))
+ (error "TinyTf: Can't view HTML, file not available [%s]"
+ (prin1-to-string file)))
+ (,@ body))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-convert-view-default ()
+ "View last HTML with `browse-url'."
+ (interactive)
+ (tinytf-convert-view-macro
+ ;; (browse-url file)
+ (tinyurl-agent-funcall 'url file)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-convert-view-html-source ()
+ "View last HTML with `find-file-other-window'."
+ (interactive)
+ (tinytf-convert-view-macro
+ (find-file-other-window file)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinytf-convert-file-name-html (file)
+ "Make FILE.txt FILE.html"
+ (concat (file-name-sans-extension file) ".html"))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-convert-buffer-file-name-html-source (buffer)
+ "Return filename from where to read plain text.
+For files this should be `buffer-file-name', but for buffer
+that are not associated with file, a temporary filename is
+generated using `ti::temp-file'."
+ (or (buffer-file-name buffer)
+ (ti::temp-file "tinytf-temp.html" 'temp-dir)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-convert-html-source (&optional buffer)
+ "Return BUFFER's source file name. Default is `current-buffer'.
+See `tinytf-:buffer-file-name-html-source-function'"
+ (or (funcall
+ tinytf-:buffer-file-name-html-source-function
+ (or buffer
+ (current-buffer)))
+ (error "TinyTf: HTML source function failed.")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-convert-html-destinaton (&optional buffer)
+ "Return BUFFER's destination file name. Default is `current-buffer'.
+See `tinytf-:buffer-file-name-html-destination-function'"
+ (let* ((file (funcall
+ tinytf-:buffer-file-name-html-destination-function
+ (or buffer
+ (current-buffer)))))
+ (unless file
+ (error "TinyTf: HTML destination function failed %s."
+ (prin1-to-string
+ tinytf-:buffer-file-name-html-destination-function)))
+ (setq tinytf-:file-last-html-generated file)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinytf-file-name-html (file)
+ "Make FILE.txt => FILE.html"
+ (concat (file-name-sans-extension file) ".html"))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-convert-buffer-file-name-html-destination (buffer)
+ "Make buffer's FILE.txt => FILE.html"
+ (tinytf-file-name-html (buffer-file-name buffer)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinyperl-convert-binary-t2html ()
+ "Return t2html.el full path."
+ (let ((bin (get 'tinytf-mode 't2html)))
+ (when (or (not bin)
+ (not (file-exists-p bin)))
+ (error
+ (substitute-command-keys "\
+No t2html.pl available. Run HTML=>Conversion menu re-evaluate\
+ \\[tinytf-utility-programs-check-force]")))
+ bin))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinytf-convert-wrapper-macro 'lisp-indent-function 1)
+(put 'tinytf-convert-wrapper-macro 'edebug-form-spec '(body))
+(defmacro tinytf-convert-wrapper-macro (temp &rest body)
+ "Define some common variables in `let'.
+
+Variables available:
+
+ file-name Buffer's file name or nil
+ file The filename (possibley generated) for HTML output.
+
+Input:
+
+ TEMP if non-nil, write temporary buffers to disk
+ BODY rest of the lisp forms."
+ (`
+ (let* ((file-name (buffer-file-name))
+ (file (tinytf-convert-html-source)))
+ (when (and (, temp)
+ (null file-name))
+ (let* ((buffer (current-buffer)))
+ (with-temp-buffer
+ (insert-buffer buffer)
+ (write-region (point-min) (point-max) file))))
+ (,@ body))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-convert-call-process (&optional options process mode)
+ "Convert buffer using Perl t2html.pl.
+In order to use this function, `tinytf-utility-programs-check' must
+have been called to set location of perl script.
+
+The current buffer is used as source. Temporary buffers
+are written on disk.
+
+Input:
+
+ OPTIONS List of option to be passed to t2html.pl
+ Following options are usually the minunum:
+ '(\"--Out\" \"buffer-file-name.txt\")
+ Nil values will be ignored.
+
+ PROCESS 'compile [this is default]
+ 'call-prosess, see also MODE
+
+ MODE This is only used for PROCESS 'call-process
+ 'noerr = Do not display log on error.
+ 'display = Display the result buffer
+ nil = Dislpay on only if process printed something
+ (a possible HTML conversion error)
+
+Return:
+
+ '(html-file-name status). non-nil status is an error.
+ Status may also be compile buffer process."
+ (interactive)
+ (setq options (delq nil options))
+ (tinytf-convert-wrapper-macro 'temp-write
+ (message "TinyTf: Generating HTML... (t2html) %s" file-name)
+ ;; This may take a while
+ ;; We feed the script to Perl and that works in every
+ ;; platform.
+ (let* ((log (get-buffer-create tinytf-:buffer-html-process))
+ (target (tinytf-convert-html-destinaton))
+ (dir (file-name-directory target))
+ (opt (append options
+ (list
+ "--Out-dir"
+ dir
+ "--Out"
+ file)))
+ status)
+ (with-current-buffer log
+ (insert (format "\nTinyTf: t2html.pl run %s\n"
+ (ti::date-standard-date 'minutes)))
+
+ (insert (format "Source: %s\n" file)
+ (format "Target: %s\n" target))
+ (cond
+ ((eq process 'call-process)
+ (with-temp-buffer
+ (apply 'call-process "perl"
+ nil
+ (current-buffer)
+ nil
+ (tinyperl-convert-binary-t2html)
+ opt)
+ (message "TinyTf: Generating HTML...done. %s" target)
+ (cond
+ ((or (eq mode 'display)
+ (and (null mode)
+ (not (ti::buffer-empty-p))))
+ (setq status 'error)
+ (append-to-buffer log (point-min) (point-max))
+ (display-buffer log))
+ ((eq mode 'noerr)
+ nil))))
+ (t
+ (let* ((command (concat
+ "perl "
+ (tinyperl-convert-binary-t2html)
+ " "
+ " --print-url "
+ (ti::list-to-string opt))))
+ (compile-internal command
+ "No more lines."
+ tinytf-:process-compile-html
+ nil nil)
+ ;; Turn on URL recognizer so that lines can be clicked
+ (with-current-buffer
+ (get-buffer
+ (format "*%s*"
+ tinytf-:process-compile-html))
+ (run-hooks 'tinytf-:process-compile-hook))
+ (message "TinyTf: Generating HTML... compile. %s"
+ target))))
+ (ti::append-to-buffer
+ log
+ (format "\nEnd: %s\n"
+ (ti::date-standard-date 'minutes)))
+ (list target status)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinytf-convert-extra-options ()
+ "If there is #t2html-* tag, return list of additional options."
+ (when (ti::re-search-check "#t2html-")
+ '("--Auto-detect")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-convert-t2html-basic ()
+ "Make 1-page HTML."
+ (interactive)
+ (tinytf-convert-call-process
+ (tinytf-convert-extra-options)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-convert-t2html-frame ()
+ "Make HTML with frames using t2html.pl"
+ (interactive)
+ (tinytf-convert-call-process
+ (append
+ (tinytf-convert-extra-options)
+ (list "--html-frame"))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-convert-t2html-as-is ()
+ "Make HTML with frames using t2html.pl"
+ (interactive)
+ (tinytf-convert-call-process '("--as-is")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-convert-t2html-link-check (&optional options)
+ "Call t2html.pl to check links with OPTIONS."
+ (interactive)
+ (tinytf-convert-wrapper-macro 'temp-write
+ (let* ((command-args
+ (concat "perl "
+ (tinyperl-convert-binary-t2html)
+ " "
+ (or options
+ "--link-check --quiet")
+ " "
+ file)))
+ ;; compile-internal:
+ ;; command
+ ;; error-message
+ ;; &optional
+ ;; name-of-mode
+ ;; parser
+ ;; error-regexp-alist
+ ;; name-function
+ ;; enter-regexp-alist
+ ;; leave-regexp-alist
+ ;; file-regexp-alist
+ ;; nomessage-regexp-alist
+ (compile-internal command-args
+ "No more lines."
+ tinytf-:process-compile-html
+ nil
+ grep-regexp-alist))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-convert-t2html-link-check-cached ()
+ "Call t2html.pl to check links by using `tinytf-:t2html-link-cache-file'."
+ (interactive)
+ (unless (stringp tinytf-:t2html-link-cache-file)
+ (error "Tinytf: `tinytf-:t2html-link-cache-file' must contain filename."))
+ (tinytf-convert-t2html-link-check
+ (format "--link-check --quiet --Link-cache %s"
+ tinytf-:t2html-link-cache-file)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-compile-mode-settings ()
+ "Install font lock and additional keybindings for Link check."
+ (let* ()))
+ ;; #todo: font-lock
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-convert-htmlize ()
+ "Convert buffer using Perl htmlize.el"
+ (interactive)
+ (unless (fboundp 'htmlize-buffer)
+ (error "TinyTf: `htmlize-buffer' is not available. You need htmlize.el"))
+ (let* ((path (get 'tinytf-mode 'htmlize))
+ (dir (file-name-directory path))
+ (elc (concat dir "htmlize.elc")))
+ (unless (file-exists-p elc)
+ (message "TinyTf: (performance) Please compile %s" path)
+ (sit-for 0.5)))
+ (let* ((html-buffer "*html*") ;; Thisis in htmlize.el, but hard coded
+ (buffer (current-buffer)))
+ ;; Prevent multple *html* buffers.
+ (if (get-buffer html-buffer)
+ (kill-buffer (get-buffer html-buffer)))
+
+ (tinytf-convert-wrapper-macro nil
+ (message "TinyTf: Generating HTML... (htmlize) %s" file-name)
+ (ti::funcall 'htmlize-buffer)
+ (with-current-buffer html-buffer
+ (write-region
+ (point-min)
+ (point-max)
+ (tinytf-convert-html-destinaton buffer)))
+ (message "TinyTf: Generating HTML...done. %s"
+ (tinytf-convert-file-name-html file)))))
+
+;;}}}
+;;{{{ misc:
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-utility-programs-check (&optional force verb)
+ "Set or disable found utilities (HTML converters). FORCE check.
+The settings will affect the main drop-down menu. If you install
+htmllize.el or t2html.pl to the system after package ais loaded,
+you must run this function.
+
+Reference:
+
+ See (symbol-plist 'tinytf-mode)."
+ (interactive (list t t))
+ (let* ((sym 'tinytf-mode)
+ ;; Affects expand-file-name to use only / in XEmacs
+ (path-separator ?/))
+ (when (or force
+ (null (get sym 't2html-checked)))
+ (let* ((path (progn
+ ;; Print messages because searching PATH may take
+ ;; some time
+ (when verb
+ (message "Tinytf: searching t2html.pl..."))
+ (prog1
+ (ti::file-get-load-path "t2html.pl" exec-path)
+ (when verb
+ (message "Tinytf: searching t2html.pl... Done.")))))
+ ;; convert to use only forward slashes.
+ (path2 (or tinytf-:binary-t2html path))
+ (bin (and path2
+ (file-exists-p path2)
+ (expand-file-name path2))))
+ (cond
+ (bin
+ (put sym 't2html-checked t)
+ (put sym 't2html bin))
+ (verb
+ (message "Tinytf: Cannot find t2html.pl along `exec-path'.")))))
+ (when (or force
+ (null (get sym 'htmlize-checked)))
+ (let* ((path (locate-library "htmlize.el")))
+ (cond
+ (path
+ (put sym 'htmlize-checked t)
+ (put sym 'htmlize path))
+ (verb
+ (message "Tinytf: Cannot find htmlize.pl along `load-path'.")))))
+ (list
+ (get sym 'htmlize)
+ (get sym 't2html))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-utility-programs-check-force ()
+ "Re-evaluate menu and find new conversion programs.
+The menu items are greyed out if the conversion programs were no
+available during startup. If you later install the conversion programs
+either to PATH or `load-path', run this function to enable menu
+selections.
+
+This function calls `tinytf-utility-programs-check' with 'force."
+ (interactive)
+ (tinytf-utility-programs-check 'force 'verb))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-fontify-current-buffer-window ()
+ "Fontify current buffer's window."
+ (let* ((buffer (current-buffer))
+ (win (get-buffer-window buffer)))
+ (when (and win
+ (window-live-p win)
+ (or font-lock-mode
+ global-font-lock-mode))
+ (select-window win)
+ (font-lock-fontify-region (window-start)
+ (min (point-max) (window-end))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-untabify-buffer ()
+ "Untabify whole buffer."
+ (interactive "*")
+ (when tinytf-mode
+ (untabify (point-min) (point-max))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-column-info ()
+ "Return column intepretation."
+ (interactive)
+ (let* ((col (current-column))
+ (elt (assq col tinytf-:column-table))
+ list
+ re
+ ret)
+ (when elt
+ (setq list (nth 1 elt))
+ (dolist (elt list)
+ (setq re (car elt))
+ (cond
+ ((not (stringp re)) ;Stop there
+ (setq ret (nth 1 elt))
+ (return))
+ ((looking-at re) ;found match ?
+ (setq ret (nth 1 elt))
+ ;; Yes, stop there
+ (return)))))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-column-info-display (&optional suppress)
+ "Display column info.
+This function displays information about the column and the text
+following it. Function does not look around the text and it will not
+detect text inside bullets or inside any other complex text.
+E.g.
+
+ o *Bullet here...
+ Continues here
+
+Cursor is at [*], which is column 12, which will indicate that the column
+is used for code examples and marked with <SAMPLE>.
+
+Input:
+ SUPPRESS If non-nil, do no display unneeded messages."
+ (interactive)
+ (let ((string (tinytf-column-info))
+ (col (current-column)))
+ (if string
+ (message "TinyTf: %s (col %d)" string col)
+ (unless suppress
+ (message "TinyTf: Nothing special at column %d" col)))))
+
+;;}}}
+;;{{{ headings
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-heading-positions (&optional and-heading-names)
+ "Read heading sections forward.
+
+Input:
+
+ AND-HEADING-NAMES see return value.
+
+Return:
+
+ '(pos pos ..)
+ '((heading pos) (heading pos) ..) If AND-HEADING-NAMES is non-nil
+ nil"
+ (let* (point
+ heading
+ list)
+ (save-excursion
+ (tinytf-heading-macro
+ (setq point (line-beginning-position))
+ (cond
+ (and-heading-names
+ ;; Dont read trailing spaces.
+ (end-of-line)
+ (if (re-search-backward "[^ \t]+" point t)
+ ;; Search 'eats' one character include it too.
+ (setq heading (buffer-substring point (1+ (point))))
+ (setq heading (buffer-substring point (point))))
+ (push (cons heading (point)) list))
+ (t
+ (push (point) list)
+ (end-of-line)))))
+ ;; Add point max there too. (due to hide region)
+ (if (and list (null and-heading-names))
+ (push (point-max) list))
+ (nreverse list)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-heading-fix-case-all (&optional confirm verb)
+ "Convert all headings to lowercase and capitalize first word.
+If CONFIRM is non-nil ask permission to fix for each heading. VERB."
+ (interactive "*P")
+ (ti::verb)
+ (tinytf-heading-macro
+ (when (and (tinytf-heading-fix-case-p)
+ (or (and
+ confirm
+ (y-or-n-p (format
+ "Fix? %s"
+ (ti::string-left
+ (ti::read-current-line) 70))))
+ (null confirm)))
+ (downcase-region (line-beginning-position) (line-end-position))
+ (capitalize-word 1))
+ (end-of-line))
+ (if verb
+ (message "TinyTf: Case fix done.")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-heading-fix-case-p ()
+ "Check if current heading need case fixing.
+Caller must ensure that current line is heading. Point is moved."
+ (beginning-of-line)
+ (if (looking-at "[0-9. \t]+") ;Forget heading numbering
+ (re-search-forward "[0-9. \t]+" (line-end-position)) )
+
+ (or (and (looking-at "[a-z]") ;It alphabet
+ (let* (case-fold-search) ;is it uppercase?
+ (not (looking-at "[A-Z]"))))
+ (save-excursion ;Howabout rest of the line; lowercase?
+ (forward-char 1)
+ (let* (case-fold-search)
+ (looking-at ".*[A-Z]")))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-heading-fix-case ()
+ "Write heading in lowercase and capitalize first word. Move heading forward.
+If current line is not a heading, do nothing.
+
+Return:
+
+ t if modified current and moved to next heading.
+ nil"
+ (interactive "*")
+ (let* ((re (concat (tinytf-regexp) "\\|" (tinytf-regexp 1)))
+ ret)
+ (when (save-excursion
+ (beginning-of-line)
+ (looking-at re))
+ (when (tinytf-heading-fix-case-p)
+ (downcase-region (line-beginning-position) (line-end-position))
+ (capitalize-word 1)
+ (setq ret t)))
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-heading-fix-newlines (&optional verb)
+ "Search all headings and remove extra newlines. VERB.
+
+Return:
+
+ nil nothing fixed
+ nbr this many fixed."
+ (interactive "*")
+ (let ((mark (point-marker)) ;Heading start point
+ (fix 0)
+ beg)
+ (ti::verb)
+ (tinytf-heading-macro
+ (move-marker mark (point))
+ (forward-line -1)
+ (setq beg (point))
+ ;; Delete previous newlines
+ (unless (bobp)
+ (cond
+ ((not (looking-at "^[ \t]*$")) ;no whitespace at all
+ (end-of-line) (insert "\n") (incf fix))
+ ((not (zerop (skip-chars-backward " \t\r\n"))) ;extra whitespace
+ (forward-line 1)
+ (delete-region beg (point)) (incf fix))))
+ (goto-char (marker-position mark))
+ (forward-line 1)
+ (setq beg (point))
+ (unless (eobp)
+ (cond
+ ((not (looking-at "^[ \t]*$")) ;no whitespace at all
+ (beginning-of-line)
+ (insert "\n")
+ (incf fix))
+ ((not (zerop (skip-chars-forward " \t\r\n"))) ;extra whitespace
+ (beginning-of-line)
+
+ ;; Skip chars forward for to next line in following case,
+ ;; see the (*) cursor position. When we do beginning of
+ ;; line; the point is 1+ BEG, but we really don't want
+ ;; to delete that region!
+ ;;
+ ;; Header 1
+ ;;
+ ;; (*)Sub header 2
+ (when (not (memq (point) (list beg (1+ beg))))
+ (delete-region beg (point))
+ (incf fix))))))
+ (setq mark nil) ;kill marker
+ (if verb
+ (if (> fix 0)
+ (message "TinyTf: fixed %d places around headings" fix)
+ (message "TinyTf: no newline fixes.")))
+
+ (if (> fix 0) ;anything to return?
+ fix)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-heading-fix (&optional verb)
+ "Search all headings and convert first letter to uppercase if needed. VERB.
+This function will only chnage the first word in the heading, no
+other case conversions are done."
+ (interactive "*P")
+ (let* ((re (concat ;Search lower letters only
+ "^" (tinytf-heading-number-regexp) "?"
+ "[a-z]"
+
+ "\\|^" (tinytf-indent 1)
+ (tinytf-heading-number-regexp) "?"
+ "[a-z]"))
+ (count 0)
+ case-fold-search)
+ (ti::verb)
+ (save-excursion
+ (ti::pmin)
+ (while (re-search-forward re nil t)
+ (backward-char 1)
+ (capitalize-word 1)
+ (incf count)))
+ (if verb
+ (message "%s: Fixed %d headings" tinytf-:mode-name count))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-heading-numbering (&optional remove verb)
+ "Number heading levels. Old numbering is replaced.
+Optionally REMOVE numbering. VERB."
+ (interactive "*P")
+ (let* ((re-no-nbr2 (if (> tinytf-:heading-number-level 0)
+ (tinytf-regexp 1)))
+ (re-no-nbr3 (if (> tinytf-:heading-number-level 1)
+ (tinytf-regexp 2)))
+ (re-nbr (tinytf-heading-number-regexp))
+ (re1 (concat "^" (tinytf-indent 0) re-nbr))
+ (re2 (if (> tinytf-:heading-number-level 0)
+ (concat "^" (tinytf-indent 1) re-nbr)))
+ (re3 (if (> tinytf-:heading-number-level 1)
+ (concat "^" (tinytf-indent 2) re-nbr)))
+ (c1 0) ;counters
+ (c2 0)
+ (c3 0)
+ (count 0)
+ (fix 0)
+ str)
+ (ti::verb)
+ (tinytf-heading-macro
+ (incf count)
+ (beginning-of-line)
+ (cond
+ (remove
+ (if (or (looking-at re1)
+ (and re2
+ (looking-at re2))
+ (and re3
+ (looking-at re3)))
+ (ti::replace-match 1)))
+ ((looking-at re1) ;heading 1
+ (incf c1)
+ (setq c2 0)
+ (setq str (tinytf-heading-string c1 c2))
+ ;; Only change if different, this prevents buffer modify flag
+ ;; change
+ (unless (tinytf-heading-same-p 0 str)
+ (incf fix)
+ (ti::replace-match 1 str)))
+ ((and re2 (looking-at re2))
+ (incf c2)
+ (setq c3 0)
+ (setq str (tinytf-heading-string c1 c2))
+ (unless (tinytf-heading-same-p 1 str)
+ (incf fix)
+ (ti::replace-match 1 str)))
+ ((and re3 (looking-at re3))
+ (incf c3)
+ (setq str (tinytf-heading-string c1 c2 c3))
+ (unless (tinytf-heading-same-p 2 str)
+ (incf fix)
+ (ti::replace-match 1 str)))
+ ((and re-no-nbr2
+ (looking-at re-no-nbr2)) ;Level 2
+ (goto-char (match-end 0))
+ (backward-char 1)
+ (incf c2)
+ (insert (tinytf-heading-string c1 c2)))
+ ((and re-no-nbr3
+ (looking-at re-no-nbr3)) ;Level 2
+ (goto-char (match-end 0))
+ (backward-char 1)
+ (incf c3)
+ (insert (tinytf-heading-string c1 c2 c3)))
+ ((looking-at "^") ;must be level 1
+ (setq c2 0) (incf c1)
+ (incf fix)
+ (insert (tinytf-heading-string c1 c2))))
+ (end-of-line))
+ (when verb
+ (message "%s: %d/%d headings numbered."
+ tinytf-:mode-name fix count))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-fix-all (&optional verb)
+ "Fix headers, untabify buffer and do other things. VERB.
+
+Note:
+
+ This function does not call following functions:
+
+ `tinytf-heading-fix-case-all', because you are in charge of the case of
+ headings. Only first letter is made uppercase.
+
+ `tinytf-toc', because the TOC in the buffer would always be substituted.
+ and this would mark buffer modified although no other changes were made.
+ Update this manually after heading changes.
+
+References:
+
+ `tinytf-:fix-all-hook' Well, you can do the misisng things here."
+ (interactive "*")
+ (ti::verb)
+ ;; when you fill paragraphs, the default Emacs has nasty habits to
+ ;; end the sentece to two spaces, which is some idiot way to separate
+ ;; two sentences (the history says that the typewriter fonts were so bad
+ ;; that the typists needed to add two spaces these).
+ ;;
+ ;; Fix them to have only standard space.
+ (if verb
+ (message "TinyTf: Fixing double spaces..."))
+ (save-excursion
+ (ti::pmin)
+ (while (re-search-forward "[a-zA-Z]+[!?.,]\\( +\\)[a-zA-Z]+" nil t)
+ (ti::replace-match 1 " ")))
+ (if verb
+ (message "TinyTf: Trimming extra blank lines..."))
+ (ti::buffer-trim-blanks (point-min) (point-max)) ;Remove trailing blanks
+ (if verb
+ (message "TinyTf: Heading fix..."))
+ (tinytf-heading-fix)
+ (tinytf-untabify-buffer)
+ (tinytf-heading-fix-newlines)
+ (if verb
+ (message "TinyTf: Checking heading numbering..."))
+ (when (tinytf-headings-numbered-p)
+ (tinytf-heading-numbering))
+ (if verb
+ (message "TinyTf: Running user fix hooks..."))
+ (run-hooks 'tinytf-:fix-all-hook)
+ (if verb
+ (message "TinyTf: Fixing done.")))
+
+;;}}}
+;;{{{ text: formatting with codes
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-paragraph-first-line-indent-fix (col)
+ "Make sure the first line in the paragraph start at column COL.
+point must be inside paragraph before calling function."
+ ;; After fill; the first line may still be ragged. fix it
+ ;;
+ ;; txt txt txt txt
+ ;; txt txt txt txt txt
+ ;; txt txt txt txt txt
+ (if (string-match "^[ \t]$" (ti::read-current-line))
+ (error "Must be inside text."))
+ (when (re-search-backward "^[ \t]*$" nil t)
+ (forward-line 1)
+ (skip-chars-forward " \t")
+ (unless (eq col (current-column))
+ (delete-region (point) (line-beginning-position))
+ (insert (make-string col ?\ )))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-move-paragraph-to-column (beg end col &optional msg noask)
+ "If region BEG END is big, ask confirmation for COL move with MSG NOASK.
+Return
+ (beg . end) Region bounds now."
+ (let* ((lines (+ (count-char-in-region beg end ?\r)
+ (count-char-in-region beg end ?\n)))
+ (max 40))
+ ;; We use markers, because the points have moved after the
+ ;; call to ti::buffer-move-paragraph-to-column. We must pass moved BEG end
+ ;; to hook functions.
+ (ti::keep-lower-order beg end)
+ (save-excursion
+ (goto-char beg)
+ (setq beg (point-marker))
+ (goto-char end)
+ (setq end (point-marker)))
+ (when (or noask
+ (< lines (1+ max))
+ (and
+ (> lines max)
+ (y-or-n-p (format "%s: really move %d lines? "
+ tinytf-:mode-name lines))))
+ (ti::buffer-move-paragraph-to-column
+ (marker-position beg) (marker-position end)
+ col)
+ (if (and (null noask) (< col 12))
+ (let ((fill-prefix (make-string col ?\ ))
+ (left-margin 0))
+ (call-interactively 'fill-paragraph)))
+ (if msg
+ (message "TinyTf:%s" msg))
+
+ (run-hook-with-args 'tinytf-:move-paragraph-hook
+ (marker-position beg) (marker-position end))
+ (cons beg end))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(tinytf-fmacro-indent-region
+ tinytf-indent-region-text
+ "Move selected region to STRONG html code position."
+ 8 (format "TinyTf: Regular text, column 8"))
+
+(tinytf-fmacro-indent-region
+ tinytf-indent-region-strong
+ "Move selected region to STRONG html code position."
+ 9 (format "TinyTf: Strong, column 9"))
+
+(tinytf-fmacro-indent-region
+ tinytf-indent-region-quote
+ "Move selected region to EMPHATISED (quoted text) html code position."
+ 10 (format "TinyTf: Quotation, column 10"))
+
+(tinytf-fmacro-indent-region
+ tinytf-indent-region-sample
+ "Move selected region to SAMPLE (example code) html code position."
+ 12 (format "TinyTf: Sample, column 12"))
+
+;;; ----------------------------------------------------------------------
+
+(tinytf-fmacro-indent-paragraph
+ tinytf-indent-paragraph-zero
+ "Move paragraph to column 0."
+ 0 (format "TinyTf: Zero, column 0"))
+
+(tinytf-fmacro-indent-paragraph
+ tinytf-indent-paragraph-2
+ "Move paragraph to column 2."
+ 2 (format "TinyTf: column 2"))
+
+(tinytf-fmacro-indent-paragraph
+ tinytf-indent-paragraph-3
+ "Move paragraph to column 3."
+ 3 (format "TinyTf: column 3"))
+
+(tinytf-fmacro-indent-paragraph
+ tinytf-indent-paragraph-5
+ "Move paragraph to column 5."
+ 5 (format "TinyTf: column 5"))
+
+(tinytf-fmacro-indent-paragraph
+ tinytf-indent-paragraph-6
+ "Move paragraph to column 6."
+ 6 (format "TinyTf: column 6")
+ (progn
+ (fill-paragraph nil)
+ (tinytf-forward-paragraph)))
+
+(tinytf-fmacro-indent-paragraph
+ tinytf-indent-paragraph-11
+ "Move paragraph to column 11."
+ 11 (format "TinyTf: column 11"))
+
+(tinytf-fmacro-indent-paragraph
+ tinytf-indent-paragraph-text
+ "Move paragraph to text position."
+ 8 (format "TinyTf: text, column 8")
+ (progn
+ (tinytf-forward-paragraph)))
+
+(tinytf-fmacro-indent-paragraph
+ tinytf-indent-paragraph-text-as-is
+ "Move paragraph to text position."
+ 8 (format "TinyTf: text, column 8")
+ (progn
+ (tinytf-forward-paragraph)))
+
+(tinytf-fmacro-indent-paragraph
+ tinytf-indent-paragraph-text-and-fill
+ "Move paragraph to text position and fill."
+ 8 (format "TinyTf: text, column 8")
+ (let* ((fill-prefix
+ (or (ti::string-match "^[ \t]+" 0 (ti::read-current-line))
+ ""))
+ (left-margin 0))
+ (fill-paragraph nil)
+ (tinytf-paragraph-first-line-indent-fix 8)
+ (tinytf-forward-paragraph)))
+
+(tinytf-fmacro-indent-paragraph
+ tinytf-indent-paragraph-quote
+ "Move paragraph to Quotation position."
+ 10 (format "TinyTf: Quotation, column 10"))
+
+(tinytf-fmacro-indent-paragraph
+ tinytf-indent-paragraph-quote-and-fill
+ "Move paragraph to Quotation position and fill."
+ 10 (format "TinyTf: Quotation, column 10")
+ (let* ((fill-prefix (or (ti::string-match
+ "^[ \t]+"
+ 0
+ (ti::read-current-line))
+ ""))
+ (left-margin 0))
+ (fill-paragraph nil)
+ (tinytf-paragraph-first-line-indent-fix 10)
+ (tinytf-forward-paragraph)))
+
+(tinytf-fmacro-indent-paragraph
+ tinytf-indent-paragraph-sample
+ "Move paragraph to Sample code position."
+ 12 (format "TinyTf: Sample, column 12")
+ (progn
+ (tinytf-forward-paragraph)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(tinytf-fmacro-mark-word
+ tinytf-mark-word-sample
+ "Put 'SAMP' code around word and move forward." ?` ?' )
+
+(tinytf-fmacro-mark-word
+ tinytf-mark-word-emp
+ "Put 'EM' code around word and move forward." ?* )
+
+(tinytf-fmacro-mark-word
+ tinytf-mark-word-strong
+ "Put 'STRONG' code around word and move forward." ?_ )
+
+(tinytf-fmacro-mark-word
+ tinytf-mark-word-big
+ "Put 'BIG' code around word and move forward." ?+ )
+
+(tinytf-fmacro-mark-word
+ tinytf-mark-word-small
+ "Put 'SMALL' code around word and move forward." ?= )
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-unmark-word ()
+ "Remove 'STRONG' and 'EMP' mark from word and move forward."
+ (interactive "*")
+ (let* ((word-skip "^ ,.;\n\r\t\f")
+ beg
+ end)
+ (flet ((marker (beg skip)
+ (save-excursion
+ (skip-chars-forward skip)
+ (list
+ (buffer-substring beg (point))
+ (point))))
+ (markup-p (word)
+ (string-match "[_*='`]+\\([^_*='`]+\\)[_*='`]+$" word)))
+ (unless (looking-at "[ \t\f]")
+ (skip-chars-backward "^ ,\n\r\t\f")
+ (setq beg (point))
+ ;; It depends how the markup has been done:
+ ;;
+ ;; This _sentence._ And new sentence.
+ ;; This _sentence_. And new sentence.
+ (dolist (try (list "^ \n\r\t\f" word-skip))
+ (multiple-value-bind (word end)
+ (marker beg try)
+ (when (string-match "[_*='`]+\\([^_*='`]+\\)[_*='`]+$" word)
+ (setq word (match-string 1 word))
+ (delete-region beg end)
+ (insert word)
+ (setq end (point))
+ (return))))
+ (unless end
+ (skip-chars-forward word-skip))
+ (skip-chars-forward " (){}<>,.;:!?\"\'\n\r\t\f")))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-mark-br-line (&optional unmark &optional verb)
+ "Mark current line with symbolic <BR>. Optionally UNMARK. VERB."
+ (interactive "*P")
+ (let* (point
+ ch)
+ (ti::verb)
+ (save-excursion
+ (beginning-of-line)
+ (if (not (looking-at "[ \t]+[^\r\n]"))
+ (if verb
+ (message "TinyTf: There must be empty spaces before line."))
+ (setq point (match-end 0))))
+ (when point
+ (goto-char (1- point))
+ (setq ch (following-char))
+ (if unmark
+ (if (char= ch ?.)
+ (delete-char 1))
+ (if (char= ch ?.)
+ (if verb
+ (message "TinyTf: Already marked as <BR>"))
+ (insert "."))))
+ (forward-line 1)
+ (skip-chars-forward " \t\r\n")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-mark-br-paragraph (&optional unmark)
+ "Mark current paragraph with symbolic <BR> codes. Optionally UNMARK."
+ (interactive "*P")
+ (let* (beg
+ end-mark)
+ (tinytf-backward-paragraph)
+ (setq beg (point))
+ (tinytf-forward-paragraph)
+ (setq end-mark (point-marker))
+ (goto-char beg)
+ (while (< (point) (marker-position end-mark))
+ (tinytf-mark-br-line unmark))
+ ;; Kill marker
+ (setq end-mark nil)))
+
+;;}}}
+;;{{{ Formatting, misc
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-bullet-format ()
+ "Reformat following bullet into Technical text bullet.
+Point sits somewhere in current bullet. Bullets accepted are:
+
+ . text here
+ + text here
+ * text here
+ - text here
+ o text here
+
+If the bullet strarts with 'o' or '.', then that is used as bullet
+mark. In all other cases 'o' is used."
+ (interactive "*")
+ (let* ((bullet-re "^[ \t]*\\([-*o.+]\\)[ \t]")
+ (para-re (concat bullet-re "\\|^[ \t]*$"))
+ (left-margin 0)
+ (char "o")
+ (str " ") ;; 8 + 4 spaces
+ fill-prefix ;; Otherwise formatting won't work right
+ beg
+ end)
+ (if (not (looking-at bullet-re))
+ (re-search-backward para-re))
+ (beginning-of-line)
+ (if (not (looking-at bullet-re))
+ (re-search-forward bullet-re))
+ ;; Set the bullet character
+ (setq char (match-string 1))
+ (if (not (member char '("o" ".")))
+ (setq char "o"))
+ (goto-char (match-end 0)) ;Over the bullet marker
+ ;; Delete [WHITE-SPACE]- text
+ (delete-region (point) (line-beginning-position))
+ (setq beg (point))
+ ;; handle continuing line
+ ;;
+ ;; - text
+ ;; text text
+ (while (and (not (looking-at bullet-re))
+ (looking-at "[ \t]*[^ \t\r\n]"))
+ (fixup-whitespace)
+ (forward-line 1))
+ (setq end (point))
+ (ti::narrow-safe beg end
+ ;; Now indent the text, then fill, and finally fix the
+ ;; bullet start
+ (goto-char (point-min))
+ (setq fill-prefix str)
+ (indent-rigidly (point-min) (point-max) (+ 8 4))
+ (call-interactively 'fill-paragraph)
+ (goto-char (point-min))
+ (fixup-whitespace)
+ (insert " " char " ")
+ (setq end (point-max)))
+ (goto-char end)
+ ;; Next paragraph
+ (if (string-match "^[ \t\r\n]*$" (ti::read-current-line))
+ (re-search-forward "^[ \t]*[^ \t\r\n]" nil t))))
+
+;;}}}
+;;{{{ movement
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-backward-paragraph ()
+ "Like `tinytf-forward-paragraph' but go backward."
+ (interactive)
+ (tinytf-paragraph-macro
+ (backward-paragraph)
+ (backward-paragraph)
+ (skip-chars-forward " \t\r\n")
+ (tinytf-goto-non-space)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-forward-paragraph ()
+ "Like `forward-paragraph' but keep cursor at the beginning of text."
+ (interactive)
+ (tinytf-paragraph-macro
+ (forward-paragraph)
+ (skip-chars-forward " \t\r\n")
+ (tinytf-goto-non-space)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-heading-start ()
+ "Goto first heading, excluding TOC heading."
+ (interactive)
+ (when (tinytf-toc-goto)
+ (tinytf-heading-forward-0)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-forward (level &optional back any)
+ "Go to next heading. Optionally search LEVEL or BACK or ANY level.
+
+Return:
+
+ nbr point if moved
+ nil"
+ (let* ((re (if any
+ (concat (tinytf-regexp) "\\|" (tinytf-regexp 1))
+ (tinytf-regexp level)))
+ case-fold-search ;case sensitive
+ point)
+ (if back
+ (when (re-search-backward re nil t)
+ (skip-chars-forward " \t") (point))
+ (cond
+ ((bolp) ;Startt seaching from next char
+ (save-excursion
+ (forward-char 1)
+ (if (re-search-forward re nil t)
+ (setq point (point))))
+ (if point ;If search ok, then move
+ (goto-char (1- point))))
+ (t
+ (when (re-search-forward re nil t)
+ (backward-char 1) (point)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-heading-forward-0 ()
+ "Forward."
+ (interactive)
+ (tinytf-forward 0))
+
+(defun tinytf-heading-forward-1 ()
+ "Forward."
+ (interactive)
+ (tinytf-forward 1))
+
+(defun tinytf-heading-forward-any ()
+ "Forward."
+ (interactive)
+ (tinytf-forward 1 nil 'any))
+
+(defun tinytf-heading-backward-0 ()
+ "Backward."
+ (interactive)
+ (tinytf-forward 0 'back))
+
+(defun tinytf-heading-backward-1 ()
+ "Backward."
+ (interactive)
+ (tinytf-forward 1 'back))
+
+(defun tinytf-heading-backward-any ()
+ "Backward."
+ (interactive)
+ (tinytf-forward 1 'back 'any))
+
+;;}}}
+;;{{{ outline control: show/hide
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-hide-region (beg end &optional show)
+ "Hide region BEG END with selective display. Optionally SHOW.
+Point is END after function finishes."
+ (let (buffer-read-only
+ (ch1 (if show ?\r ?\n))
+ (ch2 (if show ?\n ?\r)))
+ (subst-char-in-region beg end ch1 ch2)
+ (set-buffer-modified-p nil)
+ (goto-char (max beg end))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-mouse-context-sensitive (event)
+ "If `mouse-point' points indent 0 or 1 line, then hide/show level. EVENT.
+In other places call original function."
+ (interactive "e")
+
+ (mouse-set-point event)
+ (beginning-of-line)
+ (cond
+ ((or (tinytf-level-p 0)
+ (tinytf-level-p 1))
+ (tinytf-show-toggle))
+ (t
+ (ti::compat-mouse-call-original 'tinytf-mode event))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-show-buffer ()
+ "Remove selective display codes from buffer."
+ (interactive)
+ (save-excursion
+ (tinytf-hide-region (point-min) (point-max) 'show)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-hide-buffer ()
+ "Hide whole buffer."
+ (interactive)
+ ;; Save current point
+ (let ((point (line-beginning-position)))
+ (goto-char (point-min))
+ (if (tinytf-level-p 0)
+ (tinytf-hide))
+ (while (tinytf-heading-forward-0)
+ (tinytf-hide))
+ ;; But after collapsing buffer, the point is not exactly there
+ ;; any more => Go to the nearest heading which is at the beginning of
+ ;; line.
+ (goto-char point)
+ (goto-char (line-beginning-position))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-show-toggle ()
+ "Open/close level 1. Does't touch level 0."
+ (interactive)
+ (let* ((point (point)))
+ (if (looking-at ".*\r")
+ (tinytf-show) ;level is already collapsed, open it.
+ (tinytf-hide))
+ (goto-char point)
+ (tinytf-goto-non-space)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-show ()
+ "Show current level."
+ (interactive)
+ (tinytf-hide 'show))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-hide (&optional show)
+ "Hide current level. Optionally SHOW."
+ (interactive "P")
+ (let* ((ok t)
+ (point (point)))
+ (tinytf-level-macro
+ (cond
+ ((eq 1 level)
+ (tinytf-hide-region (point) (tinytf-block-end) show))
+ (t
+ (tinytf-hide-region (point) end show)
+ (setq ok (tinytf-heading-forward-any))
+ (while (and ok
+ ;; Until next level 0 ...
+ (not (eq 0 (tinytf-level-number))))
+ (setq beg (point))
+ (cond
+ ((setq ok (tinytf-heading-forward-any))
+ (beginning-of-line) (backward-char 1)
+ (if show
+ (subst-char-in-region beg (point) ?\r ?\n)
+ (subst-char-in-region beg (point) ?\n ?\r))
+ (forward-char 1))
+ (t
+ (tinytf-hide-region beg (point-max)))))
+ (set-buffer-modified-p nil)
+ (goto-char point))))))
+
+;;}}}
+;;{{{ misc: toc, exit
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-toc-p ()
+ "Check if there is heading \"Table of contents\".
+Return:
+ (beg . end) begin toc body, end of toc body
+ nil"
+
+ (let* ((re (concat ;May be Heading 1 or 2
+ "^\\("
+ (tinytf-indent 1)
+ "\\)?Table [Oo]f [Cc]ontents[ \t]*$"))
+ case-fold-search ;is sensitive
+ beg
+ end)
+ (save-excursion
+ (ti::pmin)
+ (when (re-search-forward re nil t)
+ (forward-line 1) (setq beg (point))
+ ;; - If the above command doesn't move; assume that the Toc
+ ;; has been placed to the end of buffer.
+ ;; - maybe there is nothing more that toc or toc is at
+ ;; the end where there is no more headings
+ (if (null (tinytf-heading-forward-any)) ;Not moved?
+ (ti::pmax)) ;go to end of buffer then
+ (beginning-of-line)
+ (setq end (point))
+ (cons beg end)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-toc-mouse (event)
+ "Create heading x-popup with mouse EVENT."
+ (interactive "e")
+ (tinytf-toc event))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-toc-occur ()
+ "Generate Heading occur menu."
+ (interactive)
+ (save-excursion
+ (ti::pmin)
+ (let ((toc (tinytf-toc-p))) ;Skip TOC
+ (if toc
+ (goto-char (cdr toc))))
+ (occur "^[^ \t\r\n<#]\\|^ [^ \t\r\n]")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-toc (&optional arg verb)
+ "Create table of contents.
+If there is heading level 1 whose name is \"Table of Contents\",
+update that. If there is no such heading, then show toc in separate
+buffer
+
+Input ARG can be:
+
+ nil create toc, possibly to separate buffer
+ \\[universal-argument] create toc occur
+ other must be mouse event, create x-popup toc
+
+VERB enables verbose messages."
+ (interactive "P")
+ (let* ((hlist (tinytf-heading-positions 'strings))
+ (toc (tinytf-toc-p))
+ (buffer tinytf-:buffer-heading)
+ elt)
+ (ti::verb)
+ (if (null hlist)
+ (if verb
+ (message "TinyTf: No headings found"))
+ (cond
+ ;; ..................................... generate toc to (text) ...
+ ((null arg)
+ (setq buffer (ti::temp-buffer buffer 'clear))
+ (with-current-buffer buffer
+ (dolist (elt hlist)
+ (setq elt (car elt))
+ (if (string-match "^[ \t]+" elt)
+ (insert elt "\n") ;sub heading...
+ (insert "\n" elt "\n")))
+ (insert "\n") ;; Final newline
+ (ti::pmin)
+ (ti::buffer-trim-blanks (point-min) (point-max))
+ (if (stringp tinytf-:heading-ignore-regexp-form)
+ (flush-lines tinytf-:heading-ignore-regexp-form))
+ ;; Make sure there are two newlines at the end so that
+ ;; inserted TOC is positioned nicely
+ ;; (ti::pmax)
+ ;; (when (and (looking-at "^$")
+ ;; (save-excursion
+ ;; (forward-line -1)
+ ;; (not (looking-at "^$"))))
+ ;; (insert "\n"))
+ ;; Delete leading whitespace
+ ;; 1997-08 Disabled for now and now makes:
+ ;;
+ ;; 1.1
+ ;; 1.2
+ ;; 2.0
+ ;; 2.1
+ ;;
+ (when (and toc nil)
+ ;; Convert heading 2 level to heading 1
+ (ti::pmin) (replace-string (tinytf-indent 1) ""))
+ (ti::pmin)
+ (delete-region
+ (point)
+ (progn
+ (if (zerop (skip-chars-forward " \t\r\n"))
+ (point)
+ (1- (point)))))
+ ;; Make indentation to text column
+ (when toc
+ (string-rectangle
+ (point-min)
+ (point-max)
+ (tinytf-indent 2)))) ;; with-current
+ (cond
+ (toc ;Update existing toc
+ (barf-if-buffer-read-only)
+ (delete-region (car toc) (cdr toc))
+ (ti::save-with-marker-macro
+ ;; Leave one empty line
+ (goto-char (car toc))
+ (insert-buffer buffer)))
+ (t ;No previous toc
+ (when verb
+ (pop-to-buffer buffer)
+ (ti::pmin))))) ;end cond inner
+ ;; ......................................... create toc (occur) ...
+ ((equal arg '(4))
+ (ti::occur-macro (concat (tinytf-regexp) "\\|" (tinytf-regexp 1))))
+ ;; ......................................... create toc (mouse) ...
+ (t
+ ;; ARG must be mouse-event
+ (if (null (ti::compat-window-system))
+ (message "TinyTf: Window system required to use popup menu")
+ (when (setq elt
+ (cond
+ ((< (length hlist) 20)
+ (ti::compat-popup
+ (nreverse (mapcar 'car hlist))
+ arg nil "Headings"))
+ ((fboundp 'imenu--mouse-menu)
+ ;; It's too long to be displayed in one x-widget.
+ ;; Use imenu
+ (car-safe (ti::funcall
+ 'imenu--mouse-menu hlist arg)))
+ (t
+ (message
+ "Tinytf: X-popup not available, no imenu.el")
+ nil)))
+ (let* ((ret (assoc elt hlist))
+ (pos (cdr-safe ret)))
+ (if pos
+ (goto-char pos)
+ (ti::pmin)
+ (tinytf-toc-goto)
+ (tinytf-heading-forward-0)
+ (re-search-forward elt))))))))
+ (if verb
+ (message "TinyTf: TOC generated."))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinytf-exit ()
+ "Run `tinytf-fix-all' and exit mode."
+ (interactive)
+ (tinytf-fix-all)
+ (tinytf-mode 0))
+
+;;}}}
+
+(unless tinytf-:mode-define-keys-hook ;; Set default setup
+ (ti::add-hooks
+ 'tinytf-:mode-define-keys-hook
+ '(tinytf-mode-define-keys tinytf-mode-define-f-keys)))
+
+;; It's important that this is as fast as possible
+
+(ti::byte-compile-defun-maybe '(tinytf-code-p))
+
+(tinytf-install)
+
+(provide 'tinytf)
+(run-hooks 'tinytf-:load-hook)
+
+;;; tinytf.el ends here
--- /dev/null
+;;; tinyurl.el --- Mark and jump to any URL on current line.
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 1997-2007 Jari Aalto
+;; Keywords: extensions
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program, call M-x tinyurl-version.
+;; Look at the code with folding.el.
+
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;;; Install:
+
+;; ....................................................... &t-install ...
+;; Put this file on your Emacs-Lisp load path, add following into your
+;; ~/.emacs startup file.
+;;
+;; (add-hook 'tinyurl-:load-hook 'tinyurl-install-to-packages)
+;; (require 'tinyurl)
+;;
+;; ;; To activate the mode globally add code below
+;; ;; Alternatively call global mode M-x tinyurl-mode or
+;; ;; buffer based mode M-x tinyurl-mode-1
+;;
+;; (turn-on-tinyurl-mode)
+;;
+;; ;; If you do not have permenent internet connection, add this
+;; ;; It will follow Gnus plugged mode state.
+;; (setq tinyurl-:plugged-function 'tinyurl-plugged-p)
+;;
+;; You can also use the preferred way: autoload. Only when you call the
+;; `M-x' `tinyurl-mode', this package loads. The following setup is
+;; faster than above, but it doesn't install this package automatically to
+;; VM, RMAIL, MH, gnus as the `require' method does. Call
+;; `M-x' `tinyurl-install-to-packages' for those.
+;;
+;; (add-hook 'tinyurl-:load-hook 'tinyurl-install-to-packages)
+;; (autoload 'tinyurl-mode "tinyurl" "" t)
+;; (autoload 'tinyurl-mode-1 "tinyurl" "" t)
+;; (autoload 'turn-on-tinyurl-mode-1 "tinyurl" "" t)
+;; (autoload 'turn-off-tinyurl-mode-1 "tinyurl" "" t)
+;;
+;; ;; Keybinding suggestions
+;;
+;; (global-set-key "\C-cmuu" 'tinyurl-mode)
+;; (global-set-key "\C-cmu1" 'tinyurl-mode-1)
+;; (global-set-key "\C-cmup" 'tinyurl-plugged-mode-toggle)
+;;
+;; ;; Select backend for EMAIL urls. See variable's documentation.
+;; (setq mail-user-agent 'message-user-agent)
+;;
+;; If you have any questions, use this function to contact author
+;;
+;; M-x tinyurl-submit-bug-report
+
+;;}}}
+;;{{{ Documentation
+
+;; ..................................................... &t-commentary ...
+
+;;; Commentary:
+
+;; Preface, oct 1997
+;;
+;; One day a collegue had a problem with his VM and he
+;; explained to me that he wanted the `mouse-2' to run netscape
+;; browser instead of the default Emacs `w3' browser. While he was
+;; waving his cursor over the http link, I suddendly realized: that
+;; this would be useful in RMAIL buffers too. (I later moved straight to
+;; GNUS). It seemed that every package had its own url handling: VM, TM,
+;; GNUS, MH.
+;;
+;; But really, how about the rest of the buffers and modes? There was
+;; no general ULR dispatcher minor mode that would work with any buffer
+;; and with any mode.
+;;
+;; Now there is; it is possible browse any buffer or document and
+;; jump to URLs on the line. Works for programing modes too. You
+;; just position the cursor somewhere on the line, wait 2 seconds
+;; and the URLs in the current line are marked.
+;;
+;; Overview of features
+;;
+;; o Requirements: XEmacs must contain package `overlay.el'.
+;; Emacs needs nothing special.
+;;
+;; o General URL handler: not just the regular http, ftp, but
+;; also for programming languages like Perl/Lisp/C++ and
+;; man page cut(1) references and jumping to Debian bug
+;; reports (+ WNPP) and more...
+;;
+;; o When the global minor mode is on, wait few seconds and the
+;; current line will be scanned for urls. Because not all
+;; terminals show clolor, there is additional "!" character added to
+;; the front of URL for calling you to *push* it.
+;; o Once the minor mode is turned on, it occupies every buffer,
+;; but there is also function to turn the mode on or off per buffer
+;; basis, see `tinyurl-mode-1'. When new file is loaded,
+;; `tinyurl-mode' is activated for the buffer too.
+;; o Defines binding `mouse-2' and `M-RET' to call the url at
+;; point. These bindings are electric: If there is no button to push,
+;; the original binding is called according to underlying mode.
+;; o You can change the url handler sets on the fly: e.g.
+;; call lynx for a while, then switch to Netscape or use your custom
+;; browser. See `M-x' `tinyurl-set-handler'
+;; o Centralised url handling. If you call `tinyurl-install-to-packages'
+;; then GNUS, TM, VM etc. now call TinyUrl and you only need to
+;; configure things in one place.
+;;
+;; Turning the URL recognizer on
+;;
+;; Load package with `require' or via autoload (see installation
+;; instruction at the top of file) and call `M-x' `tinyurl-mode' to
+;; toggle the global minor mode on and off. The modeline displays `Ux'
+;; when the mode is active. A character like (x) is a short name
+;; for browser that will activate, e.g. "n" for "netscape" browser,
+;; (l) for lynx and (w) w3.
+;;
+;; If you want to turn the mode on or off for current buffer only, use
+;; `M-x' `tinyurl-mode-1'.
+;;
+;; The minor mode is turned on for all newly created (C-x C-f) or
+;; visited files, but if you make a new buffer with `M-x'
+;; `switch-to-buffer', the URL mode is not turned on in those buffers.
+;;
+;; Caching URLs for later use (offline reading)
+;;
+;; The offline reading is possible with Gnus, where status can be
+;; toggled between "plugged" and "unplugged". If variable
+;; `tinyurl-:plugged-function' is set to default unpluggged condition
+;; detector function `tinyurl-plugged-p', it returns nil if Gnus is in
+;; unplugged state.
+;;
+;; The current implementation relies on gnus (`M-x' `gnus') to detect
+;; the off-line, on-line status of the network connection. This
+;; means that all "buttons" are cached to separate buffer unless you
+;; tell that you're connected via `M-x' `gnus-agent-toggle-plugged'.
+;;
+;; You can place your own unplugged state detector to variable
+;; `tinyurl-:plugged-function'. Cache buffer used is
+;; `tinyurl-:url-cache-buffer', which is *URL-cache* by default.
+;;
+;; You can force TinyUrl to change plug status by calling `M-x'
+;; `tinyurl-plugged-mode-toggle'. This internal flag overrides anything
+;; else in the system. The indicator "!" in the modeline tells if
+;; TinyUrl thinks it is in plugged state. You may need to call this
+;; function if you don't use Gnus as a primary MUA.
+;;
+;; Shortly:
+;;
+;; o If you use Gnus, toggle Agent with J j to plugged/unplugged
+;; and TinyUrl will follow Gnus's state.
+;; o If you don't use gnus, or do not have it loaded, call
+;; function `tinyurl-plugged-mode-toggle' to tell the state of the
+;; net connection.
+;;
+;; Editing the url and selecting access method manually
+;;
+;; You can pass a prefix argument like `C-u' before you press
+;; `mouse-2' or `M-RET' and edit two parameters: a) The URL location
+;; itself and b) the access method. Say e.g. that your default command
+;; table is netscape and you see url
+;;
+;; file:/users/foo/file.txt
+;;
+;; The `file:/' would be normally considered external and accessed via
+;; `url' method, which in this case is netscape. But you would like
+;; to use Emacs `find-file' instead. Send `C-u' and leave the url as
+;; is and change access method to:
+;;
+;; file
+;;
+;; That's it. Remember however that you have full control and
+;; if you choose nonsense access method, which has nothing to do with
+;; the url, then you also carry the results, whatever they may be.
+;;
+;; Ignoring URL in the buffer
+;;
+;; You can use hook `tinyurl-:dispatch-hook' to check URL. If any of
+;; the functions return t, then the original binding in the mode is
+;; called and the TinyUrl is not used. E.g. In Dired buffer you want to
+;; ignore all URLs. There is default function
+;; `tinyurl-dispatch-ignore-p' that does just this.
+;;
+;; Centralised URL handling
+;;
+;; If you called `M-x' `tinyurl-install-to-packages' or had installation:
+;;
+;; (add-hook 'tinyurl-:load-hook 'tinyurl-install-to-packages)
+;;
+;; then GNUS, VM, TM, and other packages redirect urls to TinyUrl.
+;; This way you don't have to setup each package to your taste.
+;; Plus you got the benefit that you can change url handler set
+;; on the fly with `tinyurl-set-handler'.
+;;
+;; Ignoring some buffers for mode turn on and offs
+;;
+;; If you want to exclude some buffers from the mode turn on or offs,
+;; say *VM* which does its own highlighting, then define your
+;; custom function like this
+;;
+;; (setq tinyurl-:exclude-function 'my-tinyurl-exclude)
+;;
+;; (defun my-tinyurl-exclude (buffer)
+;; "Exclude some buffers that use their own highlighting."
+;; (string-match "VM\\|Article" (buffer-name buffer)))
+;;
+;; This only concern the golobal `tinyurl-mode' function. You can
+;; still use `tinyurl-mode-1' anywhere to toggle the mode setting.
+;; You use this variable when you don't want `tinyurl-mode' to
+;; appear in buffer at all.
+;;
+;; Validating url
+;;
+;; The `tinyurl-mark-line' function doesn't check the validity of a
+;; matched regexp that was marked as pushable url. It's a dummy
+;; function that can only attach "buttons" and does nothing about
+;; their contents. But when you actually push the url, the url is run
+;; through functions in `tinyurl-:validate-hook'. When any of the
+;; function returns t, it is a *go* sign. The default handler
+;; `tinyurl-validate-url-default' rejects any url that matches
+;; "foo|bar|quux".
+;;
+;; See also `tinyurl-:reject-url-regexp' for more simpler use.
+;;
+;; Choosing what agent handles which URL
+;;
+;; There is predefined `tinyurl-:command-table' which is consulted where
+;; URL request should be delegated. By default http:// or ftp:/ or file:/
+;; requests are handed by `browse-url-netscape' and remote tar or gz
+;; fileas are loaded with ange-ftp.
+;;
+;; You can completely customize the URL delegation by writing your
+;; own url handler set and placing it to `tinyurl-:url-handler-function'.
+;; Copy the default setup and make your own modifications.
+;;
+;; Changing the url handler list
+;;
+;; When you click the url to run the viewer, the current url handler
+;; list determines what method is used. E.g. If you normally want
+;; netscape to handle your URL, then the current set is labelled
+;; "netscape". But in some situations, where you want to e.g. view text
+;; files or your resources in PC EXceed are low, or you want fast browser;
+;; then there is also "lynx" set. You change the browser set with command
+;;
+;; tinyurl-set-handler Meta mouse-2
+;;
+;; The modeline will show the first string from your active set; `Un'
+;; for Netscape, `Ul' for lynx set and `Uw' for w3 based set. You can
+;; add as many handler sets as you want by adding them to
+;; `tinyurl-:command-table'
+;;
+;; Exclamation character marks pushable URL
+;;
+;; NOTE: THE VISIBLE CHACTER APPLIES ONLY TO TERMINALS THAT DO NOT
+;; SUPPORT COLORS TO MARK PUSHABLE URLS. (Usually an Emacs started
+;; with -nw, or running inside a terminal.)
+;;
+;; When you see character "!" (netscape) or "?" (W3 browser) to appear
+;; in the front of the URLs, then you know that items are pushable.
+;; You can call the URL by clicking it with `mouse-2' or tapping
+;; `M-RET'. In the following line, two url's have been detected. The
+;; first one sends normal http request and the second one would create
+;; mail buffer for the address.
+;;
+;; Some previous line here
+;; !http://foo.com/dir/file.txt !<foo@bar.com>
+;; Another line below
+;;
+;; Elswhere your `mouse-2' and `M-RET' behave as usual. If you would
+;; like to paste(the mouse-2) somewhere in the "previous" or "another"
+;; line, that would work as you expected. But you can't paste inside
+;; the URL, because the URL is currently activated. If you need to do
+;; something like that, then you can use either of these strategies:
+;;
+;; o Use `C-y' to yamk the text inside marked url.
+;; o move cursor out of the URL line; wait few seconds for
+;; "!" to disappear (the line is cleared). Go back and paste before
+;; you see "!" to appear back again.
+;; o Turn off the mode off with `M-x' `tinyurl-mode-1' for a while if
+;; you don't need the URL features right now.
+;;
+;; _Note_: The character "!" that you see, is not a real editable
+;; character, but part of the overlay. While your text may appear to
+;; be modified. That is not what happened. See Emacs info pages for
+;; more about overlays.
+;;
+;; You can use variable `tinyurl-:display-glyph' to control if the
+;; glyph is shown or not.
+;;
+;;
+;; Accepted email URL
+;;
+;; The default accepted format is <foo@site.com> and if you see
+;; foo@site.com, that will not be recognized. Your can get this
+;; accepted by changing `tinyurl-:email-regexp'. You could use \\< and
+;; \\> (word border marker) regexps instead of default characters < >.
+;;
+;; Support for programming language URLs
+;;
+;; I'll gladly support any other languages. If you know the language
+;; you're using, drop me a mail and help me to undertand how I would
+;; add support to it. Especially I'd like to hear specs from Java
+;; programmers.
+;;
+;; C/C++
+;;
+;; The default agent to find C/C++ .h files is find-file.el's
+;; `ff-find-other-file'. This will handle your #include urls.
+;;
+;; Perl
+;;
+;; There is support for these perl statements:
+;;
+;; use package;
+;; require package;
+;;
+;; Functions that recognize those are under `tinyurl-find-url-perl*'.
+;; The default find path for perl is `@INC'. Perl related urls are
+;; delegated to separate tinyperl.el package. In addition perl compile
+;; error lines are recognized:
+;;
+;; ERROR at FILE line NBR.
+;;
+;; Perl pod page references are recognized in the format
+;;
+;; perlfunc manpage
+;; See [perltoc]
+;;
+;; Emacs lisp
+;;
+;; The url handler function is `tinyurl-find-url-lisp' and Emacs
+;; `load-path' is searched. The usual urls "load-file", "load-library"
+;; "autoload" "load" are recognized. If you need to jump to function
+;; or variable definitions, you want to use a TinyLisp package, which
+;; offers minor mode solely for Emacs lisp programming purposes:
+;; Profiling, debugging, snooping hooks, you emacs packages, browsing
+;; code etc.
+;;
+;; Other languages
+;;
+;; Please let me know if you know package or you have code that can
+;; find other languages' URLs.
+;;
+;; Debian support
+;;
+;; Debian <http://www.debian.org> uses mail based bug tracking system
+;; where each assigned task is uniquely identified. The task can
+;; be a regular bug report send via command reportbug(1) or it can
+;; be a control message where developers can hand over maintenance
+;; of packages or in turn take over maintenance of orphaned packages.
+;; Visit page <http://www.debian.org/devel/wnpp> to see what the
+;; messages look like. The messages are best monitored and read
+;; through Gnus NNTP backend using newsgroup
+;; *nntp+news.gmane.org:gmane.linux.debian.devel.wnpp*. URLs like
+;; this are buttonized (requires package tinydebian.el):
+;;
+;; Bug#NNNNNN
+;;
+;; Memory list
+;;
+;; o Remember to define `ff-search-directories' for *find-file.el*
+;; so that your C/C++ #include <url> will be found correctly.
+;;
+;; Filename filter e.g. running catdoc for MS Word files
+;;
+;; There is table `tinyurl-:file-filter-table' which can be used to
+;; handle found url. Eg if you want to treat all files ending
+;; to extension .doc as MS word files and feed them through
+;; `catdoc' http://www.ice.ru/~vitus/works/ which spits 7bit
+;; out, you can associate shell action to handle url. Respectively
+;; if you want to use `xv' for viewing your images, you can associate
+;; that to the url. The default table handles these cases if you
+;; have xv and catdoc present. See variable description for more
+;; information. (You can also use your custom lisp url handler there)
+;;
+;; If you want to load the raw file into emacs, just supply
+;; prefix argument when you push url and you will be given choice
+;; to by-pass the set filters (if there is any) for the url.
+;;
+;; Code note: adding buttons to the current line
+;;
+;; The idle timer process is used to mark current line's urls with
+;; overlays. Please wait few seconds on a line and the ulrs that
+;; can be *pushed* are marked. If there is no idle timer available,
+;; then a `post-command-hook' is used.
+;;
+;; [Next applies only to Emacs with no `run-with-idle-timer' function]
+;;
+;; Using `post-command-hook' is not an ideal solution, but at least
+;; this package works with older Emacs versions. The threshold how
+;; quicly the line is scanned for url buttons is determined by
+;; variable `tinyurl-:post-command-hook-threshold'. The deafult value
+;; 7 should give you enough time to use `mouse-2' (paste) before the
+;; line is buttonized. Remember that *vawing* you mouse creates
+;; events, so you can force buttonizing the line quite quickly.
+;;
+;; Code note: overlay properties
+;;
+;; The overlays have nice feature where you can add string to be
+;; displayed to the side of an overlay. See the overlay properties in
+;; the Emacs info pages for more. The overlay `priority' in this
+;; package is by default set to highest possible, so that the URL
+;; highighting is guarranteed to be dislayed. If you use some other
+;; package that also uses overlays, then decrease that package's
+;; overlay priorities. (If the package doesn't allow you to adjust the
+;; priorities, contact the package maintainer. To my opinion the
+;; priority value should be defined for all overlays).
+;;
+;; The only part that you should touch in the property list of the
+;; overlays, is the displayed string. You can choose anything you
+;; want, but prefer one character. By default the "!" is shown in
+;; both Windowed and non-windowed version.
+;;
+;; The overlays have property `owner' which tells to whom
+;; particular overlays belong. In this case the owner is this package,
+;; `tinyurl'. It is a good practise for all overlays to identify
+;; themselves via this 'owner property.
+;;
+;; Code Note: overlay management
+;;
+;; Let's consider what `font-lock' does for buffer for a moment: it
+;; marks whole buffer with faces (colors). While design this package,
+;; the goal was not to add buffer with full of clickable overlays,
+;; while that could have been done easily. The reason is efficiency
+;; and avoiding "highlight" bloat.
+;;
+;; Instead old overlays are removed and new ones are created only for
+;; current line, typically the count is between 1 .. 4. When you move
+;; to another place, these old overlays are destroyed and new ones
+;; created. The current line may now may have only 1 URL, so only one
+;; overlay was needed this time.
+;;
+;; For that reason you must wait for idle timer process to do its
+;; work on current line, before you can see those clickable URL
+;; buttons.
+;;
+;; Using only small number of overlays keeps the code clean and user
+;; friendly. It's also faster than buttonizing whole 500K faq
+;; document in one pass.
+;;
+;; Code Note: Adding support for new URL type
+;;
+;; If you see new url that you would like to have supported and you
+;; know lisp, then the changes needed are:
+;;
+;; o `tinyurl-mark-line', Add regexp to match the URL. Think carefully
+;; where to put the regexp and make is as restrictive as you can.
+;; Remember that first OR match is picked.
+;; o `tinyurl-type', Add new type for URL
+;; o `tinyurl-command-table-default-1' Add default handler
+;; o Write the URL handler.
+;; o Run `tinyurl-command-table-defaults-set' to make the new handler
+;; seen in the default agent function list
+;;
+;; To make changes do this:
+;;
+;; o copy original version to `tinyurl.el.orig'
+;; o Make changes
+;; o Produce diff `diff -b -w -u tinyurl.el.orig tinyurl.el'
+;;
+;; Then send diff to the maintainer. Use unified diff format (-u) if
+;; possible. Second chance is to use context diff (-c). Other diff
+;; formats are not accepted.
+;;
+;; Sending a bug report
+;;
+;; If you have a line where url is highlighted, but it doesn't cover
+;; right characters, then do this:
+;;
+;; o `M-x' `tinyurl-submit-bug-report'
+;; o Copy the _WHOLE_ line to the mail buffer.
+;; o Turn on debug with `M-x' `tinyurl-debug-toggle'
+;; o Be sure Url gets highlighted. End debug with
+;; `M-x' `tinyurl-debug-toggle' and copy the content of
+;; *tinyurl-debug* to the mail
+;; o Attach desctiption of the bug and send mail.
+;;
+;; Btw, in win32 the file url on `C:' disk is written like
+;;
+;; file://localhost/C|/foo/bar/baz.html#here
+;;
+;; And according to RFC, if you leave out the <host>, the localhost is
+;; automatically assumed.
+;;
+;; file:///C|/foo/bar/baz.html#here
+;;
+;; Known Bugs
+;;
+;; The URL is highlighted by setting `mouse-face' to property
+;; `highligh'. But I have seen that Emacs 19.34 in HP Unix with X
+;; window sometimes won't show the highlight when cursor is moved
+;; over the URL. Go figure why. I have heard similar reports from
+;; XEmacs 20.4.
+;;
+;; If you know what is causing this effect, let me know.
+;;
+;; Todo
+;;
+;; Add support for Java-Find.el
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+;;{{{ setup: require
+
+(require 'tinylibm)
+
+(eval-when-compile
+ (ti::package-use-dynamic-compilation)
+ (require 'advice))
+
+(eval-and-compile
+ (defvar gnus-plugged)
+ (defvar browse-url-browser-function)
+ (defvar gnus-button-url)
+ (defvar vm-url-browser)
+ (defvar browse-url-browser-function)
+ (autoload 'man "man" "" t)
+ (autoload 'ffap "ffap" "" t)
+ (autoload 'ff-find-other-file "find-file" "" t)
+ (autoload 'tinydebian-bug-browse-url-by-bug "tinydebian" "" t)
+ (autoload 'tinyperl-pod-by-manpage "tinyperl" "" t)
+ (autoload 'tinyperl-pod-by-module "tinyperl" "" t)
+ (autoload 'tinyperl-pod-manpage-to-file "tinyperl" "" t)
+ (autoload 'tinyperl-locate-library "tinyperl" "" t)
+ (autoload 'tinyperl-library-find-file "tinyperl" "" t)
+ (autoload 'turn-on-tinyperl-pod-view-mode "tinyperl" "" t)
+ (ti::overlay-require-macro
+ (message "\
+** tinyurl.el: Error, this Emacs does not have overlay functions.")))
+
+(ti::package-defgroup-tiny TinyUrl tinyurl-: extensions
+ "Global URL highlighting and dispatcher minor mode.")
+
+;;}}}
+;;{{{ setup: variables
+
+;;; ......................................................... &v-hooks ...
+
+(defcustom tinyurl-:load-hook '(tinyurl-install-to-packages)
+ "*Hook run when file has been loaded."
+ :type 'hook
+ :group 'TinyUrl)
+
+(defcustom tinyurl-:dispatch-hook '(tinyurl-dispatch-ignore-p)
+ "When calling urls, check if it is allowed.
+this hook's purpose is to check current buffer, current line or anything
+else to determine if pushing URL is ste wanted action. Eg in dired
+buffer the pushing acting should not be respected but passed back
+to Dired.
+
+Default function in this hook is `tinyurl-dispatch-ignore-p'.
+
+Function call arguments:
+
+ url Matched url text
+ '(buffer . point) Pointer to location of url in Emacs
+
+Function should return:
+
+ non-nil To ignore urls and pass control back to underlying mode.
+ nil Accept url and proceed."
+ :type 'hook
+ :group 'TinyUrl)
+
+(defcustom tinyurl-:validate-hook '(tinyurl-validate-url-default)
+ "Validate called url. If some of these functions return t, url is accepted.
+
+Function call arguments:
+
+ string: URL
+
+Function should return:
+
+ t Accept and continue with url
+ string Display message STRING and ignore url
+ nil Display default message 'url ignored' and ignore url"
+ :type 'hook
+ :group 'TinyUrl)
+
+;;; .......................................................... &public ...
+
+(defcustom tinyurl-:auto-activate-function
+ 'turn-on-tinyurl-mode-automatically
+ "*Function to check if there are URLs in current buffer.
+This function will automatically turn on `tinyurl-mode-1' for the
+current buffer it it returns t."
+ :type 'function
+ :group 'TinyUrl)
+
+(defcustom tinyurl-:plugged-function 'tinyurl-plugged-always-p
+ "Function to determine disconnected state.
+Function takes no arguments and should return t if Emacs is disconnected
+and unable to serve external URL requests.
+
+Possible values:
+ 'tinyurl-plugged-always-p
+ 'tinyurl-plugged-p
+
+See also: `tinyurl-:url-cache-buffer'"
+ :type 'function
+ :group 'TinyUrl)
+
+(defcustom tinyurl-:exclude-function 'tinyurl-default-exclude
+ "*Function to prohibit (de)activatiting `turl-mode' for a buffer.
+This function is called when TinyUrl mode is booted up or shut down.
+
+Function call argument:
+
+ buffer-pointer
+
+Function should return:
+
+ t if buffer is ignored"
+ :type 'function
+ :group 'TinyUrl)
+
+(defcustom tinyurl-:display-glyph (not (ti::colors-supported-p))
+ "*If non-nil, Display the Overlay glyph: !, ? or *.
+
+The shown character depends on the active command table.
+If you have non-windowed Emacs which cannot
+display faces on tty, then make sure this variable is t or you won't
+notice the buttonized urls.
+
+In Windowed Emacs the glyph may be redundant, because the face
+property already highlights the URLs. Try if you like setting nil better in
+non windowed Emacs."
+ :type 'boolean
+ :group 'TinyUrl)
+
+(defcustom tinyurl-:file-filter-table
+ (let* ((doc (executable-find "catdoc"))
+ (gimp (executable-find "gimp"))
+ (xv (executable-find "xv"))
+ (nroff (executable-find "nroff"))
+ (col (executable-find "col"))
+ (winzip (executable-find "winzip")))
+ (list
+ '("\\.pod$" . tinyurl-filter-pod)
+ (if doc
+ (cons "\\.doc$" (concat doc " %s"))) ;View MS WORD files
+ (cons "\\.\\(jpg\\|jpeg\\|gif\\)$"
+ (cond
+ (gimp
+ (concat gimp " %s"))
+ (xv
+ (concat xv " %s"))
+ (t
+ 'ignore))) ;Ignore loading pictures
+ (if (and nroff col)
+ (cons "\\.[1-9]$"
+ (concat nroff " -man"
+ " %s | "
+ col " -bx")))
+ ;; Pass ZIP pointer to win32 winzip
+ (if winzip
+ (cons "\\.zip$"
+ (function
+ ((lambda (arg)
+ (tinyurl-call-process-win32
+ winzip arg))))))))
+ "If URL is filename, then check this table for filter.
+The `%s' is substituted with the URL (filename) in SHELL-COMMAND string.
+
+If there is Lisp FUNCTION, then it is called with argument URL.
+
+Format:
+
+ '((REGEXP . SHELL-COMMAND) ;; nil element also accepted
+ (REGEXP . FUNCTION)
+ ..)
+
+Example:
+
+ The default value for this variable is set like this. If you
+ have executables `xv' and `catdoc', then the shell commands are
+ defined. If you don't have, then the slot if filled with nil,
+ which is acceptable value. The Picture file handler is set to
+ `ignore' function, if no `xv' is present to prevent loading
+ pictures into Emacs buffer.
+
+ (setq file-filter-table
+ (list
+ (if (executable-find \"catdoc\")
+ '(\"\\\\.doc$\" . \"catdoc %s\")) ;View MS WORD files
+ (if (executable-find \"xv\")
+ '(\".\\\\(jpg\\\\|jpeg\\\\|gif\\\\)$\" . \"xv %s\")
+ 'ignore)))"
+ :type '(repeat
+ (list regexp (choice
+ (string :tag "Shell command")
+ (function :tag "Function"))))
+ :group 'Tinyurl)
+
+(defcustom tinyurl-:url-handler-function 'tinyurl-handler-main
+ "Function to take care of delegating the URL to correct Agent.
+The default function `tinyurl-:command-table' uses `tinyurl-:command-table'
+
+Function call arguments:
+ string a possible url
+ type :optional A symbol describing url type. See `tinyurl-type'"
+ :type 'function
+ :group 'TinyUrl)
+
+;; This variable is set in `tinyurl-install'.
+
+(defcustom tinyurl-:command-table nil
+ "*What Agent to run when URL is beeing dispatched.
+This table cab have multiple different Agent-tables and the currently
+used table is stored at `tinyurl-:command-table'. See command
+\\[tinyurl-set-handler].
+
+The elements:
+
+ TYPE can be 'mail 'url 'file or 'other. These are the types that
+ trigger calling VALUE as function. There is special type name
+ 'overlay-plist which is used for displaying the overlay.
+ Refer to function `tinyurl-type' for all possible TYPE values.
+
+ FUNCTION Either function or value. Functions are called interactively.
+
+Format:
+
+ '((COMPLETION-NAME
+ (
+ (TYPE . VALUE)
+ ..
+ (overlay-plist (PROPERTY VAL PROPERTY VAL ..)))))
+
+References:
+
+ You can contruct one entry to this table with
+ functions `tinyurl-command-table-put' `tinyurl-command-table-put-2nd'
+ and `tinyurl-command-table-default-1'. See tinyurl.el's source code and
+ function `tinyurl-command-table-netscape' how to use these."
+ :type 'sexp
+ :group 'TinyUrl)
+
+(defcustom tinyurl-:email-regexp
+ ;; It's best to require some more characters to avoid mishits.
+ ;; There is always ".com" ".fi", at least three characters.
+ (let ((word "[^ \t\r\n,:!?%@|'#&]"))
+ (concat "<" word "+@" word "+\\." word word word "?>"))
+ "Regexp to match email address approximately."
+ :type 'string
+ :group 'TinyUrl)
+
+(defcustom tinyurl-:post-command-hook-threshold 25
+ "How often `tinyurl-mark-process-post-command' run after post command.
+This variable is used only if funtion `run-with-idle-timer' does
+not exist. If the value is 1, then function `tinyurl-mark-process-post-command'
+runs after each keypress. You should keep the value in range 10 .. 30,
+depending on how quickly you want the process to scan the line for url
+buttons."
+ :type 'integer
+ :group 'TinyUrl)
+
+(defcustom tinyurl-:url-cache-buffer "*URL-cache*"
+ "Where to store urls when Emacs is disconnected from the Net."
+ :type 'string
+ :group 'TinyUrl)
+
+(defcustom tinyurl-:reject-url-regexp
+ (concat
+ ;; "/\\(usr\\|opt\\)\\(/local\\|/ucb\\)?/s?bin"
+ ;; "\\|^/bin\\|/dev/"
+ "\\.\\(exe\\|com\\|o\\)$")
+ "Rgexp to reject URL. This is only used if URL is of type `file'."
+ :type 'regexp
+ :group 'TinyUrl)
+
+;;}}}
+;;{{{ setup: private
+
+;;; ......................................................... &private ...
+
+(defvar tinyurl-:mode-manually-turned-off nil
+ "On/Off mark when `tinyurl-mode-1' has been changed interactively.")
+
+(make-variable-buffer-local 'tinyurl-:mode-manually-turned-off)
+
+;; you can adjust this to include some more character, but please
+;; send message to maintainer if you do so.
+;;
+;; _ $ % & = are many times used in Message-ID's
+
+(defvar tinyurl-:cleaner-regexp "[^+~:/?()#%&=_$@.a-zA-Z0-9-]+"
+ "When reading the url from buffer, delete characters matching in this regexp.
+After cleaning, we should have ready URL.")
+
+(defvar tinyurl-:command-table-current nil
+ "The active command table name.")
+
+(defvar tinyurl-:event nil
+ "Last mouse event.")
+
+(defvar tinyurl-:timer-elt nil
+ "Timer element.")
+
+(defvar tinyurl-:history nil
+ "Url history.")
+
+(defvar tinyurl-:mouse-yank-at-point nil ;; mouse-yank-at-point
+ "Point used when url is clicked.
+If nil, when you click on point, the line is immediately
+scanned for urls and if the there was url under mouse point, then url
+will be followed. If there was no url then call original mouse binding.
+
+If non-nil, The mouse-point is not scanned for urls. Only existing
+overlays under point are read.
+
+In short: the t gives the usual 'run marked urls only' and t will say
+'install buttins to line, run url at point where the click happened if
+there was url'")
+
+;; Keyboard user's want to see the highlight immediately, so
+;; a 'face setting is better than the 'mouse-face, which is only
+;; seen when mouse is waved over the URL. 'face is immediately
+;; shown in the line.
+
+(defcustom tinyurl-:overlay-plist
+ (let* ((face (if (ti::compat-window-system)
+ 'mouse-face
+ 'face)))
+ (if (ti::emacs-p)
+ (list
+ 'rear-nonsticky t
+ 'rear-sticky nil
+ 'priority 1
+ face 'highlight
+ 'before-string "!"
+ 'url t
+ 'owner 'tinyurl)
+ (list
+ 'rear-nonsticky t
+ 'rear-sticky nil
+ 'priority 1
+ face 'highlight
+ 'begin-glyph (ti::funcall 'make-glyph "!")
+ 'url t
+ 'owner 'tinyurl)))
+ "*Property list (PROP VAL PROP VAL ..) used for all overlays."
+ :type 'sexp
+ :group 'TinyUrl)
+
+(defvar tinyurl-:win32-shell-execute-helper
+ (when (ti::win32-p)
+ (or (and (fboundp 'w32-shell-execute) ;; Emacs
+ 'w32-shell-execute)
+ (and (fboundp 'mswindows-shell-execute) ;; XEmacs
+ 'mswindows-shell-execute)
+ (executable-find "shellex") ;; Newer Emacs.
+ (executable-find "shellex.exe") ;; Emacs 20.2 does not check .exe
+ (error "\
+** TinyUrl: Automatic setup failed. See ´tinyurl-:win32-shell-execute-helper'.
+Can't find 'shellex' along `exec-path' with function `executable-find'.
+Visit http://www.tertius.com/projects/library/ and get shellex.exe")))
+ "*Win32 program or Emacs function to launch native Win32 programs.")
+
+;;;###autoload (autoload 'tinyurl-version "tinyurl" "Display commentary." t)
+(eval-and-compile
+ (ti::macrof-version-bug-report
+ "tinyurl.el"
+ "tinyurl"
+ tinyurl-:version-id
+ "$Id: tinyurl.el,v 2.85 2007/05/07 10:50:14 jaalto Exp $"
+ '(tinyurl-:version-id
+ tinyurl-:debug
+ tinyurl-:dispatch-hook
+ tinyurl-:validate-hook
+ tinyurl-:load-hook
+ timer-idle-list
+ timer-list
+ itimer-list
+ tinyurl-:load-hook
+ tinyurl-:dispatch-hook
+ tinyurl-:validate-hook
+ tinyurl-:display-glyph
+ tinyurl-:file-filter-table
+ tinyurl-:plugged-function
+ tinyurl-:exclude-function
+ tinyurl-:url-handler-function
+ tinyurl-:command-table
+ tinyurl-:email-regexp
+ tinyurl-:post-command-hook-threshold
+ tinyurl-:url-cache-buffer
+ tinyurl-:reject-url-regexp
+ tinyurl-:cleaner-regexp
+ tinyurl-:command-table-current
+ tinyurl-:event
+ tinyurl-:timer-elt
+ tinyurl-:history
+ tinyurl-:mouse-yank-at-point
+ tinyurl-:overlay-plist
+ tinyurl-:win32-shell-execute-helper)
+ '(tinyurl-:debug-buffer)))
+
+;;}}}
+;;{{{ mode and install
+
+;;;###autoload (autoload 'tinyurl-debug-toggle "tinyurl" "" t)
+
+(eval-and-compile (ti::macrof-debug-standard "tinyurl" "-:"))
+
+;;; .......................................................... &v-mode ...
+
+;;;###autoload (autoload 'tinyurl-mode "tinyurl" "" t)
+;;;###autoload (autoload 'turn-on-tinyurl-mode "tinyurl" "" t)
+;;;###autoload (autoload 'turn-off-tinyurl-mode "tinyurl" "" t)
+;;;###autoload (autoload 'tinyurl-commentary "tinyurl" "" t)
+
+(eval-and-compile
+ (ti::macrof-minor-mode-wizard
+ "tinyurl-" " U" nil "Url" 'TinyUrl "tinyurl-:"
+ "Mark URLs buttons on the line and call appropriate url handlers.
+
+To read the complete documentation, run `tinyurl-commentary'
+See also `tinyurl-version' (use prefix argument to see only version number).
+
+Defined keys:
+
+\\{tinyurl-:mode-map}"
+
+ "Url mode"
+ (progn ;Some mode specific things? No?
+ (tinyurl-modeline-update)
+ (cond
+ (tinyurl-mode
+ (put 'tinyurl-mode 'global t)
+ (unless (memq 'tinyurl-find-file-hook find-file-hooks)
+ (add-hook 'find-file-hooks 'tinyurl-find-file-hook)))
+ (t
+ (put 'tinyurl-mode 'global nil)
+ (when (memq 'tinyurl-find-file-hook find-file-hooks)
+ (remove-hook 'find-file-hooks 'tinyurl-find-file-hook))))
+ (when (null (get 'tinyurl-mode 'self-call))
+ (tinyurl-mode-action tinyurl-mode verb)))
+ ;; The Menubar item takes space and is not useful at least not
+ ;; now, because there is no other functionality in this mode.
+ nil
+ nil
+;;; "Tiny URL mode"
+;;; (list ;arg 10
+;;; tinyurl:mode-easymenu-name
+;;; ["Find url or call original key ESC RET" tinyurl-key-binding-default t]
+;;; ["Mode help" tinyurl-mode-help t]
+;;; )
+ (progn
+ ;; No, there is no key for `tinyurl-set-handler'. We try to
+ ;; minimize the used keys in this minor mode. Call M-x
+ ;; tinyurl-set-handler if you need to change this (not likely in
+ ;; Non-windowed Emacs)
+ (cond
+ ((ti::emacs-p)
+ (define-key root-map [?\e mouse-2] 'tinyurl-set-handler)
+ ;; We have to define this, because widget.el uses down-mouse-2
+ ;; and we must see it first.
+ (define-key root-map [down-mouse-2] 'tinyurl-mouse-binding-down)
+ (define-key root-map [mouse-2] 'tinyurl-mouse-binding))
+ (t
+ (define-key root-map [(meta button2)] 'tinyurl-set-handler)
+ (define-key root-map [(button2)] 'tinyurl-mouse-binding)))
+ (define-key root-map "\e\C-m" 'tinyurl-key-binding-default))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-mode-turn-on-ok-p ()
+ "Check if 'tinyurl-mode-1' is allowed to be turned on for the buffer.
+The buffer is seached for basic URL references and checked against
+`tinyurl-:exclude-function'."
+ (and (null tinyurl-mode)
+ (or (null tinyurl-:exclude-function)
+ (null (funcall tinyurl-:exclude-function (current-buffer))))
+ (ti::re-search-check
+ (concat "\\(ftp\\|https?\\)://"
+ "\\|<[^ \t\n]+@[^ \t\n]+>"
+ "\\|mailto:[^ \t\n]+@[^ \t\n]+"))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun turn-on-turn-off-tinyurl-mode-1-maybe ()
+ "Activate or deactivate `tinyurl-mode-1' in current buffer.
+Try to find ftp, http or email URL.
+The value of `tinyurl-:exclude-function' is consulted first."
+ (if (tinyurl-mode-turn-on-ok-p)
+ (turn-on-tinyurl-mode-1)
+ (turn-off-tinyurl-mode-1)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun turn-on-tinyurl-mode-1-maybe ()
+ "Activate `tinyurl-mode-1' in current buffer if ftp, http or email is found.
+This function is meant to be used in e.g. Article display
+hooks in Mail Agents.
+
+References:
+
+ The value of `tinyurl-:exclude-function' is consulted first."
+ (when (tinyurl-mode-turn-on-ok-p)
+ (turn-on-tinyurl-mode-1)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun turn-on-tinyurl-mode-mail ()
+ "Turn on `tinyurl-mode-1' and make `tinyurl-:mouse-yank-at-point' local."
+ (make-local-variable 'tinyurl-:mouse-yank-at-point)
+ ;; We set this to t, so that clicking url means scanning line
+ ;; immediately.
+ (setq tinyurl-:mouse-yank-at-point t)
+ (unless tinyurl-mode
+ (turn-on-tinyurl-mode-1)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun turn-on-tinyurl-mode-automatically ()
+ "This function is called from idle timer process `tinyurl-mark-process'.
+If `tinyurl-:mode-global-turned-off' is set, do nothing."
+ (when (and (get 'tinyurl-mode 'global)
+ (null tinyurl-:mode-global-turned-off)
+ (tinyurl-mode-turn-on-ok-p))
+ (turn-on-tinyurl-mode-1)
+ t))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun turn-on-tinyurl-mode-1 ()
+ "Turn URL mode on for this buffer only."
+ (interactive)
+ (unless tinyurl-mode
+ (when (interactive-p)
+ (setq tinyurl-:mode-manually-turned-off nil))
+ (tinyurl-mode-1 1)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun turn-off-tinyurl-mode-1 ()
+ "Turn URL mode off for this buffer only."
+ (interactive)
+ (when tinyurl-mode
+ (when (interactive-p)
+ (setq tinyurl-:mode-manually-turned-off t))
+ (tinyurl-mode-1 0)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-overlay-kill-in-buffer ()
+ "Kill TinyUrl overlays from whole buffer. See also `tinyurl-overlay-kill'."
+ (interactive)
+ (put 'tinyurl-mark-line 'point nil)
+ (ti::overlay-remove-region
+ (point-min) (point-max) '(owner tinyurl) 'prop-val-list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-overlay-kill ()
+ "Kill used overlays.
+This function only kills overlays recoded to internal list.
+Thje internal list may be inaccurate an to definitely wipe out
+TinyUrl overlays, use `tinyurl-overlay-kill-in-buffer'."
+ (put 'tinyurl-mark-line 'point nil)
+ (dolist (ov (get 'tinyurl-mark-line 'ov-list))
+ (delete-overlay ov)))
+
+;;; ----------------------------------------------------------------------
+;;;###autoload
+(defun tinyurl-mode-1 (arg)
+ "Turn mode on or off with mode ARG for current buffer only.
+If you want to turn on or off globally, use function `tinyurl-mode'."
+ (interactive "P")
+ (unless (assq 'tinyurl-mode minor-mode-map-alist)
+ (tinyurl-install-mode))
+ (ti::bool-toggle tinyurl-mode arg)
+ (tinyurl-modeline-update)
+ (unless tinyurl-mode ;Cleanup overlays on exit
+ (tinyurl-overlay-kill-in-buffer)
+ (tinyurl-overlay-kill))
+ (when (interactive-p)
+ (setq tinyurl-:mode-manually-turned-off (not tinyurl-mode)))
+ tinyurl-mode)
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-mode-action (&optional mode verb)
+ "Turn MODE `tinyurl-mode' on or off everywhere. See `tinyurl-mode'.
+This function must not be called directly, not even from Lisp. Use
+function `tinyurl-mode' function instead. VERB."
+ (unless (get 'tinyurl-mode 'self-call)
+ (run-hooks 'tinyurl-:mode-define-keys-hook))
+ (let* ((i 0)
+ tinyurl-:mode-define-keys-hook)
+ (unwind-protect
+ (progn
+ ;; Raise the flag to prevent calling us
+ (put 'tinyurl-mode 'self-call t)
+ ;; For every buffer, either turn mode on or off.
+ (dolist (buffer (buffer-list))
+ (incf i)
+ ;; Exclude hidden buffers
+ (when (not (string-match "^ " (buffer-name buffer)))
+ (with-current-buffer buffer
+ (cond
+ (mode
+ ;; Mark all buffers as "not modified"
+ (setq tinyurl-:mode-manually-turned-off nil)
+ (turn-on-tinyurl-mode-1-maybe))
+ (t
+ (turn-off-tinyurl-mode)
+ (setq tinyurl-:mode-manually-turned-off t)))))))
+ (when verb
+ (message "TinyUrl: Global mode is %s. Stepped through %d buffers"
+ (if mode
+ "on"
+ "off")
+ i)
+ (sit-for 1))
+ (put 'tinyurl-mode 'self-call nil))))
+
+;;; ----------------------------------------------------------------------
+;;;###autoload
+(defun tinyurl-install (&optional uninstall)
+ "Install or `UNINSTALL package."
+ (interactive "P")
+ (put 'tinyurl-plugged-p 'mode nil)
+ (ti::compat-timer-cancel-function 'tinyurl-mark-process)
+ (tinyurl-install-mode)
+ (ti::add-hooks '(Man-mode-hook
+ compilation-mode-hook)
+ 'turn-on-tinyurl-mode-1
+ uninstall)
+ (remove-hook 'post-command-hook 'tinyurl-mark-process-post-command)
+ (tinyurl-install-command-table)
+ ;; If the idle timer is available, use it. Otherwise we would have
+ ;; no other option but occupy post command hook
+ (unless uninstall
+ (if (ti::idle-timer-supported-p)
+ (setq tinyurl-:timer-elt
+ (ti::funcall 'run-with-idle-timer 2 t 'tinyurl-mark-process))
+ (add-hook 'post-command-hook
+ 'tinyurl-mark-process-post-command))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-install-to-packages (&optional restore-original)
+ "Make TinyUrl default top level url handler: GNUS, TM, VM etc.
+Optionally RESTORE-ORIGINAL url handlers."
+ (interactive "P")
+ (let* ()
+;;; (list '(gnus-button-url
+;;; gnus-button-embedded-url
+;;; tm:browse-url
+;;; vm-mouse-send-url
+;;; ))
+ (ti::add-hooks '(rmail-show-message-hook
+ vm-select-message-hook
+ mh-show-mode-hook)
+ 'turn-on-tinyurl-mode-mail
+ restore-original)
+ ;; Using advice
+ ;; 1) package may not be loaded yet, advice activated when it loads.
+ ;; 2) Changing the MUA varibles would maen requiring the feature,
+ ;; and then changing the defaults, but what guarrantees that user
+ ;; doesn't reset the vars somewhere else?
+ ;; 3) Gnus adds all button to the article, but tinyurl only looks
+ ;; current line
+ ;; See gnus-art.el
+ ;; gnus-button-embedded-url gnus-button-url gnus-url-mailto
+ (when nil ;Enabled now
+ (require 'advice)
+ (defadvice gnus-button-url (around tinyurl dis)
+ "Replace function and call `tinyurl-:url-handler-function'"
+ (let ((URL (ti::string-remove-whitespace (ad-get-arg 0))))
+ (funcall tinyurl-:url-handler-function URL)))
+ (defadvice gnus-article-push-button (around tinyurl dis)
+ "Replace function and call `tinyurl-:url-handler-function'"
+ (let ((URL (ti::string-remove-whitespace (ad-get-arg 0))))
+ (funcall tinyurl-:url-handler-function URL)))
+ (defadvice gnus-button-embedded-url (around tinyurl dis)
+ "Replace function and call `tinyurl-:url-handler-function'"
+ (let ((URL (ti::string-remove-whitespace (ad-get-arg 0))))
+ (funcall tinyurl-:url-handler-function URL)))
+ (defadvice gnus-url-mailto (around tinyurl dis)
+ "Replace function and call `tinyurl-:url-handler-function'"
+ (let ((URL (ti::string-remove-whitespace (ad-get-arg 0))))
+ (funcall tinyurl-:url-handler-function URL)))
+ ;; vm-mouse-send-url (url &optional browser)
+ (defadvice vm-mouse-send-url (around tinyurl act)
+ "Replace function and call `tinyurl-:url-handler-function'"
+ (funcall tinyurl-:url-handler-function (ad-get-arg 0))))
+ ;; TM/SEMI Unfortunately has no hook that runs when preview
+ ;; buffer is created with
+ (when nil
+ (require 'advice)
+ (defadvice tm:browse-url (around tinyurl act) ;TM.el
+ "Replace function and call `tinyurl-:url-handler-function'"
+ (tinyurl-at-point 'verb))
+ (defadvice mime-viewer/make-preview-buffer (after tinyurl act)
+ "Call `turn-on-tinyurl-mode-mail'."
+ (turn-on-tinyurl-mode-mail))
+ (defadvice mime-edit-preview-message (after tinyurl act)
+ "Call `turn-on-tinyurl-mode-mail'."
+ (turn-on-tinyurl-mode-mail))
+ (if restore-original
+ (ti::advice-control list "tinyurl" 'disable)
+ (ti::advice-control list "tinyurl")))
+ (when (ti::win32-p)
+ (defconst gnus-button-url 'tinyurl-dispatcher-1) ; GNUS
+ ;; VM
+ (defconst vm-url-browser 'tinyurl-dispatcher-1))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-find-file-hook ()
+ "Turn on tinyurl mode if `tinyurl-:mode-global' is non-nil."
+ (when (and (get 'tinyurl-mode 'global)
+ (null tinyurl-mode))
+ (turn-on-tinyurl-mode-1)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-set-handler (table)
+ "Set active url handler command TABLE."
+ (interactive
+ (list (completing-read
+ "TinyUrl, use command table: " tinyurl-:command-table nil t)))
+ (setq tinyurl-:command-table-current table)
+ (tinyurl-modeline-update))
+
+;;}}}
+;;{{{ misc
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-plugged-p ()
+ "Return plugged status."
+ (or (get 'tinyurl-plugged-p 'mode)
+ (ti::mail-plugged-p)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-plugged-always-p ()
+ "Return true plugged status."
+ t)
+
+;;; ----------------------------------------------------------------------
+;;; Called by the Line marker process to keep track of the Gnus mode changes
+;;;
+(defun tinyurl-plugged-update ()
+ "Update plugged status."
+ (put 'tinyurl-plugged-p 'mode (tinyurl-plugged-p)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-plugged-mode-toggle (&optional arg verb)
+ "Set plugged status according to ARG. 1 means plugged and 0 unplugged.
+When mode is nil, assume unplugged unless `ti::mail-plugged-p'
+\(Gnus) says otherwise."
+ (interactive "P")
+ (let* ((mode (get 'tinyurl-plugged-p 'mode)))
+ (ti::verb)
+ (ti::bool-toggle mode arg)
+ (put 'tinyurl-plugged-p 'mode mode)
+ (if verb
+ (message "TinyUrl: %s"
+ (if mode "Plugged" "Unplugged")))
+
+ (if (boundp 'gnus-plugged)
+ (setq gnus-plugged mode))
+
+ (tinyurl-modeline-update)
+ (get 'tinyurl-plugged-p 'mode)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-call-process-win32 (binary &rest args)
+ "Call Win32 native BINARY with ARGS"
+ (interactive)
+ (cond
+ ((stringp tinyurl-:win32-shell-execute-helper)
+ (apply 'call-process
+ tinyurl-:win32-shell-execute-helper
+ nil
+ nil
+ nil
+ ;; binary
+ args))
+ ((functionp tinyurl-:win32-shell-execute-helper)
+ (apply tinyurl-:win32-shell-execute-helper "open" args))
+ (t
+ (message
+ "TinyUrl: `tinyurl-:win32-shell-execute-helper' not configured."))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-default-exclude (buffer)
+ "Default function for `tinyurl-:exclude-function' to ignore BUFFER.
+Ignores VM, W3, DIRED, ARCHIVE, COMPILE, GREP buffers.
+
+The buffer ignore status is recorded to the plist of
+function ´tinyurl-default-exclude', which you can recall with:
+
+ (get 'tinyurl-default-exclude 'exclude-list)"
+ (with-current-buffer buffer
+ (let* ((exclude-list (get 'tinyurl-default-exclude
+ 'exclude-list))
+ (nok-status (assq buffer exclude-list)))
+ (unless nok-status
+ (let* ((name (symbol-name major-mode))
+ (stat (string-match
+ (concat
+ "^w3-\\|^vm-\\|dired\\|archive\\|compil\\|grep$"
+ "\\|archive")
+ name)))
+ (when stat
+ (pushnew (cons buffer 'exclude) exclude-list :test 'equal)
+ (put 'tinyurl-default-exclude 'exclude-list exclude-list)
+ (message "TinyUrl: Excluded buffer ´%s' Major-mode: %s"
+ (buffer-name)
+ name)
+ stat))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-command-table-put (table key value)
+ "Use command TABLE entry and change KEY's value to new VALUE."
+ (let* (elt
+ new
+ ok)
+ (while (setq elt (pop table))
+ (when (eq (car elt) key)
+ (setq elt (cons key value)
+ ok t))
+ (push elt new))
+ (or ok
+ (error "TinyUrl: No key %s found" key))
+ (nreverse new)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-command-table-put-2nd (table key1 key2 value)
+ "Use command TABLE, find KEY1, change 2nd level KEY2's value to new VALUE.
+The TABLE is modified in place."
+ (let* (elt
+ list
+ mem
+ new
+ ok)
+ (or (setq elt (assq key1 table))
+ (error "TinyUrl: Key1 %s does not exist" key1))
+ (setq list (nth 1 elt))
+ (while list
+ (setq mem (car list))
+ (push mem new)
+ (when (eq mem key2)
+ ;; Raise flag, change value
+ (setq ok t)
+ (push value new)
+ ;; skip next element, because this is the old value.
+ (setq list (cdr list)))
+ (setq list (cdr list)))
+ (setq new (nreverse new))
+ (unless ok
+ (error "No key2 '%s'" key2))
+
+ (setcdr elt (list new)) ; Change key1's right hand list
+ table))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-browse-url-browser-function ()
+ "Return default `browse-url-browser-function'."
+ (when (and (boundp 'browse-url-browser-function)
+ browse-url-browser-function)
+ ;; If the value is not a function it should be a list of pairs
+ ;; (REGEXP . FUNCTION)
+ (cond
+ ((functionp browse-url-browser-function)
+ (if (not (eq browse-url-browser-function
+ 'tinyurl-dispatcher-1))
+ browse-url-browser-function))
+ ((listp browse-url-browser-function)
+ (dolist (elt browse-url-browser-function)
+ (when (string-match "netscape" (symbol-name (cdr-safe elt)))
+ (return (cdr elt))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-user-default-browser-type ()
+ "What kind of browser user used before? \"netscape\" or \"iexplore."
+ (let* ((browse (tinyurl-browse-url-browser-function))
+ (user-default
+ (when browse
+ (cond
+ ((string-match "netscape" (symbol-name browse))
+ 'netscape)
+ ((ti::win32-p)
+ 'iexplore)
+ (t
+ ;; Don't know. Use whatever is there.
+ 'default)))))
+ user-default))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-user-command-table-default ()
+ "Return default command table choice.
+This might be \"netscape\" or \"iexplore\"."
+ (interactive)
+ (let* ((default (tinyurl-user-default-browser-type)))
+ (cond
+ ((ti::win32-p) ;Win32
+ (let ((net (executable-find "netscape")))
+ (if (and net
+ (eq default 'netscape))
+ "netscape"
+ ;; "c:/Program Files/Internet Explorer/iexplore.exe
+ "iexplore")))
+ (t ;Unix
+ (if (not (ti::compat-window-system))
+ "w3"
+ ;; In Unix the name has "r" at the end
+ (let* ((ie (executable-find "iexplorer")))
+ (cond
+ (ie
+ "iexplore")
+ ((eq default 'netscape)
+ "netscape")
+ (t
+ "default"))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-command-table-default-1 ()
+ "Return default `tinyurl-:command-table' entry.
+If you change this function's source, run
+
+ (tinyurl-install-command-table 'force)
+
+References:
+ `tinyurl-:overlay-plist'"
+ (list
+ ;; could also use `tinyurl-find-url-mail'
+ '(mail . tinyurl-find-url-mail-browse-url)
+ '(url-message-id . tinyurl-find-url-message-id)
+ '(url-http . tinyurl-find-url-http) ;; www.x.com
+ '(url-ftp . tinyurl-find-url-file) ;; ftp://site.com
+ '(url . browse-url)
+ '(url-ange . find-file) ;; /foo@site.com:
+ '(url-debian-bts . tinyurl-find-debian-bts-bug) ;; Bug#NNNNNN
+ '(file . tinyurl-find-url-file)
+ '(file-packed . tinyurl-find-url-file)
+ '(file-code-c . ff-find-other-file)
+ '(file-code-lisp . tinyurl-find-url-lisp)
+ '(file-code-perl . tinyurl-find-url-perl)
+ '(file-code-perl-pod-manpage . tinyurl-find-url-perl-pod-manpage)
+ '(file-code-perl-pod-module . tinyurl-find-url-perl-pod-module)
+ '(file-code-perl-method . tinyurl-find-url-perl-method)
+ '(compiler-perl-in-file-at-line . tinyurl-find-url-perl-compile)
+ '(compiler-perl-at-line . tinyurl-find-url-perl-compile)
+ '(compiler-php-at-line . tinyurl-find-url-php-compile)
+ '(file-other . ffap)
+ '(man . tinyurl-find-url-man)
+ '(other . tinyurl-find-url-file)
+ (list
+ 'overlay-plist
+ tinyurl-:overlay-plist)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defmacro tinyurl-command-table-before-string (entry string)
+ "Replace property 'before-string in ENTRY with STRING."
+ (`
+ (if (ti::emacs-p)
+ (tinyurl-command-table-put-2nd
+ (, entry) 'overlay-plist 'before-string (, string))
+ (tinyurl-command-table-put-2nd
+ (, entry) 'overlay-plist 'begin-glyph
+ (ti::funcall 'make-glyph (, string))))))
+
+;;; ----------------------------------------------------------------------
+;;; This is a copy from function `browse-url'.
+(defun tinyurl-command-browse-url-default-browser-function-1
+ (&optional url)
+ "Return function from `browse-url-browser-function' for URL.
+URL defaults to http"
+ (when (boundp 'browse-url-browser-function)
+ (if (functionp browse-url-browser-function)
+ browse-url-browser-function
+ ;; The `function' can be an alist; look down it for first match
+ ;; and apply the function (which might be a lambda).
+ (dolist (elt browse-url-browser-function)
+ (when (string-match (car elt) (or url "http"))
+ (return (cdr elt)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-command-browse-url-default-browser-function ()
+ "Find brose-url.el function that would call the default broser.
+If not found, signal error."
+ (or (tinyurl-command-browse-url-default-browser-function-1)
+ (error "TinyUrl: `browse-url-browser-function' is not set.
+Has brose-url.el been loaded?")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-command-table-default ()
+ "Return \"default\" entry."
+ (let* ((entry (tinyurl-command-table-default-1)))
+ ;; (setq entry (tinyurl-command-table-put
+ ;; entry
+ ;; 'url
+ ;; (tinyurl-command-browse-url-default-browser-function)))
+ (tinyurl-command-table-before-string entry "!")
+ entry))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-command-table-netscape ()
+ "Return Netscape entry."
+ (let* ((entry (tinyurl-command-table-default-1)))
+ (when (executable-find "netscape")
+ (setq entry (tinyurl-command-table-put
+ entry 'url 'browse-url-netscape))
+ (tinyurl-command-table-before-string entry "!")
+ entry)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-command-table-iexplore ()
+ "Return Unix Iexplorer entry."
+ (let* ((entry (tinyurl-command-table-default-1)))
+ (when (executable-find "iexplorer") ;; Extra "r" in name
+ (setq entry (tinyurl-command-table-put
+ entry 'url 'browse-url-iexplore))
+ (tinyurl-command-table-before-string entry "!")
+ entry)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-command-table-netscape-win32 ()
+ "Return Netscape entry."
+ (let* ((entry (tinyurl-command-table-default-1)))
+ (setq entry (tinyurl-command-table-put
+ entry 'url 'tinyurl-find-url-win32-netscape))
+ (tinyurl-command-table-before-string entry "!")
+ entry))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-command-table-iexplore-win32 ()
+ "Return Netscape entry."
+ (let* ((entry (tinyurl-command-table-default-1)))
+ (setq entry (tinyurl-command-table-put
+ entry 'url 'tinyurl-find-url-win32-iexplore))
+ (tinyurl-command-table-before-string entry "@")
+ entry))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-command-table-lynx ()
+ "Return Lynx entry."
+ (let* ((entry (tinyurl-command-table-default-1)))
+ (setq entry (tinyurl-command-table-put
+ entry 'url 'browse-url-lynx-emacs))
+ (tinyurl-command-table-before-string entry "*")
+ entry))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-command-table-w3 ()
+ "Return W3 entry."
+ (let* ((entry (tinyurl-command-table-default-1)))
+ (setq entry (tinyurl-command-table-put
+ entry 'url 'browse-url-w3))
+ (tinyurl-command-table-before-string entry "?")
+ entry))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-command-table-defaults ()
+ "Return default value for `tinyurl-:command-table'."
+ (delq nil ;remove empty entries
+ (list
+ (list "default" (tinyurl-command-table-default))
+ (if (ti::win32-p)
+ (list "netscape" (tinyurl-command-table-netscape-win32))
+ (list "netscape" (tinyurl-command-table-netscape)))
+ (if (ti::win32-p)
+ (list "iexplore" (tinyurl-command-table-iexplore-win32))
+ (list "iexplore" (tinyurl-command-table-iexplore)))
+ ;; FIXME: Ahem, there is Lynx for Win32; but I don't know
+ ;; if anybody uses it.
+ (unless (ti::win32-p)
+ (list "lynx" (tinyurl-command-table-lynx)))
+ (list "w3" (tinyurl-command-table-w3)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-command-table-defaults-set ()
+ "Set `tinyurl-:command-table' to defaults."
+ (interactive)
+ (setq tinyurl-:command-table (tinyurl-command-table-defaults)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-install-command-table (&optional force)
+ "Set default values to `tinyurl-:command-table'. FORCE reset."
+ (if force
+ (tinyurl-command-table-defaults-set)
+ (or tinyurl-:command-table
+ (tinyurl-command-table-defaults-set)))
+ ;; Some safety measure needed..
+ (unless (stringp (caar tinyurl-:command-table))
+ (error "TinyUrl: Setting `tinyurl-:command-table' failed."))
+ ;; Set default only if it is NIL
+ (unless (stringp tinyurl-:command-table-current)
+ (setq tinyurl-:command-table-current
+ (tinyurl-user-command-table-default))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-modeline-update ()
+ "Update modeline name."
+ (tinyurl-install-command-table)
+ (tinyurl-plugged-update)
+ (setq tinyurl-:mode-name
+ (concat " U"
+ (downcase (ti::string-left tinyurl-:command-table-current 1))
+ (if (funcall tinyurl-:plugged-function)
+ "!" "")))
+ (ti::compat-modeline-update))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinyurl-set-mouse-maybe (event)
+ "Set point to mouse EVENT and mark URLs in the line."
+ (when (and event (null tinyurl-:mouse-yank-at-point))
+ (goto-char (ti::mouse-point event))
+ (tinyurl-mark-line)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinyurl-table (table)
+ "Return command TABLE."
+ (or (nth 1 (assoc table tinyurl-:command-table))
+ (prog1 nil)))
+ ;; (message "TinyUrl: [ERROR] No such command table: [%s] " table)
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-table-current (&optional table)
+ "Return copy of active command table.
+References:
+ `tinyurl-:display-glyph'"
+ (let* ((table (tinyurl-table
+ (or table
+ tinyurl-:command-table-current))))
+ (when (and table
+ (null tinyurl-:display-glyph))
+ ;; Make local copy and changing `before-string' to ""
+ (setq table (copy-tree table))
+ (setcar (nthcdr 1 (member
+ (if (ti::emacs-p)
+ 'before-string
+ 'begin-glyph)
+ (nth 1 (assq 'overlay-plist table))))
+ (if (ti::emacs-p)
+ ""
+ (ti::funcall 'make-glyph ""))))
+ table))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinyurl-overlay-plist (&optional table)
+ "Return overlay plist of TABLE."
+ (nth 1 (assq 'overlay-plist (tinyurl-table-current table))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinyurl-agent-function (type)
+ "Return agent function for TYPE. See `tinyurl-:command-table'."
+ (let ((elt (cdr (assq type (tinyurl-table-current)))))
+ (unless elt
+ (error "Tinyurl: Unknown type %s" type))
+ (tinyurl-debug "tinyurl-agent-function" elt)
+ elt))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinyurl-agent-funcall (type url)
+ "Call correct function according to TYPE and pass it an URL."
+ (funcall (tinyurl-agent-function type) url))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinyurl-types ()
+ "Return known url types in `tinyurl-:command-table-current'."
+ (mapcar 'car (tinyurl-table-current)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-mouse-binding (event)
+ "Jump to URL at point or call original function with mouse EVENT."
+ (interactive "e")
+ (setq tinyurl-:event event)
+ (tinyurl-dispatcher event 'mouse))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-mouse-binding-down (event)
+ "Jump to URL at point or call original function with mouse EVENT."
+ (interactive "e")
+ (setq tinyurl-:event event)
+ (put 'tinyurl-:event 'down-event event))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-key-binding-default ()
+ "Jump to URL at point or call original ESC RET key binding."
+ (interactive)
+ (setq tinyurl-:event nil)
+ (tinyurl-mark-line)
+ (tinyurl-dispatcher "\e\C-m" 'key))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinyurl-overlay-get (&optional point)
+ "Reeturn overlay from current POINT if there is any '(owner tinyurl)."
+ (let* ((list (overlays-at (or point (point)))))
+ (if list
+ (ti::overlay-get-prop list '(owner tinyurl)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinyurl-get-filter (url)
+ "Return filter or any for URL."
+ (cdr-safe (ti::list-find (delq nil tinyurl-:file-filter-table) url)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-filter-pod (url)
+ "Handle Perl pod URL."
+ (let* ((pod (or (get 'tinyurl-filter-pod 'pod2text)
+ (executable-find "pod2text")
+ (message "TinyUrl: No `pod2text' command found.")
+ nil))
+ (buffer shell-command-output-buffer))
+ (put 'tinyurl-filter-pod 'pod2text pod)
+ (if (null pod)
+ (find-file url)
+ (call-process pod nil buffer nil url)
+ (when (and (get-buffer buffer)
+ (featurep 'tinyperl))
+ (with-current-buffer buffer
+ (turn-on-tinyperl-pod-view-mode))
+ (ti::pop-to-buffer-or-window buffer)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-overlay-kill ()
+ "Kill used overlays.
+This function only kills overlays recoded to internal list.
+The internal list may be inaccurate. To completely wipe out
+TinyUrl owned overlays, use `tinyurl-overlay-kill-in-buffer'."
+ (put 'tinyurl-mark-line 'point nil)
+ (dolist (ov (get 'tinyurl-mark-line 'ov-list))
+ (delete-overlay ov)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-overlay-kill-in-buffer ()
+ "Kill TinyUrl overlays from whole buffer. See also `tinyurl-overlay-kill'."
+ (interactive)
+ (put 'tinyurl-mark-line 'point nil)
+ (ti::overlay-remove-region
+ (point-min)
+ (point-max)
+ '(owner tinyurl)
+ 'prop-val-list))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-dispatch-ignore-p (&rest dummy)
+ "Check if control is passed back to underlying mode. Ignore DUMMY."
+ (memq major-mode '(archive-mode
+ dired-mode
+ dired-virtual-mode
+ tar-mode
+ zip-mode)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-dispatcher-1 (url)
+ "Redirect URL to proper agent handler."
+ (interactive)
+ (let* ((fid "tinyurl-dispatcher-1:")
+ (tinyurl-:file-filter-table tinyurl-:file-filter-table) ;; make copy
+ url-type
+ tmp
+ ret)
+ ;; ....................................................... do-it ...
+ (cond
+ ((and tinyurl-:validate-hook
+ (not (eq t (setq ret (run-hook-with-args-until-success
+ 'tinyurl-:validate-hook url)))))
+ (if (not (stringp ret))
+ (message "TinyUrl: url ignored. See tinyurl:-url-validate-hook")
+ (message ret)))
+ (t ;; it's ok
+ (when current-prefix-arg
+ (setq url (read-from-minibuffer
+ "(TinyUrl) edit: "
+ url
+ nil
+ nil
+ 'tinyurl-:history))
+ ;; User can also control the access method, But beware.
+ ;; Trying to call Url that is not Perl type is disastrous
+ (unless (ti::nil-p url)
+ (setq url-type
+ (intern
+ (completing-read
+ "(TinyUrl) Select type: "
+ (ti::list-to-assoc-menu
+ (mapcar 'symbol-name (tinyurl-types)))
+ nil
+ 'match-needed
+ (if (tinyurl-type url)
+ (symbol-name (tinyurl-type url))
+ nil)))))
+ (when (and (setq tmp (tinyurl-get-filter url))
+ (y-or-n-p
+ (format "(TinyUrl) By-pass filter [%s]? "
+ (prin1-to-string tmp))))
+ (setq tinyurl-:file-filter-table nil))) ;; when
+ (tinyurl-debug fid url-type tinyurl-:url-handler-function url)
+ (if (not (ti::nil-p url))
+ (funcall tinyurl-:url-handler-function url url-type))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-gnus-callback-at-point ()
+ "Return gnus-callback text property at point."
+ (get-text-property (point) 'gnus-callback))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-call-original-mouse (event)
+ "Call original mouse-2 function, unless in compilation buffer."
+ (let* ((mode (symbol-name major-mode))
+ (function
+ (let* ((local (current-local-map))
+ tinyurl-mode)
+ (or (and local
+ (if (ti::emacs-p)
+ (lookup-key local [mouse-2])
+ (lookup-key local [(button2)])))
+ (if (ti::emacs-p)
+ (lookup-key global-map [mouse-2])
+ (lookup-key global-map [(button2)]))))))
+ (if (and (string-match "yank" (symbol-name function))
+ (or (string-match "compil" mode) ;compilation, compile
+ buffer-read-only))
+ (message "TinyUrl: Nothing to (yank) here.")
+ (ti::compat-mouse-call-original 'tinyurl-mode event))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-gnus-data-at-point ()
+ "Return gnus-data text property at point."
+ (get-text-property (point) 'gnus-data))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-dispatcher (&optional event type)
+ "See if there is URL at point. Otherwise act like usual key/mouse call.
+
+Input:
+
+ EVENT mouse-event or key binding
+ TYPE 'mouse or 'key. The EVENT type"
+
+ (let* ((ov (tinyurl-overlay-get))
+ (url (and ov
+ (ti::overlay-buffer-substring ov 'no-properties)))
+ (nok-p (or (null url)
+ (and tinyurl-:dispatch-hook
+ (run-hook-with-args-until-success
+ 'tinyurl-:dispatch-hook
+ url
+ (cons (current-buffer) (point))))))
+ ;; (mouse-2 . gnus-article-push-button)
+ ;; (gnus-callback gnus-article-toggle-cited-text)
+ (gnus-callback (tinyurl-gnus-callback-at-point))
+ (gnus-data (tinyurl-gnus-data-at-point)))
+ ;; Notice that if you add text near the overlay, the overlay
+ ;; starts stretching an the beg end point do not accurately
+ ;; designate the URL.
+ ;;
+ ;; Also see this example url that may be in quotes, "ftp://foo.com/"
+ ;; or surrounded by parenthesis, whatever. We remove invalid
+ ;; characters. The "#" must stay, ebacsue it's NAME tag inside URL
+ ;;
+ ;; ftp://foo.com/this.txt#tag
+ ;; ftp://foo.com/perl.pl?params
+
+ (when (eq type 'mouse)
+ (tinyurl-set-mouse-maybe event))
+ (cond
+ (nok-p
+ (cond
+ ((eq type 'mouse)
+ ;; The underlying application may have defined down-event; like
+ ;; widget.el does in Gnus. In that case; we must give priority
+ ;; to down-event. Otherwise call normal mouse-2 event.
+ (let* ((down-event (get 'tinyurl-:event 'down-event))
+ (down-func (if down-event
+ (ti::compat-mouse-call-original-function
+ 'tinyurl-mode
+ down-event))))
+ ;; Now clear events, so that these old ones are not used.
+ (setq tinyurl-:event nil)
+ (put 'tinyurl-:event 'down-event nil)
+ (cond
+ (gnus-callback
+ (funcall gnus-callback gnus-data))
+ ((and down-func
+ (fboundp down-func))
+ (tinyurl-call-original-mouse down-event))
+ (t
+ (tinyurl-call-original-mouse event)))))
+ (t
+ (ti::compat-key-call-original 'tinyurl-mode event))))
+ (t
+ (tinyurl-dispatcher-1 url)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-at-point (&optional verb)
+ "Mark line for urls and go to the url at point if any. VERB."
+ (interactive)
+ (ti::verb)
+ (tinyurl-mark-line)
+ (let* ((ov (tinyurl-overlay-get))
+ (URL (and ov
+ (buffer-substring-no-properties
+ (overlay-start ov) (overlay-end ov)))))
+ (cond
+ (URL
+ (funcall tinyurl-:url-handler-function))
+ (verb
+ (message "TinyUrl: No url found.")))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-validate-url-default (url)
+ "Default URL validate.
+- Discard foo|bar|quux urls and character $, like in $THIS_DIR.
+- Discard Files that do not exist.
+- Discard all /dev or /proc files
+
+Return:
+
+ t URL accepted
+ string Error Message."
+
+ (let* ((fid "tinyurl-validate-url-default:")
+ (info (ti::file-path-and-line-info url)) ;FILE:NBR --> FILE
+ (type (tinyurl-type url))
+ ret)
+ (if info
+ (setq url (car info)))
+ (setq
+ ret
+ (cond
+ ((string-match "^/\\(dev\\|proc\\)/" url)
+ (format "TinyUrl: (url validate) Device file ignored"))
+ ((string-match
+ (concat
+ "^\\(/usr\\(/local\\)?\\|/opt\\|/vol\\)?/s?bin/"
+ ;; Ehm. What to do with Windows and Cygwin Files? This is
+ ;; an approximation
+ "\\|^C:[\\/]win")
+ url)
+ (format "TinyUrl: (url validate) Binary file ignored"))
+ ((ti::file-name-remote-p url)
+ t) ;do not check ange-ftp
+ ((or (string-match "\\<\\(foo\\|bar\\|quux\\)" url)
+ (string-match "\\$" url))
+ (format "TinyUrl: (url validate) Invalid keyword '%s' in URL [%s]"
+ (match-string 0 url)
+ url))
+ ((and (string-match "^[~/\\]\\|^[a-z]:[/\\]" url)
+ ;; Ange is called if file contains :, prevent it
+ (not (string-match "^/[a-z]+@[0-9a-z.-]+:" url))
+ (not (file-exists-p url)))
+ (format "TinyUrl: (url validate) File not found [%s]" url))
+ ((and (string-match "file" (symbol-name type))
+ (stringp tinyurl-:reject-url-regexp)
+ (string-match tinyurl-:reject-url-regexp url))
+ "TinyUrl: (url validate) rejected by `tinyurl-:reject-url-regexp'")
+ ((and (string-match (or (ti::id-info nil 'cache) "") "perl")
+ (save-excursion
+ (beginning-of-line)
+ (looking-at
+ (concat
+ ".*\\("
+ "=~\\|!~\\|=!" ; =~ or !~ =!
+ "\\|! *m?/" ; if ( ! /this/ )
+ "\\|if[ \t]+m?/" ; $1 if /match/
+ "\\|=[ \t]+m?/" ; = m/this/
+ "\\|\\<s/" ; s/this/that
+ "\\|\\<qq?/" ; q/word word word/;
+ "\\)"))))
+ (concat "TinyUrl: (url validate) Perl like statement rejected: "
+ (match-string 1)))
+ (t
+ t)))
+ (tinyurl-debug fid url ret)
+ ret))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-validate-url-perl-method (url)
+ "Check Perl Foo::Bar->new(...)."
+ (cond
+ ((not (string-match "perl" (ti::id-info)))
+ "TinyUrl: (perl url validate) rejected due to non-perl buffer")
+ (t
+ t))) ;; accept
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-validate-url-email (url)
+ "Accept email url only if it doesn't overlap with http://.
+E.g. Following url would be targetted as email, because it has <.*@.*>
+
+<URL:http://groups.google.com/groups?as_q=&as_umsgid=3cgd8m0w.fsf@blue.sea.net>"
+ (cond
+ ((string-match "http://\\|file:/\\|ftp://" url)
+ "TinyUrl: (email url validate) rejected due to URI reference: %s" url)
+ ((not (string-match
+ "[0-9a-z.-]+@[0-9a-z]+\\(\\.[0-9a-z-]+\\)*\\.[a-z]+>?$" url))
+ "TinyUrl: (email url validate) does no look like mail address: %s" url)
+ (t
+ t))) ;; accept
+
+;;}}}
+;;{{{ URL handler
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-find-url-lisp (url)
+ "Find Emacs Llisp package URL."
+ (let* ((file (ti::string-match "[\"']\\([^\"')]+\\)" 1 url)))
+ (when file
+ (setq file (replace-regexp-in-string "c$" "" file))
+ (setq file (ti::string-verify-ends file "\\.el" ".el")))
+ (cond
+ ((null file)
+ (message "TinyUrl: Odd url %s" url))
+ ((null (setq file (locate-library file)))
+ (message "TinyUrl: %s not found from lisp `load-path'" url))
+ (t
+ (find-file file)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-find-debian-bts-bug (url)
+ "Find Debian BTS bug URL."
+ (let (bug)
+ (when (setq bug (ti::string-match "\\([0-9]+\\)" 1 url))
+ (if (eq (length bug) 6)
+ (tinydebian-bug-browse-url-by-bug bug)
+ (message "TinyUrl: Incorrect bug number %s" bug)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-find-url-php-compile (url)
+ "Find PHP compiler error URL."
+ ;; <b>Parse error</b>: parse error in <b>FILE.php</b> on line <b>161</b><br>
+ (let* ((file (ti::string-match
+ "parse error in <b>\\([^<\n]+\\)</b> *on line"
+ 1
+ url))
+ (line (ti::string-match
+ "parse error in.*on line <b>\\([0-9]+\\)"
+ 1
+ url)))
+ (if (null line) ;Quiet byte compiler: unused var
+ (setq line nil))
+ ;; FIXME: Actually the general FILE-FIND URL method already can grab
+ ;; the filename and jump to the correct location, so I'm not sure we need
+ ;; specific PHP url handler.
+ (if file ;; This is no-op, quiet byte compiler for now.
+ (setq file file))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-find-url-perl-pod-manpage (url)
+ "Find perl POD manpage URL."
+ (setq url (ti::string-match "perl[^] ,.\n\t]+" 0 url))
+ (let* (point)
+ ;; Check if the referenced pod page is on the current buffer
+ ;; NAME
+ ;; perlfunc - Perl builtin functions
+ ;;
+ ;; DESCRIPTION
+ (setq point (ti::re-search-check (format "NAME\n +%s -" url)))
+ (if point
+ (goto-char point)
+ (tinyperl-pod-by-manpage (tinyperl-pod-manpage-to-file url)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-find-url-perl-pod-module (url)
+ "Find perl POD page: URL."
+ (setq url (replace-regexp-in-string " +manpage" "" url))
+ (tinyperl-pod-by-module (tinyperl-pod-manpage-to-file url)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-find-url-perl-1 (file &optional method)
+ "Go to Perl FILE and put point to optional METHOD."
+ (let* ((regexp (if method
+ (concat "^[ \t]*sub[ \t\n\r]*"
+ method
+ "\\>")))
+ elt)
+ (if (null (setq elt (tinyperl-locate-library file)))
+ (message "TinyUrl: No Perl module found, %s" file)
+ (switch-to-buffer (tinyperl-library-find-file elt))
+ (when method
+ (unless (re-search-forward regexp nil t)
+ (message "TinyUrl: Hm, can't find sub using [%s]" regexp))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-find-url-perl-method (url)
+ "Find Perl Foo::Bar->new(...) URL."
+ (let* (file
+ method)
+ (when (string-match "\\([^ \t\n]+\\)->\\([^ \t\n]+\\)" url)
+ (setq file (match-string 1 url)
+ method (match-string 2 url)))
+ (cond
+ ((null file)
+ (message "TinyUrl: Opps, odd perl URL %s" url)
+ (sleep-for 1))
+ (t
+ (tinyurl-find-url-perl-1 file method)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-find-url-perl (url)
+ "Find Perl `require' and `use' URL."
+ (let* (file)
+ (cond
+ ((setq file (ti::string-match
+ "use[ \t]+\\([^ \t\n;]+\\)" 1 url))
+ (setq file (concat file ".pm")))
+ ((setq file (ti::string-match
+ "require[ \t'\"]+\\([^ '\"\t\n;]+\\)" 1 url))))
+ (cond
+ ((null file)
+ (message "TinyUrl: Opps, odd perl URL %s" url)
+ (sleep-for 1))
+ (t
+ (tinyurl-find-url-perl-1 file)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-find-url-perl-compile (url &optional noerr)
+ "Parse Perl compile output style URL.
+
+ error in file FILE at line LINE
+ at FILE line LINE.
+
+If NOERR is non-nil, signal no error if file does not exist."
+ (let* ((fid "tinyurl-find-url-perl-compile:")
+ file
+ line)
+ (cond
+ ((or (string-match "in file +\\([^ \t\n]+\\) at line \\([0-9]+\\)" url)
+ (string-match "at +\\([^ \t\n]+\\) line \\([0-9]+\\)" url))
+ (setq file (match-string 1 url)
+ line (string-to-int (match-string 2 url)))))
+ (tinyurl-debug fid 'url url 'file file 'line line)
+ (if (null file)
+ (error "Tinyurl: Can't recognize URL [%s]" url))
+
+ (cond
+ ((or (ti::find-file-or-window file line 'must-exist)
+ ;; drop path name
+ (ti::find-file-or-window (file-name-nondirectory file)
+ line 'must-exist))
+ t) ;ok
+ (t
+ (unless noerr
+ (error "TinyUrl: Can't locate %s" file))
+ nil))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-file-name-filter (url &optional line)
+ "Check URL and LINE for filter in `tinyurl-:file-filter-table'.
+Return:
+ non-nil if Filter was used."
+ (let* ((filter (tinyurl-get-filter url)))
+ (tinyurl-debug "tinyurl-file-name-filter" url filter)
+ (cond
+ ((stringp filter)
+ (shell-command (format filter url))
+ t)
+ ((and (not (ti::bool-p filter))
+ (fboundp filter))
+ (funcall filter url)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-guess-line-number-at-point ()
+ "Read current line and guess the line number."
+ (let* ()
+ (save-excursion
+ (beginning-of-line)
+ (cond
+ ((looking-at ".*[ \t]+line[ \t]+\\([0-9]+\\)")
+ (string-to-int (match-string 1)))
+ ((looking-at ".*on line +<b>\\([0-9]+\\)</b>")
+ ;; PHP writes HTML => </b> on line <b>161</b><br>
+ (string-to-int (match-string 1)))
+ ((looking-at "^.+:\\([0-9]+\\):")
+ ;; Grep output
+ ;; test.pl:119:use integer;
+ (string-to-int (match-string 1)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-find-url-file (url &optional line)
+ "Go to ULR and optional LINE.
+If LINE is not given, it is guessed freom the context.
+Convert URL ftp:// to ange-ftp format and use `find-file'."
+ (let* ((fid "tinyurl-find-url-file: ")
+ (info (ti::file-path-and-line-info url)))
+ (when info
+ (setq url (car info)))
+ (unless line
+ (setq line (tinyurl-guess-line-number-at-point)))
+ (setq url (cond
+ ((string-match "://" url)
+ (ti::string-url-to-ange-ftp url))
+ ((string-match "file:\\(.*\\)" url)
+ (match-string 1 url))
+ (t
+ url)))
+ (tinyurl-debug fid 'URL url 'INFO info 'LINE line)
+ (unless (integerp line) ;; Make sure it's integer
+ (setq line nil))
+ (cond
+ ((tinyurl-file-name-filter url line))
+ (t
+ (ti::select-frame-non-dedicated)
+ (prog1 (ti::find-file-or-window url line (not 'must-exist) info)
+ (when info
+ (goto-line (cdr info))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-find-url-mail-browse-url (url)
+ "Call brose-url with argument URL"
+ (unless (string-match "^mailto:" url)
+ ;; Needed due to `browse-url-browser-function' which contains
+ ;; '(("^mailto:" . browse-url-mail) ...
+ (setq url (concat "mailto:" url))
+ (browse-url url)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-find-url-mail (url)
+ "Ignore URL and call 'mail."
+ (if (fboundp 'compose-mail)
+ (call-interactively 'compose-mail) ;New Emacs
+ (call-interactively 'mail-other-window)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-find-url-man (url)
+ "Manpage URL handler."
+ ;; Url can have leading or trailing spaces: " crontab (5) "
+ (let* ((program (if (string-match "[^ \t\r\n()]+" url)
+ (match-string 0 url)))
+ (page (if (string-match "(\\([^ \t\r\n()]+\\)" url)
+ (match-string 1 url)))
+ (ref (cond
+ ((and page
+ ;; skip basic references like: cut(1)
+ (> (string-to-int page) 1))
+ (format "%s(%s)" program page))
+ (program
+ program))))
+ (man ref)))
+
+;;; ----------------------------------------------------------------------
+;;; FIXME: What about various mailing list archives?
+;;; FIXME: Perhaps Message-id query should be delegated to proper archives
+;;;
+(defun tinyurl-find-url-message-id (url)
+ "Get URL by Message-id."
+ (unless (setq url (ti::string-match "<\\([^ \t\n>]+\\)>" 1 url))
+ (error "TinyMail: invalid Message-id. Missing <>"))
+ (tinyurl-debug "tinyurl-find-url-message-id" url)
+ (setq url
+ (concat
+ "http://groups.google.com/groups?as_q=&as_umsgid="
+ url
+ ""))
+ (tinyurl-agent-funcall 'url url))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-find-url-http (url)
+ "Simple 'www.*' URL handler."
+ (unless (string-match "://" url)
+ (setq url (concat "http://" url)))
+ (tinyurl-debug "tinyurl-find-url-http" url)
+ (tinyurl-agent-funcall 'url url))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-find-url-win32-netscape (url)
+ "External URL handler."
+ (tinyurl-call-process-win32 "netscape" url))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-find-url-win32-iexplore (url)
+ "External URL handler."
+ (tinyurl-call-process-win32 "iexplore" url))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-cache-url (url)
+ "Add URL to the beginning of buffer `tinyurl-:url-cache-buffer'."
+ (let* ((buffer (get-buffer-create tinyurl-:url-cache-buffer)))
+ (tinyurl-debug "tinyurl-cache-url" url)
+ (if (eq (current-buffer) buffer)
+ (error "TinyUrl: Can't cache URL in `tinyurl-:url-cache-buffer'")
+ (with-current-buffer buffer
+ (ti::pmin)
+ (unless tinyurl-mode (tinyurl-mode-1 1))
+ (if (re-search-forward (format "^%s$" (regexp-quote url)) nil t)
+ (message "TinyUrl: already cached %s" url)
+ (insert url "\n")
+ (message "TinyUrl: cached %s" url))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-url-clean (url type)
+ "Clean URL if needed."
+ (if (not (tinyurl-type-external-p url type))
+ url
+ (if (stringp tinyurl-:cleaner-regexp)
+ (replace-regexp-in-string
+ tinyurl-:cleaner-regexp "" url)
+ url)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-type (url)
+ "Return type of URL. Or all types if TYPES id non-nil, URL is then ignored.
+Returned types (symbols) are:
+
+ (external) url
+ url-http
+ url-ftp url-ange
+ url-debian-bts
+ (other) mail
+ file-code-lisp
+ file-code-perl
+ file-code-perl-pod-manpage
+ file-code-perl-pod-module
+ file-code-perl-method
+ file-code-c
+ file-packed
+ file
+ compiler-perl"
+ (cond
+ ;; .................................................... browser url ...
+ ((string-match
+ "Message-id:\\|References:\\|In[ \n\t]+Article[ \n\t]+"
+ url) 'url-message-id)
+ ((string-match "\\(https?\\|telnet\\|wais\\|news\\|file\\):" url) 'url)
+ ((string-match "^[ \t]*www\\." url) 'url-http)
+ ;; my.site.com/dir/dir
+ ((string-match "^[^/]+\\....?/" url) 'url-http)
+ ;; Treat .html files through browser
+ ((string-match "ftp:[^ \t\n]+\\.s?html?" url) 'url-http)
+ ((string-match "ftp:" url) 'url-ftp)
+ ((string-match "/[^@\n]+@[^@\n]+:" url) 'url-ange)
+ ((string-match "@\\|mailto:" url) 'mail)
+ ((string-match
+ "#[0-9]+\\>\\|\\<\\(RF.\\|IT.\\|O\\) +[0-9]+" url)
+ 'url-debian-bts)
+ ;; ........................................................... code ...
+ ((string-match "(\\(load\\|load-library\\|require\\) " url)
+ 'file-code-lisp)
+ ((string-match "use \\|require " url) 'file-code-perl)
+ ((string-match "::.*->" url) 'file-code-perl-method)
+ ;; in the perlipc manpage.
+ ;; See p.264 in [perlipc]
+ ((string-match "perl[^ \t\n]+[ \t\n]+manpage\\|\\[perl[^ \n\t]+\\]" url)
+ 'file-code-perl-pod-manpage)
+ ((string-match "\\<perl[^ \t\n]+\\." url)
+ 'file-code-perl-pod-manpage)
+ ((string-match "::.*manpage" url) 'file-code-perl-pod-module)
+ ((string-match "#include" url) 'file-code-c)
+ ;; ...................................................... compilers ...
+ ((string-match " parse error in <b>.*</b> on line" url)
+ 'compiler-php-at-line)
+ ((string-match " in file.*at line " url) 'compiler-perl-in-file-at-line)
+ ((string-match " at .* line " url) 'compiler-perl-at-line)
+ ;; ................................................... system files ...
+ ((string-match "\\.tar\\|\\.gz\\.tgz" url) 'file-packed)
+ ((string-match "[/\\]" url) 'file)
+ ((string-match "^[^ \t\n]+:[0-9]+:" url) 'file) ;; file.txt:line:
+ ((string-match "[a-z.]+(.*)" url) 'man)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-type-external-p (url type)
+ "Check if TYPE is external. URL is unused."
+ (string-match "url\\|ftp" (symbol-name type)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-handler-mail-after (url &optional type)
+ "Compose URL as mail. Optional TYPE can be given."
+ (let ((fid "tinyurl-handler-mail-after")
+ point
+ to
+ subject)
+ (catch 'done
+ ;; ffap would send mailto: to the ffap-url-fetcher which
+ ;; usually is 'browse-url-netscape, but you really
+ ;; don't want to compose mail with it...
+ (setq url (replace-regexp-in-string "mailto:" "" url))
+ ;; mailto:a@b.com?subject=test
+ (setq to (ti::string-match "[^?]+" 0 url)
+ subject (ti::string-match "\\?Subject=\\([^?]+\\)" 1 url))
+ ;; This can also be a external call, like Mozilla mail...
+ (tinyurl-debug fid 'url url 'to to 'subject subject)
+ (tinyurl-agent-funcall 'mail url)
+ (setq point (point))
+ (ti::pmin)
+ (unless (re-search-forward "^To: " nil t)
+ (goto-char point)
+ (throw 'done))
+ (insert to)
+ (ti::pmin)
+ (unless (re-search-forward "^Subject: " nil t)
+ (goto-char point)
+ (message "TinyUrl: [ERROR] Cannot continue,Subject: not found")
+ (throw 'done))
+ (when subject
+ (insert (replace-regexp-in-string "[%]20" " " subject))
+ (ti::mail-text-start 'move))
+ ;; We can be a bit smarter, Usually the mailing linst have
+ ;; address xxx-request@foo.com, so add implicit "subsribe"
+ ;; to the subject fields. User may add "un" if he wants that
+ ;; instead.
+ (save-excursion
+ (cond
+ ((string-match "-request@" clean)
+ (insert "subscribe")))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-handler-main (url &optional type)
+ "Handle URL and forward it to right agent function. TYPE of url can be given.
+References: `tinyurl-:command-table'"
+ (let* ((fid "tinyurl-handler-main")
+ (raw-list '(url-message-id
+ compiler-perl-in-file-at-line
+ compiler-perl-at-line))
+ (unplugged (not (funcall tinyurl-:plugged-function)))
+ func
+ to
+ subject
+ clean)
+ (or type
+ (setq type (tinyurl-type url)))
+ (setq clean (tinyurl-url-clean url type))
+ (tinyurl-debug fid 'TYPE type 'URL url 'CLEAN clean 'PLUGGED unplugged)
+ (message "TinyUrl: Accessing %s" clean)
+ (cond
+ ((eq type nil)
+ (message "TinyUrl: Strange Error, Couldn't detect URL type: [%s] [%s]"
+ url clean))
+ ((eq type 'mail)
+ (tinyurl-handler-mail-after clean type))
+ (t
+ (if (and (tinyurl-type-external-p clean type)
+ unplugged)
+ (tinyurl-cache-url url)
+ (setq func (tinyurl-agent-function type))
+ (tinyurl-debug fid 'LAST-CASE-TYPE type 'FUNC func 'URL url clean)
+ (tinyurl-debug fid 'FUNCALL func 'URL url 'CLEAN clean)
+ (if (memq type raw-list)
+ (funcall func url) ;RAW
+ (funcall func clean)))))))
+
+;;}}}
+;;{{{ Marking line
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-mark-process-post-command ()
+ "Used in `post-command-hook'."
+ (when tinyurl-mode
+ (let* (counter)
+ (unless (integerp (setq counter (get 'tinyurl-mode 'counter)))
+ (setq counter 0))
+ (incf counter)
+ (put 'tinyurl-mode 'counter counter)
+ ;; Activate only every 5th time.
+ (when (zerop (% counter tinyurl-:post-command-hook-threshold))
+ (put 'tinyurl-mode 'counter 0)
+ (tinyurl-mark-process)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-mark-mouse ()
+ "Mark URLs on current mouse line."
+ (when (fboundp 'mouse-position)
+ (multiple-value-bind (line col)
+ (ti::compat-mouse-position-coordinates)
+ (when (and line col)
+ (save-excursion
+ (goto-char (window-start))
+ (forward-line line)
+;;; (ti::d! (ti::read-current-line))
+ (let* ((end (line-end-position)))
+ (when (not (eq end
+ (get 'tinyurl-mark-line 'mouse)))
+ (put 'tinyurl-mark-line 'mouse end)
+ (tinyurl-mark-line))))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-mark-process ()
+ "Mark URLs on current line and `mouse-position'."
+ (when (and (or tinyurl-mode
+ (and (null tinyurl-:mode-manually-turned-off)
+ (get 'tinyurl-mode 'global)
+ ;; Auto-activate if URL appear anywhere in buffer
+ (and (fboundp tinyurl-:auto-activate-function)
+ (funcall tinyurl-:auto-activate-function)))))
+ ;; Check if we have already marked this line
+ (let* ((end (line-end-position)))
+ (when (not (eq end
+ (get 'tinyurl-mark-line 'point)))
+ (put 'tinyurl-mark-line 'point end)
+ (tinyurl-mark-line)))
+ (tinyurl-mark-mouse)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-default-mark-table ()
+ "Return default table used by `tinyurl-mark-line'.
+Format:
+ '( (REGEXP [SUB-MATCH] [SPAN-FLAG] [VALIDATE-HANDLER]) ..)
+
+REGEXP To mark the URL
+SUB-MATCH In REGEXP to match URL
+SPAN-FLAG If non-nil, then regexp match does not end to the end of
+ current line.
+VALIDATE-HANDLER Function to discard and check marked url"
+ (let* ((site "[-a-z0-9.]+")
+ (white " \t\r\n\f") ;whitespace
+ (white-file " *?\t\r\n\f") ;whitespace, exclude wildcards
+ (white-re (concat "[" white "]"))
+ (nwhite-re (concat "[^" white "]"))
+ (word (concat "[^][(){}<>$^*?:\"'" white "]")) ;; filename word
+ (word+ (concat word "+"))
+;;; (word* (concat word "*"))
+ (url-word+ (concat "[^][{}<>$^*\"'" white "]+")) ;; include ?
+ (url-word* (concat "[^][{}<>$^*\"'" white "]*"))
+ (non-spc (concat "[^\"';" white "]"))
+ (non-spc+ (concat non-spc "+"))
+ ;; (non-spc* (concat non-spc "*"))
+ (slash (if (ti::win32-p)
+ "\\/" ;Accept both
+ "/")) ;only in Unix
+ (slash-re (format "[%s]" slash))
+ (drive (if (ti::win32-p)
+ "[a-zA-Z]:" ; D:\dir\file.txt
+ "")) ; In Unix no drive letter
+ (compiler-number "\\(:[0-9]+:\\)")
+ (maybe-number "\\(:[0-9]+\\)?")
+ (table
+ (list
+ (list (concat "\\<mailto:" white-re "*" nwhite-re "+") 0 'span)
+ ;; This must come first
+ (list "<URL:\\([^>]+\\)>" 1 'span)
+ (list
+ (concat
+ "\\(Message-Id:\\|References:\\|In Article\\)"
+ white-re "*<[^>" white "]+>")
+ 0
+ 'span)
+ (list
+ (concat
+ "\\(\\(\\(ftp\\|https?\\|telnet\\|gopher\\|www\\|wais\\|news\\)://"
+ "\\|file:/\\)\\)"
+ url-word+)
+ 0)
+ (list tinyurl-:email-regexp 0 nil 'tinyurl-validate-url-email)
+ ;; If it starets with "www" and ends to 2-3 characters, it must
+ ;; be http pointer
+ ;;
+ ;; The regexp starts with "[^/], so that http://www match isn't
+ ;; replaced with this.
+ (list
+ (concat
+ "[^/]www\\.\\([-a-z0-9]+\.\\)+[a-z][a-z][a-z]?"
+ url-word*
+ "\\>")
+ 0)
+ ;; C/C++
+ ;;
+ ;; #include <stdio.h>
+ (list
+ (concat
+ "^[ \t]*#include +<[^>]+>"
+ "\\|^[ \t]*#include +\"[^\"]+\"")
+ 0)
+ ;; Debian
+ ;;
+ ;; bug#NNNNNN
+ ;; RFA NNNNNN package -- ...
+ ;; O NNNNNN package -- ...
+ ;; Closes: #NNNNNN
+ ;;
+ (list
+ (concat
+ "\\<bug#[0-9]+\\>"
+ "\\|Closes:? +#[0-9]+\\>"
+ "\\|\\<\\(RF.\\|IT\\.\\|O\\) +[0-9]+\\>")
+ 0)
+ ;; Perl code statements
+ ;;
+ ;; require 'library.pl';
+ ;; use Module;
+ (list
+ (concat
+ "\\<require[ \t\"']+[_a-z0-9.]+pl[ \t\"']*;"
+ "\\|\\<use[ \t]+[_a-z0-9:]+[ \t]*;")
+ 0)
+ ;; Perl Foo::Bar->new(...);
+ '("\\<[A-Za-z]+::[A-Za-z]+\\(->[A-Za-z]+\\)?"
+ 0
+ nil
+ tinyurl-validate-url-perl-method)
+ ;; Browsing Perl POD pages
+ ;;
+ ;; "See perlfunc manpage"
+ ;; "See [perlfaq2]"
+ ;; Devel::DProf manpage
+ ;;
+ ;; SEE ALSO
+ ;; perlrequick.
+ ;; perlretut.
+ ;; "Regexp Quote-Like Operators" in perlop.
+ (list
+ (concat
+ "\\<perl" nwhite-re "+" white-re "+manpage"
+ "\\|\\[perl" nwhite-re "+\\]"
+ "\\|[A-Z][a-z]+::[A-Z][a-z]" white-re "+manpage"
+ "\\|^[ \t]+perl" nwhite-re "+\\.[ \t]*$"
+ "\\|in[ \t]+perl" nwhite-re "+\\.[ \t]*$")
+ 0
+ 'span)
+ ;; [Compiler output]
+ ;; Perl error messages
+ ;;
+ ;; Global symbol "x" requires explicit package name
+ ;; at /users/foo/bin/file.pl line 289.
+ ;;
+ ;; syntax error in file ./fle.pl at line 268
+ (list
+ (concat
+ " in file +" non-spc+ " +at +line +[0-9]+"
+ "\\| at +" non-spc+ " +line +[0-9]+")
+ 0)
+ ;; Manual pages . Examples from HP-UX
+ ;;
+ ;; cut(1), ypmake(1M), unistd.h(5), typeahead(3X)
+ ;; termios(7), sshd(8), html2ps(1) ssh-agent(1)
+ ;; crontab(5)
+ (list
+ "\\<[-_a-z.0-9]+([1-9][CMSX]?)"
+ 0)
+ ;; Lisp
+ ;;
+ ;; (load "file.el")
+ ;; (load-library "file.el")
+ ;; (load-file "file.el")
+ ;; (require 'feature)
+ (list
+ (concat
+ "(\\(load\\|load-library\\|load-file\\|require\\)[ \t\"']+"
+ word+)
+ 0)
+ ;; ............................................ local files ...
+ ;; Local files, this must be last because the regexp is "loose"
+ ;; and would match if put above.
+ ;;
+ ;; ~foo/dir/file.txt
+ ;; /users/foo/file.txt
+ ;; /usr/include/shadow.h:8
+ ;;
+ ;; D:\dir\dir\file.txt
+ ;; D:/dir/dir/file.txt
+ ;; //server/dir/that/there
+ ;;
+ ;; This still highlights statement like /.*
+ ;; Can't do nothing about that. I don't want to make enourmously
+ ;; complex regexp NOT to match false filenames. So we have to
+ ;; bear with some mishits
+ ;;
+ ;; () grouped regexp reads: (SLASH NOT-SLASH|~SLASH)word*nbr?
+ ;; The purpose is not to match double slash C++ comments //
+ (list
+ (concat
+ ;; Must be at the begining of line, or after whitespace
+ "\\(^\\|[ \t]\\)"
+ "\\(" "\\(" drive "\\|//\\|[\\][\\]\\)?"
+ slash-re "[^" white-file slash "]"
+ "\\|~" slash-re "?\\)"
+ word+
+ maybe-number
+ ;; Must be 'alone' and separated from others.
+ "\\([ \t]\\|$\\)")
+ 0
+ nil
+ 'tinyurl-validate-url-default)
+ ;; Last try, the file may be inside Emacs already
+ ;; this-file.el:12: The matched line...
+ (list
+ (concat "^\\(" nwhite-re "+\\)" compiler-number )
+ 0
+ nil
+ 'tinyurl-validate-url-default)))) ;; list of regexps end
+ table))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyurl-mark-line ()
+ "Mark URLs with overlays on current line.
+Return:
+ list of overlays where the regexps matched.
+
+ '((ov ov ..) (regexp regexp ..))"
+ (interactive)
+ (let* ((fid "tinyurl-mark-line:")
+ (plist (tinyurl-overlay-plist))
+ (table (tinyurl-default-mark-table))
+ regexp
+ level
+ function
+ url
+ ov-stat
+ olist
+ ov-list
+ match-list
+ end
+ type)
+ ;; Delete old overlays first
+ (tinyurl-overlay-kill)
+ (tinyurl-modeline-update) ;; update plugged status
+ ;; Now mark all urls with overlays on current line
+ ;; OV-LIST contains generated overlays.
+ (save-excursion
+ ;; Allow line span (setq end (line-end-position))
+ (beginning-of-line)
+ (dolist (elt table)
+ (setq regexp (nth 0 elt)
+ level (or (nth 1 elt) 0)
+ end (line-end-position)
+ type (nth 2 elt)
+ function (nth 3 elt)
+ olist nil)
+ ;; If it is allowed to span multiple lines,
+ ;; then limit the scanning to average of 3 lines
+ ;; whose length is estimated 50 characters.
+ ;;
+ ;; Adjust calculated pos according to point-max
+ (cond
+ ((eq type 'no-limit)
+ (setq end nil))
+ ((and (eq type 'span)
+ ;; There must be spanning url in this line
+ (string-match regexp
+ (buffer-substring-no-properties
+ (line-beginning-position)
+ (min
+ (+ 200 (line-beginning-position))
+ (point-max)))))
+ (setq end
+ (let ((pos (+ (point) (* 3 50))))
+ (if (> pos (point-max))
+ (point-max)
+ pos)))))
+ ;; ................................................... do work ...
+ (tinyurl-debug fid "DOLIST-ELT: " end elt)
+ (if (and plist
+ (stringp regexp))
+ (setq olist
+ (nth 1
+ (ti::overlay-re-search
+ regexp
+ level
+ plist
+ end ;MAX-POINT
+ nil nil nil ;BACK REUSE REUSE-P
+ '(owner tinyurl)))))
+ (when olist
+ (tinyurl-debug fid "OVERLAY-LIST" olist)
+ (dolist (ov olist)
+ (cond
+ ((not (overlayp ov))
+ (message "TinyUrl: ERROR, non-overlay %s"
+ (prin1-to-string ov))
+ (tinyurl-debug fid 'NON-OVERLAY ov))
+ (t
+ (setq url (ti::overlay-buffer-substring ov 'no-properties))
+ ;; - If some previous regexp marks identical overlay,
+ ;; do not add it to the list.
+ (when (and ov-list
+ (not (member url ov-list)))
+ (setq ov-stat (or (null function)
+ (funcall function url)))
+ (tinyurl-debug fid 'STATUS ov-stat 'FUNC function 'URL url "\n")
+ (cond
+ ((eq ov-stat t)
+ (push regexp match-list)
+ (push ov ov-list))
+ (t
+ (delete-overlay ov))))))))))
+ ;; Save the created overlay list, we don't want to bloat buffer
+ ;; full of overlays.
+ (put 'tinyurl-mark-line 'ov-list ov-list)
+ (put 'tinyurl-mark-line 'match-list match-list)
+ (tinyurl-debug fid "RET OV-LIST" ov-list)
+ (when (and ov-list match-list) ;Return value
+ (list ov-list match-list))))
+
+;;}}}
+
+(add-hook 'tinyurl-:mode-define-keys-hook 'tinyurl-mode-define-keys)
+
+(tinyurl-install)
+
+(provide 'tinyurl)
+(run-hooks 'tinyurl-:load-hook)
+
+;;; tinyurl.el ends here
--- /dev/null
+;;; tinyvc.el --- CVS and RCS log minor mode. Checkout, Check-in...
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 1996-2007 Jari Aalto
+;; Keywords: tools
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program, call M-x tinyvc-version.
+;; Look at the code with folding.el.
+
+;; COPYRIGHT NOTICE
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;;; Install:
+
+;; ....................................................... &t-install ...
+;; Put this file on your Emacs-Lisp load path, add following into your
+;; ~/.emacs startup file. Before doing require see tinyvc-:load-hook.
+;;
+;; (require 'tinyvc)
+;;
+;; Or prefer autoload: your emacs loads this package only when you
+;; need it. This is for 19.30+
+;;
+;; (eval-after-load "vc" '(progn (require 'tinyvc)))
+;;
+;; In very old Emacs releases which have different `eval-after-load' or none
+;; at all, use this code:
+;;
+;; (defadvice vc-print-log (after tirl act)
+;; "Run hook tinyvc-:vc-print-log-hook."
+;; (require 'tinyvc)
+;; (run-hooks 'tinyvc-:vc-print-log-hook))
+;;
+;; If you define your own bindings and use menu, Update following variable
+;; and call M-x `tinyvc-install-mode'.
+;;
+;; tinyvc-:mode-menu-main
+;;
+;; If you have any questions, use this function
+;;
+;; M-x tinyvc-submit-bug-report
+
+;;}}}
+
+;;{{{ Documentation
+
+;; ..................................................... &t-commentary ...
+
+;;; Commentary:
+
+;; Preface, Dec 1996
+;;
+;; In work there may be very complex RCS revision numbers, multiple
+;; branches and I may have several branches CheckedOut for testing,
+;; correcting, and developing new features. It seemed natural to
+;; handle this "multiversioning" control from the log output.
+;;
+;; Overview of features
+;;
+;; o Companion to *vc.el*, Minor mode for the log buffer (C-x v l)
+;; o Highlighing supported in Windowed emacs's.
+;; o You can 1) Lock a file 2) unclock file
+;; 3) show status 4) pop to buffer where log belongs and more
+;; 5) ChekOut multiple revisions for viewing purposes
+;; 6) (un/mark viewed versions) and more..
+;;
+;; Do you need this package
+;;
+;; If you don't use RCS/CVS don't load this package, it only works for
+;; `log' output and expects to parse buffers in that format. If you
+;; don't use many branches and thusly vc's log output much, this
+;; package may not be essential to you. This pacakge uses colors if
+;; window system is detected, but it partially copes with non-window
+;; system too, so that e.g. marks appear in the buffer as charaxter
+;; codes.
+;;
+;; revision 1.25 locked by: xx;
+;; date: 1997/11/10 17:20:45; author: xx; state: Exp; lines: +3
+;;
+;; In the above lines the first line, starting from "1.25" is
+;; highlighted (version number). In next line: 97/11/10
+;; (the YY year is significant), "xx" and "Exp" are highlighted.
+
+;;}}}
+;;{{{ history
+
+;;; Change Log:
+
+;;; Code:
+
+;;{{{ setup: library
+
+(require 'tinylibm)
+
+(eval-and-compile
+ (ti::package-use-dynamic-compilation)
+ (autoload 'font-lock-mode "font-lock" t t))
+
+(ti::package-defgroup-tiny TinyVc tinyvc-: tools
+ "Version control rlog minor mode. ChecOut, CheckIn.
+ Overview of features
+ o Companion to vc.el, Minor mode forlog buffer (C-x v l)
+ o Highlighing supported in windowed Emacs.
+ o You can do CheckOut, Lock a file, unclock file(s), show status
+ for current rcs file in emacs and ChekOut multiple revision
+ for viewing purposes (un/marking viewed versions)")
+
+;;}}}
+;;{{{ setup: mode
+
+(defcustom tinyvc-:menu-use-p t
+ "*Should we use echo-area menu?."
+ :type 'boolean
+ :group 'TinyVc)
+
+;;;###autoload (autoload 'tinyvc-mode "tinyvc" "" t)
+;;;###autoload (autoload 'turn-on-tinyvc-mode "tinyvc" "" t)
+;;;###autoload (autoload 'turn-off-tinyvc-mode "tinyvc" "" t)
+;;;###autoload (autoload 'tinyvc-commentary "tinyvc" "" t)
+;;;###autoload (autoload 'tinyvc-version "tinyvc" "" t)
+
+(eval-and-compile
+
+ (ti::macrof-minor-mode-wizard
+ "tinyvc-" " Rlog" "'" "Rlog" 'TinyVc "tinyvc-:" ;1-6
+
+ "RCS Log minor mode.
+With this mode you can CheckOut, Lock, unlock the file whose version
+log your're looking at. You can also 'find file' some specific version
+to temporary buffer e.g. to look at some changes in that version.
+
+By default the commands are accessed through guided echo menu. You
+can use the normal Emacs keymap choice too by settings
+`tinyvc-:menu-use-p' to nil and calling `tinyvc-install-mode'.
+
+Mode description:
+
+\\{tinyvc-:mode-prefix-map}"
+
+ "RCS rlog "
+ nil
+ "RCS Rlog minor mode menu."
+ (list
+ tinyvc-:mode-easymenu-name
+ ["Do CheckOut at point" tinyvc-do-co t]
+ ["Do CheckOut at point (lock) " tinyvc-do-co-l t]
+ ["Do CheckOut head " tinyvc-do-co-head t]
+ ["Unlock version" tinyvc-cancel-co t]
+ ["Unlock unsafely version" tinyvc-unlock-unsafely t]
+ "----"
+ ["Find (show) this revision" tinyvc-find-file-tmp t]
+ ["Mark 'find' versions" tinyvc-mark t]
+ ["Pop to RCS buffer" tinyvc-pop-to-buffer t]
+ ["Kill temporary files (flush)" tinyvc-kill-tmp t]
+ ["Reload rlog" tinyvc-reload t]
+ "----"
+ ["Package version" tinyvc-version t]
+ ["Package commentary" tinyvc-commentary t]
+ ["Mode help" tinyvc-mode-help t]
+ ["Mode off" tinyvc-mode t])
+ (progn
+ (define-key map "h" 'tinyvc-do-co-head)
+ (define-key map "k" 'tinyvc-kill-tmp)
+ (define-key map "l" 'tinyvc-do-co-l)
+ (define-key map "m" 'tinyvc-mark)
+ (define-key map "f" 'tinyvc-find-file-tmp)
+ (define-key map "o" 'tinyvc-do-co)
+ (define-key map "p" 'tinyvc-pop-to-buffer)
+ (define-key map "r" 'tinyvc-reload)
+ (define-key map "u" 'tinyvc-cancel-co)
+ (define-key map "U" 'tinyvc-unlock-unsafely)
+ (define-key map "?" 'tinyvc-mode-help)
+ (define-key map "Hm" 'tinyvc-mode-help)
+ (define-key map "Hc" 'tinyvc-commentary)
+ (define-key map "Hv" 'tinyvc-version))))
+
+;;; ......................................................... &v-hooks ...
+
+(defcustom tinyvc-:load-hook nil
+ "*Hook that is run when package is loaded."
+ :type 'hook
+ :group 'TinyVc)
+
+(defcustom tinyvc-:vc-print-log-hook
+ '(turn-on-tinyvc-mode
+ tinyvc-rename-buffer
+ tinyvc-select-backend
+ turn-on-font-lock-mode-maybe)
+ "*Hook run after `vc-print-log' command.
+See also `tinyvc-:invoked-buffer' what the functions in this hook
+can examine."
+ :type 'hook
+ :group 'TinyVc)
+
+;;}}}
+;;{{{ setup: public, user configurable
+
+(defcustom tinyvc-:cmd-function 'tinyvc-cmd-get-rcs
+ "*Return RCS executable shell command.
+See `tinyvc-cmd-get' source code. Input parameters are symbols:
+
+ 'co 'ci 'rcs 'rcsdiff.
+
+Predefined functions you coud assign to this variable:
+
+ `tinyvc-cmd-get-rcs'
+ `tinyvc-cmd-get-vcs'
+
+Note:
+
+ This variable is set to buffer local and one of the above choices is
+ set if `tinyvc-select-backend' function, which is installed in
+ `tinyvc-:vc-print-log-hook' recognized the backend."
+ :type 'hook
+ :group 'TinyVc)
+
+(defcustom tinyvc-:locker-name (user-login-name)
+ "*Your RCS locker ID that apperas in the lock statement."
+ :type 'string
+ :group 'TinyVc)
+
+(defcustom tinyvc-:font-lock-keywords
+ '((".*file:[ \t]+\\([^\n]+\\)" 1 'region)
+ ("^head:.*" 0 font-lock-reference-face)
+ ("^locks:[ \t]+\\([^\n]+\\)" 1 font-lock-keyword-face)
+ ("^total revisions:[ \t0-9]+" 0 font-lock-keyword-face)
+ ("revision[ \t]+\\([^\n]+\\)" 1 font-lock-type-face)
+
+ ("date: +..\\([^ \t\n]+\\)" 1 font-lock-reference-face)
+ ("author: +\\([^ \t\n]+\\)" 1 font-lock-keyword-face)
+ ("state: +\\([^ \t\n]+\\)" 1 font-lock-reference-face))
+ "Font lock keywords."
+ :type 'sexp
+ :group 'TinyVc)
+
+;;}}}
+;;{{{ setup: private
+
+(defvar tinyvc-:invoked-buffer nil
+ "When you call `vc-print-log', the buffer-pointer is recored here.")
+(put 'tinyvc-:invoked-buffer 'permanent-local t)
+
+(defvar tinyvc-:shell-buffer "*tinyvc-tmp*"
+ "Shell buffer.")
+
+;;}}}
+;;{{{ version
+
+(eval-and-compile
+ (ti::macrof-version-bug-report
+ "tinyvc.el"
+ "tinyvc"
+ tinyvc-:version-id
+ "$Id: tinyvc.el,v 2.47 2007/05/01 17:21:01 jaalto Exp $"
+ '(tinyvc-:version-id
+ tinyvc-:load-hook
+ tinyvc-:mode-name
+ tinyvc-:mode-prefix-key)))
+
+;;}}}
+;;{{{ Minor mode
+
+(defvar tinyvc-:mode-menu-main
+ '("\
+uU)nlock l)ock o=co l=co-l h=co-head p)op f)ind m)ark k)ill r)eload [scM]"
+ ((?u . ( (call-interactively 'tinyvc-cancel-co)))
+ (?U . ( (tinyvc-unlock-unsafely ti::menu-:prefix-arg 'verb)))
+ (?o . ( (call-interactively 'tinyvc-do-co)))
+ (?l . ( (call-interactively 'tinyvc-do-co-l)))
+ (?h . ( (call-interactively 'tinyvc-do-co-head)))
+ (?f . ( (tinyvc-find-file-tmp ti::menu-:prefix-arg 'verb)))
+ (?p . ( (call-interactively 'tinyvc-pop-to-buffer)))
+ (?k . ( (call-interactively 'tinyvc-kill-tmp)))
+ (?m . ( (tinyvc-mark ti::menu-:prefix-arg 'verb)))
+ (?r . ( (call-interactively 'tinyvc-reload)))
+ (?s . ( (call-interactively 'tinyvc-status)))
+ (?c . ( (call-interactively 'tinyvc-chmod-toggle)))
+ (?M . ( (tinyurl-mode-help)))))
+ "RCS Log browsing minor mode commands.
+
+In alphabetical order.
+
+c = Toggle chmod in the file underneath for this buffer.
+ You need this eg if you main version is locked. But you have
+ made a branch where you want to continue.
+f = `find-file'. Load the version in the line to temporary buffer
+h = go to the head: string in the log buffer
+k = Kill all temporary version files that have been loaded with 'f' command
+ above.
+l = lock the current version found in the line
+m = Mark this line.
+p = `pop-to-buffer'. Go to to buffer where this Log belongs to.
+r = Reload Rlog buffer (it may be old if you have deposited new versions)
+s = Status. Show some of the file's status information.
+uU = Cancel Checkout with 'co'")
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyvc-mode-menu (&optional arg)
+ "Call Echo area mode menu with ARG."
+ (interactive "P")
+ (ti::menu-menu 'tinyvc-:mode-menu-main arg))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyvc-install-to-emacs (&optional off)
+ "Turn on `tinyvc-mode' in appropriate buffers."
+ (interactive "P")
+ ;; User may have multiple logs, loop through all buffers.
+ (dolist (buffer (buffer-list))
+ (when buffer-file-name
+ (with-current-buffer buffer
+ (save-excursion
+ (ti::pmin)
+ ;; CVS log is similar to RCS
+ ;;
+ ;; RCS file: /users/foo/RCS/file.txt,v
+ ;; Working file: file.txt
+ ;; head: 1.23
+ ;; branch:
+ ;; locks: strict
+ (when (looking-at "^RCS file: .*,v")
+ (if off
+ (when tinyvc-mode
+ (message "TinyVc: Mode turned off, %s" (buffer-name))
+ (turn-off-tinyvc-mode))
+ (unless tinyvc-mode
+ (message "TinyVc: Mode turned on, %s" (buffer-name))
+ (turn-on-tinyvc-mode)))))))))
+
+;;}}}
+;;{{{ Macros
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinyvc-do-macro 'lisp-indent-function 0)
+(defmacro tinyvc-do-macro (&rest body)
+ "Store info to variables 'ver' and 'file'. Variable VERB must e also bound.
+If 'ver' of 'file' cannot be set, print message and do nothing with BODY."
+ (`
+ (when (and (or (setq ver (tinyvc-get-version))
+ (error "No version found on the line."))
+ (or (setq file (tinyvc-get-filename))
+ (error "Can't find rcs file name from buffer.")))
+ ;; We must find absolute path; this isn't enough
+ ;;
+ ;; Working file: tm-view.el
+ (unless (string-match "/" file)
+ (let (buffer)
+ (cond
+ ((setq buffer (get-buffer file))
+ (save-excursion
+ (set-buffer buffer)
+ (setq file buffer-file-name)))
+ (t
+ (error "Can't find absolute filename %s" file)))))
+ (,@ body))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinyvc-file-confirm-macro 'lisp-indent-function 2)
+(defmacro tinyvc-file-confirm-macro (file verb &rest body)
+ "Make sure FILE is read-only before continuing.
+If VERB is nil, don't do any checkings or ask from user when
+executing BODY."
+ (`
+ (when (or (null (, verb))
+ (and (, verb)
+ (or (ti::file-read-only-p (, file))
+ (y-or-n-p
+ (format "Writable %s exist, are you sure "
+ (file-name-nondirectory (, file)))))))
+ (,@ body))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinyvc-lock-listed-p ()
+ "See if there is locks in listing."
+ (save-excursion
+ (ti::pmin)
+ ;; locks: strict
+ ;; jaalto: 1.1
+ (re-search-forward "^locks:")
+ (forward-line 1)
+ (looking-at "^[ \t]+")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinyvc-get-tmp-list (file)
+ "Return used temporary buffers matching FILE."
+ (when file
+ (setq file (file-name-nondirectory file))
+ (ti::dolist-buffer-list
+ (string-match (format "\\*%s.*[0-9]+\\*" file) (buffer-name))
+ 'map-temporary-buffers-too)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(put 'tinyvc-do-over-locks-macro 'lisp-indent-function 2)
+(defmacro tinyvc-do-over-locks-macro (user ver &rest body)
+ "USER and VER is currently unused. Execute BODY over 'locks:' keyword.
+
+While the macro loops each line; the variables 'user' and 'ver'
+are updated. If you want to terminate macro, move point away from the
+lock lines: eg by (goto-char (point-min)))."
+ (`
+ (save-excursion
+ (ti::pmin) (re-search-forward "^locks:") (forward-line 1)
+ (while (looking-at "^[ \t]+\\([^:]+\\):[ \t]\\([.0-9]+\\)")
+ (setq user (match-string 1) ver (match-string 2))
+ (,@ body)
+ (forward-line 1)))))
+
+;;}}}
+;;{{{ Rcs interface
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinyvc-cmd-cd-template (file &optional options)
+ "Create 'cd' command template: \"cd DIR; %s FILE OPTIONS\"."
+ (interactive)
+ (concat "cd " (file-name-directory file) "; "
+ "%s " (or options "") " " (file-name-nondirectory file)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyvc-cmd-get-cvs (sym)
+ "Return RCS executable according to SYM."
+ ;; This is default function. User may return "my-co" for 'co
+ ;; command in certain situations etc in his own function.
+ ;;
+ ;; "cvs co" is for
+ ;; the initial checkout of a file only, after that,
+ ;; "cvs update" is used.
+ (cond
+ ((eq 'co sym) "cvs update")
+ ((eq 'ci sym) "cvs commit")
+ ((eq 'rcs sym) "cvs rcs")
+ ((eq 'rlog sym) "cvs log")
+ ((eq 'rcsdiff sym) "cvs diff") ;; -j<old-rev> -j<new-rev>"
+ (t
+ (error "No cmd %s " sym))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyvc-cmd-get-rcs (sym)
+ "Return RCS executable according to SYM."
+ ;; This is default function. User may return "my-co" for 'co
+ ;; command in certain situations etc in his own function.
+ (cond
+ ((eq 'co sym) (symbol-name sym))
+ ((eq 'ci sym) (symbol-name sym))
+ ((eq 'rcs sym) (symbol-name sym))
+ ((eq 'rlog sym) (symbol-name sym))
+ ((eq 'rcsdiff sym) (symbol-name sym))
+ (t
+ (error "No cmd %s " sym))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyvc-cmd-exec (sym shell-cmd &optional buffer noerr)
+ "Execute shell command. If error, show result buffer.
+
+Input:
+
+ SYM Command symbol like 'co
+ SHELL-CMD Full shell command. If this command has %s in
+ a string, then RCS-SH-EXE is sprintf'd into that position.
+ Normally the rcs exe is prepended to the command.
+ BUFFER where to put shell command results
+ NOERR ignore errors
+
+References:
+
+ `tinyvc-:cmd-function'"
+ (let* ((exe (funcall tinyvc-:cmd-function sym))
+ (send (if (string-match "%s" shell-cmd)
+ (format shell-cmd exe sym)
+ (format "%s %s" exe shell-cmd)))
+ (out (or buffer (ti::temp-buffer tinyvc-:shell-buffer 'clear))))
+ (shell-command send out)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyvc-cmd-diff-p (file &optional options)
+ "Return t if there is diff for FILE with diff OPTIONS."
+ (if (zerop
+ (tinyvc-cmd-exec
+ 'rcsdiff
+ (tinyvc-cmd-cd-template file (or options "-q"))
+ nil
+ 'noerr))
+ nil
+ t))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyvc-cmd-rcs (file &optional options)
+ "Run rcs command on FILE with OPTIONS."
+ (tinyvc-cmd-exec 'rcs (tinyvc-cmd-cd-template file options)))
+
+;;}}}
+;;{{{ Misc
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyvc-lock-list ()
+ "Return lock list. '((USER . LOCK-VER) ..)."
+ (let (list
+ user
+ ver)
+ (tinyvc-do-over-locks-macro user ver
+ (push (cons user ver) list))
+ (nreverse list)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyvc-load-to-buffer (dest &optional noerr)
+ "Examine `tinyvc-:shell-buffer' and copy the output to DEST buffer.
+If DEST does not exist, it is created. NOERR ignores errors."
+ (interactive)
+ (let ((shell tinyvc-:shell-buffer)
+ point)
+ (with-current-buffer shell
+ (ti::pmin)
+ (cond ; -p switch
+ ((looking-at ".*-->[ \t]+stdout")
+ (forward-line 2) (setq point (point)))
+ ((save-excursion ; rlog
+ (forward-line 1)
+ (looking-at "RCS file:")
+ (setq point (point)))))
+ (when point ;Only if start point set
+ (if (not (get-buffer dest))
+ (setq dest (ti::temp-buffer dest 'clear))
+ (ti::erase-buffer dest))
+ (append-to-buffer dest point (point-max))))
+ (when (and (null noerr)
+ (null point))
+ (pop-to-buffer shell)
+ (error "Nothing to load from shell buffer."))
+
+ ;; return success status
+ point))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyvc-reload (&optional verb)
+ "Replace buffer with current log. VERB."
+ (interactive)
+ (let ((file (tinyvc-get-filename)))
+ (ti::verb)
+ (tinyvc-cmd-exec 'rlog file nil 'noerr)
+ (erase-buffer)
+ (tinyvc-load-to-buffer (current-buffer))
+ (run-hook-with-args-until-success 'tinyvc-:vc-print-log-hook)
+ (if verb
+ (message "Updated."))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyvc-status ()
+ "Show file status."
+ (interactive)
+ (let* ((file (tinyvc-get-filename))
+ (buffer (get-file-buffer file))
+ str
+ fn
+ ver)
+ (if buffer
+ (setq ver (ti::vc-rcs-buffer-version buffer)))
+ (setq fn (file-name-nondirectory file)
+ str (ti::file-access-mode-to-string
+ (file-modes file)))
+ (message "%s%s has modes %s " (if ver (concat ver " ")) fn str)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyvc-chmod-toggle (&optional verb)
+ "Toggle between =r and +w. VERB."
+ (interactive)
+ (let* ((file (tinyvc-get-filename))
+ (modes (file-modes file)))
+ (ti::verb)
+ (if (ti::file-read-only-p file)
+ (set-file-modes file (ti::file-mode-make-writable modes))
+ (set-file-modes file (ti::file-mode-make-read-only-all modes)))
+ (if verb
+ (tinyvc-status))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyvc-select-backend ()
+ "Select RCS or CVS command for the log buffer: set `tinyvc-:cmd-function'."
+ (interactive)
+ (let* ((buffer tinyvc-:invoked-buffer)
+ file
+ type)
+ (when (and
+ buffer
+ (get-buffer buffer)
+ (setq file
+ (with-current-buffer buffer (buffer-file-name))))
+ (if (fboundp 'vc-buffer-backend) ;19.30+
+ (setq type (ti::funcall 'vc-buffer-backend))
+ ;; nope; that function does not exist. (19.28, 21.2+)
+ (setq type (vc-file-getprop file 'vc-backend)))
+ (make-local-variable 'tinyvc-:cmd-function)
+ (cond
+ ((equal type 'RCS)
+ (setq tinyvc-:cmd-function 'tinyvc-cmd-get-rcs))
+ ((equal type 'CVS)
+ (setq tinyvc-:cmd-function 'tinyvc-cmd-get-rcs))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyvc-rename-buffer ()
+ "Rename buffer to *Rlog* if the the previous buffer name was *vc*.
+Other vc commands normally destroy the log buffer, so renaming
+it keeps it alive until next rlog command."
+ (interactive)
+ (let* ((buffer (get-buffer "*Rlog*")))
+ (when (string= "*vc*" (buffer-name))
+ (if buffer (kill-buffer buffer)) ; Remove old log buffer if it exists.
+ (rename-buffer "*Rlog*"))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defsubst tinyvc-char-mark-p (&optional remove)
+ "Check if there is marker character at the beginning of line.
+Move point. Optionally REMOVE marker."
+ (beginning-of-line)
+ (char= (following-char) ?>))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyvc-char-mark (&optional unmark)
+ "Mark the line, or UNMARK."
+ (interactive)
+ (cond
+ ((and unmark (tinyvc-char-mark-p))
+ (delete-char 1))
+ ((and (null unmark) (tinyvc-char-mark-p))
+ nil) ;there is already mark
+ ((null unmark)
+ (insert ">"))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyvc-buffer-version (file)
+ "If FILE is in emacs, return version number."
+ (if (get-file-buffer file) ;Loaded into emacs already
+ (ti::vc-rcs-buffer-version (get-file-buffer file))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyvc-get-filename ()
+ "Return filename or nil."
+ (save-excursion
+ (ti::pmin)
+ (cond
+ ((re-search-forward "RCS file:[ \t]+\\([^ \n\t]+\\)")
+ (ti::remove-properties (ti::vc-rcs-normal-file (match-string 1))))
+ ((re-search-forward "Working file:[ \t]+\\([^ \n\t]+\\)")
+ (ti::remove-properties (match-string 1))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyvc-get-version ()
+ "Return version on current line."
+ (let* ((line (ti::read-current-line))
+ (ver (ti::string-match "[0-9]+\\.[0-9.]+" 0 line))
+ (dots (and ver
+ (count-char-in-string ?. ver))))
+ (if (and ver
+ ;; Must be odd count
+ (not (eq 1 (% dots 2)))) ;odd, 1.1 or 1.1.1.1
+ (setq ver nil)) ;cancel
+ ver))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyvc-file-untouched-p (file)
+ "Check if buffer is in emacs and that FILE is not modified.
+If the file is not in emacs, run rcsdiff.
+
+Return:
+ str buffer's RCS version if untouched.
+ t if file was not in emacs and there was no rcsdiff."
+ (let* (buffer
+ untouched
+ ret)
+ (setq buffer (get-file-buffer file))
+ (cond
+ ((null buffer) ;cond1
+ (if (ti::file-read-only-p file) ;If it's readonly, suppose no diffs
+ (setq ret t)
+ (if (tinyvc-cmd-diff-p file)
+ (setq ret t))))
+ (buffer ;cond2:
+ (save-excursion ;already loaded into emacs
+ (set-buffer buffer)
+ (unless (buffer-modified-p)
+ (setq untouched t))
+ (if untouched
+ (setq ret (ti::vc-rcs-buffer-version))))))
+ ret))
+
+;;}}}
+;;{{{ interactive
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyvc-mark (&optional unmark verb)
+ "Mark revisions that were loaded by \\[tinyvc-find-file-tmp].
+Optionally UNMARK. VERB."
+ (interactive "P")
+ (let* ((list (tinyvc-get-tmp-list (tinyvc-get-filename)))
+ (len (if list (length list)))
+ beg
+ end
+ re
+ ver)
+ (ti::verb)
+ (save-excursion
+ (dolist (elt list)
+ (setq ver (ti::string-match "[0-9]+[.0-9]+" 0 elt))
+ (setq re (format "\\(revision\\)[ \t]+%s[^ \t]*$" ver))
+ (ti::pmin)
+ (when (re-search-forward re nil t)
+ (cond
+ ((ti::compat-window-system) ;Windowed -- use colors
+ (setq beg (match-beginning 1) end (match-end 1))
+ (if unmark
+ (put-text-property beg end 'face 'default)
+ (put-text-property beg end 'face 'region)))
+ (t ;Non-Windowed
+ (tinyvc-char-mark unmark))))))
+ (if verb
+ (if (null len)
+ (message "No temporary files.")
+ (message "%smarked %d items" (if unmark "un" "") len)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyvc-kill-tmp ()
+ "Kill all tmp buffers that were loaded from call \\[tinyvc-find-file-tmp]."
+ (interactive)
+ (let ((file (tinyvc-get-filename)))
+ (if (null file)
+ (message "No RCS filename found.")
+ (dolist (file (tinyvc-get-tmp-list file))
+ (kill-buffer file)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyvc-pop-to-buffer ()
+ "Pop to buffer accordig to this rlog."
+ (interactive)
+ (let* ((file (tinyvc-get-filename))
+ (buffer (get-file-buffer file)))
+ (if buffer
+ (pop-to-buffer buffer)
+ (if (y-or-n-p (format "No %s buffer, load "
+ (file-name-nondirectory file)))
+ (find-file file)))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyvc-find-file-tmp (&optional no-pop verb)
+ "Find the current version into Emacs.
+The file will be Checked Out by using pipes and the created
+temporary buffer will not have any filename association.
+
+You can use this function to e.g. get version 1.1.1.1 and 1.1.1.2 into
+emacs while your workfile stays somewhere else. Nice for pasting
+text from other versions.
+
+Input:
+ NO-POP do not `pop-to-buffer' after rcs call.
+ VERB Verbose messages."
+ (interactive "P")
+ (let* (file
+ ver
+ buffer)
+ (ti::verb)
+ (tinyvc-do-macro
+ (setq buffer (format "*%s %s*" (file-name-nondirectory file) ver))
+ (if (get-buffer buffer)
+ (if (null no-pop)
+ (pop-to-buffer buffer))
+ (tinyvc-cmd-exec 'co (format "-p -r%s %s" ver file))
+ (tinyvc-load-to-buffer buffer)
+ (if (null no-pop)
+ (pop-to-buffer buffer))))
+ (if (and verb no-pop)
+ (message "Loaded %s" ver))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyvc-unlock-unsafely (&optional all verb)
+ "Read 'locks:' keyword and unlock first locked version in the list.
+If there is no locks, then do nothing. ALL unlocks all locks.
+
+This is unsafe function, because no attempt is made to
+check if the file has changes. You may loose data is you call
+this fnction without checking the diffs.
+
+Input:
+
+ ALL Unlock all version locked.
+ VERB Verbose messags.
+
+Notes:
+ `tinyvc-:locker-name' other locks are not touched ever.
+ No buffer reverting is attempted."
+ (interactive)
+ (let* ((name tinyvc-:locker-name)
+ user
+ ver
+ file
+ done)
+ (ti::verb)
+ (if (and verb
+ (null (y-or-n-p "unlock: Are you absolutely sure ")))
+ (error "Aborted."))
+ (setq file (tinyvc-get-filename))
+ (if (and verb
+ (not (ti::file-read-only-p file)))
+ (if (null (y-or-n-p (format "%s is writable, proceed "
+ (file-name-nondirectory file))))
+ (error "Aborted.")))
+ (set-file-modes file (ti::file-mode-make-read-only-all (file-modes file)))
+ (tinyvc-do-over-locks-macro user ver
+ (when (string= user name)
+ (if verb
+ (message "Unlocking %s" ver))
+ (tinyvc-cmd-exec 'co (format "-u%s %s" ver file))
+ (setq done t)
+ (if (null all)
+ ;; Terminate lock macro loop
+ (ti::pmin))))
+ (when done
+ (tinyvc-reload)
+ (if verb
+ (message "done.")))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyvc-cancel-co (&optional verb)
+ "Cancel Checkout for current revision, so that file is no more locked.
+Notice that the lock status is based on the buffer content. Do
+\\[tinyvc-reload] to update the log if needed. VERB.
+
+Chmod undelying file to read-only."
+ (interactive)
+ (let* (buffer
+ ver
+ file
+ llist)
+ (ti::verb)
+ (tinyvc-do-macro
+ (setq llist (tinyvc-lock-list))
+ (if (null llist)
+ (if verb
+ (message "Lock list seems to be empty."))
+ (if (not (rassoc ver llist))
+ (if verb
+ (message "%s is not locked." ver))
+ (set-file-modes file 292) ;444oct, rrr
+ (tinyvc-cmd-exec 'co (format "-u%s %s" ver file))
+ (tinyvc-reload) ;Update
+ (when (setq buffer (get-file-buffer file))
+ (pop-to-buffer buffer)
+ (call-interactively 'revert-buffer)
+ (message ""))
+ (if verb
+ (message "Revision %s unlocked." ver)))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyvc-do-co-l ()
+ "Do co and lock the version number on the line."
+ (interactive)
+ (let* (old-buffer
+ ver
+ file)
+ (tinyvc-do-macro
+ (setq old-buffer (get-file-buffer file))
+ (if (not (tinyvc-file-untouched-p file))
+ (error "'%s' modified or buffer not read-only." file))
+ (if (file-writable-p file)
+ (error "Can't lock: Underlying file is writable."))
+ (when (or (null (tinyvc-lock-listed-p))
+ (y-or-n-p "There is already lock, proceed? "))
+ (tinyvc-cmd-exec 'co (format "-l%s %s" ver file))
+ (tinyvc-reload)
+ (pop-to-buffer (find-file-noselect file))
+ (when old-buffer
+ (call-interactively 'revert-buffer)
+ (message ""))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyvc-do-co-head ()
+ "CheckOut the HEAD revision."
+ (interactive)
+ (ti::pmin)
+ (if (re-search-forward "^head: ")
+ (call-interactively 'tinyvc-do-co)
+ (message "Hm, Can't find the 'head:' tag anywhere? ")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyvc-do-co (&optional replace verb)
+ "Checkout specific revision around current point.
+REPLACE current emacs buffer with this version if the existing file in emacs
+is read-only. VERB."
+ (interactive "P")
+ (let* (verb
+ ver file
+ untouched
+ buffer
+ buffer-ver
+ ret)
+ (ti::verb)
+ (tinyvc-do-macro
+ (setq buffer (find-buffer-visiting file)
+ untouched (tinyvc-file-untouched-p file)
+ buffer-ver (or (tinyvc-buffer-version file) ""))
+ (tinyvc-file-confirm-macro file verb
+ (cond
+ ((string= ver buffer-ver)
+ (if verb
+ (message (format "%s v%s already in emacs." buffer ver)))
+ (setq ret buffer))
+ ((or (and
+ (file-writable-p file)
+ (y-or-n-p "Writable file, needs chmod, ok? ")
+ (progn
+ (set-file-modes
+ file (ti::file-mode-make-read-only (file-modes file)))
+ t))
+ (null buffer)
+ untouched)
+ (when (or (null verb)
+ (null buffer)
+ (and verb
+ (y-or-n-p
+ (format "Untouched %s, replace %s with version %s ?"
+ (file-name-nondirectory file)
+ buffer-ver ver))))
+ ;; (if buffer (kill-buffer buffer))
+ (tinyvc-cmd-exec 'co (format "-r%s %s " ver file))
+ (with-current-buffer buffer
+ (revert-buffer nil 'no-confirm)
+ (setq buffer (current-buffer)))
+ (if verb
+ (display-buffer buffer))))
+ (t
+ (if verb
+ (message (format "Changed buffer exist, cancelled.")))))))
+ ret))
+
+;;}}}
+
+(if (boundp 'vc-print-log-hook) ;Not Exist in 19.34
+ (ti::add-hooks 'vc-print-log-hook tinyvc-:vc-print-log-hook)
+ (eval-when-compile (require 'advice))
+ (defadvice vc-print-log (around tirl act)
+ "Run hook `tinyvc-:vc-print-log-hook'."
+ (let* ((BuffeR (current-buffer)))
+ ad-do-it
+ (make-local-variable 'tinyvc-:invoked-buffer)
+ (put 'tinyvc-:invoked-buffer 'permanent-local t)
+ (setq tinyvc-:invoked-buffer BuffeR)
+ (run-hooks 'tinyvc-:vc-print-log-hook))))
+
+(add-hook 'tinyvc-:mode-define-keys-hook 'tinyvc-mode-define-keys)
+
+(provide 'tinyvc)
+
+(tinyvc-install-to-emacs)
+(run-hooks 'tinyvc-:load-hook)
+
+;;; tinyvc.el ends here
--- /dev/null
+;;; tinyxreg.el --- Restore points and window configuration with X-popup
+
+;; This file is not part of Emacs
+
+;;{{{ Id
+
+;; Copyright (C) 1995-2007 Jari Aalto
+;; Keywords: tools
+;; Author: Jari Aalto
+;; Maintainer: Jari Aalto
+;;
+;; To get information on this program, call M-x tinyxreg-version.
+;; Look at the code with folding.el.
+
+;; COPYRIGHT NOTICE
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
+
+;;}}}
+;;{{{ Install
+
+;;; Install:
+
+;; ....................................................... &t-install ...
+;; Put this file on your Emacs-Lisp load path, add following into your
+;; ~/.emacs startup file.
+;;
+;; (when window-system
+;; (global-set-key "\C-x/" 'tinyxreg-point-to-register)
+;; (global-set-key "\C-x\\" 'tinyxreg-remove-register)
+;; ;; The non-graphical "jump" is at C-x j
+;; (global-set-key "\C-cj" 'tinyxreg-jump-to-register)
+;; (require 'tinyxreg))
+;;
+;; Or use autoload, preferfed, because your emacs starts up faster.
+;;
+;; (when window-system
+;; (global-set-key "\C-x/" 'tinyxreg-point-to-register)
+;; (global-set-key "\C-x\\" 'tinyxreg-remove-register)
+;; (global-set-key "\C-cj" 'tinyxreg-jump-to-register)
+;; (autoload 'tinyxreg-jump-to-register "tinyxreg" "" t)
+;; (autoload 'tinyxreg-jump-to-register-mouse "tinyxreg" "" t)
+;; (autoload 'tinyxreg-point-to-register "tinyxreg" "" t)
+;; (autoload 'tinyxreg-point-to-register-mouse "tinyxreg" "" t)
+;; (autoload 'tinyxreg-remove-reg "tinyxreg" "" t)
+;; (autoload 'tinyxreg-trash "tinyxreg" "" t))
+;;
+;; If you have any questions or comments, use this function
+;;
+;; M-x tinyxreg-submit-bug-report
+
+;;}}}
+;;{{{ Documentation
+
+;; ..................................................... &t-commentary ...
+
+;;; Commentary:
+
+;; Preface, oct 1995
+;;
+;; There was a post in comp.emacs by <cpg@cs.utexas.edu> Carlos Puchol
+;;
+;; I find that my life would be remarkably eased if only I could
+;; "jump" to the marks from a menu. Please, let me know if i can
+;; implement this myself through some sort of macro or something.
+;;
+;; It was an interesteing idea and some sketching was flying in the air.
+;; The original plan wasn't to write any serious code; just tossing
+;; around some experiments with of functions.
+;; As a result it soon become a complete package and after a while
+;; a properly packaged set.
+;;
+;; Overview of features
+;;
+;; o Store points and window configurations to registers.
+;; o Use popup to pick register associated with the file. In short
+;; this package offers graphical user interface for the the
+;; C-x j "jump to register".
+;;
+;; Register update note
+;;
+;; If you wonder why some of the registers disappear from the popup
+;; while you were sure you just stored some point to them, the reason
+;; is that If you kill some buffer, or reload it again with
+;; find-alternate-file that means that the register reference "dies".
+;; That's why the main function tinyxreg-jump-to-register calls a
+;; house keeping function tinyxreg-update to make sure you can't
+;; select invalid registers. So, trust the poup: it tells what
+;; registes are available.
+
+;;}}}
+
+;;; Change Log:
+
+;;; Code:
+
+;;{{{ setup: libraries
+
+(require 'tinylibm)
+(eval-when-compile (ti::package-use-dynamic-compilation))
+
+(ti::package-defgroup-tiny TinyXreg tinyxreg-: tools
+ "Restoring points/win cfg stroed in reg. via X-popup
+ Overview of features
+
+ o Store points and window configurations to registers.
+ o Use popup to pick register associated with the file. In short
+ this package offers graphical user interface for the the
+ C-x j \"jump to register\".")
+
+;;}}}
+;;{{{ setup: hooks
+
+(defcustom tinyxreg-:load-hook nil
+ "*Hook that is run when package is loaded."
+ :type 'hook
+ :group 'TinyXreg)
+
+;;}}}
+;;{{{ setup: public, user configurable
+
+(defcustom tinyxreg-:x-coord 170
+ "*Default menu coordinate."
+ :type 'integer
+ :group 'TinyXreg)
+
+(defcustom tinyxreg-:y-coord 170
+ "*Default menu coordinate."
+ :type 'integer
+ :group 'TinyXreg)
+
+(defcustom tinyxreg-:description-func 'tinyxreg-description
+ "*Function to return popup description string.
+Function should accept two arguments: REGISTER and WINDOW-ARG"
+ :type 'function
+ :group 'TinyXreg)
+
+(defcustom tinyxreg-:title "Register list"
+ "*Popup title."
+ :type 'string
+ :group 'TinyXreg)
+
+(defcustom tinyxreg-:buffer-fmt "%-20s"
+ "*Format for filename.
+Filename length reserved for default popup description.
+
+Note: The entries itself are stored in this form, so changing this
+affects only new entries."
+ :type '(string :tag "Format string")
+ :group 'TinyXreg)
+
+(defcustom tinyxreg-:wcfg-fmt '(concat "\177 Win " bn)
+ "*Lisp form to for window configuration.
+This is the Window config FORM that is evaled when
+the description is put into the list. You can use variable BN
+to refer current buffer name.
+
+Remember that list will be sorted later, so you may want to have
+common beginning for all win cfg registers."
+ :type '(sexp :tag "Lisp form")
+ :group 'TinyXreg)
+
+;;}}}
+;;{{{ setup: private
+
+(defvar tinyxreg-:preg nil
+ "Hold point markers.")
+
+(defvar tinyxreg-:wreg nil
+ "Hold window markers.")
+
+;;}}}
+;;{{{ setup: version
+
+;;; ....................................................... &v-version ...
+
+;;;###autoload (autoload 'tinyxreg-version "tinyxreg" "Display commentary." t)
+
+(eval-and-compile
+ (ti::macrof-version-bug-report
+ "tinyxreg.el"
+ "tinyreg"
+ tinyxreg-:version-id
+ "$Id: tinyxreg.el,v 2.43 2007/05/06 23:15:20 jaalto Exp $"
+ '(tinyxreg-:version-id
+ tinyxreg-:load-hook
+ tinyxreg-:preg
+ tinyxreg-:wreg
+ tinyxreg-:x-coord
+ tinyxreg-:y-coord
+ tinyxreg-:description-func
+ tinyxreg-:title
+ tinyxreg-:buffer-fmt
+ tinyxreg-:wcfg-fmt)))
+
+;;}}}
+;;{{{ misc
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyxreg-event ()
+ "Return fake event."
+ (ti::compat-make-fake-event tinyxreg-:x-coord tinyxreg-:y-coord))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyxreg-list ()
+ "Return register list, point list + window list."
+ (let* ((ptr tinyxreg-:wreg)
+ (list (copy-sequence tinyxreg-:preg)))
+ ;; concat two lists
+ (dolist (elt ptr)
+ (push elt list))
+ (nreverse list)))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyxreg-install-default-key-bindings ()
+ "Install default key bindings."
+ (interactive)
+ ;; There is no other good use for these
+ (global-set-key "\C-x/" 'tinyxreg-point-to-register)
+ (global-set-key "\C-x\\" 'tinyxreg-remove-register)
+ ;; The "C-c j" is like C-x j , but showing the popup
+ (global-set-key "\C-cj" 'tinyxreg-jump-to-register)
+ ;; C-x is so easy to reach with left hand... and free
+ (global-set-key [(control c) (mouse-1)] 'tinyxreg-jump-to-register-mouse)
+ (global-set-key [(control c) (shift mouse-1)] 'tinyxreg-point-to-register-mouse)
+ (when (interactive-p)
+ (message "TinyXreg: Register Keys bound ok.")))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyxreg-remove-reg (char &optional arg)
+ "Remove register CHAR from stored window and point lists.
+ARG suggests looking in window list."
+ (interactive "cRemove register: \nP")
+ (let* ((ptr (if arg tinyxreg-:wreg tinyxreg-:preg))
+ elt)
+ (when (setq elt (rassq char ptr))
+ (if arg
+ (setq tinyxreg-:wreg (delete elt tinyxreg-:wreg))
+ (setq tinyxreg-:preg (delete elt tinyxreg-:preg))))))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyxreg-update ()
+ "Kill all registers from lists that are not alive any more.
+Eg. marker dies if you revert the buffer; kill and load it again."
+ (let* ((ptr tinyxreg-:preg)
+ reg
+ list)
+ ;; We simple copy valid elements to another list
+ (dolist (elt ptr)
+ (setq reg (cdr elt))
+ (if (ti::register-live-p reg)
+ (push elt list)))
+ (setq tinyxreg-:preg list)
+ (setq ptr tinyxreg-:wreg)))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyxreg-trash ()
+ "Empties both window and point caches."
+ (interactive)
+ (setq tinyxreg-:preg nil tinyxreg-:wreg nil)
+ (if (interactive-p)
+ (message "TinyXreg: Register lists trashed.")))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyxreg-kill-reg (char)
+ "Kill register CHAR from all lists."
+ (tinyxreg-remove-reg char nil)
+ (tinyxreg-remove-reg char 'window))
+
+;;; ----------------------------------------------------------------------
+;;;
+(defun tinyxreg-add-reg (char arg &optional desc)
+ "Store register CHAR to window or point list.
+ARG tells to store to window list. DESC is string to use."
+ (let* ((desc (if (stringp desc)
+ desc
+ (char-to-string char)))
+ (data (cons desc char)))
+ (if arg
+ (push data tinyxreg-:wreg)
+ (push data tinyxreg-:preg))))
+
+;;}}}
+;;{{{ storing
+
+;; ----------------------------------------------------------------------
+;;; So that you call this from mouse
+;;;
+(defun tinyxreg-description (register &optional arg)
+ "Return description text for popup list.
+REGISTER is stored register and if ARG is non-nil the register
+contains window configuration."
+ (let* ((bn (file-name-nondirectory (buffer-name)))
+ (cfg tinyxreg-:wcfg-fmt))
+ (format (concat tinyxreg-:buffer-fmt " %4s %s")
+ (if arg
+ ;; the 177 should print nice block
+ ;; so that sorting puts cfg entries last
+ (eval cfg)
+ bn)
+ (if arg
+ ""
+ (int-to-string
+ (count-lines (point-min-marker) (line-beginning-position))))
+ (char-to-string register))))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyxreg-point-to-register-mouse (event)
+ "Call `tinyxreg-point-to-register' using mouse EVENT."
+ (interactive "e")
+ ;; - User using "flying" mouse paste mode? See var mouse-yank-at-point
+ ;; - If he is, then move cursor visually to mouse point first.
+ (if (null mouse-yank-at-point)
+ (mouse-set-point event))
+ (call-interactively 'tinyxreg-point-to-register))
+
+;;; ----------------------------------------------------------------------
+;;; based on register.el::point-to-register
+;;;
+;;;###autoload
+(defun tinyxreg-point-to-register (char &optional arg)
+ "Store point to CHAR and to X-popup list.
+With prefix ARG, store current frame configuration. VERBOSE enables
+message printing.
+
+Use \\[tinyxreg-point-to-register] to go to that location or restore the
+configuration."
+ (interactive
+ (list
+ (let (CHAR
+ (msg
+ (cond
+ (current-prefix-arg
+ "TinyXreg: Store Window cfg to register: " )
+ (t
+ "TinyXreg: Store point to register: "))))
+ (setq CHAR (ti::read-char-safe-until msg))
+ ;; Show where it got stored.
+ (message (concat msg (char-to-string CHAR)))
+ CHAR)
+ current-prefix-arg))
+ (let* ((dfunc tinyxreg-:description-func)
+ desc)
+ (setq desc ;get the popup description
+ (if (fboundp dfunc)
+ (funcall dfunc char arg)
+ nil))
+ (tinyxreg-remove-reg char arg)
+ (tinyxreg-add-reg char arg desc)
+ (set-register ;; Now the normal emacs thing
+ char
+ (if (null arg)
+ (point-marker)
+ (current-frame-configuration)))))
+
+;;}}}
+;;{{{ jumping
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyxreg-remove-register ()
+ "Remove register from popup list.
+See `tinyxreg-jump-to-register-mouse' for more."
+ (interactive)
+ (tinyxreg-jump-to-register-mouse nil 'remove))
+
+;;; ----------------------------------------------------------------------
+;;; - for calling from keybord
+;;;
+;;;###autoload
+(defun tinyxreg-jump-to-register (&optional remove)
+ "Call `tinyxreg-jump-to-register-mouse' with REMOVE."
+ (interactive)
+ (tinyxreg-jump-to-register-mouse nil remove))
+
+;;; ----------------------------------------------------------------------
+;;;
+;;;###autoload
+(defun tinyxreg-jump-to-register-mouse (event &optional remove verb)
+ "Displays list of registers using mouse EVENT.
+Restore register or optionally REMOVE register from X-list.
+Input:
+
+ EVENT mouse event
+ REMOVE flag, if non-nil, remove register.
+ VERB flag, Allow verbose messages."
+ (interactive "e\nP")
+ (let* ((event (or event
+ (ti::compat-make-fake-event
+ tinyxreg-:x-coord tinyxreg-:y-coord)))
+ (title (interactive-p))
+ ref-list
+ list
+ data
+ char)
+ (ti::verb)
+ (tinyxreg-update) ;update register list
+ (setq ref-list (tinyxreg-list)
+ list (mapcar 'car ref-list))
+ (cond
+ ((null (ti::compat-window-system))
+ (message "TinyXreg: sorry, Requires X to use X-popup"))
+ ((null list)
+ (if verb
+ (message "TinyXreg: sorry, both register lists are empty.")))
+ (t
+ (setq data (ti::compat-popup list event nil title))
+ (if (null data)
+ (if verb
+ (message "TinyXreg: register not selected."))
+ (setq char (cdr-safe (assoc data ref-list)))
+ (cond
+ (remove
+ ;; Remove from both lists
+ (tinyxreg-kill-reg char)
+ (cond
+ (verb
+ (message
+ (concat "TinyXreg: register ["
+ (char-to-string char) "] removed"))
+ ;; too fast otw when you move mouse..
+ (sleep-for 1))))
+ (t
+ (jump-to-register char nil))))))))
+
+;;}}}
+
+(provide 'tinyxreg)
+(run-hooks 'tinyxreg-:load-hook)
+
+;;; tinyxreg.el ends here