From 290916b0f03829f63211afffd72e018f41013d7b Mon Sep 17 00:00:00 2001
From: Dimitri Fontaine <dim@tapoueh.org>
Date: Wed, 14 Jan 2015 20:54:11 +0100
Subject: [PATCH] Attempt at fixing --self-upgrade.

The option currently only works within the same build environment where
the image was first build, as noted in #133. This is an attempt at
convincing ASDF not to load systems that pgloader depends on in order to
be able to load only the new pgloader definition.

While it looks sound in principle, I failed to have it work in the lab.
Given that previous to this patch nothing works at all, it's not a
regression, let's push it as is makes the code saner.

Also, it looks like asdf::*immutable-systems* is what we want here, but
that's asdf 3.1.x and we're not there yet.
---
 src/hooks.lisp  |  7 +++++++
 src/main.lisp   | 26 +++++++++++++++-----------
 src/params.lisp |  4 ++++
 3 files changed, 26 insertions(+), 11 deletions(-)

diff --git a/src/hooks.lisp b/src/hooks.lisp
index febc0a5..fea9841 100644
--- a/src/hooks.lisp
+++ b/src/hooks.lisp
@@ -29,3 +29,10 @@
 
 #+ccl  (push #'close-foreign-libs *save-exit-functions*)
 #+sbcl (push #'close-foreign-libs sb-ext:*init-hooks*)
+
+;;;
+;;; Register all loaded systems in the image, so that ASDF don't search for
+;;; them again when doing --self-upgrade
+;;;
+(setf pgloader::*self-upgrade-immutable-systems*
+      (remove "pgloader" (asdf:already-loaded-systems) :test #'string=))
diff --git a/src/main.lisp b/src/main.lisp
index efe446b..6c6823d 100644
--- a/src/main.lisp
+++ b/src/main.lisp
@@ -115,7 +115,7 @@
 (defvar *self-upgraded-already* nil
   "Keep track if we did reload our own source code already.")
 
-(defun self-upgrade (namestring)
+(defun self-upgrade (namestring &optional debug)
   "Load pgloader sources at PATH-TO-PGLOADER-SOURCES."
   (let ((pgloader-pathname (uiop:directory-exists-p
                             (uiop:parse-unix-namestring namestring))))
@@ -125,15 +125,19 @@
 
     ;; now the real thing
     (handler-case
-        (handler-bind ((condition #'muffle-warning))
+        (handler-bind ((warning #'muffle-warning))
           (let ((asdf:*central-registry* (list* pgloader-pathname
                                                 asdf:*central-registry*)))
             (format t "Self-upgrading from sources at ~s~%"
                     (uiop:native-namestring pgloader-pathname))
             (with-output-to-string (*standard-output*)
-              (asdf:operate 'asdf:load-op :pgloader :verbose nil))))
+              (asdf:load-system :pgloader
+                                :verbose nil
+                                :force-not *self-upgrade-immutable-systems*))))
       (condition (c)
-        (format t "Fatal: ~a~%" c)))))
+        (format t "Fatal: ~a~%" c)
+        (format t "~a~%" *self-upgrade-immutable-systems*)
+        (when debug (invoke-debugger c))))))
 
 (defun parse-summary-filename (summary debug)
   "Return the pathname where to write the summary output."
@@ -179,13 +183,6 @@
                                 with set field cast type encoding before after)
 	  options
 
-        ;; First thing: Self Upgrade?
-        (when self-upgrade
-          (unless *self-upgraded-already*
-            (self-upgrade self-upgrade)
-            (let ((*self-upgraded-already* t))
-              (main argv))))
-
         ;; parse the log thresholds
         (setf *log-min-messages*
               (log-threshold log-min-messages
@@ -199,6 +196,13 @@
               debug   (member *client-min-messages* '(:debug :data))
               quiet   (and (not verbose) (not debug)))
 
+        ;; First thing: Self Upgrade?
+        (when self-upgrade
+          (unless *self-upgraded-already*
+            (self-upgrade self-upgrade debug)
+            (let ((*self-upgraded-already* t))
+              (main argv))))
+
 	;; First care about the root directory where pgloader is supposed to
 	;; output its data logs and reject files
         (let ((root-dir-truename (or (probe-file root-dir)
diff --git a/src/params.lisp b/src/params.lisp
index 4c83ce0..d515aa9 100644
--- a/src/params.lisp
+++ b/src/params.lisp
@@ -6,6 +6,7 @@
 (defpackage #:pgloader.params
   (:use #:cl)
   (:export #:*version-string*
+           #:*self-upgrade-immutable-systems*
 	   #:*csv-path-root*
 	   #:*root-dir*
 	   #:*log-filename*
@@ -50,6 +51,9 @@
                (if *release* *minor-version* (git-hash)))
   "pgloader version strings, following Emacs versionning model.")
 
+(defvar *self-upgrade-immutable-systems* nil
+  "Used for --self-upgrade.")
+
 ;;;
 ;;; We need that to setup our default connection parameters
 ;;;