(defun org-filetags-extract (content) "Extracts the list of tags from a #+FILETAGS: line." (let ((lines (uiop:split-string content :separator '(#\Newline)))) (dolist (line lines) (when (uiop:string-prefix-p "#+FILETAGS:" (string-trim '(#\Space) line)) (let ((tag-str (string-trim " :" (subseq (string-trim '(#\Space) line) 10)))) (return-from org-filetags-extract (mapcar (lambda (tag) (format nil ":~a" (string-trim '(#\Space) tag))) (uiop:split-string tag-str :separator '(#\space #\tab)))))))) nil) (defun org-privacy-tag-p (tags-list) "Returns T if any tag in TAGS-LIST matches bouncer-privacy-tags." (let ((privacy-tags (symbol-value (find-symbol "BOUNCER-PRIVACY-TAGS" :passepartout)))) (when (and tags-list privacy-tags) (some (lambda (tag) (some (lambda (private-tag) (string-equal (string-trim '(#\: #\space) tag) (string-trim '(#\: #\space) private-tag)) privacy-tags)) tags-list))))) (defun org-privacy-strip (content) "Removes Org headlines whose :TAGS: property contains a privacy-filtered tag. Returns the filtered content as a string." (let* ((lines (uiop:split-string content :separator '(#\Newline))) (result-lines nil) (skip-depth nil) (current-tags nil) (in-properties nil)) (dolist (line lines) (cond (skip-depth ;; We're inside a skipped subtree (when (and (uiop:string-prefix-p "*" (string-trim '(#\Space) line)) (<= (length (string-trim '(#\Space) line)) skip-depth)) (setf skip-depth nil))) ((uiop:string-prefix-p ":PROPERTIES:" (string-trim '(#\Space) line)) (setf in-properties t) (push line result-lines)) ((uiop:string-prefix-p ":END:" (string-trim '(#\Space) line)) (setf in-properties nil) (when current-tags (when (org-privacy-tag-p (reverse current-tags)) (setf skip-depth (length (car (last result-lines (1+ (position-if (lambda (l) (uiop:string-prefix-p "*" (string-trim '(#\Space) l))) (reverse result-lines)))))))) (setf current-tags nil)) (push line result-lines)) ((and in-properties (uiop:string-prefix-p ":TAGS:" (string-trim '(#\Space) line))) (let ((tag-val (string-trim '(#\Space) (subseq (string-trim '(#\Space) line) 6)))) (setf current-tags (uiop:split-string tag-val :separator '(#\space #\tab)))) (push line result-lines)) (t (push line result-lines)))) (format nil "~{~a~%~}" (nreverse result-lines)))) (defun org-read-file (filepath) "Reads an Org file into a string, applying privacy filtering." (let* ((raw (uiop:read-file-string filepath)) (filetags (org-filetags-extract raw))) (if (org-privacy-tag-p filetags) (progn (harness-log "UTILS-ORG: Blocked read of ~a — file-level privacy tag(s) ~a" filepath filetags) nil) (org-privacy-strip raw)))) (defun org-write-file (filepath content) "Writes content to an Org file." (uiop:with-output-file (s filepath :if-exists :supersede) (format s "~a" content))) (defun org-id-generate () "Generates a new UUID for an Org node." (string-downcase (format nil "~a" (uuid:make-v4-uuid)))) (defun org-id-format (id) "Ensures the ID has the 'id:' prefix." (if (uiop:string-prefix-p "id:" id) id (format nil "id:~a" id))) (defun org-property-set (ast target-id property value) "Recursively sets a property on a headline with a matching ID in the AST." (let ((type (getf ast :type)) (props (getf ast :properties)) (contents (getf ast :contents))) (when (and (eq type :HEADLINE) (string= (getf props :ID) target-id)) (setf (getf (getf ast :properties) property) value) (return-from org-property-set t)) (dolist (child contents) (when (listp child) (when (org-property-set child target-id property value) (return-from org-property-set t))))) nil) (defun org-todo-set (ast target-id status) "Sets the TODO status of a headline in the AST." (org-property-set ast target-id :TODO status)) (defun org-headline-add (ast parent-id title) "Adds a new headline as a child of the parent-id in the AST." (let* ((type (getf ast :type)) (props (getf ast :properties)) (id (getf props :ID)) (contents (getf ast :contents))) (when (and (eq type :HEADLINE) (string= id parent-id)) (let ((new-node (list :type :HEADLINE :properties (list :ID (org-id-format (org-id-generate)) :TITLE title) :contents nil))) (setf (getf ast :contents) (append contents (list new-node))) (return-from org-headline-add t))) (dolist (child contents) (when (listp child) (when (org-headline-add child parent-id title) (return-from org-headline-add t))))) nil) (defun org-headline-find-by-id (ast id) "Finds a headline by its ID in the AST." (let ((props (getf ast :properties))) (when (string= (getf props :ID) id) (return-from org-headline-find-by-id ast)) (dolist (child (getf ast :contents)) (when (listp child) (let ((found (org-headline-find-by-id child id))) (when found (return-from org-headline-find-by-id found))))) nil)) (defun org-headline-find-by-title (ast title) "Finds a headline by its title in the AST." (let ((props (getf ast :properties))) (when (string-equal (getf props :TITLE) title) (return-from org-headline-find-by-title ast)) (dolist (child (getf ast :contents)) (when (listp child) (let ((found (org-headline-find-by-title child title))) (when found (return-from org-headline-find-by-title found))))) nil)) (defun org-modify (filepath id changes) "Placeholder for Emacs-driven modification of a specific node." (declare (ignore changes)) (harness-log "UTILS-ORG: Applying changes to ~a in ~a" id filepath) t) (defun org-ast-render (ast) "Minimal converter from AST back to Org text (Placeholder)." (declare (ignore ast)) "* TITLE (Placeholder)") (defskill :passepartout-programming-org :priority 100 :trigger (lambda (ctx) (declare (ignore ctx)) nil)) (defpackage :passepartout-utils-org-tests (:use :cl :fiveam :passepartout) (:export #:utils-org-suite)) (in-package :passepartout-utils-org-tests) (def-suite utils-org-suite :description "Tests for Utils Org skill.") (in-suite utils-org-suite) (test id-generation (let ((id1 (org-id-generate)) (id2 (org-id-generate))) (is (plusp (length id1))) (is (not (string= id1 id2))))) (test id-format (let ((formatted (org-id-format "abc12345"))) (is (search "id:" formatted)))) (test property-setter (let ((ast (list :type :HEADLINE :properties (list :ID "id:test123" :TITLE "Test") :contents nil))) (org-property-set ast "id:test123" :STATUS "ACTIVE") (is (string= (getf (getf ast :properties) :STATUS) "ACTIVE")))) (test todo-setter (let ((ast (list :type :HEADLINE :properties (list :ID "id:todo001" :TITLE "Task") :contents nil))) (org-todo-set ast "id:todo001" "DONE") (is (string= (getf (getf ast :properties) :TODO) "DONE"))))