emacs.d/elpa/fakir-20140729.1652/fakir.el

;;; fakir.el --- fakeing bits of Emacs -*- lexical-binding: t -*-
;; Copyright (C) 2012  Nic Ferrier

;; Author: Nic Ferrier <nferrier@ferrier.me.uk>
;; Maintainer: Nic Ferrier <nferrier@ferrier.me.uk>
;; URL: http://github.com/nicferrier/emacs-fakir
;; Package-Version: 20140729.1652
;; Created: 17th March 2012
;; Version: 0.1.9
;; Keywords: lisp, tools
;; Package-Requires: ((noflet "0.0.8")(dash "1.3.2")(kv "0.0.19"))

;; This file is NOT part of GNU Emacs.

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

;;; Source code
;;
;; fakir's code can be found here:
;;   http://github.com/nicferrier/fakir

;;; Style note
;;
;; This codes uses the Emacs style of:
;;
;;    fakir--private-function
;;
;; for private functions and macros.

;;; Commentary:
;;
;; This is a collection of tools to make testing Emacs core functions
;; easier.

;;; Code:

(require 'ert)
(require 'dash)
(require 'noflet)
(require 'kv)
(eval-when-compile (require 'cl))


(defun fakir-make-unix-socket (&optional name)
  "Make a unix socket server process optionally based on NAME.

Returns a list of the processes socket file and the process object."
  (let* ((socket-file
          (concat "/tmp/" (apply 'make-temp-name
                                 (list (or name "fakir-make-unix-socket")))))
         (myproc (make-network-process
                  :name socket-file
                  :family 'local :server t
                  :service socket-file)))
    (list socket-file myproc)))

(defmacro* fakir-with-unix-socket ((socket-sym &optional socket-name) &rest body)
  "Execute BODY with a Unix socket server bound to SOCKET-SYM.

Optionally the socket is created with SOCKET-NAME which means
that the file used to back the socket is named after SOCKET-NAME.

The socket process is closed on completion and the associated
file is deleted."
  (declare (indent 1))
  (let ((spv (make-symbol "spv"))
        (sockfilev (make-symbol "sockfilev")))
    `(let* ((,spv (fakir-make-unix-socket ,socket-name))
            (,sockfilev (car ,spv))
            (,socket-sym (cadr ,spv)))
       (unwind-protect
            (progn
              ,@body)
         (delete-process ,socket-sym)
         (delete-file ,sockfilev)))))

(defmacro fakir-with-file-buffer (buffer-var &rest body)
  "Make a buffer visiting a file and assign it to BUFFER-VAR.

The file only exists for the scope of the macro.  Both the file
and the buffer visiting it are destroyed when the scope exits."
  (declare (indent 1))
  (let ((filev (make-symbol "filev")))
    `(let* ((,filev (make-temp-file  "filebuf"))
            (,buffer-var (find-file-noselect ,filev)))
       (unwind-protect
            (progn ,@body)
         (with-current-buffer ,buffer-var
           (set-buffer-modified-p nil))
         (kill-buffer ,buffer-var)
         (delete-file ,filev)))))

;; Mocking processes

(defvar fakir-mock-process-require-specified-buffer nil
  "Tell `fakir-mock-process' that you require a buffer to be set.

This is used, for example, to make `elnode--filter' testing work
properly. Normally, tests do not need to set the process-buffer
directly, they can just expect it to be there. `elnode--filter',
though, needs to set the process-buffer to work properly.")


(defun fakir/make-hash-table (alist) ; possible redundant now.
  "Make a hash table from the ALIST.

The ALIST looks like a let-list."
  (let ((bindings (make-hash-table :test 'equal)))
    (loop for f in (append
                    (list (list :fakir-mock-process t))
                    alist)
       do
         (cond
           ((and f (listp f))
            (puthash (car f) (cadr f) bindings))
           (t
            (puthash f nil bindings))))
    bindings))

(defun fakir/get-or-create-buf (pvbuf pv-alist &optional specified-buf)
  "Special get or create to support the process mocking.

PVBUF is a, possibly existing, buffer reference.  If nil then we
create the buffer.

PV-ALIST is an alist of properties, possibly containing the
`:buffer' property which specifies a string to be used as the
content of the buffer.

SPECIFIED-BUF is an optional buffer to use instead of a dummy
created one."
  (if (bufferp pvbuf)
      pvbuf
    (setq pvbuf
    (if fakir-mock-process-require-specified-buffer
        (if (bufferp specified-buf)
      specified-buf
    nil)
      (or specified-buf
    (get-buffer-create
     (generate-new-buffer-name
      "* fakir mock proc buf *")))))
    ;; If we've got a buffer value then insert it.
    (when (kva :buffer pv-alist)
      (with-current-buffer pvbuf
  (insert (kva :buffer pv-alist))))
    pvbuf))


(defmacro fakir-mock-proc-properties (process-obj &rest body)
  "Mock process property list functions.

Within BODY the functions `process-get', `process-put' and
`process-plist' and `set-process-plist' are all mocked to use a
hashtable if the process passed to them is `eq' to PROCESS-OBJ."
  (declare (indent 1)
           (debug (sexp &rest form)))
  (let ((proc-plist (make-symbol "procpropsv")))
    `(let (,proc-plist)
       (macrolet ((or-args (form &rest args)
                    `(if (eq proc ,,process-obj)
                         ,form
                         (apply this-fn ,@args))))
         (noflet ((process-get (proc name)
                    (or-args (plist-get ,proc-plist name) proc name))
                  (process-put (proc name value)
                    (or-args
                     (if ,proc-plist
                         (plist-put ,proc-plist name value)
                         (setq ,proc-plist (list name value)))
                     proc name value))
                  (process-plist (proc)
                    (or-args ,proc-plist proc))
                  (set-process-plist (proc props)
                    (or-args (setq ,proc-plist props) proc props)))
           ,@body)))))

(defun fakir/let-bindings->alist (bindings)
  "Turn let like BINDINGS into an alist.

Makes sure the resulting alist has `consed' pairs rather than
lists.

Generally useful macro helper should be elsewhere."
  (loop for p in bindings
     collect
       (if (and p (listp p))
           (list 'cons `(quote ,(car p)) (cadr p))
           (list 'cons `,p nil))))

(defmacro fakir-mock-process (process-symbol process-bindings &rest body)
  "Allow easier testing by mocking the process functions.

For example:

 (fakir-mock-process :fake
      (:elnode-http-params
       (:elnode-http-method \"GET\")
       (:elnode-http-query \"a=10\"))
   (should (equal 10 (elnode-http-param :fake \"a\"))))

Causes:

 (process-get :fake :elnode-http-method)

to always return \"GET\".

`process-put' is also remapped, to set any setting.

`process-buffer' is also remapped, to deliver the value of the
key `:buffer' if present and a dummy buffer otherwise.

`delete-process' is also remapped, to throw
`:mock-process-finished' to the catch called
`:mock-process-finished'.  You can implement your own catch to do
something with the `delete-process' event.

`process-send-string' is also remapped to send to a fake output
buffer.  The fake buffer can be returned with
`fakir-get-output-buffer'.

In normal circumstances, we return what the BODY returned."
  (declare
   (debug (sexp sexp &rest form))
   (indent defun))
  (let ((get-or-create-buf (make-symbol "get-or-create-buf"))
        (fakir-kill-buffer (make-symbol "fakir-kill-buffer"))
  (pvvar (make-symbol "pv"))
        (pvoutbuf (make-symbol "pvoutbuf"))
        (pvbuf (make-symbol "buf"))
        (result (make-symbol "result")))
    `(let ((,pvvar (list ,@(fakir/let-bindings->alist process-bindings)))
           ;; This is a buffer for the output
           (,pvoutbuf (get-buffer-create "*fakir-outbuf*"))
           ;; For assigning the result of the body
           ,result
           ;; Dummy buffer variable for the process - we fill this in
           ;; dynamically in 'process-buffer
           ,pvbuf)
       (fakir-mock-proc-properties ,process-symbol
         (flet ((fakir-get-output-buffer () ,pvoutbuf)
                (,get-or-create-buf (proc &optional specified-buf)
                  (setq ,pvbuf (fakir/get-or-create-buf
                                ,pvbuf
                                ,pvvar
                                specified-buf)))
                (,fakir-kill-buffer (buf)
                  (when (bufferp buf)
                    (with-current-buffer buf (set-buffer-modified-p nil))
                    (kill-buffer buf))))
           (unwind-protect
                (macrolet ((or-args (form &rest args)
                             `(if (eq proc ,,process-symbol)
                                  ,form
                                  (apply this-fn (list ,@args)))))
                  ;; Rebind the process function interface
                  (noflet
                      ((processp (proc) (or-args t proc))
                       (process-send-eof (proc) (or-args t proc))
                       (process-status (proc) (or-args 'fake proc))
                       (process-buffer (proc) (or-args (,get-or-create-buf proc) proc))
                       (process-contact (proc &optional arg) ; FIXME - elnode specific
                         (or-args (list "localhost" 8000) proc))
                       (process-send-string (proc str)
                         (or-args
                          (with-current-buffer ,pvoutbuf
                            (save-excursion
                              (goto-char (point-max))
                              (insert str)))
                          proc))
                       (delete-process (proc)
                         (or-args
                          (throw :mock-process-finished :mock-process-finished)
                          proc))
                       (set-process-buffer (proc buffer)
                         (or-args (,get-or-create-buf proc buffer) proc)))
                    (set-process-plist ,process-symbol (kvalist->plist ,pvvar))
                    (setq ,result
                          (catch :mock-process-finished
                            ,@body))))
             ;; Now clean up
             (,fakir-kill-buffer ,pvbuf)
             (,fakir-kill-buffer ,pvoutbuf)))))))


;; Time utils

(defun fakir-time-encode (time-str)
  "Encode the TIME-STR as an EmacsLisp time."
  ;; FIXME this should be part of Emacs probably; I've had to
  ;; implement this in Elnode as well
  (apply 'encode-time (parse-time-string time-str)))

;; A structure to represent a mock file

(defstruct fakir-file
  filename
  directory
  (content "")
  ;; obviously there should be all the state of the file here
  (mtime "Mon, Feb 27 2012 22:10:19 GMT")
  (directory-p nil))

(defun fakir-file (&rest args)
  "Make a fakir-file, a struct.

:FILENAME is the basename of the file

:DIRECTORY is the dirname of the file

:CONTENT is a string of content for the file

:MTIME is the modified time, with a default around the time fakir
was written.

:DIRECTORY-P specifies whether this file is a directory or a file."
  (apply 'make-fakir-file args))

(defun fakir--file-check (file)
  "Implements the type check for FILE is a `fakir--file'."
  (if (not (fakir-file-p file))
      (error "not an fakir--file")))

(defun fakir--file-fqn (file)
  "Return the fully qualified name of FILE, an `fakir--file'."
  (fakir--file-check file)
  (let* ((fqfn
          (concat
           (file-name-as-directory
            (fakir-file-directory file))
           (fakir-file-filename file))))
    fqfn))

(defun fakir--file-rename (src-file to-file-name)
  "Rename the `fakir-file' SRC-FILE."
  (fakir--file-check src-file)
  (let ((base-file-name (file-name-nondirectory to-file-name))
        (file-dir (file-name-directory to-file-name)))
    (setf (fakir-file-directory src-file) file-dir)
    (setf (fakir-file-filename src-file) base-file-name)))

(defun fakir--file-mod-time (file &optional raw)
  "Return the encoded mtime of FILE, an `fakir--file'.

If RAW is t then return the raw value, a string."
  (fakir--file-check file)
  (if raw
      (fakir-file-mtime file)
    (fakir-time-encode (fakir-file-mtime file))))

(defun fakir--file-attribs (file)
  "Return an answer as `file-attributes' for FILE.

Currently WE ONLY SUPPORT MODIFIED-TIME."
  (fakir--file-check file)
  (list (fakir-file-directory-p file)
        t t t t
        (fakir--file-mod-time file)))

(defun fakir--file-home (file)
  "Return the home part of FILE or nil.

The home part of FILE is the part that is the home directory of
the user. If it's not a user FILE then it won't have a home
part."
  (fakir--file-check file)
  (let* ((fqn (fakir--file-fqn file))
         (home-root
          (save-match-data
            (when
                (string-match
                 "^\\(/home/[A-Za-z][A-Za-z0-9-]+\\)\\(/.*\\)*"
                 fqn)
              (match-string 1 fqn)))))
    home-root))

(defun fakir--file-path (faked-file)
  "Make a path name from the FAKED-FILE."
  (concat
   (file-name-as-directory
    (fakir-file-directory faked-file))
   (fakir-file-filename faked-file)))

(defvar fakir--home-root "/home/fakir"
  "String to use as the home-root.")

(defun fakir--join (file-name &optional dir)
  "Join FILE-NAME to DIR or `fakir--home-root'."
  (concat
   (file-name-as-directory (or dir fakir--home-root))
   file-name))

(defun fakir--expand (file-name rooted-p)
  "Functional file-name expand."
  (let ((path
         (mapconcat
          'identity
          (let ((l
                 (-reduce
                  (lambda (a b)
                    (if (string= b "..")
                        (if (consp a)
                            (reverse (cdr (reverse a)))
                            (list a))
                        (if (consp a)
                            (append a (list b))
                            (list a b))))
                  (cdr (split-string file-name "/")))))
            (if (listp l) l (list l)))
          "/")))
    (if (and rooted-p (not (equal ?\/ (elt path 0))))
        (concat "/" path)
        path)))

(defun fakir--expand-file-name (file-name dir)
  "Implementation of ~ and .. handling for FILE-NAME."
  (let* ((fqfn
          (if (string-match "^\\(~/\\|/\\).*" file-name)
              file-name
              ;; Else it's both
              (fakir--join file-name dir)))
         (file-path
          ;; Replace ~/ with the home-root
          (replace-regexp-in-string
           "^~/\\(.*\\)"
           (lambda (m) (fakir--join (match-string 1 m)))
           fqfn))
         (new-path
          (fakir--expand
           file-path
           (equal ?\/ (elt file-path 0)))))
    new-path))

(defun fakir--find-file (fakir-file)
  "`find-file' implementation for FAKIR-FILE."
  (let ((buf (get-buffer (fakir-file-filename fakir-file))))
    (if (bufferp buf)
        buf
        ;; Else make one and put the content in it
        (with-current-buffer
            (get-buffer-create (fakir-file-filename fakir-file))
          (insert (fakir-file-content fakir-file))
          (current-buffer)))))

(defun fakir-file-path (fakir-file)
  "Make the path for FAKIR-FILE."
  (concat (fakir-file-directory fakir-file)
          (fakir-file-filename fakir-file)))


(defun fakir--file-parent-directories (faked-file)
  "Return the parent directories for a FAKED-FILE."
  (let ((directory-path (fakir-file-directory faked-file))
        (path "")
        (path-list '("/")))
    (dolist (path-part (split-string directory-path "/" t))
      (let ((current-path (concat path "/" path-part)))
        (push current-path path-list)
        (setq path current-path)))
    path-list))

(defun fakir--namespace-put (faked-file namespace)
  "Put given FAKED-FILE and its parent folders into the given NAMESPACE."
  (puthash (fakir--file-path faked-file) faked-file namespace)
  (dolist (parent-dir (fakir--file-parent-directories faked-file))
    (puthash
     parent-dir
     (fakir-file
      :filename (file-name-nondirectory parent-dir)
      :directory (file-name-directory parent-dir)
      :content ""
      :directory-p t)
     namespace)))

(defun fakir--namespace (faked-file &rest other-files)
  "Make a namespace with FAKED-FILE in it.

Also adds the directory for the FAKED-FILE.

If OTHER-FILES are specified they are added to."
  (let ((ns (make-hash-table :test 'equal)))
    (fakir--namespace-put faked-file ns)
    (dolist (other-file other-files)
      (fakir--namespace-put other-file ns))
    ns))

(defun fakir--namespace-lookup (file-name namespace)
  "Lookup FILE-NAME in NAMESPACE.

Looks up the FILE-NAME"
  (kvhash->alist namespace)
  (or
   (gethash file-name namespace)
   (gethash
    (file-name-as-directory file-name)
    namespace)))

(defvar fakir-file-namespace nil
  "Namespace used by `fakir--file-cond'.")

(defmacro fakir--file-cond (file-name then &rest else)
  "Do THEN or ELSE if FILE-NAME is a faked file.

Uses the `fakir-file-namepsace' to detect that.

The `fakir-file' for the FILE-NAME is locally bound in the THEN
clause to `this-fakir-file'."
  (declare (indent 1))
  (let ((file-name-v (make-symbol "file-namev"))
        (found-file (make-symbol "ff")))
    `(let* ((,file-name-v ,file-name)
            (,found-file
             (fakir--namespace-lookup
              ,file-name-v fakir-file-namespace)))
       (if (fakir-file-p ,found-file)
           (let ((this-fakir-file ,found-file))
             ,then)
           ,@else))))

(defun fakir--write-region (fakir-file start end file-name
                            &optional append visit lockname mustbenew)
  "Fake `write-region' function to write to FAKIR-FILE.

`fakir-fake-file' does not call this unless the FILE-NAME exists
as a declared fake-file.  Thus you cannot use this to save files
you have not explicitly declared as fake."
  (let ((to-write
         (cond
           ((equal start nil) (buffer-string))
           ((stringp start) start)
           (t (buffer-substring start end)))))
    (setf
     (fakir-file-content fakir-file)
     (if append
         (concat (fakir-file-content fakir-file) to-write)
         to-write))))

(defun fakir--parent-fakir-file (file)
  "Return the parent fakir-file for FILE from the current namespace."
  (fakir--file-check file)
  (let ((parent-file-name (directory-file-name
                           (fakir-file-directory file))))
    (fakir--namespace-lookup parent-file-name fakir-file-namespace)))

(defun fakir--directory-fakir-files (directory)
  "Return all fakir-files that are inside the given DIRECTORY."
  (let ((directory (file-name-as-directory directory))
        directory-fakir-files)

    (loop for fakir-file being the hash-value of fakir-file-namespace
          if (equal (file-name-as-directory
                     (fakir-file-directory fakir-file))
                    directory)
          collect fakir-file)))

(defun fakir--directory-files-and-attributes (directory &optional full match nosort id-format)
  "Return a list of faked files and their faked attributes in DIRECTORY.

There are four optional arguments:
If FULL is non-nil, return absolute file names.  Otherwise return names
 that are relative to the specified directory.
If MATCH is non-nil, mention only file names that match the regexp MATCH.
If NOSORT is non-nil, the list is not sorted--its order is unpredictable.
 NOSORT is useful if you plan to sort the result yourself.
ID-FORMAT is ignored.  Instead we use the fakir format (see `fakir--file-attribs')."
  (let* ((directory-fakir-file
          (fakir--namespace-lookup
           directory
           fakir-file-namespace))
         (parent-fakir-file (fakir--parent-fakir-file directory-fakir-file))
         (directory-fakir-files (fakir--directory-fakir-files directory))
         files-and-attributes)

    (if (or (not match) (string-match match "."))
        (push (cons (if full
                       (concat (file-name-as-directory directory) ".")
                     ".")
                   (fakir--file-attribs directory-fakir-file))
             files-and-attributes))

    (if (or (not match) (string-match match ".."))
        (push (cons (if full
                        (concat (file-name-as-directory directory) "..")
                      "..")
                    (fakir--file-attribs parent-fakir-file))
              files-and-attributes))

    (dolist (fakir-file directory-fakir-files)
      (if (or (not match) (string-match match (fakir-file-filename fakir-file)))
          (push (cons (if full
                          (fakir--file-fqn fakir-file)
                        (fakir-file-filename fakir-file))
                      (fakir--file-attribs fakir-file))
                files-and-attributes)))

    (if nosort
        files-and-attributes
      (sort files-and-attributes
            #'(lambda (s1 s2)
                (string-lessp (car s1) (car s2)))))))

(defun fakir--directory-files (directory &optional full match nosort)
  "Return a list of names of faked files in DIRECTORY.

There are three optional arguments:
If FULL is non-nil, return absolute file names.  Otherwise return names
 that are relative to the specified directory.
If MATCH is non-nil, mention only file names that match the regexp MATCH.
If NOSORT is non-nil, the list is not sorted--its order is unpredictable.
 Otherwise, the list returned is sorted with `string-lessp'.
 NOSORT is useful if you plan to sort the result yourself."
  (mapcar 'car (fakir--directory-files-and-attributes directory full match nosort)))

(defmacro fakir-fake-file (faked-file &rest body)
  "Fake FAKED-FILE and evaluate BODY.

FAKED-FILE must be a `fakir-file' object or a list of
`fakir-file' objects."
  (declare (indent 1)
           (debug (sexp &rest form)))
  (let ((ffv (make-symbol "ff")))
    `(let* ((,ffv ,faked-file)
            (fakir-file-namespace
             (if (fakir-file-p ,ffv)
                 (fakir--namespace ,ffv)
                 (apply 'fakir--namespace ,ffv))))
       (noflet
           ((expand-file-name (file-name &optional dir)
              (let ((expanded
                     (fakir--expand-file-name file-name dir)))
                (fakir--file-cond expanded
                  expanded
                  (funcall this-fn file-name dir))))
            (file-attributes (file-name)
              (fakir--file-cond file-name
                (fakir--file-attribs this-fakir-file)
                (funcall this-fn file-name)))
            (file-exists-p (file-name)
              (fakir--file-cond file-name
                t
                (funcall this-fn file-name)))
            (file-directory-p (file-name)
              (fakir--file-cond file-name
                (fakir-file-directory-p this-fakir-file)
                (funcall this-fn file-name)))
            (file-regular-p (file-name)
              (fakir--file-cond file-name
                (not (fakir-file-directory-p this-fakir-file))
                (funcall this-fn file-name)))
            (write-region (start end file-name &optional append visit lockname mustbenew)
              (fakir--file-cond file-name
                (fakir--write-region
                 this-fakir-file ; the faked file - should match file-name
                 start end file-name append visit mustbenew)
                (funcall this-fn start end file-name append visit mustbenew)))
            (rename-file (from to)
              (fakir--file-cond from
                (fakir--file-rename this-fakir-file to)
                (funcall this-fn from to)))
            (insert-file-contents
                (file-name &optional visit beg end replace)
              (fakir--file-cond file-name
                (insert (fakir-file-content this-fakir-file))
                (funcall this-fn file-name)))
            (insert-file-contents-literally
                (file-name &optional visit beg end replace)
              (fakir--file-cond file-name
                (insert (fakir-file-content this-fakir-file))
                (funcall this-fn file-name)))
            (find-file (file-name)
              (fakir--file-cond file-name
                (fakir--find-file this-fakir-file)
                (funcall this-fn file-name)))
            (find-file-noselect (file-name)
              (fakir--file-cond file-name
                (fakir--find-file this-fakir-file)
                (funcall this-fn file-name)))
            (directory-files (directory &optional full match nosort)
              (fakir--file-cond directory
                (fakir--directory-files directory full match nosort)
                (funcall this-fn directory full match nosort)))
            (directory-files-and-attributes (directory &optional full match nosort id-format)
              (fakir--file-cond directory
                (fakir--directory-files-and-attributes directory full match nosort id-format)
                (funcall this-fn directory full match nosort))))
         ,@body))))

(defmacro fakir-mock-file (faked-file &rest body)
  (declare (debug (sexp &rest form))
           (indent 1))
  `(fakir-fake-file ,faked-file ,@body))

(provide 'fakir)

;;; fakir.el ends here