+++ /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
projects / lib.git / commitdiff