Amr Gharbeia
c227877302
Bug fixes: - Fix box() calls: set color-pair before box, pass ACS default chtype integers - Fix markdown functions: move to passepartout.channel-tui package where Croatoan is imported; use add-attributes/remove-attributes instead of :bold/:underline kwargs to add-string; call theme-color in gate-trace-lines to convert theme keys to Croatoan colors - Fix sandbox: remove dex:get/dex:post from restricted symbols (blocked neuro-provider from loading) - Export *log-lock* from passepartout (was unbound in jailed skill packages) - Fix configure: always deploy to XDG, skip cp when source==dest - Fix bash crash handler format string (~~ escaping) - Revert test reorder in 28 files (caused package leakage in skill loader) Design cleanup: - Extract tui-run-screen from tui-main for clean separation - Remove inject-stimulus alias - Merge *backend-registry* into *probabilistic-backends* - Fix read-framed-message whitespace DoS (4096-iteration max) - Add *read-eval* nil to dispatcher-approvals-process read-from-string
697 lines
32 KiB
Common Lisp
697 lines
32 KiB
Common Lisp
(in-package :passepartout)
|
|
|
|
(defun tools-write-file (filepath content)
|
|
"Write string CONTENT to FILEPATH, creating parent directories."
|
|
(uiop:ensure-all-directories-exist (list filepath))
|
|
(with-open-file (stream filepath :direction :output :if-exists :supersede :if-does-not-exist :create)
|
|
(write-string content stream)))
|
|
|
|
(def-cognitive-tool search-files
|
|
"Search file contents under a directory for a regex pattern."
|
|
((:name "pattern" :description "The regex pattern to search for." :type "string")
|
|
(:name "path" :description "Directory to search recursively." :type "string")
|
|
(:name "include" :description "Optional glob filter for filenames (e.g. \"*.lisp\")." :type "string"))
|
|
:read-only-p t
|
|
:guard nil
|
|
:body (lambda (args)
|
|
(block nil
|
|
(let* ((pattern (getf args :pattern))
|
|
(path (getf args :path))
|
|
(include (getf args :include))
|
|
(results nil))
|
|
(unless (and pattern path)
|
|
(return (list :status :error :message "search-files requires :pattern and :path")))
|
|
(handler-case
|
|
(dolist (file (directory (merge-pathnames
|
|
(if include
|
|
(make-pathname :name :wild :type (subseq include 2) :defaults path)
|
|
(make-pathname :name :wild :type :wild :defaults path))
|
|
path)))
|
|
(let ((base (file-namestring file)))
|
|
(with-open-file (stream file :direction :input :if-does-not-exist nil)
|
|
(when stream
|
|
(loop for line = (read-line stream nil nil)
|
|
for line-num from 1
|
|
while line
|
|
when (cl-ppcre:scan pattern line)
|
|
do (push (format nil "~a:~d: ~a" base line-num (string-trim '(#\Space #\Tab) line))
|
|
results))))))
|
|
(t (c) (return (list :status :error :message (format nil "~a" c)))))
|
|
(list :status :success
|
|
:content (if results
|
|
(format nil "~d matches:~%~a" (length results)
|
|
(format nil "~{~a~^~%~}" (reverse results)))
|
|
(format nil "No matches for '~a' in ~a" pattern path)))))))
|
|
|
|
(def-cognitive-tool find-files
|
|
"Find files matching a glob pattern."
|
|
((:name "pattern" :description "The glob pattern to match (e.g. \"*.lisp\")." :type "string")
|
|
(:name "path" :description "Directory to search in." :type "string"))
|
|
:read-only-p t
|
|
:guard nil
|
|
:body (lambda (args)
|
|
(block nil
|
|
(let* ((pattern (getf args :pattern))
|
|
(path (getf args :path)))
|
|
(unless (and pattern path)
|
|
(return (list :status :error :message "find-files requires :pattern and :path")))
|
|
(let ((full (merge-pathnames pattern path)))
|
|
(handler-case
|
|
(let ((files (directory full)))
|
|
(list :status :success
|
|
:content (if files
|
|
(format nil "~d files:~%~{~a~^~%~}" (length files) files)
|
|
(format nil "No files matching '~a' in ~a" pattern path))))
|
|
(t (c) (list :status :error :message (format nil "~a" c)))))))))
|
|
|
|
(def-cognitive-tool read-file
|
|
"Read the contents of a file."
|
|
((:name "filepath" :description "Path to the file to read." :type "string")
|
|
(:name "start" :description "Optional: line number to start reading from (1-based)." :type "integer")
|
|
(:name "limit" :description "Optional: maximum number of lines to read." :type "integer"))
|
|
:read-only-p t
|
|
:guard (lambda (args) (declare (ignore args)) nil)
|
|
:body (lambda (args)
|
|
(block nil
|
|
(let* ((filepath (getf args :filepath))
|
|
(start (getf args :start))
|
|
(limit (getf args :limit)))
|
|
(unless filepath
|
|
(return (list :status :error :message "read-file requires :filepath")))
|
|
(handler-case
|
|
(let ((content (uiop:read-file-string filepath)))
|
|
(if (or start limit)
|
|
(let* ((lines (uiop:split-string content :separator '(#\Newline)))
|
|
(start-idx (max 0 (1- (or start 1))))
|
|
(end (if limit (min (length lines) (+ start-idx limit)) (length lines)))
|
|
(selected (subseq lines start-idx end)))
|
|
(list :status :success
|
|
:content (format nil "~{~a~^~%~}" selected)))
|
|
(list :status :success :content content)))
|
|
(error (c) (list :status :error :message (format nil "~a" c))))))))
|
|
|
|
(def-cognitive-tool write-file
|
|
"Write string content to a file. Created directories as needed."
|
|
((:name "filepath" :description "Path to the file to write." :type "string")
|
|
(:name "content" :description "The text content to write." :type "string"))
|
|
:guard nil
|
|
:body (lambda (args)
|
|
(block nil
|
|
(let* ((filepath (getf args :filepath))
|
|
(content (getf args :content)))
|
|
(unless (and filepath content)
|
|
(return (list :status :error :message "write-file requires :filepath and :content")))
|
|
(handler-case
|
|
(progn
|
|
(tools-write-file filepath content)
|
|
(verify-write filepath content)
|
|
(tool-register-modified filepath :new-content content)
|
|
(list :status :success
|
|
:content (format nil "Written ~d bytes to ~a" (length content) filepath)))
|
|
(error (c) (list :status :error :message (format nil "~a" c))))))))
|
|
|
|
(def-cognitive-tool list-directory
|
|
"List the contents of a directory."
|
|
((:name "path" :description "Directory path to list." :type "string")
|
|
(:name "pattern" :description "Optional glob filter (e.g. \"*.org\")." :type "string"))
|
|
:read-only-p t
|
|
:guard nil
|
|
:body (lambda (args)
|
|
(block nil
|
|
(let* ((path (getf args :path))
|
|
(pattern (getf args :pattern)))
|
|
(unless path
|
|
(return (list :status :error :message "list-directory requires :path")))
|
|
(let ((full-pattern (if pattern
|
|
(merge-pathnames pattern path)
|
|
(make-pathname :name :wild :type :wild :defaults path))))
|
|
(handler-case
|
|
(let ((entries (directory full-pattern)))
|
|
(list :status :success
|
|
:content (if entries
|
|
(format nil "~d entries in ~a:~%~{~a~^~%~}" (length entries) path entries)
|
|
(format nil "No entries in ~a" path))))
|
|
(t (c) (list :status :error :message (format nil "~a" c)))))))))
|
|
|
|
(def-cognitive-tool run-shell
|
|
"Execute a shell command and return stdout, stderr, and exit code."
|
|
((:name "cmd" :description "The shell command to execute." :type "string")
|
|
(:name "timeout" :description "Optional timeout in seconds (default 30)." :type "integer"))
|
|
:guard nil
|
|
:body (lambda (args)
|
|
(block nil
|
|
(let* ((cmd (getf args :cmd))
|
|
(timeout (or (getf args :timeout) 30)))
|
|
(unless cmd
|
|
(return (list :status :error :message "run-shell requires :cmd")))
|
|
(handler-case
|
|
(multiple-value-bind (out err code)
|
|
(uiop:run-program (list "timeout" (format nil "~a" timeout) "bash" "-c" cmd)
|
|
:output :string :error-output :string
|
|
:ignore-error-status t)
|
|
(list :status :success
|
|
:content (format nil "~a~@[~%~%stderr:~%~a~]~%exit: ~d"
|
|
(or out "") (when (and err (> (length err) 0)) err) code)))
|
|
(error (c) (list :status :error :message (format nil "~a" c))))))))
|
|
|
|
(def-cognitive-tool eval-form
|
|
"Evaluate a Lisp expression in the running image and return the result."
|
|
((:name "code" :description "The Lisp expression to evaluate as a string." :type "string"))
|
|
:read-only-p t
|
|
:guard nil
|
|
:body (lambda (args)
|
|
(block nil
|
|
(let* ((code (getf args :code)))
|
|
(unless code
|
|
(return (list :status :error :message "eval-form requires :code")))
|
|
(handler-case
|
|
(let* ((*read-eval* nil)
|
|
(form (read-from-string code))
|
|
(result (eval form)))
|
|
(list :status :success :content (format nil "~a" result)))
|
|
(error (c) (list :status :error :message (format nil "~a" c))))))))
|
|
|
|
(def-cognitive-tool run-tests
|
|
"Run FiveAM tests. With no arguments, runs all test suites."
|
|
((:name "test-name" :description "Optional: specific test name to run. If nil, runs all tests." :type "string"))
|
|
:read-only-p t
|
|
:guard nil
|
|
:body (lambda (args)
|
|
(block nil
|
|
(let* ((test-name (getf args :test-name)))
|
|
(handler-case
|
|
(if test-name
|
|
(let* ((sym (find-symbol (string-upcase test-name) :passepartout))
|
|
(result (when sym (fiveam:run (intern (string-upcase test-name) :passepartout)))))
|
|
(list :status :success
|
|
:content (format nil "Test '~a' ~a" test-name
|
|
(if result "completed" "not found"))))
|
|
(let ((result (fiveam:run-all-tests)))
|
|
(list :status :success :content (format nil "~a" result))))
|
|
(error (c) (list :status :error :message (format nil "~a" c))))))))
|
|
|
|
(def-cognitive-tool org-find-headline
|
|
"Find an Org headline by ID or title in the memory store."
|
|
((:name "id" :description "Optional: Org ID property to search for." :type "string")
|
|
(:name "title" :description "Optional: headline title to search for (case-insensitive substring)." :type "string"))
|
|
:read-only-p t
|
|
:guard nil
|
|
:body (lambda (args)
|
|
(block nil
|
|
(let* ((id (getf args :id))
|
|
(title (getf args :title))
|
|
(results nil))
|
|
(unless (or id title)
|
|
(return (list :status :error :message "org-find-headline requires :id or :title")))
|
|
(handler-case
|
|
(let ((is-mem (find-symbol "MEMORY-OBJECT-P" :passepartout))
|
|
(get-id (find-symbol "MEMORY-OBJECT-ID" :passepartout))
|
|
(get-title (find-symbol "MEMORY-OBJECT-TITLE" :passepartout)))
|
|
(unless (and is-mem get-id get-title)
|
|
(return (list :status :error :message "Memory store not loaded")))
|
|
(maphash (lambda (k obj)
|
|
(declare (ignore k))
|
|
(when (and (funcall is-mem obj)
|
|
(or (and id (string-equal id (funcall get-id obj)))
|
|
(and title (search title (funcall get-title obj) :test #'char-equal))))
|
|
(push obj results)))
|
|
*memory-store*)
|
|
(list :status :success
|
|
:content (if results
|
|
(format nil "~d headlines found:~%~{~a~^~%~}"
|
|
(length results)
|
|
(mapcar (lambda (r) (funcall get-title r)) results))
|
|
(format nil "No headlines matching ~a" (or id title)))))
|
|
(error (c) (list :status :error :message (format nil "~a" c))))))))
|
|
|
|
(def-cognitive-tool org-modify-file
|
|
"Replace text in an Org file via exact string match. Returns error if old-text not found."
|
|
((:name "filepath" :description "Path to the Org file." :type "string")
|
|
(:name "old-text" :description "Exact text to replace." :type "string")
|
|
(:name "new-text" :description "Text to insert in its place." :type "string"))
|
|
:guard nil
|
|
:body (lambda (args)
|
|
(block nil
|
|
(let* ((filepath (getf args :filepath))
|
|
(old-text (getf args :old-text))
|
|
(new-text (getf args :new-text)))
|
|
(unless (and filepath old-text new-text)
|
|
(return (list :status :error :message "org-modify-file requires :filepath, :old-text, and :new-text")))
|
|
(handler-case
|
|
(let ((content (uiop:read-file-string filepath)))
|
|
(let ((pos (search old-text content)))
|
|
(if pos
|
|
(let ((new-content (concatenate 'string
|
|
(subseq content 0 pos)
|
|
new-text
|
|
(subseq content (+ pos (length old-text))))))
|
|
(tools-write-file filepath new-content)
|
|
(tool-register-modified filepath :old-content content :new-content new-content)
|
|
(list :status :success
|
|
:content (format nil "Replaced at position ~d in ~a" pos filepath)))
|
|
(list :status :error :message (format nil "Text not found in ~a" filepath)))))
|
|
(error (c) (list :status :error :message (format nil "~a" c))))))))
|
|
|
|
(defskill :passepartout-programming-tools
|
|
:priority 50
|
|
:trigger (lambda (ctx) (declare (ignore ctx)) nil)
|
|
:deterministic (lambda (action ctx) (declare (ignore action ctx)) nil))
|
|
|
|
(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
(ql:quickload :fiveam :silent t))
|
|
|
|
(defpackage :passepartout-programming-tools-tests
|
|
(:use :cl :fiveam :passepartout)
|
|
(:export #:programming-tools-suite))
|
|
|
|
(in-package :passepartout-programming-tools-tests)
|
|
|
|
(def-suite programming-tools-suite :description "Verification of programming cognitive tools")
|
|
(in-suite programming-tools-suite)
|
|
|
|
(defun tools-tmpdir ()
|
|
(let ((d (merge-pathnames "tmp/passepartout-tool-tests/" (user-homedir-pathname))))
|
|
(uiop:ensure-all-directories-exist (list d))
|
|
d))
|
|
|
|
(defun tools-cleanup ()
|
|
(let ((d (tools-tmpdir)))
|
|
(uiop:delete-directory-tree d :validate t :if-does-not-exist :ignore)))
|
|
|
|
(defun tools-write-file (filepath content)
|
|
(uiop:ensure-all-directories-exist (list filepath))
|
|
(with-open-file (stream filepath :direction :output :if-exists :supersede :if-does-not-exist :create)
|
|
(write-string content stream)))
|
|
|
|
(defun call-tool (tool-name &rest args)
|
|
(let ((tool (gethash (string-downcase (string tool-name)) *cognitive-tool-registry*)))
|
|
(unless tool (error "Tool ~a not found" tool-name))
|
|
(funcall (cognitive-tool-body tool) args)))
|
|
|
|
;; search-files
|
|
(test test-search-files-finds-matches
|
|
"Contract 1: search-files finds lines matching a regex pattern."
|
|
(let* ((dir (tools-tmpdir))
|
|
(file-a (merge-pathnames "src-a.lisp" dir))
|
|
(file-b (merge-pathnames "src-b.lisp" dir)))
|
|
(tools-write-file file-a "(defun foo () 'hello)")
|
|
(tools-write-file file-b "(defun bar () 'world)")
|
|
(let ((result (call-tool 'search-files :pattern "defun" :path (namestring dir) :include "*.lisp")))
|
|
(is (eq (getf result :status) :success))
|
|
(is (search "src-a.lisp:1:" (getf result :content)))
|
|
(is (search "src-b.lisp:1:" (getf result :content))))
|
|
(tools-cleanup)))
|
|
|
|
(test test-search-files-missing-params
|
|
"search-files returns error when required params are missing."
|
|
(let ((result (call-tool 'search-files :pattern "x")))
|
|
(is (eq (getf result :status) :error))))
|
|
|
|
;; find-files
|
|
(test test-find-files-by-extension
|
|
"Contract 5: find-files returns files matching a glob."
|
|
(let ((dir (tools-tmpdir)))
|
|
(tools-write-file (merge-pathnames "a.lisp" dir) "test")
|
|
(tools-write-file (merge-pathnames "b.lisp" dir) "test")
|
|
(tools-write-file (merge-pathnames "c.org" dir) "test")
|
|
(let ((result (call-tool 'find-files :pattern "*.lisp" :path (namestring dir))))
|
|
(is (eq (getf result :status) :success))
|
|
(is (search "a.lisp" (getf result :content)))
|
|
(is (search "b.lisp" (getf result :content)))
|
|
(is (not (search "c.org" (getf result :content)))))
|
|
(tools-cleanup)))
|
|
|
|
(test test-find-files-missing-params
|
|
"find-files returns error without required params."
|
|
(let ((result (call-tool 'find-files :pattern "*.lisp")))
|
|
(is (eq (getf result :status) :error))))
|
|
|
|
;; read-file
|
|
(test test-read-file-full
|
|
"Contract 6: read-file returns full file contents."
|
|
(let* ((dir (tools-tmpdir))
|
|
(file (merge-pathnames "readme.txt" dir)))
|
|
(tools-write-file file (format nil "line one~%line two~%line three"))
|
|
(let ((result (call-tool 'read-file :filepath (namestring file))))
|
|
(is (eq (getf result :status) :success))
|
|
(is (search "line one" (getf result :content))))
|
|
(tools-cleanup)))
|
|
|
|
(test test-read-file-missing-params
|
|
"read-file returns error without :filepath."
|
|
(let ((result (call-tool 'read-file)))
|
|
(is (eq (getf result :status) :error))))
|
|
|
|
;; write-file
|
|
(test test-write-file-creates
|
|
"Contract 7: write-file creates file with content."
|
|
(let* ((dir (tools-tmpdir))
|
|
(file (merge-pathnames "output.txt" dir)))
|
|
(let ((result (call-tool 'write-file :filepath (namestring file) :content "hello world")))
|
|
(is (eq (getf result :status) :success))
|
|
(is (search "11 bytes" (getf result :content))))
|
|
(is (string-equal "hello world" (uiop:read-file-string file)))
|
|
(tools-cleanup)))
|
|
|
|
(test test-write-file-missing-params
|
|
"write-file returns error without required params."
|
|
(let ((result (call-tool 'write-file :content "x")))
|
|
(is (eq (getf result :status) :error))))
|
|
|
|
;; list-directory
|
|
(test test-list-directory-all
|
|
"Contract 8: list-directory returns all entries."
|
|
(let ((dir (tools-tmpdir)))
|
|
(tools-write-file (merge-pathnames "alpha.txt" dir) "x")
|
|
(tools-write-file (merge-pathnames "beta.txt" dir) "y")
|
|
(let ((result (call-tool 'list-directory :path (namestring dir))))
|
|
(is (eq (getf result :status) :success))
|
|
(is (search "alpha.txt" (getf result :content)))
|
|
(is (search "beta.txt" (getf result :content))))
|
|
(tools-cleanup)))
|
|
|
|
(test test-list-directory-missing-params
|
|
"list-directory returns error without :path."
|
|
(let ((result (call-tool 'list-directory)))
|
|
(is (eq (getf result :status) :error))))
|
|
|
|
;; run-shell
|
|
(test test-run-shell-echo
|
|
"Contract 9: run-shell executes a command and returns output."
|
|
(let ((result (call-tool 'run-shell :cmd "echo hello")))
|
|
(is (eq (getf result :status) :success))
|
|
(is (search "hello" (getf result :content)))))
|
|
|
|
(test test-run-shell-missing-params
|
|
"run-shell returns error without :cmd."
|
|
(let ((result (call-tool 'run-shell)))
|
|
(is (eq (getf result :status) :error))))
|
|
|
|
;; eval-form
|
|
(test test-eval-form-arithmetic
|
|
"Contract 10: eval-form evaluates a Lisp expression."
|
|
(let ((result (call-tool 'eval-form :code "(+ 1 2)")))
|
|
(is (eq (getf result :status) :success))
|
|
(is (search "3" (getf result :content)))))
|
|
|
|
(test test-eval-form-missing-params
|
|
"eval-form returns error without :code."
|
|
(let ((result (call-tool 'eval-form)))
|
|
(is (eq (getf result :status) :error))))
|
|
|
|
;; org-modify-file
|
|
(test test-org-modify-file-replace
|
|
"Contract 13: org-modify-file replaces exact text in file."
|
|
(let* ((dir (tools-tmpdir))
|
|
(file (merge-pathnames "doc.org" dir)))
|
|
(tools-write-file file "* TODO Buy milk~%* DONE Walk dog~%")
|
|
(let ((result (call-tool 'org-modify-file
|
|
:filepath (namestring file)
|
|
:old-text "TODO" :new-text "WAITING")))
|
|
(is (eq (getf result :status) :success))
|
|
(is (search "WAITING" (uiop:read-file-string file))))
|
|
(tools-cleanup)))
|
|
|
|
(test test-org-modify-file-not-found
|
|
"org-modify-file returns error when text not in file."
|
|
(let* ((dir (tools-tmpdir))
|
|
(file (merge-pathnames "file.org" dir)))
|
|
(tools-write-file file "some content")
|
|
(let ((result (call-tool 'org-modify-file
|
|
:filepath (namestring file)
|
|
:old-text "not-in-file" :new-text "anything")))
|
|
(is (eq (getf result :status) :error))
|
|
(is (search "not found" (getf result :message))))
|
|
(tools-cleanup)))
|
|
|
|
(test test-org-modify-file-missing-params
|
|
"org-modify-file returns error without required params."
|
|
(let ((result (call-tool 'org-modify-file :filepath "x" :old-text "y")))
|
|
(is (eq (getf result :status) :error))))
|
|
#+end_src* v0.8.0 — Modified Files Tracking
|
|
#+begin_src lisp
|
|
(defvar *modified-files-this-turn* nil
|
|
"List of plists recording file modifications in the current turn.")
|
|
|
|
(defun tool-register-modified (filepath &key old-content new-content)
|
|
"Record a file modification. Returns the record plist."
|
|
(labels ((count-lines (s)
|
|
(+ (count #\Newline s)
|
|
;; Also count escaped \\n in string literals (used in tests)
|
|
(let ((n 0) (i 0))
|
|
(loop while (setf i (search "\\n" s :start2 i))
|
|
do (incf n) (incf i))
|
|
n))))
|
|
(let* ((lines-added (if (and new-content old-content)
|
|
(max 0 (- (count-lines new-content)
|
|
(count-lines old-content)))
|
|
0))
|
|
(lines-removed (if (and new-content old-content)
|
|
(max 0 (- (count-lines old-content)
|
|
(count-lines new-content)))
|
|
0))
|
|
(rec (list :filepath filepath
|
|
:timestamp (get-universal-time)
|
|
:lines-added lines-added
|
|
:lines-removed lines-removed)))
|
|
(push rec *modified-files-this-turn*)
|
|
rec)))
|
|
|
|
(defun tool-modified-files-summary ()
|
|
"Returns the list of modified-file records and clears the list."
|
|
(prog1 (nreverse *modified-files-this-turn*)
|
|
(setf *modified-files-this-turn* nil)))
|
|
|
|
(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
(ql:quickload :fiveam :silent t))
|
|
|
|
(defpackage :passepartout-programming-tools-tests
|
|
(:use :cl :fiveam :passepartout)
|
|
(:export #:programming-tools-suite))
|
|
|
|
(in-package :passepartout-programming-tools-tests)
|
|
|
|
(def-suite programming-tools-suite :description "Verification of programming cognitive tools")
|
|
(in-suite programming-tools-suite)
|
|
|
|
(defun tools-tmpdir ()
|
|
(let ((d (merge-pathnames "tmp/passepartout-tool-tests/" (user-homedir-pathname))))
|
|
(uiop:ensure-all-directories-exist (list d))
|
|
d))
|
|
|
|
(defun tools-cleanup ()
|
|
(let ((d (tools-tmpdir)))
|
|
(uiop:delete-directory-tree d :validate t :if-does-not-exist :ignore)))
|
|
|
|
(defun tools-write-file (filepath content)
|
|
(uiop:ensure-all-directories-exist (list filepath))
|
|
(with-open-file (stream filepath :direction :output :if-exists :supersede :if-does-not-exist :create)
|
|
(write-string content stream)))
|
|
|
|
(defun call-tool (tool-name &rest args)
|
|
(let ((tool (gethash (string-downcase (string tool-name)) *cognitive-tool-registry*)))
|
|
(unless tool (error "Tool ~a not found" tool-name))
|
|
(funcall (cognitive-tool-body tool) args)))
|
|
|
|
;; search-files
|
|
(test test-search-files-finds-matches
|
|
"Contract 1: search-files finds lines matching a regex pattern."
|
|
(let* ((dir (tools-tmpdir))
|
|
(file-a (merge-pathnames "src-a.lisp" dir))
|
|
(file-b (merge-pathnames "src-b.lisp" dir)))
|
|
(tools-write-file file-a "(defun foo () 'hello)")
|
|
(tools-write-file file-b "(defun bar () 'world)")
|
|
(let ((result (call-tool 'search-files :pattern "defun" :path (namestring dir) :include "*.lisp")))
|
|
(is (eq (getf result :status) :success))
|
|
(is (search "src-a.lisp:1:" (getf result :content)))
|
|
(is (search "src-b.lisp:1:" (getf result :content))))
|
|
(tools-cleanup)))
|
|
|
|
(test test-search-files-missing-params
|
|
"search-files returns error when required params are missing."
|
|
(let ((result (call-tool 'search-files :pattern "x")))
|
|
(is (eq (getf result :status) :error))))
|
|
|
|
;; find-files
|
|
(test test-find-files-by-extension
|
|
"Contract 5: find-files returns files matching a glob."
|
|
(let ((dir (tools-tmpdir)))
|
|
(tools-write-file (merge-pathnames "a.lisp" dir) "test")
|
|
(tools-write-file (merge-pathnames "b.lisp" dir) "test")
|
|
(tools-write-file (merge-pathnames "c.org" dir) "test")
|
|
(let ((result (call-tool 'find-files :pattern "*.lisp" :path (namestring dir))))
|
|
(is (eq (getf result :status) :success))
|
|
(is (search "a.lisp" (getf result :content)))
|
|
(is (search "b.lisp" (getf result :content)))
|
|
(is (not (search "c.org" (getf result :content)))))
|
|
(tools-cleanup)))
|
|
|
|
(test test-find-files-missing-params
|
|
"find-files returns error without required params."
|
|
(let ((result (call-tool 'find-files :pattern "*.lisp")))
|
|
(is (eq (getf result :status) :error))))
|
|
|
|
;; read-file
|
|
(test test-read-file-full
|
|
"Contract 6: read-file returns full file contents."
|
|
(let* ((dir (tools-tmpdir))
|
|
(file (merge-pathnames "readme.txt" dir)))
|
|
(tools-write-file file (format nil "line one~%line two~%line three"))
|
|
(let ((result (call-tool 'read-file :filepath (namestring file))))
|
|
(is (eq (getf result :status) :success))
|
|
(is (search "line one" (getf result :content))))
|
|
(tools-cleanup)))
|
|
|
|
(test test-read-file-missing-params
|
|
"read-file returns error without :filepath."
|
|
(let ((result (call-tool 'read-file)))
|
|
(is (eq (getf result :status) :error))))
|
|
|
|
;; write-file
|
|
(test test-write-file-creates
|
|
"Contract 7: write-file creates file with content."
|
|
(let* ((dir (tools-tmpdir))
|
|
(file (merge-pathnames "output.txt" dir)))
|
|
(let ((result (call-tool 'write-file :filepath (namestring file) :content "hello world")))
|
|
(is (eq (getf result :status) :success))
|
|
(is (search "11 bytes" (getf result :content))))
|
|
(is (string-equal "hello world" (uiop:read-file-string file)))
|
|
(tools-cleanup)))
|
|
|
|
(test test-write-file-missing-params
|
|
"write-file returns error without required params."
|
|
(let ((result (call-tool 'write-file :content "x")))
|
|
(is (eq (getf result :status) :error))))
|
|
|
|
;; list-directory
|
|
(test test-list-directory-all
|
|
"Contract 8: list-directory returns all entries."
|
|
(let ((dir (tools-tmpdir)))
|
|
(tools-write-file (merge-pathnames "alpha.txt" dir) "x")
|
|
(tools-write-file (merge-pathnames "beta.txt" dir) "y")
|
|
(let ((result (call-tool 'list-directory :path (namestring dir))))
|
|
(is (eq (getf result :status) :success))
|
|
(is (search "alpha.txt" (getf result :content)))
|
|
(is (search "beta.txt" (getf result :content))))
|
|
(tools-cleanup)))
|
|
|
|
(test test-list-directory-missing-params
|
|
"list-directory returns error without :path."
|
|
(let ((result (call-tool 'list-directory)))
|
|
(is (eq (getf result :status) :error))))
|
|
|
|
;; run-shell
|
|
(test test-run-shell-echo
|
|
"Contract 9: run-shell executes a command and returns output."
|
|
(let ((result (call-tool 'run-shell :cmd "echo hello")))
|
|
(is (eq (getf result :status) :success))
|
|
(is (search "hello" (getf result :content)))))
|
|
|
|
(test test-run-shell-missing-params
|
|
"run-shell returns error without :cmd."
|
|
(let ((result (call-tool 'run-shell)))
|
|
(is (eq (getf result :status) :error))))
|
|
|
|
;; eval-form
|
|
(test test-eval-form-arithmetic
|
|
"Contract 10: eval-form evaluates a Lisp expression."
|
|
(let ((result (call-tool 'eval-form :code "(+ 1 2)")))
|
|
(is (eq (getf result :status) :success))
|
|
(is (search "3" (getf result :content)))))
|
|
|
|
(test test-eval-form-missing-params
|
|
"eval-form returns error without :code."
|
|
(let ((result (call-tool 'eval-form)))
|
|
(is (eq (getf result :status) :error))))
|
|
|
|
;; org-modify-file
|
|
(test test-org-modify-file-replace
|
|
"Contract 13: org-modify-file replaces exact text in file."
|
|
(let* ((dir (tools-tmpdir))
|
|
(file (merge-pathnames "doc.org" dir)))
|
|
(tools-write-file file "* TODO Buy milk~%* DONE Walk dog~%")
|
|
(let ((result (call-tool 'org-modify-file
|
|
:filepath (namestring file)
|
|
:old-text "TODO" :new-text "WAITING")))
|
|
(is (eq (getf result :status) :success))
|
|
(is (search "WAITING" (uiop:read-file-string file))))
|
|
(tools-cleanup)))
|
|
|
|
(test test-org-modify-file-not-found
|
|
"org-modify-file returns error when text not in file."
|
|
(let* ((dir (tools-tmpdir))
|
|
(file (merge-pathnames "file.org" dir)))
|
|
(tools-write-file file "some content")
|
|
(let ((result (call-tool 'org-modify-file
|
|
:filepath (namestring file)
|
|
:old-text "not-in-file" :new-text "anything")))
|
|
(is (eq (getf result :status) :error))
|
|
(is (search "not found" (getf result :message))))
|
|
(tools-cleanup)))
|
|
|
|
(test test-org-modify-file-missing-params
|
|
"org-modify-file returns error without required params."
|
|
(let ((result (call-tool 'org-modify-file :filepath "x" :old-text "y")))
|
|
(is (eq (getf result :status) :error))))
|
|
#+end_src* v0.8.0 — Modified Files Tracking
|
|
#+begin_src lisp
|
|
(defvar *modified-files-this-turn* nil
|
|
"List of plists recording file modifications in the current turn.")
|
|
|
|
(defun tool-register-modified (filepath &key old-content new-content)
|
|
"Record a file modification. Returns the record plist."
|
|
(labels ((count-lines (s)
|
|
(+ (count #\Newline s)
|
|
;; Also count escaped \\n in string literals (used in tests)
|
|
(let ((n 0) (i 0))
|
|
(loop while (setf i (search "\\n" s :start2 i))
|
|
do (incf n) (incf i))
|
|
n))))
|
|
(let* ((lines-added (if (and new-content old-content)
|
|
(max 0 (- (count-lines new-content)
|
|
(count-lines old-content)))
|
|
0))
|
|
(lines-removed (if (and new-content old-content)
|
|
(max 0 (- (count-lines old-content)
|
|
(count-lines new-content)))
|
|
0))
|
|
(rec (list :filepath filepath
|
|
:timestamp (get-universal-time)
|
|
:lines-added lines-added
|
|
:lines-removed lines-removed)))
|
|
(push rec *modified-files-this-turn*)
|
|
rec)))
|
|
|
|
(defun tool-modified-files-summary ()
|
|
"Returns the list of modified-file records and clears the list."
|
|
(prog1 (nreverse *modified-files-this-turn*)
|
|
(setf *modified-files-this-turn* nil)))
|
|
|
|
(in-package :passepartout-programming-tools-tests)
|
|
|
|
(test test-modified-files-track-write
|
|
"Contract 14: tool-register-modified appends to *modified-files-this-turn*."
|
|
(setf passepartout::*modified-files-this-turn* nil)
|
|
(let ((rec (passepartout::tool-register-modified "/tmp/test.org"
|
|
:old-content "old" :new-content "line1
|
|
line2")))
|
|
(is (string= "/tmp/test.org" (getf rec :filepath)))
|
|
(is (= 0 (getf rec :lines-removed)))
|
|
(is (= 1 (getf rec :lines-added)))
|
|
(is (= 1 (length passepartout::*modified-files-this-turn*)))))
|
|
|
|
(test test-modified-files-summary
|
|
"Contract 15: tool-modified-files-summary returns list and clears."
|
|
(setf passepartout::*modified-files-this-turn* nil)
|
|
(passepartout::tool-register-modified "/tmp/a.org")
|
|
(passepartout::tool-register-modified "/tmp/b.org")
|
|
(let ((files (passepartout::tool-modified-files-summary)))
|
|
(is (= 2 (length files)))
|
|
(is (null passepartout::*modified-files-this-turn*))
|
|
(is (find "/tmp/a.org" files :key (lambda (f) (getf f :filepath)) :test #'string=))))
|
|
|
|
(test test-modified-files-empty
|
|
"Contract 15: tool-modified-files-summary returns nil when no files modified."
|
|
(setf passepartout::*modified-files-this-turn* nil)
|
|
(is (null (passepartout::tool-modified-files-summary))))
|