asynq/rtest.el

   1 ;;;_ tinydb/rtest.el --- Rtest tests for persist
   2
   3 ;;;_. Headers
   4 ;;;_ , License
   5 ;; Copyright (C) 2010  Tom Breton (Tehom)
   6
   7 ;; Author: Tom Breton (Tehom) <tehom@panix.com>
   8 ;; Keywords: lisp, maint, internal
   9
  10 ;; This file is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; This file is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to
  22 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;;_ , Commentary:
  26
  27 ;;
  28
  29
  30 ;;;_ , Requires
  31 (require 'tinydb/asynq)
  32 ;;;_. Body
  33 ;;;_  . Test helpers
  34 (defun persist:th:make-usual-tq (initial)
  35    ""
  36    (tinydb-make-q
  37       ;;Create.
  38       #'identity
  39       ;;Get
  40       #'identity
  41       ;;Put
  42       #'(lambda (old-obj obj)
  43            obj)
  44       ;;Type predicate that always passes
  45       #'list
  46       ;;Initial value
  47       initial
  48       ))
  49 ;;;_   , tinydb-alist-push
  50 (rtest:deftest tinydb-alist-push
  51    (  "Operation: Push an element"
  52       (with-timeout (1.5)
  53          (let
  54             ((list '())
  55                (tq
  56                   (persist:th:make-usual-tq '((b 144)))))
  57
  58             (tinydb-alist-push tq 'a '(12))
  59             (tinydb-q-do-pending tq)
  60             (assert
  61                (rtest:sets=
  62                   (tinydb-q->obj tq)
  63                   '((a 12) (b 144)))
  64                t)
  65
  66             t))))
  67
  68 ;;;_   , tinydb-alist-assoc
  69 (rtest:deftest tinydb-alist-assoc
  70    (  "Proves: Can read from it via `tinydb-alist-assoc'."
  71       (with-timeout (1.5)
  72          (let*
  73             ((list '((a 12)(b 144)))
  74                (tq
  75                   (persist:th:make-usual-tq list))
  76                (result
  77                   (tinydb-alist-assoc tq 'a)))
  78
  79             (assert
  80                (equal
  81                   (tinydb-q->obj tq)
  82                   list)
  83                t)
  84             (assert
  85                (equal
  86                   result
  87                   '(a 12))
  88                t)
  89
  90             t))))
  91 ;;;_   , tinydb-alist--remove
  92 (rtest:deftest tinydb-alist--remove
  93
  94    (  "Gives the expected results"
  95       (progn
  96          (assert
  97             (equal
  98                (tinydb-alist--remove (list '(1 a)'(2 b)) 1)
  99                '((2 b)))
 100             t)
 101          (assert
 102             (equal
 103                (tinydb-alist--remove (list '(1 a)'(2 b)) 2)
 104                '((1 a)))
 105             t)
 106          t)))
 107
 108 ;;;_   , tinydb-alist-update
 109
 110 (rtest:deftest tinydb-alist-update
 111    (  "Proves: It updates an element."
 112       (with-timeout (1.5)
 113          (let*
 114             (  (list (list (list 'a 12)(list 'b 144)))
 115                (tq
 116                   (persist:th:make-usual-tq list)))
 117             (tinydb-alist-update tq 'a
 118                #'(lambda (old old-p key)
 119                     (assert (equal old '(12)) t)
 120                     (assert (equal key 'a) t)
 121                     '(1728)))
 122             (tinydb-q-do-pending tq)
 123             (assert
 124                (rtest:sets=
 125                   (tinydb-q->obj tq)
 126                   '((a 1728)(b 144)))
 127                t)
 128
 129             (assert
 130                (equal
 131                   (tinydb-alist-assoc tq 'a)
 132                   '(a 1728))
 133                t)
 134             t))))
 135
 136 ;;;_   , tinydb-alist-pushnew
 137 (rtest:deftest tinydb-alist-pushnew
 138
 139    (  "Situation: Element is not already there.
 140 Response: Add it."
 141       (with-timeout (1.5)
 142          (let*
 143             (  (list (list (list 'a 12)(list 'b 144)))
 144                (tq
 145                   (persist:th:make-usual-tq list)))
 146             (tinydb-alist-pushnew tq 'c '(1728))
 147             (tinydb-q-do-pending tq)
 148             (assert
 149                (rtest:sets=
 150                   (tinydb-q->obj tq)
 151                   '((a 12)(b 144)(c 1728)))
 152                t)
 153
 154             (assert
 155                (equal
 156                   (tinydb-alist-assoc tq 'c)
 157                   '(c 1728))
 158                t)
 159             t)))
 160
 161    (  "Situation: Element is already there.
 162 Response: No change."
 163       (with-timeout (1.5)
 164          (let*
 165             (  (list (list (list 'a 12)(list 'b 144)))
 166                (tq
 167                   (persist:th:make-usual-tq list)))
 168             (tinydb-alist-pushnew tq 'a '(13))
 169             (tinydb-q-do-pending tq)
 170
 171             (assert
 172                (rtest:sets=
 173                   (tinydb-q->obj tq)
 174                   '((a 12)(b 144)))
 175                t)
 176
 177             (assert
 178                (equal
 179                   (tinydb-alist-assoc tq 'a)
 180                   '(a 12))
 181                t)
 182             t))))
 183 ;;;_   , tinydb-alist-push-replace
 184 (rtest:deftest tinydb-alist-push-replace
 185
 186    (  "Situation: Element is not already there.
 187 Response: Add it."
 188       (with-timeout (1.5)
 189          (let*
 190             (  (list (list (list 'a 12)(list 'b 144)))
 191                (tq
 192                   (persist:th:make-usual-tq list)))
 193             (tinydb-alist-push-replace tq 'c '(1728))
 194             (tinydb-q-do-pending tq)
 195             (assert
 196                (rtest:sets=
 197                   (tinydb-q->obj tq)
 198                   '((a 12)(b 144)(c 1728)))
 199                t)
 200
 201             (assert
 202                (equal
 203                   (tinydb-alist-assoc tq 'c)
 204                   '(c 1728))
 205                t)
 206             t)))
 207
 208    (  "Situation: Element is already there.
 209 Response: It replaces the old element."
 210       (with-timeout (1.5)
 211          (let*
 212             (  (list (list (list 'a 12)(list 'b 144)))
 213                (tq
 214                   (persist:th:make-usual-tq list)))
 215             (tinydb-alist-push-replace tq 'a '(1728))
 216             (tinydb-q-do-pending tq)
 217
 218             (assert
 219                (rtest:sets=
 220                   (tinydb-q->obj tq)
 221                   '((a 1728)(b 144)))
 222                t)
 223
 224             (assert
 225                (equal
 226                   (tinydb-alist-assoc tq 'a)
 227                   '(a 1728))
 228                t)
 229             t))))
 230
 231 ;;;_  . Reentrancy tests
 232
 233 ;;These tests are theoretically sensitive to processor speed, but the
 234 ;;specified durations are extremely generous so there shouldn't be a
 235 ;;problem.
 236 (rtest:deftest tinydb/reentrancy
 237
 238    (  "Proves: Timer events can run during sleep-for."
 239       (let
 240          ((recorded '()))
 241          (run-with-timer 0.1 nil
 242             #'(lambda ()
 243                  (push (list 'timed (current-time)) recorded)))
 244          (sleep-for 1.0)
 245          (push (list 'delayed (current-time)) recorded)
 246          (assert
 247             (assq 'timed recorded)
 248             t)
 249          (assert
 250             (assq 'delayed recorded)
 251             t)
 252          (let*
 253             (  (timed-ran-at   (second (assq 'timed   recorded)))
 254                (delayed-ran-at (second (assq 'delayed recorded)))
 255                (time-diff (time-subtract delayed-ran-at timed-ran-at)))
 256
 257             (assert
 258                (time-less-p time-diff (seconds-to-time 0.99))
 259                t)
 260             (assert
 261                (time-less-p (seconds-to-time 0.80) time-diff)
 262                t)
 263             t)))
 264
 265    (  "Proves: Validates the testing mechanism with sit-for vs a
 266       single timer."
 267       (with-timeout (1.5)
 268          (let
 269             ((list '()))
 270
 271             (run-with-timer 0.2 nil
 272                #'(lambda ()
 273                     (push "Start 2" list)
 274                     (sit-for 0.2)
 275                     (push "End 2" list)))
 276
 277             (push "Start test" list)
 278             (sit-for 0.2)
 279             (push "End test" list)
 280             (assert
 281                (equal
 282                   (reverse list)
 283                   '("Start test" "Start 2" "End 2" "End test"))
 284                t)
 285             t)))
 286
 287    (  "Proves: Validates the testing mechanism with multiple run-with-timers.
 288       (which somehow nests their sit-for calls)"
 289       (with-timeout (1.5)
 290          (let
 291             ((list '()))
 292             (run-with-timer 0.1 nil
 293                #'(lambda ()
 294                     (push "Start 1" list)
 295                     (sit-for 0.1)
 296                     (sit-for 0.1)
 297                     (push "End 1" list)))
 298             (run-with-timer 0.2 nil
 299                #'(lambda ()
 300                     (push "Start 2" list)
 301                     (sit-for 0.1)
 302                     (sit-for 0.1)
 303                     (push "End 2" list)))
 304
 305             (push "Start test" list)
 306             (sit-for 0.6)
 307             (push "End test" list)
 308             (assert
 309                (equal
 310                   (reverse list)
 311                   '("Start test" "Start 1" "Start 2"
 312                       "End 2" "End 1" "End test"))
 313                t)
 314             t)))
 315
 316
 317    (  "Proves: Can see the internal object (at all)."
 318       (with-timeout (1.5)
 319          (let*
 320             ((list '())
 321                (tq
 322                   (persist:th:make-usual-tq '(12)))
 323                (result nil))
 324
 325             (tinydb-q-will-call
 326                tq t
 327                #'(lambda (obj)
 328                     (setq result obj)))
 329             (assert
 330                (equal
 331                   (tinydb-q->obj tq)
 332                   '(12))
 333                t)
 334             (assert
 335                (equal
 336                   result
 337                   '(12))
 338                t)
 339             t)))
 340
 341    (  "Proves: Calling `tinydb-q-will-call' recursively in handler
 342       gives an error.
 343 FIX ME:  This logic has changed.  Now it's only reads that require
 344 errors to be raised.
 345 "
 346       (with-timeout (1.5)
 347          (let
 348             ((list '())
 349                (tq
 350                   (persist:th:make-usual-tq '(12))))
 351
 352             (push "Start test" list)
 353             (tinydb-q-will-call
 354                tq nil
 355                #'(lambda (obj)
 356                     (assert
 357                        (emth:gives-error
 358                           (tinydb-q-will-call tq t #'identity))
 359                        t)))
 360
 361             (push "End test" list)
 362             (assert
 363                (equal
 364                   (reverse list)
 365                   '("Start test" "End test"))
 366                t)
 367             (assert
 368                (equal
 369                   (tinydb-q->obj tq)
 370                   '(12))
 371                t)
 372             t)))
 373
 374    '  ;;No longer guaranteed
 375    (  "Proves: Can write asynchronously to it."
 376       (with-timeout (1.5)
 377          (let
 378             ((list '())
 379                (tq
 380                   (persist:th:make-usual-tq '(12))))
 381             (push "Start test" list)
 382             (run-with-timer 0.1 nil
 383                #'(lambda (arg)
 384                     (push "Start 1" list)
 385                     (tinydb-q-will-call
 386                        tq nil
 387                        #'(lambda (obj x)
 388                             (sleep-for 0.2)
 389                             (push "End 1" list)
 390                             (throw 'tinydb-q-new-obj
 391                                (cons x obj)))
 392                        arg))
 393                144)
 394
 395             (run-with-timer 0.2 nil
 396                #'(lambda (arg)
 397                     (push "Start 2" list)
 398                     (tinydb-q-will-call
 399                        tq nil
 400                        #'(lambda (obj x)
 401                             (sleep-for 0.2)
 402                             (throw 'tinydb-q-new-obj
 403                                (cons x obj)))
 404                        arg))
 405                 1728)
 406
 407             (sit-for 0.6)
 408             (tinydb-q-do-pending tq)
 409             (push "End test" list)
 410             (assert
 411                (equal
 412                   (reverse list)
 413                   '("Start test" "Start 1" "Start 2"
 414                       "End 1" "End test"))
 415                t)
 416             (assert
 417                (rtest:sets=
 418                   (tinydb-q->obj tq)
 419                   '(1728 144 12))
 420                t)
 421             t)))
 422
 423
 424    )
 425
 426
 427 ;;;_. Footers
 428 ;;;_ , Provides
 429
 430 (provide 'tinydb/rtest)
 431
 432 ;;;_ * Local emacs vars.
 433 ;;;_  + Local variables:
 434 ;;;_  + mode: allout
 435 ;;;_  + End:
 436
 437 ;;;_ , End
 438 ;;; tinydb/rtest.el ends here