cgit.sxemacs.org Git - packages/blob - xemacs-packages/elib/elib-test.el

   1 ;;;; $Id: elib-test.el,v 1.1.1.1 1998-10-07 11:10:57 jareth Exp $
   2 ;;;; This file contains functions for testing all packages in ELIB.
   3
   4 ;; Copyright (C) 1991-1995 Free Software Foundation
   5
   6 ;; Author: Per Cederqvist <ceder@lysator.liu.se>
   7 ;;      Inge Wallin <inge@lysator.liu.se>
   8 ;; Maintainer: elib-maintainers@lysator.liu.se
   9 ;; Created: 3 Aug 1992
  10
  11 ;;;; This file is part of the GNU Emacs lisp library, Elib.
  12 ;;;;
  13 ;;;; GNU Elib is free software; you can redistribute it and/or modify
  14 ;;;; it under the terms of the GNU General Public License as published by
  15 ;;;; the Free Software Foundation; either version 2, or (at your option)
  16 ;;;; any later version.
  17 ;;;;
  18 ;;;; GNU Elib is distributed in the hope that it will be useful,
  19 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;;;; GNU General Public License for more details.
  22 ;;;;
  23 ;;;; You should have received a copy of the GNU General Public License
  24 ;;;; along with GNU Elib; see the file COPYING.  If not, write to
  25 ;;;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  26 ;;;; Boston, MA 02111-1307, USA
  27 ;;;;
  28
  29 ;;; Code:
  30
  31 (require 'backquote)
  32
  33 ;;; ================================================================
  34 ;;; Routines common to all the ELIB packages.
  35
  36
  37 (defun test-package (package-test-suite)
  38   "Run through a list of test cases.
  39 Each test case is a list of one of the following types:
  40  (test-case error expected-error)
  41  (test-case result expected-result)
  42  (test-case dont-care)"
  43
  44   (interactive "Xtest suite: ")
  45   (let ((testno 0)
  46         (all-is-ok t))
  47     (mapcar (function
  48              (lambda (ele)
  49                (if (not (test-a-case ele testno))
  50                    (setq all-is-ok nil))
  51                (setq testno (1+ testno))))
  52             package-test-suite)
  53     (if all-is-ok
  54         (princ "None of the errors have been found.\n"))))
  55
  56
  57 (defun test-a-case (test-case testno)
  58   ;; Return t if ok and nil if error.
  59
  60   (let* ((test-data (car test-case))
  61          (result-type (car (cdr test-case)))
  62          (expected-result (if (eq result-type 'dont-care)
  63                               nil
  64                             (car (cdr (cdr test-case)))))
  65          result)
  66     (cond
  67      ((eq result-type 'error)
  68
  69       ;; An error expected:
  70       (condition-case error
  71           (progn
  72             (setq result (eval test-data))
  73             (princ (format "%3d: An error should have occured here: %s\n"
  74                            testno test-case))
  75             (princ (format "     The result was: %s\n" result))
  76             nil)
  77         (error (if (equal error expected-result)
  78                    t
  79                  (princ (format "%3d: Wrong error.\n" testno))
  80                  (princ (format "     %s\n" error))
  81                  (princ (format "     The error should have been:\n     %s\n"
  82                                 expected-result))
  83                  nil))))
  84
  85      ((or (eq result-type 'result)
  86           (eq result-type 'dont-care))
  87
  88       ;; No error expected:
  89       (condition-case error
  90           (let ((result (eval test-data)))
  91             (if (or (eq result-type 'dont-care)
  92                     (equal result expected-result))
  93                 t
  94               (princ
  95                (format
  96                 "%3d: Wrong result while evaluating\n%s\nThe result: %s\n"
  97                 testno test-case result))
  98               (princ (format "     The result should have been: %s\n"
  99                              expected-result))
 100               nil))
 101         (error
 102          (princ
 103           (format
 104            "%3d: An error occured while evaluating\n%s\nThe error:\n     %s\n"
 105            testno test-case error))
 106          (if (eq result-type 'result)
 107              (princ (format "     The result should have been:\n     %s\n"
 108                             expected-result)))
 109          nil)))
 110      (t
 111       (princ (format "%3d: Misformed test case:\n     %s\n"
 112                      testno test-case))))))
 113
 114
 115 ;;; ================================================================
 116 ;;;         Tests for the function variety of the stack.
 117
 118
 119 (setq stack-f-tests
 120       '(((setq stk (stack-create)) result (STACK))
 121         ((setq xyz 'xyz) result xyz)
 122
 123         ((stack-p stk) result t)
 124         ((stack-empty stk) result t)
 125         ((stack-pop stk) result nil)
 126         ((stack-top stk) result nil)
 127         ((stack-length stk) result 0)
 128         ((stack-all stk) result nil)
 129
 130         ((stack-p xyz) result nil)
 131         ((stack-empty xyz) error (wrong-type-argument listp xyz))
 132         ((stack-pop xyz) error (wrong-type-argument listp xyz))
 133         ((stack-top xyz) error (wrong-type-argument listp xyz))
 134         ((stack-length xyz) error (wrong-type-argument listp xyz))
 135         ((stack-all xyz) error (wrong-type-argument listp xyz))
 136
 137         ((setq stk2 (stack-copy stk)) result (STACK))
 138         ((eq stk stk2) result nil)
 139         ((equal stk stk2) result t)
 140
 141         ((stack-push stk 'a) result (a))
 142         ((stack-top stk) result a)
 143         ((stack-all stk) result (a))
 144         ((stack-empty stk) result nil)
 145         ((stack-length stk) result 1)
 146
 147         ((stack-push stk 'b) result (b a))
 148         ((stack-all stk) result (b a))
 149         ((stack-length stk) result 2)
 150         ((stack-nth stk -1) result b)
 151         ((stack-nth stk 0) result b)
 152         ((stack-nth stk 1) result a)
 153         ((stack-nth stk 2) result nil)
 154         ((stack-nth stk 3) result nil)
 155
 156         ((setq stk2 (stack-copy stk)) result (STACK b a))
 157         ((eq stk stk2) result nil)
 158         ((equal stk stk2) result t)
 159
 160         ((stack-pop stk) result b)
 161         ((stack-all stk) result (a))
 162         ((stack-pop stk) result a)
 163         ((stack-all stk) result nil)
 164         ((stack-empty stk) result t)
 165
 166         ((stack-push stk 'a) result (a))
 167         ((stack-push stk 'b) result (b a))
 168         ((stack-clear stk) result nil)
 169         ((stack-p stk) result t)
 170         ((stack-empty stk) result t)
 171         ((stack-pop stk) result nil)
 172         ((stack-top stk) result nil)
 173         ((stack-length stk) result 0)
 174         ((stack-all stk) result nil)
 175         ))
 176 (setq stack-m-tests stack-f-tests)
 177
 178
 179 (defun test-stack-f ()
 180     (interactive)
 181     (let ((load-path '(".")))
 182       (require 'stack-f)
 183       (with-output-to-temp-buffer "*Elib-test*"
 184         (princ "stack-f:\n")
 185         (test-package stack-f-tests))))
 186
 187
 188 ;;
 189 ;; Use the same tests for stack-m as for stack-f
 190 ;;
 191 (defun test-stack-m ()
 192     (interactive)
 193     (let ((load-path '(".")))
 194       (require 'stack-m)
 195       (with-output-to-temp-buffer "*Elib-test*"
 196         (princ "stack-m:\n")
 197         (test-package stack-m-tests))))
 198
 199
 200
 201
 202 ;;; ================================================================
 203 ;;;         Tests for the function variety of the queue.
 204
 205
 206 (setq queue-f-tests
 207       '(((setq que (queue-create)) result (QUEUE nil))
 208         ((setq xyz 'xyz) result xyz)
 209
 210         ((queue-p que) result t)
 211         ((queue-empty que) result t)
 212         ((queue-dequeue que) result nil)
 213         ((queue-first que) result nil)
 214         ((queue-length que) result 0)
 215         ((queue-all que) result nil)
 216
 217         ((queue-p xyz) result nil)
 218         ((queue-empty xyz) error (wrong-type-argument listp xyz))
 219         ((queue-dequeue xyz) error (wrong-type-argument listp xyz))
 220         ((queue-first xyz) error (wrong-type-argument listp xyz))
 221         ((queue-length xyz) error (wrong-type-argument listp xyz))
 222         ((queue-all xyz) error (wrong-type-argument listp xyz))
 223
 224         ((setq que2 (queue-copy que)) result (QUEUE nil))
 225         ((eq que que2) result nil)
 226         ((equal que que2) result t)
 227
 228         ((queue-enqueue que 'a) result (a))
 229         ((queue-first que) result a)
 230         ((queue-all que) result (a))
 231         ((queue-empty que) result nil)
 232         ((queue-length que) result 1)
 233
 234         ((queue-enqueue que 'b) result (b))
 235         ((queue-all que) result (a b))
 236         ((queue-length que) result 2)
 237         ((queue-nth que -1) result a)
 238         ((queue-nth que 0) result a)
 239         ((queue-nth que 1) result b)
 240         ((queue-nth que 2) result nil)
 241         ((queue-nth que 3) result nil)
 242
 243         ((setq que2 (queue-copy que)) result (QUEUE (a b) b))
 244         ((eq que que2) result nil)
 245         ((equal que que2) result t)
 246
 247         ((queue-dequeue que) result a)
 248         ((queue-all que) result (b))
 249         ((queue-dequeue que) result b)
 250         ((queue-all que) result nil)
 251         ((queue-empty que) result t)
 252
 253         ((queue-enqueue que 'a) dont-care)
 254         ((queue-enqueue que 'b) dont-care)
 255         ((queue-clear que) dont-care)
 256         ((queue-p que) result t)
 257         ((queue-empty que) result t)
 258         ((queue-dequeue que) result nil)
 259         ((queue-first que) result nil)
 260         ((queue-length que) result 0)
 261         ((queue-all que) result nil)
 262         ))
 263 (setq queue-m-tests queue-f-tests)
 264
 265
 266 (defun test-queue-f ()
 267     (interactive)
 268     (let ((load-path '(".")))
 269       (require 'queue-f)
 270       (with-output-to-temp-buffer "*Elib-test*"
 271         (princ "queue-f:\n")
 272         (test-package queue-f-tests))))
 273
 274 ;;
 275 ;; Use the same tests for queue-m as for queue-f
 276 ;;
 277 (defun test-queue-m ()
 278     (interactive)
 279     (let ((load-path '(".")))
 280       (require 'queue-m)
 281       (with-output-to-temp-buffer "*Elib-test*"
 282         (princ "queue-m:\n")
 283         (test-package queue-m-tests))))
 284
 285
 286 ;;; ================================================================
 287 ;;;         Tests for the string package.
 288
 289 (setq string-tests
 290       '(((string-replace-match "foo" "kallefoopelle" "bar")
 291          result "kallebarpelle")
 292         ((string-replace-match "[0-9]" "le127" "bar\\\\\\&\\\\")
 293          result "lebar\\1\\27")
 294         ((string-replace-match "f\\([^f]*\\)f\\([^f]*\\)f"
 295                                "abcdefghijfdddfojsan" "\\2\\1")
 296          result "abcdedddghijojsan")
 297         ((string-split "," "foo,bar,baz") result ("foo" "bar" "baz"))
 298         ((string-split "," "foo,bar,baz" 2) result ("foo" "bar"))))
 299
 300
 301 (defun test-string ()
 302     (interactive)
 303     (let ((load-path '(".")))
 304       (require 'string)
 305       (with-output-to-temp-buffer "*Elib-test*"
 306         (princ "string:\n")
 307         (test-package string-tests))))
 308
 309 ;;; ================================================================
 310 ;;;         Tests for the doubly linked list.
 311
 312 (setq dll-tests
 313       '(
 314         ((setq a (dll-create)) dont-care)
 315         ((dll-p a) result t)
 316         ((dll-p nil) result nil)
 317         ((setq b (dll-create-from-list (list 'a 'b 'c))) dont-care)
 318         ((setq c (dll-copy b)) dont-care)
 319         ((dll-enter-first c 'f) dont-care)
 320         ((dll-enter-last c 'l) dont-care)
 321         ((setq n (dll-nth c 2)) dont-care)
 322         ((dll-element c n) result b)
 323         ((dll-enter-after c n 'after) dont-care)
 324         ((dll-element c n) result b)
 325         ((dll-enter-before c n 'before) dont-care)
 326         ((dll-element c n) result b)
 327         ((dll-first a) result nil)
 328         ((dll-first b) result a)
 329         ((dll-first c) result f)
 330         ((dll-empty b) result nil)
 331         ((dll-last a) result nil)
 332         ((dll-last b) result c)
 333         ((dll-last c) result l)
 334         ((dll-element c n) result b)
 335         ((dll-all c) result (f a before b after c l))
 336         ((dll-element c (dll-next c n)) result after)
 337         ((dll-element c (dll-previous c n)) result before)
 338         ((dll-next b (dll-nth b 2)) result nil)
 339         ((dll-next b (dll-nth b -1)) result nil)
 340         ((dll-previous c (dll-nth c 0)) result nil)
 341         ((dll-all a) result nil)
 342         ((dll-all b) result (a b c))
 343         ((dll-all c) result (f a before b after c l))
 344         ((dll-delete c n) result b)
 345         ((dll-all c) result (f a before after c l))
 346         ((setq d (dll-copy c)) dont-care)
 347         ((dll-delete-first b) result a)
 348         ((dll-all b) result (b c))
 349         ((dll-delete-last b) result c)
 350         ((dll-all b) result (b))
 351         ((dll-delete-last b) result b)
 352         ((dll-all b) result nil)
 353         ((dll-clear c) dont-care)
 354         ((dll-all c) result nil)
 355         ((dll-clear c) dont-care)
 356         ((dll-all c) result nil)
 357         ((dll-p n) result nil)
 358         ((dll-p a) result t)
 359         ((dll-p b) result t)
 360         ((dll-empty a) result t)
 361         ((dll-empty b) result t)
 362         ((dll-all d) result (f a before after c l))
 363         ((dll-previous d (dll-nth d 0)) result nil)
 364         ((let (xxx)
 365            (dll-map-reverse (function (lambda (x) (setq xxx (cons x xxx)))) d)
 366            xxx) result (f a before after c l))
 367         ((let (xxx)
 368            (dll-map (function (lambda (x) (setq xxx (cons x xxx)))) d)
 369            xxx) result (l c after before a f))
 370         ((dll-filter d (function (lambda (x)
 371                                    (or (equal x 'after)
 372                                        (equal x 'before))))) dont-care)
 373         ((dll-all d) result (before after))
 374         ((dll-length a) result 0)
 375         ((dll-length d) result 2)
 376         ((setq a (dll-create-from-list (list 7 2 843 2 8 19 7 289))) dont-care)
 377         ((dll-sort a (function <)) dont-care)
 378         ((dll-all a) result (2 2 7 7 8 19 289 843))
 379         ))
 380
 381 (setq dll-debug-tests dll-tests)
 382
 383 (defun test-dll ()
 384     (interactive)
 385     (let ((load-path '(".")))
 386       (load-library "dll")
 387       (with-output-to-temp-buffer "*Elib-test*"
 388         (princ "dll:\n")
 389         (test-package dll-tests))))
 390
 391 (defun test-dll-debug ()
 392     (interactive)
 393     (let ((load-path '(".")))
 394       (load-library "dll-debug")
 395       (with-output-to-temp-buffer "*Elib-test*"
 396         (princ "dll-debug:\n")
 397         (test-package dll-debug-tests))))
 398
 399 ;;; ================================================================
 400 ;;;         Tests for the cookie mode.
 401
 402 (setq cookie-tests
 403       '(
 404         ((kill-buffer (get-buffer-create "*Cookie-buffer*")) dont-care)
 405         ((setq a (collection-create "*Cookie-buffer*"
 406                                     (function insert)
 407                                     "Header" "Footer"))
 408          dont-care)
 409         ((collection-empty a) result t)
 410         ((collection-length a) result 0)
 411         ((collection-list-cookies a) result nil)
 412         ((cookie-enter-first a "1") dont-care)
 413         ((cookie-enter-last a "2") dont-care)
 414         ((collection-append-cookies a '("3" "4")) dont-care)
 415         ((collection-empty a) result nil)
 416         ((collection-length a) result 4)
 417         ((collection-list-cookies a) result ("1" "2" "3" "4"))
 418         ((eq (collection-buffer a) (get-buffer "*Cookie-buffer*"))
 419          result t)
 420         ((save-window-excursion
 421            (set-buffer (collection-buffer a))
 422            (buffer-string))
 423          result "Header\n1\n2\n3\n4\nFooter\n")
 424       ((eq (tin-locate a 1) (tin-nth a 0)) result t)
 425       ((eq (tin-locate a 2) (tin-nth a 0)) result t)
 426       ((eq (tin-locate a 7) (tin-nth a 0)) result t)
 427       ((eq (tin-locate a 8) (tin-nth a 0)) result t)
 428       ((eq (tin-locate a 9) (tin-nth a 0)) result t)
 429       ((eq (tin-locate a 9) (tin-nth a 1)) result nil)
 430       ((eq (tin-locate a 10) (tin-nth a 0)) result nil)
 431       ((eq (tin-locate a 10) (tin-nth a 1)) result t)
 432       ((eq (tin-locate a 12) (tin-nth a 2)) result t)
 433       ((eq (tin-locate a 14) (tin-nth a 3)) result t)
 434       ((eq (tin-locate a 16) (tin-nth a 3)) result t)
 435       ((eq (tin-locate a 18) (tin-nth a 3)) result t)
 436
 437       ;; Test that last-tin is reset when collection-filter-cookies is called.
 438       ((tin-goto a (tin-locate a 12)) dont-care)
 439       ((collection-filter-cookies
 440         a (function (lambda (x) (not (string= x "3"))))) dont-care)
 441       ((collection-list-cookies a) result ("1" "2" "4"))
 442       ((tin-goto-previous a 13 1) dont-care)
 443
 444 ))
 445
 446 (defun test-cookie ()
 447     (interactive)
 448     (save-some-buffers)
 449     (let ((load-path '(".")))
 450       (load-library "cookie")
 451       (with-output-to-temp-buffer "*Elib-test*"
 452         (princ "cookie:\n")
 453         (test-package cookie-tests))))
 454
 455
 456 ;;; ================================================================
 457 ;;;            Functions for testing a binary tree.
 458 ;;;            (not yet working)
 459
 460
 461 (require 'bintree)
 462
 463
 464 (defun bintree-print (tree)
 465   "Print the binary tree TREE on stdout."
 466   (princ "\n")
 467   (do-bintree-print (elib-bintree-root tree) 0)
 468   nil)
 469
 470
 471 (defun do-bintree-print (root level)
 472   "Print the binary tre starting with the root node ROOT at level LEVEL."
 473   (if (null root)
 474       (princ "empty tree")
 475     (if (elib-node-left root)
 476         (do-bintree-print (elib-node-left root) (1+ level)))
 477     (let ((lvl level))
 478       (while (> lvl 0)
 479         (princ "   ")
 480         (setq lvl (1- lvl))))
 481     (princ (elib-node-data root))
 482     (princ "\n")
 483     (if (elib-node-right root)
 484         (do-bintree-print (elib-node-right root) (1+ level)))))
 485
 486
 487 (defun bintree-enter-list (tree list)
 488   "Enter into TREE all elements of LIST."
 489   (mapcar (function (lambda (x) (elib-bintree-enter tree x)))
 490           list))
 491
 492
 493 ;;; ================================================================
 494 ;;;            Functions for testing an AVL tree.
 495 ;;;            (not yet working)
 496
 497
 498 (require 'avltree)
 499
 500
 501 (defun avltree-print (tree)
 502   "Print the binary tree TREE on stdout."
 503   (princ "\n")
 504   (do-avltree-print (elib-avl-root tree) 0)
 505   nil)
 506
 507
 508 (defun do-avltree-print (root level)
 509   "Print the binary tre starting with the root node ROOT at level LEVEL."
 510   (if (null root)
 511       (princ "empty tree")
 512     (if (elib-node-left root)
 513         (do-avltree-print (elib-node-left root) (1+ level)))
 514     (let ((lvl level))
 515       (while (> lvl 0)
 516         (princ "   ")
 517         (setq lvl (1- lvl))))
 518     (princ (elib-node-data root))
 519     (princ " ")
 520     (princ (elib-avl-node-balance root))
 521     (princ "\n")
 522     (if (elib-node-right root)
 523         (do-avltree-print (elib-node-right root) (1+ level)))))
 524
 525
 526 (defun avltree-enter-list (tree list)
 527   "Enter into TREE all elements of LIST."
 528   (mapcar (function (lambda (x) (elib-avltree-enter tree x)))
 529           list))
 530
 531
 532 ;;; ================================================================
 533 ;;;                      Test the entire Elib.
 534
 535
 536 ;; Note that some tests are commented away.  That is because they
 537 ;; are not yet written.
 538
 539
 540 (setq elib-packages
 541       '("stack-f"
 542         "stack-m"
 543         "queue-f"
 544         "queue-m"
 545         "dll-debug"
 546         ;; Check cookie immediately after dll-debug, so that we can
 547         ;; see the output.
 548         "cookie"
 549         "dll"
 550         ;; Check cookie again, in case dll-debug behaves differently.
 551         "cookie"
 552 ;;;     "elib-node"
 553 ;;;     "bintree"
 554 ;;;     "avltree"
 555         "string"
 556 ;;;     "read"
 557         ))
 558
 559
 560 (defun elib-test-all ()
 561   "Test all packages within ELIB for errors."
 562   (interactive)
 563   (let ((load-path '(".")))
 564     (with-output-to-temp-buffer "*Elib-test*"
 565       (mapcar (function
 566                (lambda (package-name)
 567                  (load-library package-name)
 568                  (princ (format "%s:\n" package-name))
 569                  (test-package (eval (intern (concat package-name
 570                                                      "-tests"))))))
 571               elib-packages))))
 572
 573 ;;; elib-test.el ends here