jul-mode.el 33 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843
  1. ;;; jul-mode.el --- Simple package system for Dragora -*- lexical-binding: t -*-
  2. ;; Copyright (C) 2016 Kevin Bloom <kdb4@openmailbox.org>
  3. ;; Author: Kevin Bloom <kdb4@openmailbox.org>
  4. ;; Created: 16 May 2016
  5. ;; Version: 0.3.9
  6. ;; Keywords: application
  7. ;; Package-Requires: ((tabulated-list "1.0"))
  8. ;; This program is free software: you can redistribute it and/or modify
  9. ;; it under the terms of the GNU General Public License as published by
  10. ;; the Free Software Foundation, either version 3 of the License, or
  11. ;; (at your option) any later version.
  12. ;; This program is distributed in the hope that it will be useful,
  13. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  15. ;; GNU General Public License for more details.
  16. ;; You should have received a copy of the GNU General Public License
  17. ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
  18. ;;; Changelog:
  19. ;; 12 August 2016 - Querying to clean only removed selected files (bug fix)
  20. ;; 11 August 2016 - Bug fixes, querying to clean temp after install/upgrade,docs
  21. ;; 10 August 2016 - Fixed a big mark for installation bug (archs any and noarch)
  22. ;; 9 August 2016 - Added sha1sum checks
  23. ;; 8 August 2016 - Added a `jul-package-list-installed' command
  24. ;; 3 August 2016 - Made the version comparitor better, still needs work!
  25. ;; 2 August 2016 - Blocked install of other archs, added emacs-arch variable
  26. ;; 1 August 2016 - Output buffers are nice now
  27. ;; 28 July 2016 - Implemented cleaning of temp direcrory, pkg output buffer
  28. ;; 27 July 2016 - Got auto refreshing and multi-function per exceute working
  29. ;; 25 July 2016 - Added the 'tom' repo
  30. ;; 8 June 2016 - Works with newest version of jul
  31. ;; 6 June 2016 - Rewritting jul-mode to work with newer version of jul. (0.3)
  32. ;; 31 May 2016 - Wrote the upgrading functions. They work, however, bugs!
  33. ;; 23 May 2016 - Wrote the installation and removal functions. They work!
  34. ;; 20 May 2016 - Started adding keys for doing tasks. Got installed stuff
  35. ;; working.
  36. ;; 19 May 2016 - Got pulling of all repos and listing them on screen working.
  37. ;; 17 May 2016 - Got commication with server.
  38. ;; 16 May 2016 - Created package. On this day, I got something working.
  39. ;;; Commentary:
  40. ;; The idea behind jul-mode is to bring jul, the "package manager" for the
  41. ;; Dragora user repo, to Emacs. This will hopefully make jul and the repos
  42. ;; easier to use and more powerful. That being said, you will (hopefully) be
  43. ;; able to do most of your package management in jul-mode as well.
  44. ;; It's important to note that all of the code is based on (or from) the source
  45. ;; for the built-in Emacs package `package.el'. Without that source, it would
  46. ;; have taken ages to write this.
  47. ;; Version 0.3 and up uses the jul program to list the uninstalled packages.
  48. ;; So you must have version 0.4 or higher of jul installed for this to
  49. ;; work (I think). All versions must be ran on Dragora 2.2; D3.x is not
  50. ;; supported yet.
  51. ;;; Todo:
  52. ;; Remove temp file from the `jul search' command
  53. ;; Filtering
  54. ;; Don't allow the installation of a package that is all ready installed.
  55. ;; This technically is done already thanks to `pkg' but it only tells you in the
  56. ;; output buffer.
  57. ;; Better version comparitor in the works!
  58. ;; Remove the `sync-flag' variable
  59. ;;; BUGS
  60. ;; If you have a package that uses a hyphen in the version (like
  61. ;; ImageMagick has a version of 7.0.5-6), you will get a package name
  62. ;; that includes the version and under the `version' header, you'll
  63. ;; get the number after the hyphen. So, as an example, ImageMagick
  64. ;; looks like: ImageMagick-7.0.5 and the version is 6 However, the
  65. ;; "fix" to this is to follow the correct package naming guidelines
  66. ;; which doesn't include hyphenated versions.
  67. ;; Tom's repo doesn't really work... Especially the sdl package.
  68. ;;; Code:
  69. (eval-when-compile (require 'cl-lib))
  70. (require 'tabulated-list)
  71. (defgroup jul-package nil
  72. "Manager for Dragora User packages."
  73. :group 'applications
  74. :version "0.3.9")
  75. (defcustom jul-package-repos
  76. '(("frusen" . "http://gungre.ch/dragora/repo/frusen/stable/")
  77. ("kelsoo" . "http://gungre.ch/dragora/repo/kelsoo/")
  78. ("mprodrigues" . "http://gungre.ch/dragora/repo/mprodrigues/")
  79. ("tom" . "http://92.19.232.58:82/dragora/repo/tom/")) ;don't use this yet
  80. "An alist of repos from which to fetch.
  81. The defaults include all the repos found on the gungre.ch site.
  82. Each element has the form (ID . LOCATION).
  83. ID is an archive name, as a string.
  84. LOCATION specifies the base location for the archive.
  85. If it starts with \"http:\", it is treated as a HTTP URL;
  86. otherwise it should be an absolute directory name.
  87. (Other types of URL are currently not supported.)
  88. Only add locations that you trust, since fetching and installing
  89. a package can kill you in your sleep."
  90. :type '(alist :key-type (string :tag "Repo name")
  91. :value-type (string :tag "URL or directory name"))
  92. :risky t
  93. :group 'jul-package
  94. :version "0.3.9")
  95. (cl-defstruct (jul-package-desc
  96. ;; Rename the default constructor from `make-package-desc'.
  97. (:constructor jul-package-desc-create)
  98. (:constructor
  99. jul-package-desc-from-define
  100. (name-string version-string arch-string repo-string build-string
  101. description-string
  102. &aux
  103. (name (intern name-string))
  104. (version version-string)
  105. (arch arch-string)
  106. (repo repo-string)
  107. (build build-string)
  108. (description description-string))))
  109. "Structure containing information about an individual package.
  110. Slots:
  111. `name' Name of the package, as a symbol
  112. `version' Version of the package, as a string
  113. `arch' Architecture of the package, as a string
  114. `repo' The name of the archive (as a string) whence this came
  115. `build' The current build, as a string
  116. `description' A short description of the package, as a string"
  117. name
  118. version
  119. arch
  120. repo
  121. build
  122. description)
  123. ;; Although not common Emacs Lisp practice, I find it helpful to have earmuffs
  124. ;; on the "global" variables.
  125. (defvar *jul-package-installed* nil
  126. "This list contains the packages installed on your system.
  127. Each element is of the form (NAME . J-PKG-DESC) where NAME is the name
  128. of the package and J-PKG-DESC is a cl-struct-jul-package-desc.")
  129. (put '*jul-package-installed* 'risky-local-variable t)
  130. (defvar *jul-package-repo* nil
  131. "This list contains all the packages that are currently on the gungre.ch
  132. server. Each element is of the form (NAME . J-PKG-DESC) where NAME is the name
  133. of the package and J-PKG-DESC is a cl-struct-jul-package-desc.")
  134. (put '*jul-package-repo* 'risky-local-variable t)
  135. (defvar *jul-package-temp-dir* "~/.emacs.d/elpa/jul-mode/"
  136. "This variable contains the directory in which jul-mode stuff is done
  137. temporarily.
  138. It is recommended you pick a nice place.")
  139. (put '*jul-package-temp-dir* 'risky-local-variable t)
  140. (defvar *jul-package-installed-dir* "/var/db/pkg/"
  141. "This variable contains the directory in which Dragora keeps installed
  142. packages")
  143. (put '*jul-package-installed-dir* 'risky-local-variable t)
  144. (defvar *emacs-arch* (if (string-match "x86_64" (version))
  145. "x86_64"
  146. "i486")
  147. "This variable is so you can easily determine which packages you can install."
  148. )
  149. (defvar sync-flag t
  150. "Non-nil means sync with server. When nil, don't.
  151. This temperary variable is used to make sure you don't sync with the server
  152. when you don't want to. For example, when you try to refresh the list of
  153. packages, but you are only viewing the installed ones, this will make sure that
  154. you don't sync with the server on the refresh.")
  155. (defvar jul-package-menu-mode-map
  156. (let ((map (make-sparse-keymap))
  157. (menu-map (make-sparse-keymap "jul-package")))
  158. (set-keymap-parent map tabulated-list-mode-map)
  159. (define-key map "u" 'jul-package-menu-mark-unmark)
  160. (define-key map "d" 'jul-package-menu-mark-delete)
  161. (define-key map "i" 'jul-package-menu-mark-install)
  162. (define-key map "U" 'jul-package-menu-mark-upgrades)
  163. (define-key map "r" 'jul-package-menu-refresh)
  164. (define-key map "f" 'jul-package-menu-filter) ;not implemented yet
  165. (define-key map "x" 'jul-package-menu-execute)
  166. (define-key map "C" 'jul-package-clean-temp-dir)
  167. (define-key menu-map [mq]
  168. '(menu-item "Quit" quit-window
  169. :help "Quit package selection"))
  170. (define-key menu-map [s1] '("--"))
  171. (define-key menu-map [mn]
  172. '(menu-item "Next" next-line
  173. :help "Next Line"))
  174. (define-key menu-map [mp]
  175. '(menu-item "Previous" previous-line
  176. :help "Previous Line"))
  177. (define-key menu-map [mi]
  178. '(menu-item "Mark for Install" jul-package-menu-mark-install
  179. :help "Mark package for installation, move to the next line"))
  180. (define-key menu-map [mu]
  181. '(menu-item "Remove mark" jul-package-menu-mark-unmark
  182. :help "Unmark a package from removal, installation, etc."))
  183. (define-key menu-map [md]
  184. '(menu-item "Mark for Removal" jul-package-menu-mark-delete
  185. :help "Mark package for removal, move to the next line"))
  186. (define-key menu-map [mupgrades]
  187. '(menu-item "Mark Upgradable Packages" jul-package-menu-mark-upgrades
  188. :help "Mark packages that need upgraded"))
  189. (define-key menu-map [mx]
  190. '(menu-item "Execute Actions" jul-package-menu-execute
  191. :help "Perform all the marked actions"))
  192. (define-key menu-map [mC]
  193. '(menu-item "Clean temp directory" jul-package-clean-temp-dir
  194. :help
  195. "Remove all .tlz & sha1sum files from the temp directory"))
  196. map)
  197. "Local keymap for `jul-package-menu-mode' buffers.")
  198. (defun jul-package-menu-refresh ()
  199. "Refresh the package list."
  200. (interactive)
  201. (unless (derived-mode-p 'jul-package-menu-mode)
  202. (user-error "The current buffer is not a Package Menu"))
  203. (jul-package-refresh-contents sync-flag)
  204. (jul-package-menu--generate t t))
  205. (defun jul-package-clean-temp-dir ()
  206. "This function just remove all files from the temperary directory.
  207. It purges the directory of all tlz and sha1sums."
  208. (interactive)
  209. (shell-command (format "rm %s*.tlz %s*.sha1sum"
  210. *jul-package-temp-dir* *jul-package-temp-dir*))
  211. (message "Temp directory cleaned!"))
  212. (defun jul-package-menu--find-upgrades ()
  213. "This function looks though all the current tabulated entries and finds the
  214. ones that are in need of upgrading.
  215. First it seperates them into two list, installed and available, then it removes
  216. the stuff that isn't the same architecture as the stuff you have installed.
  217. Then it compares versions and will place the ones with the newer version into
  218. the upgrades list."
  219. (let (installed available upgrades)
  220. ;; Build list of installed/available packages in this buffer.
  221. (dolist (entry tabulated-list-entries)
  222. ;; ENTRY is (PKG-DESC [NAME VERSION ARCH BUILD REPO])
  223. (let ((pkg-desc (car entry))
  224. (repo (aref (cadr entry) 4)))
  225. (cond ((string= repo "installed")
  226. (push pkg-desc installed))
  227. (t ;assuming everything else isn't installed
  228. (push (cons (jul-package-desc-name pkg-desc) pkg-desc)
  229. available)))))
  230. ;; Remove packages that aren't the same arch
  231. (dolist (elt available) ;remove other arch
  232. (let ((pack-arch (jul-package-desc-arch (cdr elt))))
  233. (unless (or
  234. (string= *emacs-arch* pack-arch)
  235. (string= "noarch" pack-arch)
  236. (string= "any" pack-arch))
  237. (setf available (remove elt available)))))
  238. ;; Loop through list of installed packages, finding upgrades.
  239. (dolist (pkg-desc installed)
  240. (let ((avail-pkg (assq (jul-package-desc-name pkg-desc) available)))
  241. (when avail-pkg
  242. (let ((number-inst-list-ver
  243. (mapcar #'string-to-number
  244. (split-string
  245. (jul-package-desc-version pkg-desc)
  246. "[a-z._]")))
  247. (number-avail-list-ver
  248. (mapcar #'string-to-number
  249. (split-string
  250. (jul-package-desc-version (cdr avail-pkg))
  251. "[a-z._]"))))
  252. (when (version-list-<
  253. number-inst-list-ver
  254. number-avail-list-ver)
  255. (push avail-pkg upgrades))))))
  256. upgrades))
  257. (defun jul-package-menu-mark-upgrades ()
  258. "This function will select all the packages to be upgraded.
  259. Note that when upgrading the `pkg' program (Dragora's package
  260. manipulation program) will automatically update the installed list.
  261. Therefore, you do not need to select an installed package for
  262. removal."
  263. (interactive)
  264. (let ((packs-to-upgrade (jul-package-menu--find-upgrades)))
  265. (if (null packs-to-upgrade)
  266. (message "No packages to upgrade.")
  267. (progn
  268. (goto-char (point-min))
  269. (while (not (eobp))
  270. (let* ((pkg-desc (tabulated-list-get-id))
  271. (upgrade (cdr (assq (jul-package-desc-name pkg-desc)
  272. packs-to-upgrade))))
  273. (cond ((null upgrade)
  274. (forward-line 1))
  275. ((equal pkg-desc upgrade)
  276. (tabulated-list-put-tag "U" t))
  277. (t
  278. (tabulated-list-put-tag " " t)))))))))
  279. (defun jul-package-desc-full-name (pkg-desc)
  280. "PKG-DESC should get the tabulated list ID.
  281. This function just concats the package name with the version"
  282. (format "%s-%s"
  283. (jul-package-desc-name pkg-desc)
  284. (jul-package-desc-version pkg-desc)))
  285. ;; This probably could be written better... But so could 80% of this program
  286. (defun sha1sum-check (full-pack-sha1)
  287. "This function check the sha1. Return t if okay, nil if not.
  288. FULL-PACK-SHA1 is the full name of the package you wish to check."
  289. (let ((cur-dir (cadr (split-string (pwd) " "))))
  290. (with-temp-buffer
  291. (shell-command (concat "cd " *jul-package-temp-dir* " ; sha1sum -c "
  292. full-pack-sha1)
  293. (current-buffer))
  294. (goto-char (point-min))
  295. (when (search-forward "OK" nil t)
  296. t))
  297. (shell-command "cd " cur-dir)))
  298. (defun jul-package-upgrade (pkg-list)
  299. "PKG-LIST should a list of all the packages to be upgraded of the form
  300. tabulated-list-id.
  301. This function will download and upgrade all packages using
  302. the Dragora's package manipulation tool 'pkg'.
  303. This function also checks the sha1sum of the package. If it fails, that package
  304. doesn't get added to the string-of-pkg string. As long as 1 package passes the
  305. check, the `pass' lexical variable will let you upgrade."
  306. (let (string-of-pkg pass)
  307. (dolist (pkg pkg-list)
  308. (let* ((pack-name (format "%s" (jul-package-desc-name pkg)))
  309. (full-tlz (concat pack-name "-"
  310. (jul-package-desc-version pkg) "-"
  311. (jul-package-desc-arch pkg) "-"
  312. (jul-package-desc-build pkg)
  313. ".tlz"))
  314. (full-sha1 (concat full-tlz ".sha1sum"))
  315. (full-tlz-path (concat *jul-package-temp-dir* full-tlz))
  316. (full-sha1-path (concat *jul-package-temp-dir* full-sha1))
  317. (repo))
  318. (dolist (elt jul-package-repos)
  319. (when (string= (jul-package-desc-repo pkg) (car elt))
  320. (setf repo (cdr elt))))
  321. (with-temp-file full-tlz-path
  322. (url-insert-file-contents (concat repo pack-name "/" full-tlz)))
  323. (with-temp-file full-sha1-path
  324. (url-insert-file-contents (concat repo pack-name "/" full-sha1)))
  325. (when (sha1sum-check full-sha1-path)
  326. (message "sha1sum check passed!")
  327. (setf pass t) ;at least one package has to pass
  328. (setf string-of-pkg (concat string-of-pkg full-tlz-path " ")))))
  329. (when pass
  330. (let ((buf (get-buffer-create "*pkg upgrade Output*")))
  331. (switch-to-buffer buf)
  332. (shell-command (concat "echo "
  333. (read-passwd "Password: ") " | sudo -S pkg upgrade "
  334. string-of-pkg) buf))
  335. (switch-to-buffer "*jul-package-list*"))
  336. (jul-package-menu-refresh)))
  337. (defun jul-package-install (pkg-list)
  338. "PKG-LIST should a list of all the packages to be upgraded of the
  339. form tabulated-list-id. This function will download and install PKG
  340. using the Dragora's package manipulation tool 'pkg'.
  341. This function also checks the sha1sum of the package. If it fails, that package
  342. doesn't get added to the string-of-pkg string. As long as 1 package passes the
  343. check, the `pass' lexical variable will let you install."
  344. (let (string-of-pkg pass)
  345. (dolist (pkg pkg-list)
  346. (let* ((pack-name (format "%s" (jul-package-desc-name pkg)))
  347. (full-tlz (concat pack-name "-"
  348. (jul-package-desc-version pkg) "-"
  349. (jul-package-desc-arch pkg) "-"
  350. (jul-package-desc-build pkg)
  351. ".tlz"))
  352. (full-sha1 (concat full-tlz ".sha1sum"))
  353. (full-tlz-path (concat *jul-package-temp-dir* full-tlz))
  354. (full-sha1-path (concat *jul-package-temp-dir* full-sha1))
  355. (repo))
  356. (dolist (elt jul-package-repos)
  357. (when (string= (jul-package-desc-repo pkg) (car elt))
  358. (setf repo (cdr elt))))
  359. (with-temp-file full-tlz-path
  360. (url-insert-file-contents (concat repo pack-name "/" full-tlz)))
  361. (with-temp-file full-sha1-path
  362. (url-insert-file-contents (concat repo pack-name "/" full-sha1)))
  363. (when (sha1sum-check full-sha1-path)
  364. (message "sha1sum check passed!")
  365. (setf pass t) ;at least one package has to pass
  366. (setf string-of-pkg (concat string-of-pkg full-tlz-path " ")))))
  367. (when pass
  368. (let ((buf (get-buffer-create "*pkg add Output*")))
  369. (switch-to-buffer buf)
  370. (shell-command (concat "echo "
  371. (read-passwd "Password: ") " | sudo -S pkg add "
  372. string-of-pkg) buf))
  373. (switch-to-buffer "*jul-package-list*"))
  374. (jul-package-menu-refresh)))
  375. (defun jul-package-delete (pkg-list)
  376. "PKG-LIST should a list of all the packages to be removed of the
  377. form tabulated-list-id. This function will uninstall and remove
  378. installed packages using the Dragora package manipulation tool 'pkg'."
  379. (let (string-of-pkg)
  380. (dolist (pkg pkg-list)
  381. (let* ((full-tlz (concat (format "%s" (jul-package-desc-name pkg)) "-"
  382. (jul-package-desc-version pkg) "-"
  383. (jul-package-desc-arch pkg) "-"
  384. (jul-package-desc-build pkg) ".tlz"))
  385. (full-tlz-path (concat *jul-package-installed-dir* full-tlz)))
  386. (setf string-of-pkg (concat string-of-pkg full-tlz-path " "))))
  387. (let ((buf (get-buffer-create "*pkg remove Output*")))
  388. (switch-to-buffer buf)
  389. (shell-command (concat "echo "
  390. (read-passwd "Password: ") " | sudo -S pkg remove "
  391. string-of-pkg) buf))
  392. (if (member "*jul-package-list*" (mapcar #'buffer-name (buffer-list)))
  393. (switch-to-buffer "*jul-package-list*")
  394. (switch-to-buffer "*jul-package-installed-list*"))
  395. (jul-package-menu-refresh)))
  396. (defun jul-package-remove-tlz (pkg-list)
  397. "PKG-LIST should be a list of all the packages to be removed from the temp
  398. directory of the from tabulated-list-id."
  399. (let (string-of-pkg)
  400. (dolist (pkg pkg-list)
  401. (let* ((full-tlz (concat (format "%s" (jul-package-desc-name pkg)) "-"
  402. (jul-package-desc-version pkg) "-"
  403. (jul-package-desc-arch pkg) "-"
  404. (jul-package-desc-build pkg) ".tlz*"))
  405. (full-tlz-path (concat *jul-package-temp-dir* full-tlz)))
  406. (setf string-of-pkg (concat string-of-pkg full-tlz-path " "))))
  407. (shell-command (concat "rm " string-of-pkg)))
  408. (message "Files removed!"))
  409. (defun jul-package-menu-execute (&optional noquery)
  410. "Perform marked Package Menu actions.
  411. Packages marked for installation are downloaded and installed;
  412. Packages marked for upgrade are downloaded and upgraded;
  413. packages marked for deletion are removed.
  414. Optional argument NOQUERY non-nil means do not ask the user to confirm."
  415. (interactive)
  416. (unless (derived-mode-p 'jul-package-menu-mode)
  417. (error "The current buffer is not in Package Menu mode"))
  418. (let (install-list delete-list upgrade-list cmd pkg-desc)
  419. (save-excursion
  420. (goto-char (point-min))
  421. (while (not (eobp))
  422. (setq cmd (char-after))
  423. (unless (eq cmd ?\s)
  424. ;; This is the key PKG-DESC.
  425. (setq pkg-desc (tabulated-list-get-id))
  426. (cond ((eq cmd ?D)
  427. (push pkg-desc delete-list))
  428. ((eq cmd ?I)
  429. (push pkg-desc install-list))
  430. ((eq cmd ?U)
  431. (push pkg-desc upgrade-list))))
  432. (forward-line)))
  433. (when install-list
  434. (if (or
  435. noquery
  436. (yes-or-no-p
  437. (if (= (length install-list) 1)
  438. (format "Install package `%s'? "
  439. (jul-package-desc-full-name (car install-list)))
  440. (format "Install these %d packages (%s)? "
  441. (length install-list)
  442. (mapconcat #'jul-package-desc-full-name
  443. install-list ", ")))))
  444. (jul-package-install install-list)))
  445. ;; Delete packages, prompting if necessary.
  446. (when delete-list
  447. (if (or
  448. noquery
  449. (yes-or-no-p
  450. (if (= (length delete-list) 1)
  451. (format "Delete package `%s'? "
  452. (jul-package-desc-full-name (car delete-list)))
  453. (format "Delete these %d packages (%s)? "
  454. (length delete-list)
  455. (mapconcat #'jul-package-desc-full-name
  456. delete-list ", ")))))
  457. (jul-package-delete delete-list)))
  458. (when upgrade-list
  459. (if (or
  460. noquery
  461. (yes-or-no-p
  462. (if (= (length upgrade-list) 1)
  463. (format "Upgrade package `%s'? "
  464. (jul-package-desc-full-name (car upgrade-list)))
  465. (format "Upgrade these %d packages (%s)? "
  466. (length upgrade-list)
  467. (mapconcat #'jul-package-desc-full-name
  468. upgrade-list ", ")))))
  469. (jul-package-upgrade upgrade-list)))
  470. ;; Remove the tlz files that you probably don't need
  471. (when (or install-list upgrade-list) ;anything with a new .tlz
  472. (let ((tlz-list (append install-list upgrade-list)))
  473. (if (or
  474. noquery
  475. (yes-or-no-p
  476. (if (= (length tlz-list) 1)
  477. (format "Clean package `%s' from temp directory? "
  478. (jul-package-desc-full-name (car tlz-list)))
  479. (format "Clean these %d packages (%s) from temp directory? "
  480. (length tlz-list)
  481. (mapconcat #'jul-package-desc-full-name
  482. tlz-list ", ")))))
  483. (jul-package-remove-tlz tlz-list))))
  484. (if (or delete-list install-list upgrade-list)
  485. (jul-package-menu--generate t t)
  486. (message "No operations specified."))))
  487. (defun jul-package-menu-mark-delete (&optional _num)
  488. "Mark current package for deletion/removal and move to the next line."
  489. (interactive "p")
  490. (if (string= (jul-package-menu-get-repo) "installed")
  491. (tabulated-list-put-tag "D" t)
  492. (forward-line)))
  493. (defun jul-package-menu-mark-unmark (&optional _num)
  494. "Clear any mark on a package and move to the next line."
  495. (interactive "p")
  496. (tabulated-list-put-tag " " t))
  497. (defun jul-package-menu-mark-install (&optional _num)
  498. "Mark a package for installation and move to the next line.
  499. This function will only let you select packages that are the
  500. same arch as your system (and anything that isn't arch
  501. specific)."
  502. (interactive "p")
  503. (let ((pack-arch (jul-package-menu-get-arch)))
  504. (if (or (string= (jul-package-menu-get-repo) "installed")
  505. (not (or (string= *emacs-arch* pack-arch)
  506. (string= "noarch" pack-arch)
  507. (string= "any" pack-arch))))
  508. (forward-line)
  509. (tabulated-list-put-tag "I" t))))
  510. (defun jul-package-menu-get-repo ()
  511. "Grab the current package's repo."
  512. (let* ((id (tabulated-list-get-id))
  513. (entry (and id (assq id tabulated-list-entries))))
  514. (if entry
  515. (aref (cadr entry) 4)
  516. "")))
  517. (defun jul-package-menu-get-arch ()
  518. "Grab the current package's arch."
  519. (let* ((id (tabulated-list-get-id))
  520. (entry (and id (assq id tabulated-list-entries))))
  521. (if entry
  522. (aref (cadr entry) 2)
  523. "")))
  524. (define-derived-mode jul-package-menu-mode tabulated-list-mode "Jul Package Menu"
  525. "Major mode for browsing a list of packages"
  526. (setq tabulated-list-format
  527. `[("Package" 25 nil) ;there will eventually be something (not just nil)
  528. ("Version" 20 nil)
  529. ("Arch" 10 nil)
  530. ("Build" 10 nil)
  531. ("Repo" 13 nil)
  532. ("Description" 0 nil)])
  533. (setq tabulated-list-padding 2)
  534. ;; There will be some sort of refreshing thing
  535. (setq tabulated-list-sort-key (cons "Repo" nil))
  536. (add-hook 'tabulated-list-revert-hook 'jul-package-menu--refresh nil)
  537. (tabulated-list-init-header))
  538. (defun jul-package--push (pkg-desc listname)
  539. "A simple funtion used to check if the current package is alright in the list
  540. to be printed to the screen."
  541. (unless (member pkg-desc listname)
  542. pkg-desc))
  543. (defun jul-space-fixer (split-pack)
  544. "SPLIT-PACK should be the full name of a package after being split by the
  545. split-string function with ' '.
  546. This function will return a list that contains 3 elements: the repo, the full
  547. package name, and the description (if there is one) of the form
  548. '(DESCRIPTION REPO PACKAGE)."
  549. (let (pkg-list description)
  550. (dolist (elt split-pack)
  551. (unless (string= elt "")
  552. (setf pkg-list (cons elt pkg-list))))
  553. (setf pkg-list (reverse pkg-list)) ;so that description is in right order
  554. (while (> (length pkg-list) 2)
  555. (let ((word (car (cddr pkg-list))))
  556. (setf description (concat description word " "))
  557. (setf pkg-list (remove word pkg-list))))
  558. (if description
  559. (push description pkg-list)
  560. (push " " pkg-list))))
  561. (defun jul-hyphenated-name-fixer (split-pack)
  562. "SPLIT-PACK should be the full name of a package after being split by the
  563. split-string function with '-'.
  564. This function will make sure that it doesn't use a part of the name of the
  565. package as the version, build, or arch. It does this by checking the size of
  566. SPLIT-PACK."
  567. (if (> (length split-pack) 4)
  568. (let* ((fir-word (car split-pack))
  569. (sec-word (cadr split-pack))
  570. (new-word (concat fir-word "-" sec-word)))
  571. (jul-hyphenated-name-fixer (cons new-word (remove sec-word
  572. (remove fir-word
  573. split-pack)))))
  574. split-pack))
  575. (defun jul-parse-n-place (file)
  576. "Grab each package that is found in FILE and place into a list.
  577. This is rather inefficient and will be changed soon."
  578. (with-temp-buffer
  579. (insert-file-contents file)
  580. (let ((num-of-packs (count-lines (point-min) (point-max)))
  581. (current-pack 0)
  582. (pack-list nil))
  583. (while (< current-pack num-of-packs)
  584. (let ((first-point (point)))
  585. (end-of-line)
  586. (copy-region-as-kill first-point (point))
  587. (let* ((raw-output (jul-space-fixer
  588. (split-string (car kill-ring) " ")))
  589. (split-pack (jul-hyphenated-name-fixer
  590. (split-string (car (cddr raw-output)) "-")))
  591. (struct-pack (jul-package-desc-from-define
  592. (car split-pack)
  593. (cadr split-pack)
  594. (car (cddr split-pack))
  595. (cadr raw-output)
  596. (car (split-string
  597. (cadr (cddr split-pack)) ".tlz"))
  598. (car raw-output))))
  599. (setf pack-list (cons (cons
  600. (jul-package-desc-name struct-pack)
  601. struct-pack)
  602. pack-list)))
  603. (forward-line)
  604. (beginning-of-line))
  605. (setf current-pack (+ current-pack 1)))
  606. pack-list)))
  607. (defmacro jul-package--with-work-buffer (location file &rest body)
  608. "Run BODY in a buffer containing the contents of FILE at LOCATION.
  609. LOCATION is the base location of a package archive, and should be
  610. one of the URLs (or file names) specified in `package-archives'.
  611. FILE is the name of a file relative to that base location.
  612. This macro retrieves FILE from LOCATION into a temporary buffer,
  613. and evaluates BODY while that buffer is current. This work
  614. buffer is killed afterwards. Return the last value in BODY."
  615. (declare (indent 2) (debug t))
  616. `(with-temp-buffer
  617. (if (string-match-p "\\`https?:" ,location)
  618. (url-insert-file-contents (concat ,location ,file))
  619. (unless (file-name-absolute-p ,location)
  620. (error "Repo location %s is not an absolute file name"
  621. ,location))
  622. (insert-file-contents (expand-file-name ,file ,location)))
  623. ,@body))
  624. (defun jul-package--download-one-repo (file repo)
  625. "Retrieve an repo FILE from REPO, and cache it.
  626. REPO should be a cons cell of the form (NAME . LOCATION),
  627. similar to an entry in `*jul-package-repo*'."
  628. (let ((dir (expand-file-name (format "repos/%s" (car repo))
  629. *jul-package-temp-dir*)))
  630. (jul-package--with-work-buffer (cdr repo) file
  631. ;; Read the retrieved buffer to make sure it is valid (e.g. it
  632. ;; may fetch a URL redirect page).
  633. ;; (when (stringp (read (current-buffer)))
  634. (progn
  635. (make-directory dir t)
  636. (write-region nil nil (expand-file-name file dir) nil 'silent)))))
  637. ;; Needs improved, maybe make a list of directories to remove?
  638. (defun jul-remove-unwanted-directories (list-of-files)
  639. "LIST-OF-FILES should be the contents of installed directory.
  640. This function will remove the directories we don't wish to show in jul-mode."
  641. (remove "."
  642. (remove ".."
  643. (remove "description"
  644. (remove "post-install"
  645. (remove "pre-post"
  646. (remove "removed"
  647. list-of-files)))))))
  648. (defun jul-package-refresh-contents (&optional sync)
  649. "This function will grab the current version of the
  650. database files on the user repo and add all the packages to a
  651. big list. SYNC is used to sync with jul or not. If SYNC is
  652. nil, then do NOT sync with the server. If non-nil, sync with
  653. server. It also probes the installed directory on your
  654. system and makes a list of all the installed programs."
  655. (setf *jul-package-repo* nil) ;clear current uninstalled items list
  656. (setf *jul-package-installed* nil) ;clear current installed items list
  657. (when sync
  658. (unless (file-directory-p *jul-package-temp-dir*)
  659. (make-directory *jul-package-temp-dir*))
  660. (let ((temp-file (concat *jul-package-temp-dir* "temp")))
  661. (shell-command "jul sync")
  662. (shell-command (concat "jul search > " temp-file))
  663. (message "Syncing jul...")
  664. (setf *jul-package-repo* (jul-parse-n-place temp-file)))
  665. (message "Sync complete"))
  666. (let* ((installed-pack-dir-contents (directory-files
  667. *jul-package-installed-dir*))
  668. (installed-pack-list
  669. (jul-remove-unwanted-directories installed-pack-dir-contents)))
  670. (dolist (elt installed-pack-list)
  671. (let* ((split-pack (jul-hyphenated-name-fixer (split-string elt "-")))
  672. (cur-pack-struct (jul-package-desc-from-define
  673. (car split-pack)
  674. (cadr split-pack)
  675. (car (cddr split-pack))
  676. "installed"
  677. (cadr (cddr split-pack))
  678. " "))
  679. (cur-pack-list (cons (jul-package-desc-name cur-pack-struct)
  680. cur-pack-struct)))
  681. (setf *jul-package-installed* (cons cur-pack-list
  682. *jul-package-installed*)))))
  683. (message "Complete"))
  684. (defun jul-package-menu--print-info (pkg-desc)
  685. "Convert the complicated jul-package-desc-struct, to something the tabulated
  686. mode can read. PKG-DESC is of form jul-package-desc-struct"
  687. (let ((name (jul-package-desc-name pkg-desc))
  688. (version (jul-package-desc-version pkg-desc))
  689. (arch (jul-package-desc-arch pkg-desc))
  690. (repo (jul-package-desc-repo pkg-desc))
  691. (build (jul-package-desc-build pkg-desc))
  692. (description (jul-package-desc-description pkg-desc)))
  693. `(,pkg-desc
  694. ,`[,(list (symbol-name name)) ,version ,arch ,build ,repo ,description])))
  695. (defun jul-package-menu--refresh (&optional packages)
  696. "Refresh the displayed menu."
  697. (unless packages (setq packages t))
  698. (let ((info-list nil)
  699. (name nil))
  700. ;; Installed packages:
  701. (dolist (elt *jul-package-installed*) ;needs to be updated before this
  702. (setq name (car elt))
  703. (when packages
  704. (setq info-list
  705. (cons (jul-package--push (cdr elt) info-list) info-list))))
  706. ;; Uninstalled Packages:
  707. (when *jul-package-repo*
  708. (dolist (elt *jul-package-repo*) ;needs to be updated before this
  709. (setq name (car elt))
  710. (when (or (eq packages t) (memq name packages))
  711. (setq info-list
  712. (cons (jul-package--push (cdr elt) info-list) info-list)))))
  713. (setq tabulated-list-entries
  714. (mapcar #'jul-package-menu--print-info info-list))))
  715. (defun jul-package-menu--generate (remember-pos packages)
  716. "Populate the Package Menu.
  717. If REMEMBER-POS is non-nil, keep point on the same entry.
  718. PACKAGES should be t, which means to display all known packages,
  719. or a list of package names (symbols) to display."
  720. (jul-package-menu--refresh packages)
  721. (setf (car (aref tabulated-list-format 0)) "Package")
  722. (tabulated-list-init-header)
  723. (tabulated-list-print remember-pos))
  724. (defun jul-list-package (&optional packages)
  725. "A mode used to browser, install, and remove Dragora binaries from the user
  726. repo and system."
  727. (interactive)
  728. (setf sync-flag t)
  729. (let* ((buf (get-buffer-create "*jul-package-list*"))
  730. (win (get-buffer-window buf)))
  731. (with-current-buffer buf
  732. (jul-package-menu-mode)
  733. (jul-package-refresh-contents sync-flag)
  734. (jul-package-menu--generate nil packages))
  735. (if win
  736. (select-window win)
  737. (switch-to-buffer buf))))
  738. (defun jul-list-installed (&optional packages)
  739. "A mode used to browser and remove Dragora binaries from the system."
  740. (interactive)
  741. (setf sync-flag nil)
  742. (let* ((buf (get-buffer-create "*jul-package-installed-list*"))
  743. (win (get-buffer-window buf)))
  744. (with-current-buffer buf
  745. (jul-package-menu-mode)
  746. (jul-package-refresh-contents sync-flag)
  747. (jul-package-menu--generate nil packages))
  748. (if win
  749. (select-window win)
  750. (switch-to-buffer buf))))
  751. ;;; jul-mode.el ends here