Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

version 0.0.8; use flet-overrides; changes the contract of mock-process

  • Loading branch information...
commit 8e876efe020fd038b6bc4b824192d1c90deb57a0 1 parent 330b517
nferrier authored

Showing 1 changed file with 174 additions and 68 deletions. Show diff stats Hide diff stats

  1. +174 68 fakir.el
242 fakir.el
@@ -4,7 +4,7 @@
4 4 ;; Author: Nic Ferrier <nferrier@ferrier.me.uk>
5 5 ;; Maintainer: Nic Ferrier <nferrier@ferrier.me.uk>
6 6 ;; Created: 17th March 2012
7   -;; Version: 0.0.7
  7 +;; Version: 0.0.8
8 8 ;; Keywords: lisp, tools
9 9
10 10 ;; This file is NOT part of GNU Emacs.
@@ -46,6 +46,98 @@
46 46 (require 'ert)
47 47 (eval-when-compile (require 'cl))
48 48
  49 +
  50 +;; A little support code - not sure I can be bothered to package this
  51 +;; seperately
  52 +
  53 +(defmacro* flet-overrides (predicate
  54 + bindings
  55 + &rest form)
  56 + "Override functions only when an argument tests true.
  57 +
  58 +PREDICATE is some test to be applied to a specified argument
  59 +of each bound FUNC to decide whether to execute the overridden
  60 +code or the existing code.
  61 +
  62 +For each function, TEST-ARG specifies the name of the argument in
  63 +the ARGLIST which will be passed to the PREDICATE.
  64 +
  65 +BODY defines the code to be run for the specified FUNC when the
  66 +PREDICATE is `t' for the TEST-ARG.
  67 +
  68 +This is really useful when you want to mock a set of functions
  69 +that operate on a particular type, processes for example:
  70 +
  71 + (flet-overrides fake-process-p
  72 + ((process-buffer process (process)
  73 + (get-buffer-create \"\"))
  74 + (process-status process (process)
  75 + \"run\")
  76 + (delete-process process (process)
  77 + t)
  78 + (set-process-buffer process (process buffer)
  79 + nil))
  80 + ;; Code under test
  81 + ...)
  82 +
  83 +\(fn PREDICATE ((FUNC TEST-ARG ARGLIST BODY...) ...) FORM...)"
  84 + (declare (indent defun))
  85 + (let*
  86 + ((flets
  87 + (loop
  88 + for i in bindings
  89 + collect
  90 + (destructuring-bind (name test-arg args &rest body) i
  91 + (let ((saved-func-namev (make-symbol "saved-func-name")))
  92 + (let ((saved-func-namev
  93 + (intern (format "saved-func-%s"
  94 + (symbol-name name)))))
  95 + `(,name ,args
  96 + (if (not (,predicate ,test-arg))
  97 + (funcall ,saved-func-namev ,@args)
  98 + ,@body)))))))
  99 + (lets
  100 + (loop
  101 + for i in bindings
  102 + collect
  103 + (destructuring-bind (name test-arg args &rest body) i
  104 + (let ((saved-func-namev (make-symbol "saved-func-name")))
  105 + (let ((saved-func-namev
  106 + (intern (format "saved-func-%s"
  107 + (symbol-name name)))))
  108 + `(,saved-func-namev
  109 + (symbol-function (quote ,name)))))))))
  110 + `(let ,lets
  111 + (flet ,flets
  112 + ,@form))))
  113 +
  114 +(ert-deftest flet-overrides ()
  115 + "Test the flet-override stuff."
  116 + (flet ((my-test (x)
  117 + (and
  118 + (listp x)
  119 + (let ((v (car x)))
  120 + (eq :object v))))
  121 + (my-func (x y)
  122 + (format "strings: %s %s" x y))
  123 + (my-proc (z)
  124 + (* 2 x)))
  125 + (flet-overrides
  126 + my-test ; the type predicate we'll use
  127 + ((my-func a (a b)
  128 + (+ (cadr a) b))
  129 + (my-proc y (x y)
  130 + (+ 10 y)))
  131 + (should
  132 + (equal
  133 + '("strings: nic caroline" 7)
  134 + (list
  135 + ;; This call doesn't match the predicate
  136 + (my-func "nic" "caroline")
  137 + ;; This call does match the predicate
  138 + (my-func '(:object 5) 2)))))))
  139 +
  140 +
49 141 ;; Mocking processes
50 142
51 143 (defvar fakir-mock-process-require-specified-buffer nil
@@ -85,20 +177,50 @@ The ALIST looks like a let-list."
85 177 (should (equal nil (gethash 'fakir-single-value h)))
86 178 (should (equal nil (gethash ':self-evaling-symbol-as-well h)))))
87 179
88   -(defmacro fakir-mock-process (process-bindings &rest body)
  180 +(defun fakir--get-or-create-buf (pvbuf pvvar &optional specified-buf)
  181 + "Special get or create to support the process mocking.
  182 +
  183 +PVBUF is a, possibly existing, buffer reference. If nil then we
  184 +create the buffer.
  185 +
  186 +PVVAR is a hashtable of properties, possibly containing the
  187 +`:buffer' property which specifies a string to be used as the
  188 +content of the buffer.
  189 +
  190 +SPECIFIED-BUF is an optional buffer to use instead of a dummy
  191 +created one."
  192 + (if (bufferp pvbuf)
  193 + pvbuf
  194 + (setq pvbuf
  195 + (if fakir-mock-process-require-specified-buffer
  196 + (if (bufferp specified-buf)
  197 + specified-buf
  198 + nil)
  199 + (or specified-buf
  200 + (get-buffer-create
  201 + (generate-new-buffer-name
  202 + "* fakir mock proc buf *")))))
  203 + ;; If we've got a buffer value then insert it.
  204 + (when (gethash :buffer pvvar)
  205 + (with-current-buffer pvbuf
  206 + (insert (gethash :buffer pvvar))))
  207 + pvbuf))
  208 +
  209 +
  210 +(defmacro fakir-mock-process (process-symbol process-bindings &rest body)
89 211 "Allow easier testing by mocking the process functions.
90 212
91 213 For example:
92 214
93   - (fakir-mock-process (:elnode-http-params
94   - (:elnode-http-method \"GET\")
95   - (:elnode-http-query \"a=10\"))
96   - (should (equal 10 (elnode-http-param 't \"a\")))
97   - )
  215 + (fakir-mock-process :fake
  216 + (:elnode-http-params
  217 + (:elnode-http-method \"GET\")
  218 + (:elnode-http-query \"a=10\"))
  219 + (should (equal 10 (elnode-http-param :fake \"a\"))))
98 220
99 221 Causes:
100 222
101   - (process-get anything :elnode-http-method)
  223 + (process-get :fake :elnode-http-method)
102 224
103 225 to always return \"GET\".
104 226
@@ -109,9 +231,11 @@ key `:buffer' if present and a dummy buffer otherwise.
109 231
110 232 We return what the BODY returned."
111 233 (declare
112   - (debug (sexp &rest form))
  234 + (debug (sexp sexp &rest form))
113 235 (indent defun))
114   - (let ((pvvar (make-symbol "pv"))
  236 + (let ((predfunc (make-symbol "predfunc"))
  237 + (get-or-create-buf-func (make-symbol "getorcreatebuffunc"))
  238 + (pvvar (make-symbol "pv"))
115 239 (pvbuf (make-symbol "buf"))
116 240 (result (make-symbol "result")))
117 241 `(let
@@ -127,59 +251,40 @@ We return what the BODY returned."
127 251 ;; Dummy buffer variable for the process - we fill this in
128 252 ;; dynamically in 'process-buffer
129 253 ,pvbuf)
130   - ;; Rebind the process function interface
131   - (flet ((process-get (proc key)
132   - (gethash key ,pvvar))
133   - (process-put (proc key value)
134   - (puthash key value ,pvvar))
135   - ;; We really need to define a proper fake process
136   - (processp (proc)
137   - t)
138   - (get-or-create-pvbuf
139   - (proc &optional specified-buf)
140   - (if (bufferp ,pvbuf)
141   - ,pvbuf
142   - (setq ,pvbuf
143   - (if fakir-mock-process-require-specified-buffer
144   - (if (bufferp specified-buf)
145   - specified-buf
146   - nil)
147   - (or specified-buf
148   - (get-buffer-create
149   - (generate-new-buffer-name
150   - "* fakir mock proc buf *")))))
151   - ;; If we've got a buffer value then insert it.
152   - (when (gethash :buffer ,pvvar)
153   - (with-current-buffer ,pvbuf
154   - (insert (gethash :buffer ,pvvar))))
155   - ,pvbuf))
156   - (process-send-string
157   - (proc str)
158   - (with-current-buffer (get-or-create-pvbuf proc)
159   - (save-excursion
160   - (goto-char (point-max))
161   - (insert str))))
162   - (process-send-eof
163   - (proc)
164   - t)
165   - (process-contact
166   - (proc &optional arg)
167   - (list "localhost" 8000))
168   - (process-status
169   - (proc)
170   - 'fake)
171   - (process-buffer
172   - (proc)
173   - (get-or-create-pvbuf proc))
174   - (set-process-buffer
175   - (proc buffer)
176   - (get-or-create-pvbuf proc buffer)))
177   - (setq ,result (progn ,@body)))
  254 + (flet ((,predfunc (object) (eq object ,process-symbol))
  255 + (,get-or-create-buf-func
  256 + (proc &optional specified-buf)
  257 + (setq ,pvbuf (fakir--get-or-create-buf
  258 + ,pvbuf
  259 + ,pvvar
  260 + specified-buf))))
  261 + ;; Rebind the process function interface
  262 + (flet-overrides ,predfunc
  263 + ((process-get proc (proc key) (gethash key ,pvvar))
  264 + (process-put proc (proc key value) (puthash key value ,pvvar))
  265 + (processp proc (proc) t)
  266 + (process-send-string
  267 + proc (proc str)
  268 + (with-current-buffer (,get-or-create-buf-func proc)
  269 + (save-excursion
  270 + (goto-char (point-max))
  271 + (insert str))))
  272 + (process-send-eof proc (proc) t)
  273 + (process-contact
  274 + proc (proc &optional arg)
  275 + (list "localhost" 8000))
  276 + (process-status proc (proc) 'fake)
  277 + (process-buffer proc (proc) (,get-or-create-buf-func proc))
  278 + (delete-process proc (proc) t)
  279 + (set-process-buffer
  280 + proc (proc buffer)
  281 + (,get-or-create-buf-func proc buffer)))
  282 + (setq ,result (progn ,@body))))
178 283 ;; Now clean up
179 284 (when (bufferp ,pvbuf)
180   - (with-current-buffer ,pvbuf
181   - (set-buffer-modified-p nil)
182   - (kill-buffer ,pvbuf)))
  285 + (with-current-buffer ,pvbuf
  286 + (set-buffer-modified-p nil)
  287 + (kill-buffer ,pvbuf)))
183 288 ;; Now return whatever the body returned
184 289 ,result)))
185 290
@@ -187,13 +292,14 @@ We return what the BODY returned."
187 292 "A very quick function to test mocking process macro."
188 293 (let ((somevalue 30))
189 294 (fakir-mock-process
190   - ((a 20)
191   - (:somevar 15)
192   - (:othervar somevalue))
193   - (let ((z 10))
194   - (let ((a "my string!!!"))
195   - (setq a (process-get t :somevar))
196   - (list a (process-get t :othervar)))))))
  295 + :fakeproc
  296 + ((a 20)
  297 + (:somevar 15)
  298 + (:othervar somevalue))
  299 + (let ((z 10))
  300 + (let ((a "my string!!!"))
  301 + (setq a (process-get :fakeproc :somevar))
  302 + (list a (process-get :fakeproc :othervar)))))))
197 303
198 304 (ert-deftest fakir-mock-process ()
199 305 "Test mock process."

0 comments on commit 8e876ef

Please sign in to comment.
Something went wrong with that request. Please try again.