rs@uunet.UU.NET (Rich Salz) (09/10/87)
Submitted-by: "Mark A. Ardis" <maa@sei.cmu.edu>
Posting-number: Volume 11, Issue 37
Archive-name: test.el/Part02
#! /bin/sh
# This is a shell archive, meaning:
# 1. Remove everything above the #! /bin/sh line.
# 2. Save the resulting text in a file.
# 3. Execute the file with /bin/sh (not csh) to create:
# user.texinfo
# example.texinfo
# hooks.el
# tst-utilities.el
# box.script
# test.el
# tst-achieve.el
# tst-analyze.el
# tst-annotate.el
# tst-capture.el
export PATH; PATH=/bin:/usr/bin:$PATH
echo shar: "extracting 'user.texinfo'" '(554 characters)'
if test -f 'user.texinfo'
then
echo shar: "will not over-write existing file 'user.texinfo'"
else
sed 's/^X//' << \SHAR_EOF > 'user.texinfo'
X\input texinfo @c -*-texinfo-*-
X@settitle Using the Test Package
X@titlepage
X@center @titlefont{The GNU Emacs Test Package}
X@sp 3
X@center Mark Ardis
X@center Andy Bliven
X@center Tony Bolt
X@center Franklin Davis
X@center Carl Lagoze
X@center Lorri Menard
X@center Richard Rosenthal
X@center Mike Vilot
X@center Don Zaremba
X@sp 1
X@center Wang Institute of Graduate Studies
X@center Tyngsboro, Massachusetts 01879
X@sp 1
X@center August 4, 1987
X@sp 3
X@center @copyright{} 1987 Wang Institute of Graduate Studies
X
X@end titlepage
X
X@include test.texinfo
X
X@contents
X@bye
SHAR_EOF
if test 554 -ne "`wc -c < 'user.texinfo'`"
then
echo shar: "error transmitting 'user.texinfo'" '(should have been 554 characters)'
fi
fi
echo shar: "extracting 'example.texinfo'" '(6208 characters)'
if test -f 'example.texinfo'
then
echo shar: "will not over-write existing file 'example.texinfo'"
else
sed 's/^X//' << \SHAR_EOF > 'example.texinfo'
X@example
X
X 1: ;;; box.el -- Place a box around some text
X 2: ;;; Mark Ardis, Wang Institute of Graduate Studies
X 3:
X 4: (defvar box-top-left-pattern "/*"
X 5: "* Top left corner of box as a string."
X 6: ) ; box-top-left-pattern
X 7:
X 8: (defvar box-top-right-pattern "*\"
X 9: "* Top right corner of box as a string."
X 10: ) ; box-top-left-pattern
X 11:
X 12: (defvar box-bottom-left-pattern "\*"
X 13: "* Bottom left corner of box as a string."
X 14: ) ; box-top-left-pattern
X 15:
X 16: (defvar box-bottom-right-pattern "*/"
X 17: "* Bottom right corner of box as a string."
X 18: ) ; box-top-left-pattern
X 19:
X 20: ;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
X 21:
X 22: (defun box-region (arg)
X 23: "Enclose the region between point and mark with a box. With an
X 24: argument, center the region after boxing.
X 25: The region is 'untabify'ed as a side effect of this command.
X 26: This function may give unexpected results if the beginning and
X 27: end of the region are not at the beginning and end of their
X 28: respective lines."
X 29: (interactive "P")
X 30: ; Local Variables
X 31: (let (width)
X 32: ; Body
X 33: (save-excursion
X 34: (narrow-to-region (point) (mark))
X 35: (untabify (point-min) (point-max))
X 36: ; Find the widest line
X 37: (goto-char (point-min))
X 38: (setq width 0)
X 39: (end-of-line 1)
X 40: (setq width (max width (current-column)))
X 41: (while (not (eobp))
X 42: (end-of-line 2)
X 43: (setq width (max width (current-column)))
X 44: ) ; while (not (eobp))
X 45: ; Adjust the width for the
X 46: ; left side of the box
X 47: (setq width (+ width 2))
X 48: ; Insert beginning of box
X 49: (goto-char (point-min))
X 50: (open-line 1)
X 51: (insert box-top-left-pattern)
X 52: (box-make-wide-enough width "*")
X 53: (insert box-top-right-pattern)
X 54: ; Add vertical bars
X 55: (while (not (eobp))
X 56: (beginning-of-line 2)
X 57: (insert "* ")
X 58: (box-make-wide-enough width " ")
X 59: (insert " *")
X 60: ) ; while (not (eobp))
X 61: ; Insert end of box
X 62: (newline)
X 63: (insert box-bottom-left-pattern)
X 64: (box-make-wide-enough width "*")
X 65: (insert box-bottom-right-pattern)
X 66: ; Check for prefix argument
X 67: (if arg
X 68: (progn
X 69: (goto-char (point-min))
X 70: (center-line)
X 71: (end-of-line 1)
X 72: (while (not (eobp))
X 73: (next-line 1)
X 74: (center-line)
X 75: (end-of-line 1)
X 76: ) ; while (not (eobp))
X 77: ) ; progn
X 78: ) ; if arg
X 79: ; restore initial state
X 80: (widen)
X 81: ) ; save-excursion
X 82: ) ; let
X 83: ) ; defun box-region
X 84:
X 85: ;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
X 86:
X 87: (defun box-make-wide-enough (length char)
X 88: "Increase the length of the current line to LENGTH,
X 89: by padding with CHAR at the end."
X 90: ; Local Variables
X 91: (let ()
X 92: ; Body
X 93: (end-of-line 1)
X 94: (while (< (current-column) length)
X 95: (insert char)
X 96: ) ; while (< (current-column) length)
X 97: ) ; let
X 98: ) ; defun box-make-wide-enough
X 99:
X100: ;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
X101:
X102: (defun unbox (arg)
X103: "Remove the box around the text that includes point.
X104: With an argument, left-justify lines, also.
X105: Lines unboxed have all trailing blankspace removed.
X106: Sets region around unboxed area."
X107: (interactive "P")
X108: ; Local Variables
X109: (let (start start-marker stop-marker)
X110: ; Body
X111: ; Find the beginning
X112: (if (search-backward box-top-left-pattern (point-min) t)
X113: (progn
X114: (setq start (point))
X115: (beginning-of-line 2)
X116: (re-search-forward "\\(\\s \\)*")
X117: (setq start-marker (make-marker))
X118: (set-marker start-marker (+ (point) 2))
X119: ) ; progn
X120: ; else
X121: (progn
X122: (error "Cannot find the box!")
X123: ) ; progn
X124: ) ; if
X125: ; Find the end
X126: (if (search-forward box-bottom-right-pattern (point-max) t)
X127: (progn
X128: (end-of-line 0)
X129: (backward-char 2)
X130: (setq stop-marker (make-marker))
X131: (set-marker stop-marker (point))
X132: ) ; progn
X133: ; else
X134: (progn
X135: (error "Cannot find the box!")
X136: ) ; progn
X137: ) ; if
X138: ; Remove the top line
X139: (goto-char start)
X140: (beginning-of-line)
X141: (kill-line 1)
X142: ; Remove the vertical bars
X143: (while (< (point) (marker-position stop-marker))
X144: (if arg
X145: (delete-horizontal-space)
X146: ; else
X147: (re-search-forward "\\(\\s \\)*")
X148: ) ; if arg
X149: (delete-char 2)
X150: (end-of-line 1)
X151: (delete-backward-char 2)
X152: ; Trim the end of the line
X153: (delete-horizontal-space)
X154: (beginning-of-line 2)
X155: ) ; while
X156: ; Remove the end of the box
X157: (kill-line 1)
X158: ; Set the region
X159: (end-of-line 0)
X160: (set-mark (marker-position start-marker))
X161: ) ; let
X162: ) ; defun unbox
X
X@end example
SHAR_EOF
if test 6208 -ne "`wc -c < 'example.texinfo'`"
then
echo shar: "error transmitting 'example.texinfo'" '(should have been 6208 characters)'
fi
fi
echo shar: "extracting 'hooks.el'" '(452 characters)'
if test -f 'hooks.el'
then
echo shar: "will not over-write existing file 'hooks.el'"
else
sed 's/^X//' << \SHAR_EOF > 'hooks.el'
X;;; hooks.el -- A number of example hooks
X;;; for testing gnutest
X
X(setq tst-equ-point-hook 'ignore-point)
X(setq tst-equ-contents-hook 'less-white)
X
X; return t if point2 > point1
X(defun ignore-point ()
X (setq tst-equ-result (> tst-equ-point2 tst-equ-point1))
X)
X
X
X; if contents fails then compare again but less whitespace
X(defun less-white ()
X (setq tst-equ-result
X (string-equal-less-white tst-equ-contents1 tst-equ-contents2))
X)
X
X
SHAR_EOF
if test 452 -ne "`wc -c < 'hooks.el'`"
then
echo shar: "error transmitting 'hooks.el'" '(should have been 452 characters)'
fi
fi
echo shar: "extracting 'tst-utilities.el'" '(568 characters)'
if test -f 'tst-utilities.el'
then
echo shar: "will not over-write existing file 'tst-utilities.el'"
else
sed 's/^X//' << \SHAR_EOF > 'tst-utilities.el'
X;;; tst-utilities.el - handy defuns from the GnuTest project -*- emacs-lisp -*-
X;;; Copyright (c) 1987 wang Institute of Graduate Studies
X
X(defun last-line (&optional buffer)
X "Returns number of lines in BUFFER (current-buffer if nil)"
X (save-excursion
X (set-buffer (or buffer (current-buffer)))
X (count-lines (point-min) (point-max))
X )
X )
X
X(defun current-line ()
X "Returns current line number"
X (1+ (count-lines (point-min) (point)))
X )
X
X(defun debug-on-error ()
X "Sets the variable debug-on-error to t."
X (interactive)
X (setq debug-on-error t)
X )
SHAR_EOF
if test 568 -ne "`wc -c < 'tst-utilities.el'`"
then
echo shar: "error transmitting 'tst-utilities.el'" '(should have been 568 characters)'
fi
fi
echo shar: "extracting 'box.script'" '(2719 characters)'
if test -f 'box.script'
then
echo shar: "will not over-write existing file 'box.script'"
else
sed 's/^X//' << \SHAR_EOF > 'box.script'
X;;; box.script - test script for box.el -*- emacs-lisp -*-
X
X(defun test-script ()
X (interactive)
X ; Local Variables
X (let (pre
X post
X actual
X (tst-vars-exclude-default (cons "tst-ann-tricorder"
X tst-vars-exclude-default))
X )
X ; Body
X (get-buffer-create "box.el")
X (set-buffer "box.el")
X (erase-buffer)
X (insert-file "/project/gnutest/src/box.el")
X (goto-char (point-min))
X (emacs-lisp-mode)
X (test-mode)
X (tst-instrument)
X ; 1st test run
X (get-buffer-create "box.demo")
X (set-buffer "box.demo")
X (erase-buffer)
X (insert-file "/project/gnutest/test/box.demo")
X
X (tst-capture-state-to-file "/project/gnutest/test/prebox.state" nil nil)
X (goto-char (point-min))
X (set-mark (point-max))
X (box-region nil)
X (tst-capture-state-to-file "/project/gnutest/test/boxed.state" nil nil)
X (goto-char (point-max)) ; cannot unbox from point-min
X (unbox nil)
X (tst-capture-state 'post nil nil)
X (tst-read-state-from-file 'pre "/project/gnutest/test/prebox.state")
X
X (tst-equ-state pre post "Compare before box to after unbox")
X
X (set-buffer "*equal-log*")
X (write-file "box.equallog.1")
X (erase-buffer)
X
X (message "Compared box state - 1")
X
X (set-buffer "box.demo")
X (goto-char (point-min))
X (set-mark (point-max))
X (box-region 1) ; centered box-region
X (tst-capture-state-to-file "/project/gnutest/test/cboxed.state" nil nil)
X (goto-char (point-max)) ; cannot unbox from point-min
X (unbox nil)
X (tst-capture-state 'post nil nil)
X (tst-equ-state pre post "Compare before cen-box to after unbox")
X (set-buffer "*equal-log*")
X (write-file "box.equallog.2")
X (erase-buffer)
X
X (message "Compared box state - 2")
X
X (tst-read-state-from-file 'pre "/project/gnutest/test/cboxed.state")
X (tst-read-state-from-file 'post "/project/gnutest/test/boxed.state")
X (tst-equ-state pre post "Compare centered boxed to boxed")
X
X (set-buffer "*equal-log*")
X (write-file "box.equallog.3")
X (erase-buffer)
X (message "Compared box state - 3")
X
X;;; do some cleaning up
X (delete-file "/project/gnutest/test/cboxed.state")
X (delete-file "/project/gnutest/test/boxed.state")
X (delete-file "/project/gnutest/test/prebox.state")
X
X;;; now, check the coverage
X (set-buffer "box.demo")
X (goto-char (point-min))
X (set-mark (point-max))
X (box-region 1) ; centered box-region
X (goto-char (point-max))
X (unbox 1) ;Now, everything should be covered!
X (set-buffer "box.el")
X (tst-analyze)
X (set-variable 'tst-batch-results "box.results")
X (tst-display-batch)
X;; (kill-emacs 0)
X ) ; let
X ) ; defun
X
X(load-file "/project/gnutest/src/test.el")
X(test-script)
echo shar: "a missing newline was added to 'box.script'"
SHAR_EOF
if test 2719 -ne "`wc -c < 'box.script'`"
then
echo shar: "error transmitting 'box.script'" '(should have been 2719 characters)'
fi
fi
echo shar: "extracting 'test.el'" '(5185 characters)'
if test -f 'test.el'
then
echo shar: "will not over-write existing file 'test.el'"
else
sed 's/^X//' << \SHAR_EOF > 'test.el'
X;;; test.el - the GnuTest package
X;;; Michael J. Vilot, Wang Institute, <vilot@wanginst> 7/16/87
X;;; $Header: test.el,v 1.1 87/07/23 14:38:27 ardis Exp $
X
X(require 'tst-achieve)
X(require 'tst-analyze)
X(require 'tst-capture)
X(require 'tst-display)
X(require 'tst-equal)
X(require 'tst-inequal)
X(require 'tst-instrument)
X
X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
X
X(defvar test-mode nil
X "Minor mode symbol."
X) ; test-mode
X(make-variable-buffer-local 'test-mode)
X
X(defvar test-mode-map nil
X "Keymap for test-mode."
X) ; test-mode-map
X
X(defvar tst-saved-map nil
X "Local keymap to restore when turning off test-mode."
X) ; tst-saved-map
X(make-variable-buffer-local 'tst-saved-map)
X
X(defvar tst-function nil
X "* Name of function to call to execute a set of tests."
X) ; tst-function
X(make-variable-buffer-local 'tst-function)
X
X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
X
X(defun test-mode ()
X "Toggle test-mode, a minor mode. Calls 'test-mode-hook' if it is defined.
X \\{test-mode-map}"
X (interactive)
X ; Local Variables
X (let ()
X ; Body
X (setq test-mode (not test-mode))
X (set-buffer-modified-p (buffer-modified-p)) ; Idiom to reset modeline.
X (if test-mode ; customise the keymap, run hooks
X (progn
X (tst-make-keymap)
X (and (boundp 'test-mode-hook)
X test-mode-hook
X (funcall test-mode-hook))
X ) ; progn
X ; else
X (progn ; exit test mode
X (use-local-map tst-saved-map) ; restore original bindings
X ) ; progn
X ) ; if
X ) ; let
X ) ; defun test-mode
X
X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
X;;; Functions to support metatest top-level
X
X(defun tst-execute ()
X "Execute the test script."
X (interactive)
X ; Local Variables
X (let ()
X ; Body
X (if (null tst-function)
X (setq tst-function
X (read-string "tst-execute: tst-function = "))
X ) ; if
X (funcall tst-function)
X ) ; let
X ) ; defun tst-execute
X
X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
X
X(defun tst-make-keymap ()
X "Make keymap for test-mode."
X ; Local Variables
X (let ()
X ; Body
X (setq tst-saved-map (current-local-map))
X (if (not test-mode-map)
X (progn
X (setq test-mode-map tst-saved-map)
X (define-key test-mode-map "\^c\^a" 'tst-achieve-state-from-file)
X (define-key test-mode-map "\^c\^c" 'tst-capture-state-to-file)
X (define-key test-mode-map "\^c\^r" 'tst-read-state-from-file)
X (define-key test-mode-map "\^c\^w" 'tst-write-state-to-file)
X (define-key test-mode-map "\^ca" 'tst-achieve-state)
X (define-key test-mode-map "\^cc" 'tst-capture-state)
X (define-key test-mode-map "\^cd" 'tst-display-mode)
X (define-key test-mode-map "\^ci" 'tst-instrument)
X (define-key test-mode-map "\^cf" 'tst-analyze) ; "filter"
X (define-key test-mode-map "\^cn" 'tst-new-script-buffer)
X (define-key test-mode-map "\^cq" 'test-mode) ; exit
X (define-key test-mode-map "\^cx" 'tst-execute)
X ) ; progn
X ) ; if
X (use-local-map test-mode-map)
X ) ; let
X ) ; defun tst-make-keymap
X
X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
X
X(defun tst-initialize ()
X "Create minor mode symbol and perform any other initialization."
X ; Local Variables
X (let ()
X ; Body
X (or (assq 'test-mode minor-mode-alist)
X (setq minor-mode-alist
X (cons '(test-mode " Test") minor-mode-alist)))
X ) ; let
X ) ; defun tst-initialize
X
X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
X
X(defvar tst-script-buffer "*test-script*"
X "Buffer containing user's test script."
X ) ; defvar tst-script-buffer
X
X(defconst tst-initial-script
X (concat
X "(defun test-script ()\n"
X " (interactive)\n"
X " ; Local Variables\n"
X " (let (pre post actual)\n"
X " ; Body\n"
X " (switch-to-buffer foo)\n"
X " (erase-buffer)\n"
X " (insert-file foo)\n"
X " (goto-char (point-min))\n"
X " (emacs-lisp-mode)\n"
X " (test-mode)\n"
X " (tst-instrument)\n"
X " ; 1st test run\n"
X " (tst-read-state-from-file post expected-state-file1)\n"
X " (tst-achieve-state-from-file pre initial-state-file1)\n"
X " (foo args)\n"
X " (tst-capture-state actual nil nil)\n"
X ";;; If you have a lot of tests, consider a while loop\n"
X " ) ; let\n"
X ") ; defun\n"
X ) ; concat
X "Initial contents of the test script buffer."
X ) ; defconst tst-initial-script
X
X(defun tst-new-script-buffer ()
X "Create the test script buffer and initialise its contents."
X ; Local Variables
X (let (old-buffer (current-buffer))
X ; Body
X (get-buffer-create tst-script-buffer) ; make the buffer
X (save-excursion
X (set-buffer tst-script-buffer) ; work on it
X (emacs-lisp-mode) ; in the right mode
X (test-mode) ;
X (erase-buffer) ; start fresh
X (insert tst-initial-script) ; start with something interesting
X (goto-char (point-min))
X ) ; save-excursion
X; (set-buffer old-buffer) ; switch back
X ) ; let
X ) ; defun tst-new-script-buffer
X
X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
X;; Things to do when the package is first loaded
X
X(tst-initialize)
X
X;;; end of test.el
SHAR_EOF
if test 5185 -ne "`wc -c < 'test.el'`"
then
echo shar: "error transmitting 'test.el'" '(should have been 5185 characters)'
fi
fi
echo shar: "extracting 'tst-achieve.el'" '(12466 characters)'
if test -f 'tst-achieve.el'
then
echo shar: "will not over-write existing file 'tst-achieve.el'"
else
sed 's/^X//' << \SHAR_EOF > 'tst-achieve.el'
X;; achieve.el -- functions to achieve a captured state of an emacs session
X;; This is file 2 of two files in the "regression" part of the "test" package.
X;; See also capture.el
X;; Carl Lagoze, Franklin Davis
X;; Copyright 1987 Wang Institute of Graduate Studies
X;; $Header: tst-achieve.el,v 1.8 87/07/29 22:50:12 bliven Exp $
X
X(provide 'tst-achieve)
X
X(defun member (elt list)
X "Returns non-nil if ELT is an element of LIST. Comparison done with equal.
XThe value is actually the tail of LIST whose car is ELT."
X (while (and list (not (equal elt (car list))))
X (setq list (cdr list)))
X list)
X
X(defmacro cadr (l)
X (list 'car (list 'cdr l)))
X
X(defmacro cddr (l)
X (list 'cdr (list 'cdr l)))
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;; interactive functions
X
X(defun tst-read-state-from-file (statevar file)
X "Read a captured emacs session state into STATE VARIABLE from FILE."
X (interactive "xState variable to read into: \nfFile Name: ")
X (let ()
X (save-excursion
X (message "Reading file...")
X (switch-to-buffer (make-temp-name "state"))
X (insert-file file)
X (goto-char (point-min))
X (message "Getting state from file...")
X (set statevar (read (current-buffer)))
X (kill-buffer (current-buffer))
X statevar
X ) ; save-excursion
X ) ; let
X ) ; defun tst-read-state-from-file
X
X(defun tst-achieve-state-from-file (file &optional no-process)
X "Achieve a captured emacs session state from a FILE."
X (interactive "fFile Name: ")
X (let (state)
X (tst-read-state-from-file 'state file)
X (tst-achieve-state state no-process)
X ) ; let
X ) ; defun tst-achieve-state-from-file
X
X
X(defun tst-achieve-state (state &optional no-process)
X "Achieve the saved state of an emacs session from variable STATE.
XIf tst-achieve-buffers-nondestructively is non nil, buffers not in
XSTATE are not killed. If NO_PROCESS is non nil, processes are not achieved."
X (interactive "XState to achieve: ")
X (let ()
X (tst-achieve-bufs-state (cadr (assoc 'buffers state)))
X (message "Achieving state of windows...")
X (delete-other-windows)
X (tst-achieve-windows-state (cadr (assoc 'windows state)))
X (or no-process
X (tst-achieve-processes-state (cadr (assoc 'processes state))))
X (tst-achieve-globals-state (cadr (assoc 'session state)))
X (if (interactive-p)
X (message (concat "Achieved state from " state ".")))
X ) ;let
X ) ;defun tst-achieve-state
X
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;; globals
X
X(defun tst-achieve-globals-state (ses-state)
X "Achieve global attributes saved in STATE"
X (message "Achieving state of globals...")
X (tst-achieve-syms (cadr (assoc 'global-bound-syms ses-state)) nil)
X ;; (tst-achieve-ses-functions-state)
X ;; (tst-achieve-recursive-level-state) ; only the level is captured, not
X ; the actual stack, so useless
X (ding) (ding)
X ) ;defun tst-achieve-globals-state
X
X(defun tst-achieve-syms (pairs localflag)
X "Set the value of symbols to those values in the list of PAIRS. Make
Xvariable local first if LOCALFLAG non nil.
XEach element of PAIRS looks like (symbol-name . symbol-value)"
X (mapcar
X ; the lambda here allows
X ; mapcar to pass a second
X ; argument localflag to
X ; function tst-achieve-sym,
X ; while applying it to every
X ; element in list pairs
X '(lambda (pair)
X (tst-achieve-sym pair localflag))
X pairs)
X ) ;defun tst-achieve-syms
X
X(defun tst-achieve-sym (pair localflag)
X "Set the variable named by SYMBOL-NAME-PAIR to value. Make variable
Xlocal first if LOCALFLAG not nil.
XSYMBOL-NAME-PAIR looks like (symbol-name . symbol-value)."
X (if localflag (make-local-variable (car pair)))
X (cond ((equal (car pair) t) nil) ; no-op on "t" or "nil"
X ((equal (car pair) nil) nil)
X (t (set (car pair) (tst-convert-object (cdr pair))))
X ) ; cond
X ) ; defun tst-achieve-sym
X
X(defun tst-convert-object (object)
X "Convert all descriptions of compound objects, e.g. markers,
Xprocesses, windows, into the actual objects."
X (cond ((null object) object)
X ((vectorp object) object)
X ((atom object) object)
X ((equal (car object) 'marker) (tst-convert-marker object))
X ((equal (car object) 'process) (tst-convert-process object))
X ((equal (car object) 'window) nil) ; can't do anything here with window
X ((and (listp object)
X (atom (cdr object))
X (cdr object))
X ; object is a dotted pair
X (cons (tst-convert-object (car object))
X (tst-convert-object (cdr object))))
X ((listp object) (mapcar 'tst-convert-object object))
X (t object)
X ) ; cond
X ) ; defun tst-convert-object
X
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;;; processes
X
X(defun tst-achieve-processes-state (processes-desc)
X "Achieve processes captured in a state, but only if interactive."
X (message "Achieving state of processes...")
X (mapcar 'tst-convert-process processes-desc)
X ) ; tst-achieve-processes-state
X
X(defun tst-convert-process (process-desc)
X "Create the process described by PROCESS-DESC.
XPROCESS-DESC looks like (process (command (comstring argstrings))
X;(exit-status 0) (filter filter-func) (name namestring)
X;(sentinel sentinel-func) (status runstat))"
X (let (proc live procname)
X (setq procname (cadr (assoc 'name (cddr process-desc))))
X (setq live (and
X (car (read-from-string procname))
X (eq (process-status procname) 'run)))
X (if live
X (get-process (cadr (assoc 'name (cdr process-desc))))
X ; else
X (save-excursion
X (setq proc
X (apply 'start-process
X (cadr (assoc 'name (cdr process-desc)))
X (cadr (assoc 'buffer (cdr process-desc)))
X (cadr (assoc 'command (cdr process-desc)))
X ) ; apply
X ) ; setq
X (set-process-filter
X proc
X (cadr (assoc 'filter (cdr process-desc))))
X (set-process-sentinel
X proc
X (cadr (assoc 'sentinel (cdr process-desc))))
X;;; (set-marker
X;;; (process-mark proc)
X;;; (cadr (assoc 'position
X;;; (cadr (assoc 'process-mark (cdr process-desc)))))
X;;; (process-buffer proc))
X proc
X ) ; save-excursion
X ) ; if
X ) ; let
X ) ; defun tst-convert-process
X
X(defun tst-convert-marker (marker-desc)
X "Create the marker described by MARKER-DESC.
XMARKER-DESC looks like (marker (position 23) (buffer bufname)).
XBufname is a string, and the list (buffer bufname) may be nil if no
Xbuffer is associated."
X (set-marker (make-marker)
X (cadr (assoc 'position (cdr marker-desc)))
X (if (null (cadr (assoc 'buffer (cdr marker-desc)))) nil
X (get-buffer (cadr (assoc 'buffer (cdr marker-desc)))))
X ) ; set-marker
X ) ; defun tst-convert-marker
X
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;; buffers
X
X(defun tst-achieve-bufs-state (bufs-states)
X "Achieve the buffer states as saved in BUFS-STATES.
XSee tst-capture-buffers-state for definition of BUFS-STATES.
XIf tst-achieve-buffers-nondestructively is t, buffers not in state are
Xnot killed."
X ; Local Variables
X (let ((state-buf-list) (buf-list))
X
X ;; setup each buffer that's in bufs-states
X (message "Achieving state of buffers...")
X (mapcar 'tst-achieve-buf-state bufs-states)
X
X ;; delete superfluous buffers
X (setq state-buf-list (mapcar 'tst-state-get-buf-name bufs-states))
X (setq buf-list (mapcar 'buffer-name (buffer-list)))
X (if (and (boundp tst-achieve-buffers-nondestructively)
X tst-achieve-buffers-nondestructively)
X nil
X ;; else
X (while buf-list
X (if (not (member (car buf-list) state-buf-list))
X (progn
X (kill-buffer (car buf-list))
X (message (concat "Killing buffer " (car buf-list) "...")))
X (setq buf-list (cdr buf-list))
X ) ; if
X ) ; while
X ) ; if
X ) ; let
X ) ; defun tst-achieve-bufs-state
X
X
X(defun tst-achieve-buf-state (buf-state)
X "Achieve the buffer state in BUF-STATE. See tst-capture-buffer-state
Xfor definition of BUF-STATE."
X ; Local Variables
X (let ()
X ; create buffer, set file
X (set-buffer (get-buffer-create (cadr (assoc 'buf-state-name buf-state))))
X (set-visited-file-name (cadr (assoc 'buf-state-file buf-state)))
X
X ; clear buffer contents and refill
X (if buffer-read-only (toggle-read-only))
X (delete-region (point-min) (point-max))
X (insert (cadr (assoc 'buf-state-contents buf-state)))
X
X ; set point and mark
X (set-mark (cadr (assoc 'buf-state-mark buf-state)))
X (goto-char (cadr (assoc 'buf-state-point buf-state)))
X
X ; set buffer flag(s)
X (set-buffer-modified-p (cadr (assoc 'buf-state-modified buf-state)))
X
X ; set local variables
X (kill-all-local-variables)
X (tst-achieve-local-vars (cadr (assoc 'buf-state-local-vars buf-state)))
X (use-local-map (cadr (assoc 'buf-state-local-map buf-state)))
X ) ; let
X ) ; defun tst-achieve-buf-state
X
X(defun tst-achieve-local-vars (pairs)
X "Take list of (VARIABLE . VALUE) pairs and makes local variables
Xinitialized to the value."
X (let ((localflag t))
X (mapcar
X ; the lambda here allows
X ; mapcar to pass a second
X ; argument localflag to
X ; function tst-achieve-sym
X ; while applying it to every
X ; element in list pairs
X '(lambda (pair)
X (tst-achieve-sym pair localflag))
X pairs)
X ) ; let
X ) ; defun tst-achieve-local-vars
X
X(defun tst-state-get-buf-name (bufstate)
X "Get name of buffer from BUFSTATE. See tst-capture-buffer-state for
Xdefinition fo BUFSTATE."
X (cadr (assoc 'buf-state-name bufstate))
X ) ; defun tst-state-get-buf-name
X
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;; windows
X
X(defun tst-achieve-windows-state (wstates)
X "Set the state of all windows to that described in the input list"
X (let ((sibling) (leftc-edges))
X (if (assoc 'split wstates)
X (progn
X (setq leftc-edges
X (cadr (assoc 'window-edges
X (car (cadr (assoc 'children wstates))))))
X (if (equal 'h (cadr (assoc 'split wstates)))
X (split-window-horizontally
X (-
X (cadr (cdr leftc-edges))
X (car leftc-edges)
X )
X )
X ;else vertical split
X (split-window-vertically
X (-
X (cadr (cddr leftc-edges))
X (cadr leftc-edges)
X )
X )
X ) ;if
X (setq sibling (next-window))
X ;descend to the left child
X (tst-achieve-windows-state (car (cadr (assoc 'children wstates))))
X ;go to the right child and achieve that
X (select-window sibling)
X (tst-achieve-windows-state
X (cadr (cadr (assoc 'children wstates))))
X ) ;progn
X (tst-achieve-window-state wstates)
X ) ;if assoc splits...
X ) ;let
X ) ;defun
X
X(defun tst-achieve-window-state (wstate)
X "Set the state of the current window to that discribed in the input
X a-list"
X (let ()
X (set-window-buffer (selected-window) (cadr (assoc 'window-buffer wstate)))
X (set-window-point (selected-window) (cadr (assoc 'window-point wstate)))
X (set-window-start (selected-window) (cadr (assoc 'window-start wstate)))
X ) ;let
X ) ;defun tst-achieve-window-state
X
X(defun tst-find-cur-window (wstates)
X "Given an input list of WINDOW STATES, find the one that is the current
X window of the of the state. This window has the attribute 'current-window
X set to t. Return t when this window is found."
X (let ()
X (if (assoc 'children wstates) ;if is is a compound window
X ; descend down the left subtree
X (if (not (tst-find-cur-window (car (cadr (assoc 'children wstates)))))
X ;now only descend down right subtree if left was unsuccessful
X (tst-find-cur-window (cadr (cadr (assoc 'children wstates))))
X ) ;if goto-cur...
X ; if it is a single window go to it if current-window is true
X (if (cadr (assoc 'current-window wstates))
X (tst-goto-described-window wstates)
X ) ;if assoc 'current-window
X ) ;if assoc 'children...
X ) ;let
X ) ;defun
X
X(defun tst-goto-described-window (wstate)
X "Given an input WINDOW STATE, cycle through existing windows until we
X settle in the one with edges of the one described in the state"
X (let ()
X (while (not (equal (window-edges (selected-window))
X (cadr (assoc 'window-edges wstate))
X )
X )
X (select-window (next-window))
X ) ;while
X ) ;let
X ) ;defun tst-goto-described-window
X
SHAR_EOF
if test 12466 -ne "`wc -c < 'tst-achieve.el'`"
then
echo shar: "error transmitting 'tst-achieve.el'" '(should have been 12466 characters)'
fi
fi
echo shar: "extracting 'tst-analyze.el'" '(2317 characters)'
if test -f 'tst-analyze.el'
then
echo shar: "will not over-write existing file 'tst-analyze.el'"
else
sed 's/^X//' << \SHAR_EOF > 'tst-analyze.el'
X;;; tst-analyze.el -- analyze test results
X;;; Copyright (c) 1987 Wang Institute of Graduate Studies
X
X;;; Tony Bolt
X
X(require 'tst-annotate)
X(provide 'tst-analyze)
X
X(defun tst-analyze ()
X "Driver for test analysis functions.
X Invokes tst-anl-zero-counts and tst-anl-constant-values"
X (interactive)
X (message "Analyze test results (counts) ...")
X (tst-anl-zero-counts)
X (message "Analyze test results (values) ...")
X (tst-anl-constant-values)
X (message "Analyze test results (values) ... done") t)
X
X(defun tst-anl-zero-counts ()
X "Examines the test results stored in the annotation database looking
X for lines with a zero count value, i.e. those that were not executed"
X (let ((lines (tst-ann-get-lines)))
X (cond ((null lines) nil)
X (t (mapcar 'tst-anl-zero-count lines)))))
X
X(defconst tst-anl-zero-count 'NEVER->>
X "* The value used by the display package to indicate a zero count value")
X
X(defun tst-anl-zero-count (line)
X "Given a LINE id, retrieves the value of that line's count field from
X the annotation database. If the value is zero, stores a new attribute,
X called zero, with value a string for use by the display package.
X Otherwise remove attribute zero."
X (let ((count (car (tst-ann-get line 'count))))
X (cond ((equal count 0)
X (tst-ann-put line 'zero (list tst-anl-zero-count)))
X (t (tst-ann-remove-attribute line 'zero)))))
X
X(defun tst-anl-constant-values ()
X "Examines the test results stored in the annotation database looking
X for lines which returned a constant count value every time they were
X executed"
X (let ((lines (tst-ann-get-lines)))
X (cond ((null lines) nil)
X (t (mapcar 'tst-anl-constant-value lines)))))
X
X(defun tst-anl-constant-value (line)
X "Given a LINE id, retrieves the values field and examines the list to
X determine if all the values are equal. If they are equal, stores a
X new attribute, called constant, with the value of one of those elements.
X
X If the list contains a single element then it is considered to be constant"
X
X (let ((values (tst-ann-get line 'values)))
X (while (and (not (null (cdr values)))
X (equal (car values) (car (cdr values))))
X (setq values (cdr values)))
X (if (= 1 (length values))
X (tst-ann-put line 'constant values)
X ;; else
X (tst-ann-remove-attribute line 'constant))))
X
SHAR_EOF
if test 2317 -ne "`wc -c < 'tst-analyze.el'`"
then
echo shar: "error transmitting 'tst-analyze.el'" '(should have been 2317 characters)'
fi
fi
echo shar: "extracting 'tst-annotate.el'" '(7532 characters)'
if test -f 'tst-annotate.el'
then
echo shar: "will not over-write existing file 'tst-annotate.el'"
else
sed 's/^X//' << \SHAR_EOF > 'tst-annotate.el'
X;;; tst-annotate.el --GnuTest Annotation Package
X;;; Copyright (c) 1987 Wang Institute of Graduate Studies
X
X;;; Andy Bliven <bliven@wanginst>
X;;; and Mike Vilot <vilot@wanginst>
X
X(provide 'tst-annotate)
X
X;;; ---------------------------------------------------------------------------
X;;; Private Variables--
X
X(defvar tst-ann-tricorder nil
X "* The Annotation Database. A recursive alist implementing a
Xdatabase indexed by line-number and attribute-name. Intended to be
Xaccessed only through the tst-ann-* functions."
X ) ; defvar tst-ann-tricorder
X
X
X;;; ---------------------------------------------------------------------------
X;;; Public Functions--
X
X(defun tst-ann-append (line-id attribute value)
X "Appends VALUE to the list of values for the <LINE-ID ATTRIBUTE> key."
X (let ((oldvalue (tst-ann-get line-id attribute)))
X (if (nlistp oldvalue)
X (error "value must be a list"))
X (tst-ann-put line-id attribute (append oldvalue value))
X ) ; let
X )
X
X(defun tst-ann-format (line-id attribute)
X "Returns a string of format \"LINE-ID: ATTRIBUTE = value\""
X (let ((value (tst-ann-get line-id attribute)))
X (if (null value)
X "" ; return "" for undefined
X ;; else
X (concat
X (prin1-to-string line-id) ": "
X (prin1-to-string attribute) " = "
X (prin1-to-string value)
X ) ; concat
X ) ; if
X ) ; let
X )
X
X(defun tst-ann-format-line (line-id)
X "Returns the concatenation of tst-ann-format for every attribute in LINE-ID."
X (mapconcat
X '(lambda (attr)
X (tst-ann-format line-id attr))
X (tst-ann-get-attributes line-id)
X "\n"
X ) ; concat
X )
X
X(defun tst-ann-get (line-id attribute)
X "Retrieves a value for <LINE-ID ATTRIBUTE> key."
X (tst-alist-get (tst-alist-get tst-ann-tricorder line-id) attribute)
X )
X
X(defun tst-ann-get-attributes (line-id)
X "Returns a list of attributes defined for LINE-ID."
X (mapcar 'car (tst-alist-get tst-ann-tricorder line-id))
X )
X
X(defun tst-ann-get-lines ()
X "Returns a list of lines defined in the anotation database."
X (mapcar 'car tst-ann-tricorder)
X )
X
X(defun tst-ann-get-db ()
X "Get database value."
X tst-ann-tricorder
X )
X
X(defun tst-ann-inc (line-id attribute)
X "Increments the (assumed numeric) value for <LINE-ID ATTRIBUTE> key."
X (let ((value (car (tst-ann-get line-id attribute))))
X (if (not (numberp value))
X (error "value must be numeric"))
X (tst-ann-put line-id attribute (list (1+ value)))
X )
X )
X
X(defun tst-ann-put (line-id attribute value)
X "Associates <LINE-ID ATTRIBUTE> key with VALUE."
X (let ((attr-alist (assoc line-id tst-ann-tricorder)))
X (if (null attr-alist)
X (progn
X (setq tst-ann-tricorder
X (tst-alist-put tst-ann-tricorder line-id nil))
X (setq attr-alist
X (assoc line-id tst-ann-tricorder))
X ) ; progn
X ) ; if
X (setq attr-alist (tst-alist-put attr-alist attribute value))
X value
X ) ; let
X )
X
X(defun tst-ann-remove (line-id)
X "Removes all data associated with LINE-ID from the database."
X (setq tst-ann-tricorder
X (delq tst-ann-tricorder
X (assoc line-id tst-ann-tricorder)))
X )
X
X(defun tst-ann-remove-attribute (line-id attribute)
X "Removes all data associated with both LINE-ID and ATTRIBUTE from the
X database."
X (tst-ann-put line-id attribute nil)
X )
X
X(defun tst-ann-set-db (value)
X "Set database to VALUE (either nil or obtained from tst-ann-get-db)."
X (setq tst-ann-tricorder value)
X )
X
X
X;;; ---------------------------------------------------------------------------
X;;; ALIST FUNCTIONS
X
X;;; This is a collection of functions for operating on association
X;;; lists (alists).
X
X;;; SPECIFICATION: Axiomatic specification of type alist
X;;;
X
X;;; types--
X;;; A = association list
X;;; K = key
X;;; V = value
X
X;;; signatures--
X;;; c pre: -> A "creates a new alist"
X;;; post: A -> "deletes an alist"
X;;; c put: A x K x V -> A "associate a value with a key"
X;;; get: A x K -> V "retrieve the value associated with a key"
X;;; rem: A x K -> A "remove a key from the list"
X;;; c app: A x K x V -> A "append a key to the list"
X
X;;; rules--
X;;; (post (pre)) = nil "successful termination"
X;;; (post (put A K1 V)) = (post A)
X;;; (post (app A K1 V)) = (post A)
X;;; (get (pre) K) = nil
X;;; (get (put A K1 V) K2) = (if (= K1 K2) V (get A K2))
X;;; (get (app A K1 V) K2) = (if (= K1 K2) (append (get A K1) V)
X;;; (get A K2))
X;;; (rem (pre) K1) = nil
X;;; (rem (put A K1 V) K2) = (if (= K1 K2) (rem A K2) (put (rem A K2) K1 V))
X;;; (rem (app A K1 V) K2) = (if (= K1 K2) (rem A K2) (app (rem A K2) K1 V))
X
X;;; implementation--
X;;; an ALIST is represented as a Lisp list, each element of which is a
X;;; list whose first element is the KEY and the remainder is the VALUE.
X
X
X;;; ----------------------------------------------------------------------
X;;; Alist Functions--
X
X(defun tst-alist-get (alist key)
X "generic routine to retrieve from an ALIST the value for KEY."
X (cdr (assoc key alist))
X ) ; defun tst-alist-get
X
X(defun tst-alist-put (alist key value)
X "Enter into ALIST a <KEY VALUE> pair. Returns the revised alist; use
X (setq alist (tst-alist-put alist key value)."
X
X (cond ((assoc key alist) (setcdr (assoc key alist) value) alist)
X (t (tst-alist-app alist key value))
X ) ; cond
X ) ; defun tst-alist-put
X
X(defmacro tst-alist-rem (alist key)
X "Delete from ALIST the element (KEY value)."
X (list 'setq alist (list 'delq (list 'assoc key alist) alist))
X ) ; defmacro
X
X(defun tst-alist-app (alist key value)
X "Append the <KEY VALUE> pair to ALIST. Returns a new alist--
X use (setq alist (tst-alist-app alist key value))."
X (nreverse ; by making the tail the head
X (cons ; after inserting the new item
X (cons key value) ; which is a list
X (nreverse alist) ; placed before the old tail
X ) ; cons
X ) ; nreverse
X ) ; defun tst-alist-app
X
X
X;;; ---------------------------------------------------------------------------
X;;; LIST PRETTY-PRINT FUNCTIONS
X
X(defun tst-alist-print (list)
X "Print LIST using prin1 with regular indentation and lots of newlines."
X (interactive "xExpression: ")
X (tst-alist-print-element list (current-column))
X nil
X )
X
X(defun tst-alist-print-element (list indent)
X (cond
X ((atom list) (princ list))
X ((stringp list) (prin1 list))
X ((vectorp list)
X (princ "[")
X (tst-alist-print-interior list (1+ indent))
X (princ "]"))
X ((listp list)
X (princ "(")
X (tst-alist-print-interior list (1+ indent))
X (princ ")"))
X (t (error "what are you trying to print?"))
X )
X (current-column)
X )
X
X(defun tst-alist-print-interior (list indent)
X (let (next)
X (cond
X ((atom list) (tst-alist-print-element list indent))
X ((null (cdr list)) (tst-alist-print-element (car list) indent))
X (t (setq next (tst-alist-print-element (car list) indent))
X (cond
X ((atom (car list)) ; special case for list of atoms
X (princ " ")
X (setq indent (1+ next))
X ) ; (atom (car list))
X (t ; normal case--newline between elements
X (princ "\n")
X (tst-alist-print-spaces indent)
X ) ; t
X ) ; cond
X (tst-alist-print-interior (cdr list) indent)
X ) ; t
X ) ; cond
X ) ; let
X )
X
X
X(defun tst-alist-print-spaces (n)
X (interactive "nColumn:")
X (princ (substring " " 0 n))
X nil
X )
X
echo shar: "a missing newline was added to 'tst-annotate.el'"
SHAR_EOF
if test 7532 -ne "`wc -c < 'tst-annotate.el'`"
then
echo shar: "error transmitting 'tst-annotate.el'" '(should have been 7532 characters)'
fi
fi
echo shar: "extracting 'tst-capture.el'" '(18305 characters)'
if test -f 'tst-capture.el'
then
echo shar: "will not over-write existing file 'tst-capture.el'"
else
sed 's/^X//' << \SHAR_EOF > 'tst-capture.el'
X;; capture.el -- functions to capture the state of an emacs session
X;; This is file 1 of two files in the "regression" part of the "test" package.
X;; See also achieve.el
X;; Carl Lagoze, Franklin Davis
X;; Copyright 1987 Wang Institute of Graduate Studies
X;; $Header: tst-capture.el,v 1.21 87/07/29 17:24:58 davis Exp $
X
X(provide 'tst-capture)
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;;; some utilities
X
X(defmacro cadr (l)
X (list 'car (list 'cdr l)))
X
X(defun member (elt list)
X "Returns non-nil if ELT is an element of LIST. Comparison done with equal.
XThe value is actually the tail of LIST whose car is ELT."
X (while (and list (not (equal elt (car list))))
X (setq list (cdr list)))
X list)
X
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;; variables
X
X(defvar tst-vars-exclude-default (list "values" "obarray")
X "* Default list of global variable names to be excluded by
Xtst-capture-state and tst-capture-state-to-file")
X
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;; the interactive functions
X
X(defun tst-capture-state-to-file (file bufs-list vars-exclude)
X "Write the current state of the emacs session to FILE.
XBUFS-LIST is a list of buffer names to capture; if nil all buffers
Xwill be captured.
XVARS-EXCLUDE is a list of global variables to exclude. See
Xtst-capture-state for documentation."
X (interactive "FFile name to write current state to:
XxList of buffers to capture (nil for all):
XxList global vars to exclude (all; none; nil for default excl. list): ")
X (let (state)
X (tst-capture-state 'state bufs-list vars-exclude)
X (tst-write-state-to-file state file)
X ) ;let
X ) ;defun tst-capture-state-to-file
X
X(defun tst-write-state-to-file (state file)
X "Write variable STATE containing captured emacs session state to FILE."
X (interactive "XState Name: \nFFile name to write state to: ")
X (let ()
X (message "Writing state to file...")
X (save-excursion
X (switch-to-buffer (make-temp-name "state"))
X (prin1 state (current-buffer))
X (write-file file)
X (kill-buffer (current-buffer))
X ) ; save-excursion
X ) ; let
X ) ; defun tst-write-state-to-file
X
X
X(defun tst-capture-state (statevar bufs-list vars-exclude)
X "Set variable STATE to the current state of the emacs session.
XBUFS-LIST is a list of buffer names to capture; if nil all buffers
Xwill be captured.
XVARS-EXCLUDE is a list of global variables to exclude;
Xif value is nil, default list tst-vars-exclude-default will be used;
Xif value is 'all' all global variables will be excluded (not captured);
Xif value is 'none' no global variables will be excluded (everything captured).
Xnil is returned in place of excluded variable if it exists.
X
XAn exclude-list rather than an include-list is used because it's
Xmost important to exclude particularly nasty variables. Would be nice to
Xextend this to have an include-list; perhaps also reg-exp for buffer names."
X (interactive "SState Variable:
XxList of buffers to capture (nil for all):
XxList global vars to exclude (all; none; nil for default excl. list): ")
X (let ()
X (makunbound statevar) ; don't want to capture old state var.
X (if (not (listp bufs-list))
X (error "Buffer-list must be a list of strings or nil")
X ) ; if
X (set statevar (list (tst-capture-globals-state vars-exclude)
X (tst-capture-processes-state)
X (tst-capture-buffers-state bufs-list)
X (tst-capture-windows-state)
X ))
X (message "Capturing state...done")
X ) ;let
X ) ;defun tst-capture-state
X
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;; globals capture
X
X(defun tst-capture-globals-state (vars-exclude)
X "Capture global attributes of an Emacs session.
XVARS-EXCLUDE is a list of global variables to exclude;
Xif value is nil, default list tst-vars-exclude-default will be used;
Xif value is 'all' all global variables will be excluded (not captured);
Xif value is 'none' no global variables will be excluded (everything captured)."
X (let ()
X (message "Capturing state of globals...")
X (cond ((null vars-exclude)
X (setq vars-exclude tst-vars-exclude-default))
X ((equal vars-exclude 'none) (setq vars-exclude nil))
X )
X (list 'session
X (list
X (if (equal vars-exclude 'all)
X nil
X ; else
X (tst-capture-global-syms-state vars-exclude))
X;; (tst-capture-recursive-level-state)
X ) ; list
X ) ;list 'session
X ) ;let
X ) ;defun tst-capture-globals-state
X
X(defun tst-capture-global-syms-state (vars-exclude)
X "Return the names and values of all global variables except VARS-EXCLUDE
X as a single element a-list with the key 'global-vars. The second element
X of the alist is a list of two element lists. Each two element list
X consists of a global variable name and its value."
X (list 'global-bound-syms
X (delq nil ; remove "nil" from results
X (mapcar
X ; the lambda here allows
X ; mapcar to pass a second
X ; argument vars-exclude to
X ; function
X ; tst-get-bound-val-from-string
X ; while applying it to every
X ; element in list (all-completions...)
X '(lambda (sym-string)
X (tst-get-bound-val-from-string sym-string vars-exclude))
X (all-completions "" obarray 'boundp))
X ) ; delq
X ) ; list
X ) ; defun tst-capture-global-vars-state
X
X(defun tst-get-bound-val-from-string (sym-string vars-exclude)
X "Given a SYMBOL-NAME return a cons of the symbol and its value. The cons
Xlooks like (symbol . value). Note that storing new values in this cons does
Xnot change the symbol's value. Returns nil if SYMBOL-NAME in VARS-EXCLUDE."
X (cond ((not (stringp sym-string)) nil)
X ((member sym-string vars-exclude) nil) ; return nil for excluded vars
X (t (cons (car (read-from-string sym-string))
X (tst-convert-compound-symbols
X (eval (car (read-from-string sym-string))))))
X ) ; cond
X ) ;defun tst-get-bound-val-from-string
X
X(defun tst-convert-compound-symbols (sym)
X "Given a SYMBOL, convert all marker or process objects to descriptions
Xof these objects. SYMBOL may be a list or atom or dotted pair."
X (cond ((null sym) sym)
X ((vectorp sym) sym)
X ((numberp sym) sym)
X ((and (listp sym)
X (atom (cdr sym))
X (cdr sym)) ; be sure it's not nil
X (cons ; sym is a dotted pair
X (tst-convert-compound-symbols (car sym))
X (tst-convert-compound-symbols (cdr sym))))
X ((and (listp sym) (atom (car (cdr sym)))) ; simple list
X (mapcar 'tst-convert-compound-symbols sym))
X ((atom sym)
X (cond ((markerp sym) (tst-convert-marker-symbol sym))
X ((processp sym) (tst-convert-process-symbol sym))
X ((windowp sym) (list 'window
X (tst-capture-window-state sym nil)))
X (t sym) ; not a complex object
X ) ; cond
X )
X (t sym)
X ) ; cond
X ) ; defun tst-convert-compound-symbols
X
X
X;;; the following function is not used, but could be if someone wanted this
X(defun tst-capture-recursive-level-state ()
X "Capture the current recursive editing state (only the level)"
X (let ()
X (list 'recursive-level (recursion-depth))
X ) ;let
X ) ;tst-capture-recursive-level-state
X
X
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;; processes
X
X(defun tst-capture-processes-state ()
X "Capture processes attributes of an EMACS session"
X (message "Capturing state of processes...")
X (list 'processes (tst-convert-compound-symbols (process-list)))
X ) ;defun tst-capture-processes-state
X
X(defun tst-convert-process-symbol (p)
X "Convert a process object into a list ('process <process-command>
X <process-exit-status> <process-filter> <process-name> <process-sentenel>
X <process-status>"
X (if (processp p)
X (list
X 'process
X (list 'buffer (if (process-buffer p) (buffer-name (process-buffer p))
X nil))
X (list 'process-mark (tst-convert-marker-symbol (process-mark p)))
X (list 'command (process-command p))
X (list 'exit-status (process-exit-status p))
X (list 'filter (process-filter p))
X (list 'name (process-name p))
X (list 'sentinel (process-sentinel p))
X (list 'status (process-status p))
X ) ; list
X ) ;if
X ) ;defun tst-convert-process-symbol
X
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;; buffers
X
X(defun tst-capture-buffers-state (capture-bufs-list)
X "Return the states of all the active buffers in this session as a
X single element a-list with the key 'buffers. The second element of the
X alist is a list, each element of which is the state of an active buffer."
X ; Local Variables
X (let ((bufflist) (buff-state))
X (message "Capturing state of buffers...")
X (setq bufflist (buffer-list))
X (save-excursion
X (while bufflist
X (if (or (null capture-bufs-list) ; get all if no capture-bufs-list
X ; or get this buffer if in list
X (member (buffer-name (car bufflist)) capture-bufs-list))
X (progn
X (set-buffer (car bufflist))
X (setq buff-state
X (append buff-state
X (list (tst-capture-buffer-state))))
X ) ; progn
X ) ; if
X (setq bufflist (cdr bufflist))
X ) ; while
X ) ; save-excursion
X (cons 'buffers (list buff-state))
X ) ; let
X ) ; defun tst-capture-buffers-state
X
X
X(defun tst-capture-buffer-state ()
X "Return the state of the current buffer. The state is returned as an
X a-list"
X ; Local Variables
X (let ()
X (list
X (list 'buf-state-name (buffer-name))
X (list 'buf-state-file (buffer-file-name))
X (list 'buf-state-point (point))
X (list 'buf-state-mark (mark))
X (list 'buf-state-contents (buffer-string))
X (list 'buf-state-modified (buffer-modified-p))
X (list 'buf-state-local-map (current-local-map))
X (list 'buf-state-local-vars
X (mapcar 'tst-convert-compound-symbols (buffer-local-variables)))
X ) ; list
X ) ; let
X ) ; defun tst-capture-buffer-state
X
X
X(defun tst-convert-marker-symbol (marker-symbol)
X "Convert a marker object into a list (marker <point-value> <buffer>)"
X (if (markerp marker-symbol)
X (list
X 'marker
X (list 'position (marker-position marker-symbol))
X (if (null (marker-position marker-symbol)) nil ; no buf name if nil pos.
X (list 'buffer (buffer-name (marker-buffer marker-symbol))))
X ) ; list
X ) ; if
X ) ;defun tst-convert-marker-symbol
X
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;; windows
X
X(defun tst-capture-windows-state ()
X "Return the state of emacs windows as a two element a-list. The first
X element is the key 'windows. The second element is a list
X representation of the binary tree abstraction of the window state. This
X tree is built by walking the windows (starting at the window positioned
X at 0,0) and doing a shift-reduce parse on the window-list. This parse
X has two productions:
X 0: reduce two windows to a combined window when their top/bottom
X edges are common.
X 1: reduce two windows to a combined window when their right/left
X edges are common.
X The parser has three states:
X 0: The start state. The stack is empty
X 1: 1 element on the stack
X 2: >1 element on the stack"
X (let ((stack) (state) (cur-window))
X (message "Capturing state of windows...")
X (save-window-excursion
X (setq cur-window (selected-window))
X (while (not (equal '(0 0) ;go to the upper left window
X (list (car (window-edges)) (cadr (window-edges)))))
X (select-window (next-window))
X ) ;while
X ;always shift first window
X (setq stack (tst-shift-window-stack stack cur-window))
X (setq state 1) ;state 1 when 1 element on stack
X ; At this point the base (0,0) window is on the stack and we are in
X ; state 1. Loop until we return to the condition where the state is
X ; 1 and the next window is the base window (reduced to the final state)
X (while (not (and (equal '(0 0)
X (list
X (car (window-edges (next-window)))
X (cadr (window-edges (next-window)))
X )
X )
X (= state 1)
X ))
X (if (= state 1) ;always shift
X (progn
X (select-window (next-window))
X (setq stack (tst-shift-window-stack stack cur-window))
X (setq state 2)
X ) ;progn
X (progn ;state 2
X (if (equal
X (tst-get-window-bottom-edge (cadr stack))
X (tst-get-window-top-edge (car stack)))
X (progn ;reduce by v rule
X (setq stack (tst-reduce-window-stack stack 'v))
X (if (= 1 (length stack))
X (progn
X (setq state 1)
X ) ;progn
X ) ;if
X ) ;progn
X (progn
X (if (equal
X (tst-get-window-right-edge (cadr stack))
X (tst-get-window-left-edge (car stack)))
X (progn
X (setq stack (tst-reduce-window-stack stack 'h))
X (if (= 1 (length stack))
X (progn
X (setq state 1)
X ) ;progn
X ) ;if
X )
X (progn
X (select-window (next-window))
X (setq stack (tst-shift-window-stack stack cur-window))
X ) ;progn
X ) ;if equal left and right edge
X ) ;progn-else of if top and bottom equal
X ) ;if equal top and bottom edge
X ) ;progn - state 2
X ) ;if equal state 1
X ) ;while not accept state
X ) ;save window excursion
X (list 'windows (car stack))
X ) ;let
X ) ;defun tst-capture-windows-state
X
X(defun tst-shift-window-stack (stack cur-window)
X "Perform a shift in the LR parse of the window configuration tree (i.e. put
X the state of the current window on top of the parse stack"
X (let ()
X (cons (tst-capture-window-state (selected-window) cur-window) stack)
X ) ;let
X ) ;shift-window-state
X
X(defun tst-reduce-window-stack (stack rule)
X "Perform a reduce in the LR parse of the window configuration tree. A reduce
X always pops two elements off the parse stack and pushes a new element that
X is a description of the 'combined' elements that were popped. The input
X argument rule is either 'v' if the two items at the top of the stack were
X split vertically, or 'h' if the two items at the top of the stack were
X split horizontally"
X (let ((wstatet) (wstatet-1) (combined) (edgest) (edgest-1))
X (setq wstatet (car stack))
X (setq wstatet-1 (cadr stack))
X (setq stack (cdr (cdr stack)))
X (setq combined (list
X (list 'children (list wstatet-1 wstatet))
X (list 'split rule)))
X (setq edgest (cadr (assoc 'window-edges wstatet)))
X (setq edgest-1 (cadr (assoc 'window-edges wstatet-1)))
X (setq combined (cons (list 'window-edges (list
X (car edgest-1)
X (cadr edgest-1)
X (cadr (cdr edgest))
X (cadr (cdr (cdr edgest)))
X )
X )
X combined))
X
X (setq stack (cons combined stack))
X ) ;let
X ) ;defun tst-reduce-window-stack
X
X(defun tst-get-window-top-edge (wstate)
X "Return the coordinates of the top edge of input window as a three element
X list consisting of (left-column row right-column)"
X (let ((edges))
X (setq edges (cadr (assoc 'window-edges wstate)))
X (list (car edges) (cadr edges) (cadr (cdr edges)))
X ) ;let
X ) ;defun tst-reg-get-top-edge
X
X(defun tst-get-window-bottom-edge (wstate)
X "Return the coordinates of the bottom edge of nput window as a three element
X list consisting of (left-column row right-column)"
X (let ((edges))
X (setq edges (cadr (assoc 'window-edges wstate)))
X (list (car edges) (cadr (cdr (cdr edges))) (cadr (cdr edges)))
X ) ;let
X ) ;defun tst-reg-get-top-edge
X
X(defun tst-get-window-left-edge (wstate)
X "Return the coordinates of the left edge of input window as a three element
X list consisting of (top-row column bottom-row)"
X (let ((edges))
X (setq edges (cadr (assoc 'window-edges wstate)))
X (list (cadr edges) (car edges) (cadr (cdr (cdr edges))))
X ) ;let
X ) ;defun tst-reg-get-left-edge
X
X(defun tst-get-window-right-edge (wstate)
X "Return the coordinates of the right edge of input window as a three element
X list consisting of (top-row column bottom-row)"
X (let ((edges))
X (setq edges (cadr (assoc 'window-edges wstate)))
X (list (cadr edges) (cadr (cdr edges)) (cadr (cdr (cdr edges))))
X ) ;let
X ) ;defun tst-reg-get-right-edge
X
X(defun tst-capture-window-state (window cur-window)
X "Return the state of the window as an a-list."
X (let ()
X (list
X (list 'window-edges (window-edges))
X (list 'window-buffer (buffer-name))
X (list 'window-start (window-start))
X (list 'window-point (window-point))
X (list 'current-window (equal window cur-window))
X )
X )
X )
X
SHAR_EOF
if test 18305 -ne "`wc -c < 'tst-capture.el'`"
then
echo shar: "error transmitting 'tst-capture.el'" '(should have been 18305 characters)'
fi
fi
exit 0
# End of shell archive
--
Rich $alz
Cronus Project, BBN Labs rsalz@bbn.com
Moderator, comp.sources.unix sources@uunet.uu.net