[Help-smalltalk] [PATCH] Relocatable install, 3/3

[Paolo Bonzini]

This patch allows the kernel path to relocate arbitrarily.  It will 
relocate unless the image was explicitly created with a non-standard 
--kernel-dir.

This is implemented by restoring the "Directory systemKernel" method. 
In GNU Smalltalk 2.x however we used it to search packages explicitly, 
and this does not happen in the new implementation.  We *never* use the 
system kernel directory for anything except as a default: since the 
KernelFilePath variable does not move (by design) when the image is 
relocated, we set it to nil when the image was not created with a 
non-standard --kernel-dir.  In this case "Directory kernel" will return 
the (moving) system kernel directory.

In addition, paths in the kernel methods are now made relative when the 
image is saved.  This is easier than the previous way of relocating 
paths only for DESTDIR installs.

With this patch, the GNU Smalltalk installation is relocatable (this 
helps Windows and Mac OS X users most, but is good in general). 
Probably more care would be needed if libgst.so was used really as a 
scripting engine, rather than just to share bits between gst and 
gst-tool.  In this case one should understand if the path relocation 
should be done according to the directory of the executable, or 
according to the directory of libgst.so; currently the former is 
implemented.

Paolo

diff --git a/ChangeLog b/ChangeLog
index 30f752a..9b17d5b 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,15 @@
 2008-03-15  Paolo Bonzini  <address@hidden>
 
+        * kernel/Directory.st: Readd Directory class>>#systemKernel.
+        Default Directory class>>#kernel to it.
+        * kernel/FileSegment.st: Change #relocateFrom:to: to #relocate:,
+        and #relocateFrom:to:map: to #relocateFrom:map:.
+        * scripts/Finish.st: Do not call #relocate, strip source code
+        from the last evaluated method to remove its FileSegment from the
+        image.
+
+2008-03-15  Paolo Bonzini  <address@hidden>
+
        * kernel/FileSegment.st: Add a warning that relative FileSegments
        are always interpreted from the kernel directory, and apply this
        rule in #fileName.
diff --git a/Makefile.am b/Makefile.am
index e7d695c..7c88729 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -210,11 +210,11 @@ install-data-hook::
          --srcdir="$(srcdir)" $(srcdir)/packages.xml
        $(mkdir_p) $(DESTDIR)$(imagedir)
        cd $(DESTDIR)$(imagedir) && \
-         "@abs_top_builddir@/gst" --no-user-files -i \
+         "@abs_top_builddir@/gst" --no-user-files -iS \
            --kernel-dir="$(DESTDIR)$(pkgdatadir)/kernel" \
            --image="$(DESTDIR)$(imagedir)/gst.im" \
            -f "@abs_top_srcdir@/scripts/Finish.st" \
-           "$(pkgdatadir)" "$(imagedir)" $(MODULES)
+           "$(imagedir)" $(MODULES)
 
 uninstall-local:: gst-tool
        $(GST_PACKAGE) \
diff --git a/kernel/Directory.st b/kernel/Directory.st
index c5d4940..4f1636c 100644
--- a/kernel/Directory.st
+++ b/kernel/Directory.st
@@ -82,16 +82,15 @@ virtual one).'>
     ]
 
     Directory class >> systemKernel [
-       "Answer the path to the GNU Smalltalk kernel's Smalltalk source files.
-        Same as `Directory kernel' since GNU Smalltalk 2.4."
+       "Answer the path to the installed Smalltalk kernel source files."
 
        <category: 'reading system defaults'>
-       ^self kernel
+       ^SystemKernelPath
     ]
 
     Directory class >> localKernel [
        "Answer the path to the GNU Smalltalk kernel's Smalltalk source files.
-        Same as `Directory kernel' since GNU Smalltalk 2.4."
+        Same as `Directory kernel' since GNU Smalltalk 3.0."
 
        <category: 'reading system defaults'>
        ^self kernel
@@ -122,10 +121,12 @@ virtual one).'>
 
     Directory class >> kernel [
        "Answer the path in which a local version of the GNU Smalltalk kernel's
-        Smalltalk source files were searched when the image was created"
+        Smalltalk source files were searched when the image was created."
 
        <category: 'reading system defaults'>
-       ^KernelFilePath
+       ^KernelFilePath isNil
+           ifTrue: [ SystemKernelPath ]
+           ifFalse: [ KernelFilePath ]
     ]
 
     Directory class >> append: fileName to: directory [
diff --git a/kernel/FileSegment.st b/kernel/FileSegment.st
index cd66729..5e3aa50 100644
--- a/kernel/FileSegment.st
+++ b/kernel/FileSegment.st
@@ -40,19 +40,16 @@ Object subclass: FileSegment [
 compiler to record source code locations.  I am not a part of the normal
 Smalltalk-80 kernel; I am specific to the GNU Smalltalk implementation.'>
 
-    FileSegment class >> relocateFrom: startPath to: endPath [
-       "Remove startPath from all paths that start with it, and replace it
-        with endPath.  Needed to support $(DESTDIR) when installing"
+    FileSegment class >> relocate [
+       "Remove the kernel path from all paths that start with it.  Needed to
+        support $(DESTDIR) and relocatable installation."
 
        <category: 'installing'>
-       | map |
+       | map startPath |
        map := IdentityDictionary new.
-       self allInstancesDo: 
-               [:each | 
-               each 
-                   relocateFrom: startPath
-                   to: endPath
-                   map: map]
+       startPath := Directory kernel.
+       self allInstancesDo: [:each | each relocateFrom: startPath map: map].
+       startPath = Directory systemKernel ifTrue: [KernelFilePath := nil].
     ]
 
     FileSegment class >> on: aFile startingAt: startPos for: sizeInteger [
@@ -99,11 +96,10 @@ Smalltalk-80 kernel; I am specific to the GNU Smalltalk 
implementation.'>
            withFileDo: [:fileStream | fileStream copyFrom: startPos to: 
startPos + size - 1]
     ]
 
-    relocateFrom: startPath to: endPath map: map [
-       "If the path starts with startPath, remove that part of the path
-        and replace it with endPath.  map is a Dictionary that is used
-        so that equal filenames stay equal, without increasing the amount
-        of memory that the image uses."
+    relocateFrom: startPath map: map [
+       "If the path starts with startPath, remove that part of the path.
+        map is a Dictionary that is used so that equal filenames stay equal,
+        without increasing the amount of memory that the image uses."
 
        <category: 'basic'>
        file := map at: self fileName
@@ -111,7 +107,7 @@ Smalltalk-80 kernel; I am specific to the GNU Smalltalk 
implementation.'>
                        [(self fileName startsWith: startPath) 
                            ifTrue: 
                                [map at: self fileName
-                                   put: endPath , (file copyFrom: startPath 
size + 1 to: file size)]
+                                   put: (file copyFrom: startPath size + 2)]
                            ifFalse: [file]]
     ]
 
diff --git a/libgst/ChangeLog b/libgst/ChangeLog
index 00a10a9..08e5467 100644
--- a/libgst/ChangeLog
+++ b/libgst/ChangeLog
@@ -1,5 +1,11 @@
 2008-03-15  Paolo Bonzini  <address@hidden>
 
+       * libgst/dict.c: Add SystemKernelPath.
+       * libgst/files.c: Call `FileSegment relocate' before loading
+       pre-image files.
+
+2008-03-15  Paolo Bonzini  <address@hidden>
+
        * libgst/cint.c: Relocate MODULE_PATH.
        * libgst/dict.c: Relocate paths placed in the Smalltalk dictionary.
        * libgst/files.c: Relocate image and kernel paths.  Apply default
diff --git a/libgst/dict.c b/libgst/dict.c
index 35dfab2..690439f 100644
--- a/libgst/dict.c
+++ b/libgst/dict.c
@@ -1060,6 +1060,10 @@ init_runtime_objects (void)
   char *s;
   add_smalltalk ("UserFileBasePath", _gst_string_new 
(_gst_user_file_base_path));
 
+  s = _gst_relocate_path (KERNEL_PATH);
+  add_smalltalk ("SystemKernelPath", _gst_string_new (s));
+  free (s);
+
   s = _gst_relocate_path (MODULE_PATH);
   add_smalltalk ("ModulePath", _gst_string_new (s));
   free (s);
diff --git a/libgst/files.c b/libgst/files.c
index b6a1508..e5e474a 100644
--- a/libgst/files.c
+++ b/libgst/files.c
@@ -578,6 +578,8 @@ load_standard_files (void)
        }
     }
 
+  _gst_msg_sendf (NULL, "%v %o relocate", _gst_file_segment_class);
+
   if (site_pre_image_file)
     _gst_process_file (site_pre_image_file, GST_DIR_ABS);
 
diff --git a/scripts/Finish.st b/scripts/Finish.st
index c6573ac..fca98b1 100644
--- a/scripts/Finish.st
+++ b/scripts/Finish.st
@@ -33,7 +33,7 @@
 | ok |
 ok := false.
 [
-    PackageLoader fileInPackages: (Smalltalk arguments copyFrom: 3).
+    PackageLoader fileInPackages: Smalltalk arguments allButFirst.
     ok := true
 ] valueWithUnwind.
 
@@ -41,20 +41,21 @@ ok ifFalse: [ ObjectMemory quit: 1 ]!
 
 "Symbol rebuildTable."
 
-"Remove DESTDIR and references to the build directory, from the paths
- stored in the image"
-| newImagePath oldKernelBasePath newKernelBasePath |
-oldKernelBasePath := File pathFor: KernelFilePath.
-newKernelBasePath := Smalltalk arguments at: 1.
-newImagePath := Smalltalk arguments at: 2.
-oldKernelBasePath = newKernelBasePath ifFalse: [
-    FileSegment relocateFrom: oldKernelBasePath to: newKernelBasePath ].
-
-ImageFileName := 'gst.im'.
-ImageFilePath := newImagePath.
-KernelFilePath := newKernelBasePath, '/kernel'.
-ExecutableFileName := nil.
-UserFileBasePath := nil!
-
-PackageLoader flush!
-ObjectMemory snapshot!
+Eval [
+    thisContext method stripSourceCode.
+
+    "Remove DESTDIR and references to the build directory, from the paths
+     stored in the image"
+    ImageFileName := 'gst.im'.
+    ImageFilePath := Smalltalk arguments first.
+    ExecutableFileName := nil.
+    UserFileBasePath := nil.
+
+    "The image is built using the uninstalled executable (the installed
+     executable does not work if DESTDIR is in effect and the package is
+     no relocatable!).  So, FileSegment>>#relocate does not necessarily
+     set this to nil."
+    KernelFilePath := nil.
+
+    PackageLoader flush
+]