src/facade.lisp

   1 ;; -*- mode: lisp; syntax: common-lisp; coding: utf-8-unix; package: cl-mock; -*-
   2
   3 (in-package #:cl-mock)
   4 \f
   5 ;;; syntactic sugar for defining the mock interactions
   6
   7 (defun make-lambda-pattern (literal-pattern)
   8   (let (lambda-pattern values)
   9     (loop
  10       for (car . cdr) = literal-pattern
  11       while car
  12       do (let ((sym (gensym)))
  13            (setf lambda-pattern (append lambda-pattern (list sym)))
  14            (push `(,sym . ,(if (or (symbolp car) (listp car)) `(quote ,car) car)) values)
  15            (pop literal-pattern)))
  16     (values lambda-pattern values)))
  17
  18 (defun make-test-pattern (values)
  19   `(and ,.(mapcar (lambda (value)
  20                     `(equal ,(car value) ,(cdr value)))
  21                   values)))
  22
  23 (defmacro when-called (mock-bindings call &body forms)
  24   (let ((name (if (listp call) (car call) call))
  25         (sym (gensym)))
  26     `(if-called
  27       ,mock-bindings
  28       ',name
  29       ,(if (listp call)
  30            (multiple-value-bind (lambda-pattern values)
  31                (make-lambda-pattern (cdr call))
  32              `(lambda (&rest args)
  33                 (destructuring-bind ,lambda-pattern args
  34                   ,(make-test-pattern values))))
  35            '(constantly T))
  36       (let ((,sym (fdefinition ',name)))
  37         (declare (ignorable ,sym))
  38         ,(if (cdr forms)
  39              `(let ((times 0))
  40                 (lambda (&rest args)
  41                   (declare (ignorable args))
  42                   (case (prog1 times (incf times))
  43                     ,.(loop
  44                         for i from 0
  45                         for (form . rest) on forms
  46                         collect `(,(if rest i T) ,form)))))
  47              `(lambda (&rest args)
  48                 (declare (ignorable args))
  49                 ,@forms))))))
  50
  51 (defun invocation-count (name invocations)
  52   (count name invocations :key #'car :test #'eq))
  53
  54 (defun was-called-p (name invocations)
  55   (member name invocations :key #'car :test #'eq))