(in-package #:lispsearch)

;;;; Safe .asd metadata extraction. We NEVER load an untrusted .asd into the
;;;; running image (lispsearch-plan.md §6, §13). Instead we read it as data with
;;;; *read-eval* disabled and a permissive readtable, then walk the (defsystem
;;;; ...) form. On any failure we return an empty plist.

(defun %permissive-readtable ()
  "A readtable that neutralizes #. (read-eval) so it can never execute code."
  (let ((rt (copy-readtable nil)))
    (set-dispatch-macro-character #\# #\.
      (lambda (stream char arg)
        (declare (ignore char arg))
        (let ((*read-suppress* t)) (read stream t nil t))
        nil)
      rt)
    rt))

(defun %read-asd-forms (text)
  "Read top-level forms from TEXT as data. *read-eval* is NIL; symbols intern in
ASDF-USER (which uses CL+ASDF) so `defsystem`/`asdf:defsystem` resolve. Stops at
the first unreadable form (e.g. an unknown package marker) and returns what it
has — enough to reach the root defsystem in practice."
  (let ((*read-eval* nil)
        (*readtable* (%permissive-readtable))
        (*package* (or (find-package "ASDF-USER") (find-package "CL-USER")))
        (forms '()))
    (with-input-from-string (in text)
      (loop
        (let ((form (handler-case (read in nil :eof)
                      (error () (return)))))
          (when (eq form :eof) (return))
          (push form forms))))
    (nreverse forms)))

(defun %defsystem-form-p (form)
  (and (consp form)
       (symbolp (car form))
       (string-equal (symbol-name (car form)) "DEFSYSTEM")))

(defun %as-string (v)
  "Coerce an .asd metadata value to a string (or NIL)."
  (typecase v
    (null nil)
    (string v)
    (cons (let ((parts (remove nil (mapcar #'%as-string v))))
            (when parts (format nil "~{~A~^, ~}" parts))))
    (symbol (string-downcase (symbol-name v)))
    (t (princ-to-string v))))

(defun %dep-name (dep)
  "Normalize one :depends-on entry to a system-name string. Handles plain
strings/symbols and ASDF forms like (:version \"x\" ...) / (:feature kw \"x\")."
  (typecase dep
    (string dep)
    (symbol (string-downcase (symbol-name dep)))
    (cons (if (keywordp (car dep))
              (%dep-name (find-if (lambda (x) (or (stringp x) (and (symbolp x) (not (keywordp x)))))
                                  (rest dep)))
              (%dep-name (car dep))))
    (t nil)))

(defun parse-asd (path-or-string)
  "Extract (:description :author :license :depends-on) from an .asd file or
string. Returns an empty plist on any failure; never executes the .asd."
  (handler-case
      (let* ((text (if (and (or (pathnamep path-or-string) (stringp path-or-string))
                            (ignore-errors (probe-file path-or-string)))
                       (uiop:read-file-string path-or-string)
                       path-or-string))
             (ds (find-if #'%defsystem-form-p (%read-asd-forms text))))
        (if ds
            (let ((opts (cddr ds)))   ; (defsystem NAME . option-plist)
              (list :description (%as-string (getf opts :description))
                    :author      (%as-string (getf opts :author))
                    :license     (or (%as-string (getf opts :license))
                                     (%as-string (getf opts :licence)))
                    :depends-on  (remove nil (mapcar #'%dep-name (getf opts :depends-on)))))
            '()))
    (error () '())))
