home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / unix / volume11 / test.el / part01 / tst-equal.el < prev    next >
Lisp/Scheme  |  1987-09-08  |  32KB  |  1,155 lines
  1. ;;; tst-equal.el -- A number of definitions of equality
  2. ;;; Lorri Menard, Wang Institute of Graduate Studies
  3. ;;; Don Zaremba, Wang Institute of Graduate Studies
  4. ;;; Copyright 1987 Wang Institute of Graduate Studies
  5. ;;;
  6.  
  7. (provide 'tst-equal)
  8.  
  9. (defvar tst-equ-log-all-compares "t"
  10.   "* If not nil then all comparisons are logged into the buffer
  11.      *equal-log*."
  12. )
  13.  
  14. (defvar tst-equ-max-line-diffs "15"
  15.   "* Maximum number of different lines to log when comparing
  16.      buffer contents line-by-line. "
  17. )
  18.  
  19. (defvar tst-equ-state-functions '(tst-equ-session
  20.                       tst-equ-buffers 
  21.                       tst-equ-processes
  22.                       tst-equ-windows)
  23.   "* A list of functions to be executed when comparing objects
  24.      of type state."
  25. )
  26.  
  27. (defvar tst-equ-buff-state-functions '(tst-equ-point 
  28.                   tst-equ-mark
  29.                   tst-equ-contents
  30.                   tst-equ-modified
  31.                   tst-equ-file 
  32.                   tst-equ-local-vars)
  33.   "* A list of functions to be executed when comparing objects
  34.      of type buffer-state."
  35. )
  36.  
  37. (defconst tst-equ-indent 3)
  38.  
  39. (defmacro tst-equ-level1 ()
  40.  (insert "*") (indent-to tst-equ-indent))
  41.  
  42. (defmacro tst-equ-level2 ()
  43.   (insert "**") (indent-to (* tst-equ-indent 2)))
  44.  
  45. (defmacro tst-equ-level3 ()
  46.   (insert "***") (indent-to (* tst-equ-indent 3)))
  47.  
  48. (defmacro tst-equ-level4 ()
  49.   (insert "****") (indent-to (* tst-equ-indent 4)))
  50.  
  51. (defmacro tst-equ-level5 ()
  52.   (insert "*****") (indent-to (* tst-equ-indent 5)))
  53.  
  54. (defmacro tst-equ-level6 ()
  55.   (insert "******") (indent-to (* tst-equ-indent 6)))
  56.  
  57. (defmacro tst-equ-level7 ()
  58.   (insert "*******")  (indent-to (* tst-equ-indent 7)))
  59.  
  60. (defmacro tst-equ-level8 ()
  61.   (insert "********")  (indent-to (* tst-equ-indent 8)))
  62.  
  63. (defmacro tst-equ-level9 ()
  64.   (insert "*********")  (indent-to (* tst-equ-indent 9)))
  65.  
  66.  
  67. ;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  68. ;   A number of equality testing functions follow. Each is of the
  69. ;   form tst-equ-state-component (state1 state2). Each compares a particular
  70. ;   component from the two states and returns t if equal, else nil.
  71. ;   As a side effect the buffer *equal-log* is updated with the results
  72. ;   of the comparison
  73. ;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  74.  
  75. ;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  76.  
  77. (defun tst-equ-state (tst-equ-state1 tst-equ-state2 name)
  78.   "Compares for equality the complete state of a pair of sessions.
  79.    The two parameters STATE1 and STATE2 must be complete states
  80.    as returned by tst-reg-capture-state. The results of the comparison
  81.    are written into buffer *equal-log*. NAME is used to identify the test.
  82.    Four major components are compared: session, buffers, windows, and
  83.    processes. "
  84.  
  85.   (interactive "XState variable 1:
  86. XState variable 2:
  87. sName of this test:")
  88.  
  89.  
  90.   (let (ss-fun-vector function-name tst-equ-result tst-equ-startpoint temppoint)
  91.  
  92.     (message "Comparing states...")
  93.     (setq ss-fun-vector tst-equ-state-functions)
  94.     (setq tst-equ-result t); let's be optomistic
  95.  
  96.     ; set up the log buffer
  97.     (get-buffer-create "*equal-log*")
  98.     (set-buffer "*equal-log*")
  99.     (outline-mode)
  100.     (tst-equ-level1)
  101.     (setq tst-equ-startpoint (point))    ;save "here"
  102.     (insert "State comparison: " name)
  103.     (newline)
  104.     (newline)
  105.  
  106.     (while ss-fun-vector
  107.       (progn
  108.     (setq function-name (car ss-fun-vector))
  109.     (setq ss-fun-vector (cdr ss-fun-vector))
  110.     (newline)
  111. ;;;    (insert "  " (prin1-to-string function-name))
  112.     (newline)
  113.     (if (not (funcall function-name tst-equ-state1 tst-equ-state2))
  114.         (setq tst-equ-result nil); set return value if failed
  115.       ); fi
  116.     ); ngrop
  117.       ); elihw
  118.  
  119.     ; if we failed and a hook exist then run iot
  120.     (if (and (not tst-equ-result) 'tst-equ-state-hook)
  121.            (run-hooks 'tst-equ-state-hook))
  122.  
  123.     (if (not tst-equ-result)
  124.         (progn
  125.           (setq temppoint (point))
  126.           (goto-char tst-equ-startpoint)
  127.           (insert "?")
  128.           (goto-char (1+ temppoint))
  129.           ); ngorp
  130.       );fi
  131.     (message "Comparing states... done")
  132.     tst-equ-result
  133.     ); tel
  134. ); nufed tst-equ-state
  135.  
  136. (defun tst-equ-session (state1 state2)
  137.    "Compares the session components from two states. The
  138.    two parameters STATE1 and STATE2 must be complete states
  139.    as returned by tst-reg-capture-state. The session components
  140.    include: global-bound-syms. "
  141.  
  142.    (interactive "P")
  143.  
  144.    (let (sess1 sess2 syms1 syms2 ss-startpoint ss-gs-startpoint temppoint el1 el2)
  145.     (message "Comparing state of sessions...")
  146.  
  147.     (goto-char (point-max))        ; .. of output buffer
  148.     (tst-equ-level2)
  149.     (setq ss-startpoint (point))
  150.     (insert "Sessions state")
  151.     (newline)
  152.  
  153.     (setq sess1 (cadr (assoc 'session state1)))
  154.     (setq sess2 (cadr (assoc 'session state2)))
  155.     
  156.     (tst-equ-level3)
  157.     (setq ss-gs-startpoint (point))
  158.     (insert "Global symbols")
  159.     (newline)
  160.  
  161.     (setq syms1 (cadr (assoc 'global-bound-syms sess1)))
  162.     (setq syms2 (cadr (assoc 'global-bound-syms sess2)))
  163.     (if (not (setq tst-equ-result (equal syms1 syms2)))
  164.         (progn
  165.           (while (and syms1 syms2)
  166.             (setq el1 (car syms1))
  167.             (setq syms1 (cdr syms1))
  168.             (setq el2 (assoc (car el1) syms2))
  169.             ;;        (debug "nil" el1 el2)
  170.             (if el2
  171.                 (setq syms2 (delq el2 syms2))
  172. ;;                (list 'setq syms2 (list 'delq (list 'assoc (car el1) syms2) 
  173. ;;                                        syms2))
  174.               (progn                        ;else ..
  175.                 (indent-to (* tst-equ-indent 4))
  176.                 (insert "?")
  177.                 (insert (prin1-to-string (car el1)) " not found in second state")
  178.                 (newline)
  179.                 ); ngorp
  180.               ); fi
  181.             (tst-equ-diff-element el1 el2)
  182.             ); wlihw
  183.           (if syms1
  184.               (progn
  185.                 (while syms1
  186.                   (setq el1 (car syms1))
  187.                   (setq syms1 (cdr syms1))
  188.                   (indent-to (* tst-equ-indent 4))
  189.                   (insert "?")
  190.                   (insert (prin1-to-string (car el1)) " not found in second state")
  191.                   (newline)
  192.                   ); elihw
  193.                 ); ngorp
  194.             ); fi
  195.           (if syms2
  196.               (progn
  197.                 (while syms2
  198.                   (setq el2 (car syms2))
  199.                   (setq syms2 (cdr syms2))
  200.                   (indent-to (* tst-equ-indent 4))
  201.                   (insert "?")
  202.                   (insert (prin1-to-string (car el2)) " not found in first state")
  203.                   (newline)
  204.                   ); elihw
  205.                 
  206.                 );ngorp
  207.             ); fi
  208.                 ); ngorp
  209.             ; else .. nevermind.
  210.             ); fi
  211.     (if (not tst-equ-result)
  212.         (progn
  213.           (setq temppoint (point))
  214.           (goto-char ss-startpoint)
  215.           (insert "?")
  216. ; if ever there are more things in a session, these two lines need to
  217. ;   be separate.
  218.           (goto-char ss-gs-startpoint)
  219.           (insert "?")
  220. ;
  221.           (goto-char (1+ temppoint))
  222.           );
  223.       ); fi
  224.  
  225.      tst-equ-result
  226.      ); tel
  227. )
  228. ;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  229.  
  230. (defun tst-equ-buffers (tst-equ-buffers1 tst-equ-buffers2)
  231.   "Compares the buffers components from two states. The
  232.    two parameters STATE1 and STATE2 must be complete states
  233.    as returned by tst-reg-capture-state. Compares each buffer for
  234.    equality with its corresponding buffer (by name) in the other
  235.    state. tst-equ-buffer-state is called for each pair of buffers. "
  236.  
  237.   (interactive "P")
  238.                     ; Local Variables
  239.   (let (buffers1 buffers2 buff1 buff-name buff2 tst-equ-result buf1names 
  240.                   bs-startpoint temppoint)  
  241.  
  242.     (message "Comparing state of buffers...")
  243.     (setq tst-equ-result t)
  244.     (setq buffers1 (cadr (assoc 'buffers tst-equ-buffers1))); get the first value
  245.     (setq buffers2 (cadr (assoc 'buffers tst-equ-buffers2))); get the second value
  246.  
  247.     ; set up the log buffer
  248.     (goto-char (point-max))
  249.     (tst-equ-level2)
  250.     (setq bs-startpoint (point))
  251.     (insert "Buffers state")
  252.     (newline)
  253.  
  254.     (while buffers1
  255.       (progn
  256.         (setq buff1 (car buffers1))
  257.         (setq buffers1 (cdr buffers1))
  258.     ; get the name of the 1st buffer and use it to find the second
  259.         (setq buff-name (cadr (assoc 'buf-state-name buff1)))
  260.         (setq buf1names (cons buff-name buf1names))
  261.     
  262.     ; create a log entry for this buffer
  263.  
  264.     ; now locate the second buffer
  265.     (setq buff2 (tst-equ-find-buffer-with-name tst-equ-buffers2 buff-name))
  266.     (if (not buff2)
  267.         (progn
  268.           (newline)
  269.           (indent-to (* tst-equ-indent 2))
  270.           (insert "?")
  271.           (insert buff-name " not found in second state")
  272.           (newline)
  273.           (setq tst-equ-result nil)
  274.           ); ngorp
  275.       ; else
  276.         (progn
  277.           ; now compare them and set tst-equ-result
  278.           (if (not (tst-equ-buffer-state buff1 buff2))
  279.                 (setq tst-equ-result nil)
  280.           ) ; fi 
  281.           ) ; ngorp
  282.         ); fi
  283.  
  284.     ); ngrop
  285.       ); elihw
  286. ;;; now that we have checked for everything from the first state,
  287. ;;;  want to see if there are any buffers in the second state that are
  288. ;;; not in the first one.   Remember the list "buf1names" that was built
  289. ;;; during the first while loop?  Well, we'll member this list instead
  290. ;;; of "tst-equ-find-buffer-with-name"ing it, because this seems more efficient.
  291.  
  292.     (while buffers2
  293.       (progn
  294.         (setq buff2 (car buffers2))
  295.         (setq buffers2 (cdr buffers2))
  296.  
  297.         (setq buff-name (cadr (assoc 'buf-state-name buff2)))
  298.         (if (not (member buff-name buf1names))
  299.             (progn
  300.               (newline)
  301.               (indent-to (* tst-equ-indent 4))
  302.               (insert "?")
  303.               (insert buff-name " not found in first state")
  304.               (newline)
  305.               (setq tst-equ-result nil)
  306.               ); ngorp
  307.           ); fi
  308.         ); ngorp
  309.       ); elihw
  310.               
  311.     ; if we failed and a hook exist then run it
  312.     (if (and (not tst-equ-result) 'tst-equ-buffers-hook)
  313.            (run-hooks 'tst-equ-buffers-hook))
  314.  
  315.     (if (not tst-equ-result)
  316.         (progn
  317.           (setq temppoint (point))
  318.           (goto-char bs-startpoint)
  319.           (insert "?")
  320.           (goto-char (1+ temppoint))
  321.           ); nprog
  322.       ); fi
  323.  
  324.     tst-equ-result
  325.   ) ; let
  326. ) ; defun tst-equ-buffers
  327.  
  328. ;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  329.  
  330. (defun tst-equ-windows (tst-equ-windows1 tst-equ-windows2)
  331.    "Compares the window components from two states. The
  332.    two parameters STATE1 and STATE2 must be complete states
  333.    as returned by tst-reg-capture-state."
  334.  
  335.   (interactive "P")
  336.                     ; Local Variables
  337.   (let (window1 window2 tst-equ-result start-point saved-point) 
  338.  
  339.     (message "Comparing state of windows ...")
  340.  
  341.     (setq window1 (cadr (assoc 'windows tst-equ-windows1)))
  342.     (setq window2 (cadr (assoc 'windows tst-equ-windows2)))
  343.     (setq tst-equ-result t)
  344.  
  345.     (tst-equ-level2)
  346.     (setq start-point (point))
  347.     (insert "Window state")
  348.     (newline)
  349.  
  350.     (setq tst-equ-result (tst-equ-wstates window1 window2 ))
  351.  
  352.     ; if we failed and a hook exist then run iot
  353.     (if (and (not tst-equ-result) 'tst-equ-windows-hook)
  354.            (run-hooks 'tst-equ-windows-hook))
  355.  
  356.     ; if we still fail the out a ?
  357.     (if (not tst-equ-result)
  358.     (progn
  359.       (setq saved-point (point))
  360.       (goto-char start-point)
  361.       (insert "?")
  362.       (goto-char (1+ saved-point))
  363.       ); ngorp
  364.       ); if
  365.  
  366.    tst-equ-result
  367.     ) ; let
  368. ); defun
  369.  
  370. (defun tst-equ-wstates (wstate1 wstate2)
  371.  "Check the equality of two windows"
  372.  
  373.  (let (sibling leftc-edges start-point tst-equ-result tresult obj1 obj2 assoc-list
  374.            label-list component label childs1 childs2 cl1 cl2 cr1 cr2)
  375.  
  376.    (setq tst-equ-result t)
  377.  
  378.    ; check for spilt windows 
  379.    (if (assoc 'split wstate1)
  380.        (progn
  381.      (setq childs1 (cadr (assoc 'children wstate1)))
  382.      (setq childs2 (cadr (assoc 'children wstate2)))
  383.      ; Save the children
  384.      (setq cl1 (car childs1))
  385.      (setq cl2 (car childs2))
  386.      (setq cr1 (car (cdr childs1)))
  387.      (setq cr2 (car (cdr childs2)))
  388.  
  389.      ; Now do the comparisons
  390.      (setq tresult (tst-equ-wstates cl1 cl2))
  391.      (setq tst-equ-result (and tresult (tst-equ-wstates cr1 cr2)))
  392.      ); progn
  393.      ); if split
  394.  
  395.    ; else not spilt so compare windows
  396.     (progn
  397.       ; first set up the assoc and label list
  398.       (setq assoc-list '(window-edges window-buffer window-start window-point
  399.                    current-window))
  400.       (setq label-list '(edges buffer start point current))
  401.  
  402.       ; setup *equal-log* buffer
  403.       (newline)
  404.       (tst-equ-level3)
  405.       (setq start-point (point))
  406.       (insert "window")
  407.       (newline)
  408.  
  409.       ; loop thru the full assoc list
  410.       (while assoc-list
  411.     (progn
  412.       (setq component (car assoc-list))
  413.       (setq assoc-list (cdr assoc-list))
  414.       (setq label (car label-list))
  415.       (setq label-list (cdr label-list))
  416.  
  417.       ; now get the two objects and compare them
  418.       (tst-equ-level4)
  419.       (setq obj1 (cadr (assoc component wstate1)))
  420.       (setq obj2 (cadr (assoc component wstate2)))
  421.       (setq tresult (equal obj1 obj2))
  422.       (if (not tresult)
  423.           (progn
  424.         (insert "?")
  425.         (setq tst-equ-result nil)
  426.         ); ngorp
  427.         ; else
  428.         (insert " ")
  429.         ); if
  430.       (insert (prin1-to-string component) ": ")
  431.       (tst-equ-log-diff tresult obj1 obj2)
  432.       ); progn after the while
  433.     ); while assoc-list
  434.  
  435.       tst-equ-result
  436.       ); progn
  437.    ); let
  438. ); defun
  439.  
  440. ;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  441.  
  442. (defun tst-equ-processes (state1 state2)
  443.    "Compares the process components from two states. The
  444.    two parameters STATE1 and STATE2 must be complete states
  445.    as returned by tst-reg-capture-state. The session components
  446.    include: command exit-status filter name sentinel status. "
  447.  
  448.   (interactive "P")
  449.                     ; Local Variables
  450.   (let (proc1 proc2 p1 p2 c1 c2 tst-equ-result proc-list component start-point
  451.           saved-point) 
  452.  
  453.     (message "Comparing state of processes...")
  454.     (setq proc-list '(command exit-status filter name sentinel status))
  455.  
  456.     (setq proc1 (cadr (assoc 'processes state1)))
  457.     (setq proc2 (cadr (assoc 'processes state2)))
  458.     (setq tst-equ-result t)
  459.  
  460.     (tst-equ-level2)
  461.     (setq start-point (point))
  462.     (insert "Processes state")
  463.     (newline)
  464.  
  465.     (while proc1 
  466.       (progn
  467.     (setq p1 (car proc1))
  468.     (setq proc1 (cdr proc1))
  469.     (setq p2 (car proc2))
  470.     (setq proc2 (cdr proc2))
  471.  
  472.     (setq proc-list '(command exit-status filter name 
  473.                   sentinel status process-mark))
  474.     (newline)
  475.     (while proc-list
  476.       (progn
  477.         (setq component (car proc-list))
  478.         (setq proc-list (cdr proc-list))
  479.         (setq c1 (cadr (assoc component p1)))
  480.         (setq c2 (cadr (assoc component p2)))
  481.         (setq cresult (equal c1 c2))
  482.  
  483.         (tst-equ-level3)
  484.         (if (not cresult)
  485.         (progn
  486.           (insert "?")
  487.           (setq tst-equ-result nil)
  488.           ); ngorp
  489.           ; else
  490.              (insert " ")
  491.           ); fi
  492.         (insert (prin1-to-string component) ": ")
  493.         (tst-equ-log-diff cresult c1 c2)
  494.         ); ngorp
  495.       ); elihw
  496.  
  497.  
  498.     ); ngorp
  499.       ); while proc1
  500.  
  501.     ; if we failed and a hook exist then run iot
  502.     (if (and (not tst-equ-result) 'tst-equ-processes-hook)
  503.            (run-hooks 'tst-equ-processes-hook))
  504.  
  505.     (if (not tst-equ-result)
  506.     (progn
  507.       (setq saved-point (point))
  508.       (goto-char start-point)
  509.       (insert "?")
  510.       (goto-char (1+ saved-point))
  511.       ); ngorp
  512.       ); fi
  513.     tst-equ-result
  514.   ); tel
  515. ); nufed
  516.  
  517.  
  518. (defun tst-equ-buffer-state (buff-state1 buff-state2)
  519.    "Compares two buffers for equality. The two parameters 
  520.     BUFFER1 and BUFFER2 must be buffer states as returned
  521.     by tst-equ-find-buffer. The following components are
  522.     compared by default: point mark contents file local-variables.
  523.     This can be modified by changing the elemetns in the variable
  524.     tst-equ-buff-state-functions. "
  525.  
  526.   (interactive "P")
  527.  
  528. ; Variables
  529.  
  530.   (let (bs-fun-vector function-name tst-equ-result saved-beg msg
  531.               fname
  532.               saved-end tst-equ-buffer-state-startpoint)
  533.     (get-buffer-create "*equal-log*")
  534.     (set-buffer "*equal-log*")
  535.     (outline-mode)
  536.     (goto-char (point-max))
  537.  
  538.     (newline)
  539.     (tst-equ-level2)
  540.     (setq tst-equ-buffer-state-startpoint (point))
  541.     (insert "Comparison of buffers named: "  )
  542.     (insert (cadr (assoc 'buf-state-name buff-state1)))
  543.     (newline)
  544.  
  545.     (setq msg (concat "Comparing state of buffer " 
  546.               (cadr (assoc 'buf-state-name buff-state1))))
  547.     (message msg)
  548.  
  549.   (setq bs-fun-vector tst-equ-buff-state-functions)
  550.   (setq tst-equ-result t) ; let's be optomistic
  551.  
  552.   (while bs-fun-vector
  553.     (progn
  554.       (setq function-name (car bs-fun-vector))
  555.       (setq bs-fun-vector (cdr bs-fun-vector))
  556.  
  557.       (tst-equ-level3)
  558.       (setq saved-beg (point))
  559.       (setq fname (prin1-to-string function-name))
  560.       (setq fname (substring fname (match-end 
  561.                  (string-match "tst-equ-" fname)) nil))
  562.       (insert fname ": ")
  563. ;      (newline)
  564.       (if (not (funcall function-name buff-state1 buff-state2))
  565.           (progn
  566.             (setq tst-equ-result nil)   ; set return value if failed
  567.             (setq saved-end (point))
  568.             (goto-char saved-beg)
  569.             (insert "?")
  570.             (goto-char (1+ saved-end))
  571.  
  572.             ); ngorp
  573.         ); fi
  574.  
  575.       ); progn
  576.     ); while
  577.   (if (not tst-equ-result)
  578.       (progn
  579.         (setq temppoint (point))
  580.         (goto-char tst-equ-buffer-state-startpoint)
  581.         (insert "?")
  582.         (goto-char (1+ temppoint))
  583.         ); ngorp
  584.     ); fi
  585.        tst-equ-result
  586.   ) ; let
  587.  
  588. ) ; defun tst-equ-buffer-state
  589.  
  590.  
  591. ;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  592.  
  593. (defun tst-equ-contents (buff-state1 buff-state2)
  594.   "Compares the contents component from two buffer states. "
  595.  
  596.   (interactive "P")
  597.                     ; Local Variables
  598.   (let (tst-equ-contents1 tst-equ-contents2 tst-equ-result) 
  599.     
  600.     (setq tst-equ-contents1 (cadr (assoc 'buf-state-contents buff-state1)))
  601.     (setq tst-equ-contents2 (cadr (assoc 'buf-state-contents buff-state2)))
  602.     (setq tst-equ-result (string-equal tst-equ-contents1 tst-equ-contents2))
  603.  
  604.     ; if a hook exist and we failed the compare then run the hook ..
  605.     (if (and (not tst-equ-result) 'tst-equ-contents-hook)
  606.            (run-hooks 'tst-equ-contents-hook))
  607.  
  608.     (if (not tst-equ-result)
  609.         (progn
  610.           (indent-to (* tst-equ-indent 4))
  611.           (insert "contents not equal")
  612.           ); ngorp
  613.       (progn
  614.         (indent-to (* tst-equ-indent 4))
  615.         (insert "contents equal")
  616.         ); ngorp
  617.       ); fi
  618.     (newline)
  619.     tst-equ-result
  620.   ) ; let
  621. ) ; defun tst-equ-contents
  622.  
  623. ;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  624.  
  625. (defun tst-equ-contents-region (buff-state1 buff-state2)
  626.   "Compares the contents component from two buffer states between
  627.    point and mark. "
  628.  
  629.   (interactive "P")
  630.                     ; Local Variables
  631.   (let (tst-equ-contents-region1 tst-equ-contents-region2 
  632.                  buf-point buf-mark tst-equ-result) 
  633.     
  634.     (setq tst-equ-contents-region1 (cadr (assoc 'buf-state-contents buff-state1)))
  635.     (setq buf-point (cadr (assoc 'buf-state-point buff-state1)))
  636.     (setq buf-mark  (cadr (assoc 'buf-state-mark buff-state1)))
  637.     (setq tst-equ-contents-region1 
  638.       (substring tst-equ-contents-region1 buf-point buf-mark))
  639.  
  640.     (setq tst-equ-contents-region2 (cadr (assoc 'buf-state-contents buff-state2)))
  641.     (setq buf-point (cadr (assoc 'buf-state-point buff-state2)))
  642.     (setq buf-mark  (cadr (assoc 'buf-state-mark buff-state2)))
  643.     (setq tst-equ-contents-region2
  644.       (substring tst-equ-contents-region2 buf-point buf-mark))
  645.  
  646.     (setq tst-equ-result (string-equal 
  647.           tst-equ-contents-region1 tst-equ-contents-region2))
  648.  
  649.     ; if a hook exist and we failed the compare then run the hook ..
  650.     (if (and (not tst-equ-result) 'tst-equ-contents-region-hook)
  651.            (run-hooks 'tst-equ-contents-region-hook))
  652.  
  653.     (if (not tst-equ-result)
  654.         (progn
  655.           (indent-to (* tst-equ-indent 4))
  656.           (insert "contents not equal")
  657.           ); ngorp
  658.       (progn
  659.         (indent-to (* tst-equ-indent 4))
  660.         (insert "contents equal")
  661.         ); ngorp
  662.       ); fi
  663.     (newline)
  664.     tst-equ-result
  665.   ) ; let
  666. ) ; defun tst-equ-contents-region
  667.  
  668. ;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  669.  
  670. (defun tst-equ-contents-line (buff-state1 buff-state2)
  671.   "Compares the contents component from two buffer states. Comparison
  672.    is performed line by line. Will run a hook named 'tst-equ-line-hook
  673.    that can access the strings tst-equ-line1 and tst-equ-line2. Hook is
  674.    called only if the comparison fails but can set tst-equ-result to t if
  675.    it wants."
  676.  
  677.   (interactive "P")
  678.                     ; Local Variables
  679.   (let (c1 c2 tst-equ-line1 tst-equ-line2 tst-equ-result more1 more2 
  680.        start1 end1 start2 end2 final-result found-so-far) 
  681.     
  682.     (setq c1 (cadr (assoc 'buf-state-contents buff-state1))); get the first value
  683.     (setq c2 (cadr (assoc 'buf-state-contents buff-state2))); get the second value
  684.     (setq final-result t more1 t more2 t)
  685.     (setq start1 0 start2 0 found-so-far 0); starting index in strings
  686.  
  687.  
  688.     (while (and more1 more2)
  689.       (progn
  690.     (setq end1 (string-match "\n" c1 start1))
  691.     (if (not end1)
  692.         (setq more1 nil); we hit end-of-contents
  693.     ; else
  694.       (progn
  695.         (setq tst-equ-line1 (substring c1 start1 end1 ))
  696.         (setq start1 (match-end 0))
  697.         ); ngorp
  698.       ); fi
  699.     (setq end2 (string-match "\n" c2 start2))
  700.     (if (not end2)
  701.         (setq more2 nil); we hit end-of-contents
  702.     ; else
  703.       (progn
  704.         (setq tst-equ-line2 (substring c2 start2 end2 ))
  705.         (setq start2 (match-end 0))
  706.         ); ngorp
  707.       ); fi
  708.  
  709.     ; now do the comparison if we have two lines
  710.     (if (and more1 more2)
  711.       (progn
  712.         (setq tst-equ-result (string-equal tst-equ-line1 tst-equ-line2))
  713.  
  714.         ; if a hook exist and we failed the compare then run the hook ..
  715.         (if (and (not tst-equ-result) 'tst-equ-line-hook)
  716.           (run-hooks 'tst-equ-line-hook))
  717.  
  718.         ; but test again in case hook modified result
  719.         (if (not tst-equ-result)
  720.         (progn
  721.           (setq final-result nil)
  722.           (tst-equ-log-diff-line tst-equ-line1 tst-equ-line2)
  723.           (setq found-so-far (+ 1 found-so-far))
  724.           (if (>=  found-so-far tst-equ-max-line-diffs)
  725.               (progn
  726.                 ; i want to just get out of here.
  727.                 (setq more1 nil)
  728.                 (setq more2 nil)        ;fake 'em into leaving
  729.                 ); ngorp
  730.             ); fi
  731.           ); ngorp
  732.          ); fi
  733.        ); ngorp
  734.      ); fi
  735.     ); ngorp
  736.       ); elihw
  737.     final-result
  738.   ) ; let
  739. ) ; defun tst-equ-contents-line
  740.  
  741. ;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  742.  
  743. (defun tst-equ-point (buff-state1 buff-state2)
  744.   "Compares the point component from two buffer states. "
  745.  
  746.   (interactive "P")
  747.                     ; Local Variables
  748.   (let (tst-equ-point1 tst-equ-point2 tst-equ-result) 
  749.     
  750.     (setq tst-equ-point1 (cadr (assoc 'buf-state-point buff-state1)))
  751.     (setq tst-equ-point2 (cadr (assoc 'buf-state-point buff-state2)))
  752.     (setq tst-equ-result (equal tst-equ-point1 tst-equ-point2))
  753.  
  754.     ; if a hook exist and we failed the compare then run the hook ..
  755.     (if (and (not tst-equ-result) 'tst-equ-point-hook)
  756.            (run-hooks 'tst-equ-point-hook))
  757.     
  758.     (tst-equ-log-diff tst-equ-result (int-to-string tst-equ-point1) 
  759.               (int-to-string tst-equ-point2))
  760.     tst-equ-result
  761.   ) ; let
  762. ) ; defun tst-equ-point
  763.  
  764. ;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  765.  
  766. (defun tst-equ-mark (buff-state1 buff-state2)
  767.   "Compares the mark component from two buffer states. "
  768.  
  769.   (interactive "P")
  770.                     ; Local Variables
  771.   (let (tst-equ-mark1 tst-equ-mark2 tst-equ-result) 
  772.     
  773.     (setq tst-equ-mark1 (cadr (assoc 'buf-state-mark buff-state1)))
  774.     (setq tst-equ-mark2 (cadr (assoc 'buf-state-mark buff-state2)))
  775.     (setq tst-equ-result (equal tst-equ-mark1 tst-equ-mark2))
  776.  
  777.     ; if a hook exist and we failed the compare then run the hook ..
  778.     (if (and (not tst-equ-result) 'tst-equ-mark-hook)
  779.            (run-hooks 'tst-equ-mark-hook))
  780.  
  781.     (tst-equ-log-diff tst-equ-result  tst-equ-mark1 tst-equ-mark2)
  782.     tst-equ-result
  783.  
  784.   ) ; let
  785. ) ; defun tst-equ-mark
  786.  
  787. ;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  788.  
  789. (defun tst-equ-modified (buff-state1 buff-state2)
  790.   "Compares the modified component from two buffer states. "
  791.  
  792.   (interactive "P")
  793.                     ; Local Variables
  794.   (let (tst-equ-modified1 tst-equ-modified2 tst-equ-result) 
  795.     
  796.     (setq tst-equ-modified1 (cadr (assoc 'buf-state-modified buff-state1)))
  797.     (setq tst-equ-modified2 (cadr (assoc 'buf-state-modified buff-state2)))
  798.     (setq tst-equ-result (equal tst-equ-modified1 tst-equ-modified2))
  799.  
  800.     ; if a hook exist and we failed the compare then run the hook ..
  801.     (if (and (not tst-equ-result) 'tst-equ-modified-hook)
  802.            (run-hooks 'tst-equ-modified-hook))
  803.  
  804.     (tst-equ-log-diff tst-equ-result  tst-equ-modified1 tst-equ-modified2)
  805.     tst-equ-result
  806.  
  807.   ) ; let
  808. ) ; defun tst-equ-modified
  809.  
  810. ;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  811.  
  812. (defun tst-equ-file (buff-state1 buff-state2)
  813.   "Compares the file component from two buffer states. "
  814.  
  815.   (interactive "P")
  816.                     ; Local Variables
  817.   (let (tst-equ-file1 tst-equ-file2 tst-equ-result) 
  818.     
  819.     (setq tst-equ-file1 (cadr (assoc 'buf-state-file buff-state1))); get the first value
  820.     (setq tst-equ-file2 (cadr (assoc 'buf-state-file buff-state2))); get the second value
  821.     (setq tst-equ-result (equal tst-equ-file1 tst-equ-file2))
  822.  
  823.     ; if a hook exist and we failed the compare then run the hook ..
  824.     (if (and (not tst-equ-result) 'tst-equ-file-hook)
  825.            (run-hooks 'tst-equ-file-hook))
  826.  
  827.     (tst-equ-log-diff tst-equ-result  tst-equ-file1 tst-equ-file2)
  828.     tst-equ-result
  829.  
  830.   ) ; let
  831. ) ; defun tst-equ-file
  832.  
  833.  
  834. ;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  835. (defun tst-equ-diff-element (el1 el2)
  836.   " Logs differences between the two elements based on the type of 
  837. element that it is. (keymap, vector, string, list)"
  838.  
  839.   (let ()
  840.  
  841.     (cond  ((keymapp (cdr el1)) (tst-equ-log-keymap el1 el2))
  842.            ((syntax-table-p (cdr el1)) (tst-equ-log-syntable el1 el2))
  843.            ((stringp (cdr el1)) (tst-equ-log-string el1 el2))
  844.            ((atom (cdr el1)) (tst-equ-log-atom el1 el2))
  845.            ((arrayp (cdr el1)) (tst-equ-log-array el1 el2))
  846.            (t (tst-equ-log-fubar el1 el2))
  847.            ); dnoc
  848. ); tel
  849. ); defun tst-equ-diff-element
  850.  
  851. (defun tst-equ-log-fubar (el1 el2)
  852. " Generic equal-comparer for elements of a symbol"
  853.  
  854.   (let ()
  855.     (if (not (equal el1 el2))
  856.       (progn  
  857. ;        (debug nil "in fubar" el1 el2)
  858.         (indent-to (* tst-equ-indent 4))
  859.         (insert (prin1-to-string (car el1)))
  860.         (if (cdr el1)
  861.             (insert ": "(prin1-to-string (cdr el1))  " "
  862.                 (prin1-to-string (cdr el2)))
  863.           ); fi
  864.         (newline)
  865.         ); ngorp
  866.       ); fi
  867. ); tel
  868. ); defun tst-equ-log-fubar
  869.     
  870. (defun tst-equ-log-string (el1 el2)
  871.  
  872.   (let ()
  873.  
  874.     (if (not (equal el1 el2))
  875.       (progn  
  876. ;        (debug nil "In string" (car el1))
  877.         (indent-to (* tst-equ-indent 4))
  878.         (insert (prin1-to-string (car el1)))
  879.         (newline)
  880.         ); ngorp
  881.       ); fi
  882.       ); tel
  883. ); defun tst-equ-log-string
  884.  
  885. (defun tst-equ-log-atom (el1 el2)
  886.  
  887.   (let ()
  888.  
  889.     (if (not (equal el1 el2))
  890.       (progn  
  891. ;        (debug nil "in atom" el1 el2)
  892.         (indent-to (* tst-equ-indent 4))
  893.         (insert (prin1-to-string (car el1))
  894.                 "   " (prin1-to-string (cdr el1))
  895.                 " " (prin1-to-string (cdr el2)))
  896.         (newline)
  897.         ); ngorp
  898.       ); fi
  899.       ); tel
  900. ); defun tst-equ-log-atom
  901.  
  902. (defun tst-equ-log-syntable (a1 a2)
  903.   " Outputs the differences between two syntax tables in the form:
  904.       element_number : value1  value2"
  905.  
  906.   (let (e1 e2 index)
  907. ;    (debug nil "In syntable" (car el1))
  908.     (if (not (equal a1 a2))
  909.           (while (not (= index 256))
  910.             (setq e1 (aref a1 index))
  911.             (setq e2 (aref a2 index))
  912.             (if (not (equal e1 e2))
  913.                 (progn
  914.                   (indent-to (* tst-equ-indent 4))
  915.                   (insert (prin1-to-string index) ": "
  916.                     (prin1-to-string e1) " " (prin1-to-string e2))
  917.                   (newline)
  918.                   );ngorp
  919.               ); fi
  920.             (+1 index)
  921.             ); elihw
  922.       ); fi
  923.           ); tel
  924. ); defun tst-equ-log-syntable
  925.  
  926.  
  927.  
  928. (defun tst-equ-log-keymap (a1 a2)
  929.   " Outputs only the fact that two keymaps do not match.  Has the potential
  930.      for future enhancements (like, describing which keys don't match"
  931.  
  932. ;  (debug nil "in keymap" (car el1))
  933.   (if (not (equal a1 a2))
  934.       (progn
  935.         (indent-to (* tst-equ-indent 4))
  936.         (insert (prin1-to-string (car a1)))
  937.         ); ngorp
  938.     );fi
  939. ); defun tst-equ-log-keymap
  940. ;  (let (e1 e2 index)
  941. ;          (while (not (= index 256))
  942. ;            (setq e1 (aref a1 index))
  943. ;            (setq e2 (aref a2 index))
  944. ;            (if (not (equal e1 e2))
  945. ;                (progn
  946. ;                  (indent-to (* tst-equ-indent 4))
  947. ;                  (insert (prin1-to-string index) ": "
  948. ;                    (prin1-to-string e1) " " (prin1-to-string e2))
  949. ;                  (newline)
  950. ;                  );ngorp
  951. ;              ); fi
  952. ;            (+1 index)
  953. ;            ); elihw
  954. ;
  955. ;          ); tel
  956. ;); defun tst-equ-log-syntable
  957.  
  958.  
  959.  
  960. (defun tst-equ-log-diff (equal-flag  v1 v2)
  961.   "Logs differences in *equal-log* buffer. "
  962.  
  963.  
  964.   (let ()
  965.       (if (or tst-equ-log-all-compares (not equal-flag))
  966.           (progn
  967.             (indent-to (* tst-equ-indent 4))
  968.             (insert (prin1-to-string v1) " " (prin1-to-string v2))
  969.             (newline)
  970.             ); ngorp
  971.         );fi
  972.  
  973.   ) ; let
  974. ) ; defun tst-equ-log-diff
  975. ;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  976.  
  977. (defun tst-equ-log-diff-line (line1 line2)
  978.   "Logs differences in *equal-log* buffer. "
  979.  
  980.  
  981.   (let ()
  982.  
  983.       (goto-char (point-max))
  984.       (newline)
  985.       (indent-to (* tst-equ-indent 4))
  986.       (insert "1: " line1)
  987.       (newline)
  988.       (indent-to (* tst-equ-indent 4))
  989.       (insert "2: " line2)
  990.       (newline)
  991.  
  992.   ) ; let
  993. ) ; defun tst-equ-log-diff-line
  994.  
  995.  
  996. ;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  997.  
  998. (defun tst-equ-find-buffer-with-name (state name )
  999.     "Return a buff-state of the buffer from STATE with name NAME."
  1000.  
  1001. ; Variables
  1002.  
  1003.   (let  (buffers buff-state buff-name found)
  1004.  
  1005.     (setq found nil)
  1006.     (setq buffers (cadr (assoc 'buffers state)))
  1007.  
  1008.  
  1009.     (while (not found)
  1010.       (progn
  1011.     (setq buff-state (car buffers))
  1012.     (setq buffers (cdr buffers))
  1013.     (setq buff-name (cadr (assoc 'buf-state-name buff-state)))
  1014.     (if (equal buff-name name) 
  1015.         (setq found t)
  1016.     ; else
  1017.         (progn 
  1018.           (if (not buffers) 
  1019.           (progn 
  1020.             (setq found t)
  1021.             (setq buff-state nil)
  1022.             ); progn
  1023.          ); fi
  1024.         ); ngrop
  1025.       ); if
  1026.     ); progn
  1027.       ); while
  1028.     buff-state
  1029.   ) ; let
  1030. ) ; defun tst-equ-find-buffer-with-name
  1031.  
  1032. ;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  1033.  
  1034. (defun tst-equ-named-buff-states (state1 name1 state2 name2)
  1035.   " Compares, from STATE1, the state of the buffer who's name is
  1036.     NAME1 with, from STATE2,  the state of the buffer who's name
  1037.     is NAME2. If STATE2 is nil, then a buffer of NAME2 is expected
  1038.     in STATE1. "
  1039.  
  1040.   (interactive "P")
  1041.                        
  1042. ; Variables
  1043.  
  1044.   (let  (buff-state-1 buff-state-2)
  1045.  
  1046.     ; first locate the buffers
  1047.     (setq buff-state-1 (tst-equ-find-buffer-with-name state1 name1))
  1048.     (if state2
  1049.     (setq buff-state-2 (tst-equ-find-buffer-with-name state2 name2))
  1050.     ; else
  1051.     (setq buff-state-2 (tst-equ-find-buffer-with-name state1 name2))
  1052.     ) ; if
  1053.     (tst-equ-buffer-state buff-state-1 buff-state-2)
  1054.  
  1055.   ) ; let
  1056. ) ; defun tst-equ-named-buff-states
  1057.  
  1058. (defun tst-equ-local-vars (b1  b2)
  1059.    " Compares the values of the local variables in two buffers and
  1060.      logs the ones that are different."
  1061.  
  1062.      
  1063.    (interactive "P")
  1064.  
  1065.    (let (vars1 vars2 var1 var2 tst-equ-result firsttime)
  1066.  
  1067.     (setq tst-equ-result t)            ;default to "all equal "
  1068.     (setq firsttime nil)                ;still just my first time ...
  1069.  
  1070.  
  1071.      (setq vars1 (cadr (assoc 'buf-state-local-vars b1)))
  1072.  
  1073.      (setq vars2 (cadr (assoc 'buf-state-local-vars b2)))
  1074.  
  1075.      (while vars1                        ;go through the b1 vars first.
  1076.        (setq var1 (car vars1))          ;get the next variable
  1077.        (setq vars1 (cdr vars1))            ;.. and set the list to the tail
  1078.        (setq var2 (assoc (car var1) vars2)) ; find this variable in b2
  1079.        (if var2
  1080.            (progn
  1081.              (if (not (equal var1 var2))
  1082.                  (progn
  1083.                    (if (not firsttime)
  1084.                        (progn
  1085.                          (indent-to (* tst-equ-indent 3))
  1086.                          (insert "local variables not equal ")
  1087.                          (newline)
  1088.                          (setq firsttime t)
  1089.                          ); ngorp
  1090.                      ); fi
  1091.                    (setq tst-equ-result nil)
  1092.                    (indent-to (* tst-equ-indent 4))
  1093.                    (insert (prin1-to-string (car var1))
  1094.                     "   " (prin1-to-string (cdr var1))
  1095.                     " " (prin1-to-string (cdr var2)))
  1096.                    (newline)
  1097.                    ); ngorp
  1098.          );fi
  1099.        ); ngorp
  1100.          ; else
  1101.          (progn
  1102.            (setq tst-equ-result nil)
  1103.            (if (not firsttime)
  1104.                (progn
  1105.                  (insert "?")
  1106.                  (indent-to (* tst-equ-level 3))
  1107.                  (insert "local variables not equal ")
  1108.                  (newline)
  1109.                  (setq firsttime t)
  1110.                  ); ngorp
  1111.              ); fi
  1112.            (indent-to (* tst-equ-level 4))
  1113.            (insert  (prin1-to-string (car var1)) "not found in second buffer ")
  1114.            (newline)
  1115.            ); ngorp (of else)
  1116.          ); fi [if vars2]
  1117.        ); elihw
  1118.  
  1119.      (setq vars1 (cadr (assoc 'buf-state-local-vars b1)))
  1120.      (while vars2
  1121.        
  1122.        (setq var2 (car vars2))          ;get the next variable
  1123.        (setq vars2 (cdr vars2))            ;.. and set the list to the tail
  1124.        (setq var1 (assoc (car var2) vars1))
  1125.        (if (not var1)
  1126.          (progn
  1127.            (setq tst-equ-result nil)
  1128.            (if (not firsttime)
  1129.                (progn
  1130.                  (indent-to (* tst-equ-indent 4))
  1131.                  (insert "local variables not equal:")
  1132.                  (newline)
  1133.                  (setq firsttime t)
  1134.                  ); ngorp
  1135.              ); fi
  1136.            (indent-to (* tst-equ-indent 4))
  1137.            (insert (prin1-to-string (car var2)) " not found in first buffer " )
  1138.            (newline)
  1139.            ); ngorp (of else)
  1140.          ); fi 
  1141.        ); elihw
  1142.      (if tst-equ-result
  1143.          (progn
  1144.            (indent-to (* tst-equ-indent 4))
  1145.            (insert "local variables are equal ")
  1146.            (newline)
  1147.            ); ngorp
  1148.        ); fi
  1149.      tst-equ-result                                ;return the tst-equ-result
  1150.      ); tel
  1151.    ); defun tst-equ-local-vars
  1152.  
  1153.  
  1154.  
  1155.