NetInstaller に登録されているアプリのソースをすべて取得 #xyzzy

gistfile1.lisp

(require "http-client")

(defvar *package-source-list-url*
  "http://xyzzy.s53.xrea.com/wiki/index.php?NetInstaller%2F%C7%DB%C9%DB%A5%D1%A5%C3%A5%B1%A1%BC%A5%B8%B0%EC%CD%F72")

(defvar *package-source-scanner*
  (ppcre:create-scanner "<dt>(.+?)(?:\\(.*?\\))</dt>\n<dd><a +href=\"(.+?)\"[^>]*>"
                        :single-line-mode t
                        :case-insensitive-mode t))


(defun get-all-app-src (target-directory &optional (app-src-list (app-src-list)))
  (interactive "DInstall Directory: ")
  (labels ((get-all-app-src-later (app-src-list)
             (ansify:destructuring-bind (app-src &rest app-src-rest) app-src-list
               (when app-src
                 (http-client:http-get app-src
                                       :receiver (http-client:http-file-receiver (make-temp-file-name))
                                       :onprogress #'(lambda (p)
                                                       (message "~A: ~A" p app-src))
                                       :oncomplete #'(lambda (pathname &rest ignored)
                                                       (message "Extract: ~A" app-src)
                                                       (handler-case
                                                           (unwind-protect
                                                               (extract-archive pathname target-directory)
                                                             (delete-file pathname))
                                                         (error (c)
                                                           (msgbox "アーカイブを展開できません。~%~A" app-src)))
                                                       (message "Extract done: ~A" app-src)
                                                       ))
                 (when app-src-rest
                   (start-timer 2 (alexandria:curry #'get-all-app-src-later app-src-rest) t))))))
    (when (file-exist-p target-directory)
      (or (yes-or-no-p "~A に展開します?" target-directory)
          (quit)))
    (when (path-equal target-directory (si:system-root))
      (or (yes-or-no-p "si:system-root っすよ?" target-directory)
          (quit)))
    (get-all-app-src-later app-src-list)))


(defun app-src-list (&optional (app-list (app-list)))
  (mapcar #'(lambda (app)
              (cdr (assoc "src" app :test #'string=)))
          app-list))

(defun app-list (&optional (package-list (package-list)))
  (let ((clients (mapcar #'(lambda (url/title)
                             (message "GET ~A" (car url/title))
                             (list* (http-client:http-get (car url/title))
                                    url/title))
                         package-list))
        errors)
    (values (mapcan #'(lambda (pkg/url/title)
                        (ansify:destructuring-bind (pkg url title) pkg/url/title
                          (handler-case
                              (progn
                                (message "Waiting ~A" url)
                                (let ((sexp (http-client:http-response-result pkg)))
                                  (message "Done ~A" url)
                                  (cdr (assoc "packages"
                                              (repl::read-all-from-string sexp)
                                              :test #'string=))))
                            (error (c)
                              (push (list url title c) errors)))))
                    clients)
            errors)))

(defun package-list (&optional (url *package-source-list-url*)
                                      (scanner *package-source-scanner*))
  (scan-package-source-list (http-client:http-response-result
                             (http-client:http-get url))
                            scanner))

(defun scan-package-source-list (html scanner)
  (let (r)
    (flet ((strip-html (s)
             (string-trim " \r\t\f\n"
                          (substitute-string
                           (substitute-string s "&amp;" "&")
                           "<[^<>]*>" ""))))
      (ppcre:do-register-groups ((#'strip-html title url))
          (scanner html (nreverse r))
        (push (list url title) r)))))