Permalink
Browse files

Replace cl-fad by UIOP.

  • Loading branch information...
1 parent ae2acff commit 28069455315fda9251192daf842fc567ef28fde1 @fukamachi committed Aug 26, 2015
Showing with 87 additions and 84 deletions.
  1. +1 −2 qlot-install.asd
  2. +1 −1 qlot-test.asd
  3. +12 −11 src/archive.lisp
  4. +2 −2 src/http.lisp
  5. +25 −25 src/install.lisp
  6. +2 −2 src/parser.lisp
  7. +13 −15 src/source.lisp
  8. +3 −5 src/source/git.lisp
  9. +3 −1 src/tmp.lisp
  10. +5 −1 src/util.lisp
  11. +11 −11 t/qlot.lisp
  12. +9 −8 t/server.lisp
View
@@ -15,7 +15,6 @@
:gzip-stream
:ironclad
:yason
- :cl-fad
:alexandria
:cl-ppcre
:uiop
@@ -30,7 +29,7 @@
(:file "server" :depends-on ("source" "parser" "tmp"))
(:file "http")
(:file "shell")
- (:file "tmp")
+ (:file "tmp" :depends-on ("util"))
(:file "archive")
(:file "source" :depends-on ("tmp" "util"))
(:module "dist-sources"
View
@@ -13,7 +13,7 @@
:license "MIT"
:depends-on (:qlot
:qlot-install
- :cl-fad
+ :uiop
:prove)
:components ((:module "t"
:components
View
@@ -1,9 +1,10 @@
(in-package :cl-user)
(defpackage qlot.archive
(:use :cl)
- (:import-from :fad
- :pathname-parent-directory
- :walk-directory)
+ (:import-from :uiop
+ :pathname-parent-directory-pathname
+ :directory-files
+ :subdirectories)
(:import-from :archive
:create-tar-file
:open-archive
@@ -18,9 +19,8 @@
(in-package :qlot.archive)
(defun create-tarball (directory destination)
- (let ((filelist '())
- (ignore-len (length (pathname-directory (truename (fad:pathname-parent-directory directory)))))
- (*default-pathname-defaults* (truename (fad:pathname-parent-directory directory)))
+ (let ((ignore-len (length (pathname-directory (truename (uiop:pathname-parent-directory-pathname directory)))))
+ (*default-pathname-defaults* (truename (uiop:pathname-parent-directory-pathname directory)))
(tar-file (make-pathname
:directory (pathname-directory destination)
:name (pathname-name destination)))
@@ -36,12 +36,13 @@
(find ".git"
(nthcdr ignore-len (pathname-directory path))
:test #'string=)))
- (fad:walk-directory directory
- (lambda (file)
- (push (to-relative file) filelist))
- :test (complement #'git-dir-p)))
+ (archive::create-tar-file
+ tar-file
+ (mapcar #'to-relative
+ (remove-if #'git-dir-p
+ (nconc (uiop:subdirectories directory)
+ (uiop:directory-files directory))))))
- (archive::create-tar-file tar-file filelist)
(salza2:gzip-file tar-file tar-gz-file)
(delete-file tar-file)
tar-gz-file))
View
@@ -1,7 +1,7 @@
(in-package :cl-user)
(defpackage qlot.http
(:use :cl)
- (:import-from :fad
+ (:import-from :uiop
:file-exists-p)
(:import-from :alexandria
:with-gensyms
@@ -47,7 +47,7 @@
(restart-case (setf stream (safety-http-request url :want-stream t))
(retry-download ()
:report "Retry to download."
- (when (fad:file-exists-p output)
+ (when (uiop:file-exists-p output)
(delete-file output))
(go downloading))))
(with-open-file (out output
View
@@ -29,15 +29,16 @@
:with-package-functions
:ensure-installed-in-local-quicklisp
:pathname-in-directory-p
- :all-required-systems)
- (:import-from :fad
- :pathname-as-directory
- :pathname-absolute-p
- :pathname-directory-pathname
- :generate-random-string
+ :all-required-systems
+ :generate-random-string)
+ (:import-from :uiop
+ :ensure-directory-pathname
+ :absolute-pathname-p
:file-exists-p
:directory-exists-p
- :delete-directory-and-files)
+ :directory-pathname-p
+ :pathname-directory-pathname
+ :delete-directory-tree)
(:export :install-quicklisp
:install-qlfile
:install-project))
@@ -56,7 +57,7 @@
(format t "~&Installing Quicklisp to ~A ...~%" path)
(let ((*standard-output* (make-broadcast-stream))
(quicklisp-file (merge-pathnames (format nil "quicklisp-~A.lisp"
- (fad::generate-random-string))
+ (generate-random-string))
*tmp-directory*)))
(ensure-directories-exist *tmp-directory*)
(download-file "http://beta.quicklisp.org/quicklisp.lisp"
@@ -113,18 +114,18 @@
(mapc #'uninstall (all-dists)))))
(defun canonical-qlhome (qlhome &optional (base *default-pathname-defaults*))
- (setf qlhome (fad:pathname-as-directory qlhome))
- (if (fad:pathname-absolute-p qlhome)
+ (setf qlhome (uiop:ensure-directory-pathname qlhome))
+ (if (uiop:absolute-pathname-p qlhome)
qlhome
(merge-pathnames qlhome base)))
(defun install-qlfile (file &key (quicklisp-home #P"quicklisp/"))
- (unless (fad:file-exists-p file)
+ (unless (uiop:file-exists-p file)
(error "File does not exist: ~A" file))
- (let ((qlhome (canonical-qlhome quicklisp-home (fad:pathname-directory-pathname file))))
+ (let ((qlhome (canonical-qlhome quicklisp-home (uiop:pathname-directory-pathname file))))
- (unless (fad:file-exists-p qlhome)
+ (unless (uiop:directory-exists-p qlhome)
(install-quicklisp qlhome))
(unless (find-package :ql)
@@ -135,12 +136,12 @@
(format t "~&Successfully installed.~%")))
(defun update-qlfile (file &key (quicklisp-home #P"quicklisp/"))
- (unless (fad:file-exists-p file)
+ (unless (uiop:file-exists-p file)
(error "File does not exist: ~A" file))
- (let ((qlhome (canonical-qlhome quicklisp-home (fad:pathname-directory-pathname file))))
+ (let ((qlhome (canonical-qlhome quicklisp-home (uiop:pathname-directory-pathname file))))
- (unless (fad:directory-exists-p qlhome)
+ (unless (uiop:directory-exists-p qlhome)
(error "~S does not exist." qlhome))
(unless (find-package :ql)
@@ -193,8 +194,8 @@
(update-in-place dist new-dist))))))
(defun apply-qlfile-to-qlhome (file qlhome &key ignore-lock)
- (let ((*tmp-directory* (fad:pathname-as-directory (merge-pathnames (fad::generate-random-string)
- (merge-pathnames #P"tmp/qlot/" qlhome))))
+ (let ((*tmp-directory* (uiop:ensure-directory-pathname (merge-pathnames (generate-random-string)
+ (merge-pathnames #P"tmp/qlot/" qlhome))))
(all-sources (prepare-qlfile file :ignore-lock ignore-lock)))
(start-server all-sources)
@@ -241,7 +242,7 @@
(*package* (find-package :asdf-user)))
(with-package-functions :ql (bundle-systems)
(asdf::collect-sub*directories-asd-files
- (fad:pathname-directory-pathname file)
+ (uiop:pathname-directory-pathname file)
:collect (lambda (asd)
(unless (or (pathname-in-directory-p asd qlhome)
;; KLUDGE: Ignore skeleton.asd of CL-Project
@@ -264,8 +265,7 @@
for (project-name . contents) = (freeze-source source)
do (format out "~&(~S .~% (~{~S ~S~^~% ~}))~%" project-name contents)))))
- (when (fad:directory-exists-p *tmp-directory*)
- (fad:delete-directory-and-files *tmp-directory*))))
+ (uiop:delete-directory-tree *tmp-directory* :validate t :if-does-not-exist :ignore)))
(defgeneric install-project (object &rest args)
(:method ((object symbol) &rest args)
@@ -283,12 +283,12 @@
args)))
(:method ((object pathname) &rest args &key quicklisp-home &allow-other-keys)
(let* ((object (truename object))
- (dir (fad:pathname-directory-pathname object)))
+ (dir (uiop:pathname-directory-pathname object)))
(unless quicklisp-home
(setf args
(list* :quicklisp-home (merge-pathnames #P"quicklisp/" dir)
args)))
- (if (fad:directory-pathname-p object)
+ (if (uiop:directory-pathname-p object)
(apply #'install-qlfile (find-qlfile object) args)
(apply #'install-qlfile object args)))))
@@ -308,11 +308,11 @@
args)))
(:method ((object pathname) &rest args &key quicklisp-home &allow-other-keys)
(let* ((object (truename object))
- (dir (fad:pathname-directory-pathname object)))
+ (dir (uiop:pathname-directory-pathname object)))
(unless quicklisp-home
(setf args
(list* :quicklisp-home (merge-pathnames #P"quicklisp/" dir)
args)))
- (if (fad:directory-pathname-p object)
+ (if (uiop:directory-pathname-p object)
(apply #'update-qlfile (find-qlfile object) args)
(apply #'update-qlfile object args)))))
View
@@ -15,7 +15,7 @@
:source-ql)
(:import-from :qlot.error
:qlot-qlfile-error)
- (:import-from :fad
+ (:import-from :uiop
:file-exists-p)
(:import-from :alexandria
:delete-from-plist)
@@ -88,7 +88,7 @@
(defun prepare-qlfile (file &key ignore-lock)
(let ((default-ql-source (make-source 'source-ql :all :latest))
(lock-file (and (not ignore-lock)
- (fad:file-exists-p
+ (uiop:file-exists-p
(make-pathname :defaults file
:name (file-namestring file)
:type "lock"))))
View
@@ -6,10 +6,11 @@
(:import-from :qlot.util
:find-qlfile
:with-package-functions)
- (:import-from :fad
- :list-directory
+ (:import-from :uiop
+ :directory-files
+ :subdirectories
:directory-pathname-p
- :pathname-absolute-p)
+ :absolute-pathname-p)
(:import-from :ironclad
:byte-array-to-hex-string
:digest-file
@@ -200,15 +201,15 @@
(defgeneric (setf source-directory) (value source)
(:method (value (source source-has-directory))
(setf (slot-value source 'directory)
- (if (fad:pathname-absolute-p value)
+ (if (uiop:absolute-pathname-p value)
value
(tmp-path (pathname (format nil "~(~A~)/repos/" (type-of source)))
value)))))
(defgeneric (setf source-archive) (value source)
(:method (value (source source-has-directory))
(setf (slot-value source 'archive)
- (if (fad:pathname-absolute-p value)
+ (if (uiop:absolute-pathname-p value)
value
(tmp-path (pathname (format nil "~(~A~)/archive/" (type-of source)))
value)))))
@@ -219,17 +220,14 @@
(and (equal (pathname-type path) "asd")
;; KLUDGE: Ignore skeleton.asd of CL-Project
(not (search "skeleton" (pathname-name path)))))
- (collect-asd-files (path)
- (cond
- ((and (fad:directory-pathname-p path)
- (not (find (car (last (pathname-directory path)))
- asdf::*default-source-registry-exclusions*
- :test #'string=)))
- (collect-asd-files-in-directory path))
- ((asd-file-p path) (list path) )
- (T (list))))
(collect-asd-files-in-directory (dir)
- (mapcan #'collect-asd-files (fad:list-directory dir))))
+ (unless (find (car (last (pathname-directory dir)))
+ asdf::*default-source-registry-exclusions*
+ :test #'string=)
+ (nconc
+ (remove-if-not #'asd-file-p
+ (uiop:directory-files dir))
+ (mapcan #'collect-asd-files-in-directory (uiop:subdirectories dir))))))
(collect-asd-files-in-directory (source-directory source))))
(defparameter *dependencies* nil)
View
@@ -7,9 +7,8 @@
(:import-from :qlot.shell
:safety-shell-command
:shell-command-error)
- (:import-from :fad
- :directory-exists-p
- :delete-directory-and-files)
+ (:import-from :uiop
+ :delete-directory-tree)
(:export :source-git
:retry-git-clone))
(in-package :qlot.source.git)
@@ -130,8 +129,7 @@
destination))
(retry-git-clone ()
:report "Retry to git clone the repository."
- (when (fad:directory-exists-p destination)
- (fad:delete-directory-and-files destination))
+ (uiop:delete-directory-tree destination :validate t :if-does-not-exist :ignore)
(go git-cloning))))
(when checkout-to
(let ((*error-output* (make-broadcast-stream)))
View
@@ -1,12 +1,14 @@
(in-package :cl-user)
(defpackage qlot.tmp
(:use :cl)
+ (:import-from :qlot.util
+ :generate-random-string)
(:export :*tmp-directory*
:tmp-path))
(in-package :qlot.tmp)
(defvar *tmp-directory*
- (merge-pathnames (format nil "qlot-~A/" (fad::generate-random-string))
+ (merge-pathnames (format nil "qlot-~A/" (generate-random-string))
(uiop:temporary-directory)))
(defun tmp-path (&rest pathnames)
View
@@ -8,7 +8,8 @@
:call-in-local-quicklisp
:with-local-quicklisp
:ensure-installed-in-local-quicklisp
- :all-required-systems))
+ :all-required-systems
+ :generate-random-string))
(in-package :qlot.util)
(defmacro with-quicklisp-home (qlhome &body body)
@@ -155,3 +156,6 @@ with the same key."
:test #'string=))))
system
qlhome)))
+
+(defun generate-random-string ()
+ (format nil "~36R" (random (expt 36 #-gcl 8 #+gcl 5))))
Oops, something went wrong.

0 comments on commit 2806945

Please sign in to comment.