commit c4d704df3b8ff36bd1e1a1910c955471b32ddc2f Spenser Truex <web@spensertruex.com> 2019-11-04 16:36:11 -0800 Core backups work sanely, with continuation.
TODO.org | 4 ++-- code/install.lisp | 56 ++++++++++++++++++++++++++++++++++++++++++++++++------- code/util.lisp | 26 +++++++++++++------------- 3 files changed, 64 insertions(+), 22 deletions(-)
diff --git a/TODO.org b/TODO.org index 7a35b97..9bfbc4d 100644 --- a/TODO.org +++ b/TODO.org @@ -9,8 +9,8 @@ - [0/2] Package failures :: Offer to modify init, or try another source. - [ ] Non-existent packages. - [ ] Packages failing to load. - - [0/2] Core image checks :: Revert safely. - - [ ] Core backup failed. + - [1/2] Core image checks :: Revert safely. + - [X] Core backup failed. - [ ] Check for dirty core image. - [X] Rename. equwal 2019-11-03 diff --git a/code/install.lisp b/code/install.lisp index a12fe0b..2195bec 100644 --- a/code/install.lisp +++ b/code/install.lisp @@ -1,6 +1,8 @@ (in-package #:clapt) (defparameter *installed* ";;; Leave this line for sbcl-librarian!") +(defparameter *logstream* t) +(defparameter *userstream* t) (eval-when (:compile-toplevel :load-toplevel :execute) (defun packages-doc (manager) @@ -21,16 +23,56 @@ (backup-core core (merge-pathnames #P".core.bak" sbclrc)) (update core)) -(defun installedp (sbclrc-path) - "Determine if sbcl-librarian is installed in the .sbclrc." - (with-open-file (sbclrc sbclrc-path - :direction :input - :if-does-not-exist nil) - (when sbclrc (until sbclrc *installed*)))) +(defmacro warner (level datum &rest arguments) + "Use log to manage output." + ;; This is ugly like this because using variables for a format spec is + ;; considered bad style. + (case level + (error `(error ,datum ,@arguments)) + (warn `(warn ,datum ,@arguments)) + (log `(format *logstream* (concatenate 'string "LOG: " + ,datum) + ,@arguments)) + (user `(format *userstream* ,datum ,@arguments)) + (otherwise (error "Bad warning spec.")))) + +#+5am (backup-core #p"~/org/sbcl.org" #p"~/example.delete") (defun backup-core (core backup) "Save original core image." - (copy-file core backup (* 1024 1024))) + (handler-case (copy-file core backup) + (:no-error (nothing) + (declare (ignore nothing)) + (warner user "~@{~a~}" + "Core was backed up from:" + (format nil "~%") + core + (format nil "~%to:~%") + backup + (format nil "~%"))) + (file-error (path-obj) + (let ((fail (file-error-pathname path-obj))) + (cond ((uiop:pathname-equal fail core) + (warner warn "~@{~a~}" + "The core does not exist, sbcl will have" + " to be started " + (format nil "with the:~%--core \"") + fail + (format nil "\"~%option to enable the ") + (format nil "libraries core.~%"))) + ((uiop:pathname-equal fail backup) + (warner log "~@{~a~}" + "The backup was aborted because there already is" + (format nil " one there at:~%") + fail + (format nil "~%and it is ") + (format nil "probably the vanilla one.~%"))) + (t (warner error "~@{~a~}" + "Unexpected backup failure. Submit a bug report:" + (format nil "~%core: ") core + (format nil "~%backup: ") backup + (format nil "~%failure path: ") fail + (format nil "~%")))))))) (defun write-to-init-file (sbclrc core systema) "Common Lisp code in the init file for cl-apt to install itself if not diff --git a/code/util.lisp b/code/util.lisp index 65e0783..7b11c77 100644 --- a/code/util.lisp +++ b/code/util.lisp @@ -18,19 +18,19 @@ (copy-stream from to size buffer 0)))) (defun copy-file (from to &optional (buffer-size 1024)) - (with-open-file (fr from - :element-type 'unsigned-byte - :if-does-not-exist nil) - (if fr - (with-open-file (to to :direction :output - :if-exists nil ;Want it to stay ORIGINAL. - :if-does-not-exist :create - :element-type 'unsigned-byte) - (when to - (copy-stream fr to buffer-size - (make-array buffer-size :element-type 'unsigned-byte) - 0))) - (warn "~%~%The core does not exist, sbcl will have to be started with the --core ~S option to enable the sbcl-librarian libraries core.~%~%" from)))) + "Copy a file, require file handling." + (with-open-file (fr from :element-type 'unsigned-byte + :if-does-not-exist :error) + (with-open-file (to to :direction :output + :if-exists :error + :if-does-not-exist :create + :element-type 'unsigned-byte) + (copy-stream fr to buffer-size + (make-array buffer-size :element-type 'unsigned-byte) + 0)))) +;; (copy-file #p"/home/jose/org/sbcl.org" #p"/home/jose/example.delete") + + (defun until (stream match) (let ((line (read-line stream nil nil)))