Smalltalk › Gnu

[PATCH] gst-package rewrite

_‹ Previous Topic Next Topic _›

Classic

List

Threaded

1 message

Paolo Bonzini-2

[PATCH] gst-package rewrite

This package does another substantial improvement to package management,
as it rewrites gst-package in Smalltalk.

scripts/Package.st is just a translation of the old script (just better
because it uses objects to do the parsing). It could use a further
rewrite, but this one was already quite a feat. It only emits commands
to stdout, leaving the execution to gst-package.in. This is just a
complication maybe, but the important part is to pave the way for
installing packages as .star files, and getting rid of the broken
sed-based XML parsing that gst-package was attempting.

Again, this is not complete in any way, but at least it will provide
some uniform benefits from using a better XML parser -- Mike already
beat me pretty hard because of this:

http://www.nabble.com/-RFC--handle-paths-in-a-saner-way-tf3186649.html#a8901274

One problem is that gst-package is not available anymore at configure
time, which forced me to rewrite the creation of the stamp files used to
drive the generation of documentation. In turn, this forced me to
rename the blox-tk and blox-gtk directory to blox/tk and blox/gtk (just
because "blox-tk_PACKAGE" is not a valid makefile variable name).

There are more improvements in the Package object model. It uses
exceptions to detect unavailable packages, which makes the system more
flexible. gst-package uses this to give an error on unavailable
packages instead of just skipping them.

Another feature is that Package objects now store the exact same data
that is available in packages.xml. This is needed to correctly derive
the directory of the distributed and installed files.

Paolo

2007-06-22 Paolo Bonzini <[hidden email]>

* kernel/PkgLoader.st: Store info in objects as it is in packages.xml,
resolving filenames at load time. Add DisabledPackage.
* scripts/Package.st: New.

A/ blox
A blox/stamp-classes
A i18n/stamp-classes
A kernel/stamp-classes
A scripts/Package.st
A tcp/stamp-classes
M configure.ac
M doc/Makefile.am
M gst-package.in
M Makefile.am
M kernel/PkgLoader.st
M packages.xml.in
/> blox-gtk blox/gtk
/> blox-tk blox/tk

* modified files

--- orig/Makefile.am
+++ mod/Makefile.am
@@ -22,13 +22,20 @@ ACLOCAL_AMFLAGS = -I build-aux
PACKAGE=smalltalk

DIST_SUBDIRS = lib-src snprintfv lightning sigsegv libffi opcode libgst \
- i18n tcp examples blox-tk . gtk tests doc
+ i18n tcp examples blox/tk . gtk tests doc

SUBDIRS = lib-src lightning $(subdirs)
if ENABLE_DISASSEMBLER
SUBDIRS += opcode
endif
-SUBDIRS += libgst i18n tcp examples blox-tk . doc gtk tests
+SUBDIRS += libgst i18n tcp examples blox/tk . doc gtk tests
+
+# Running gst inside the build directory...
+
+GST_ARGUMENTS = --no-user-files --kernel-dir="@abs_top_srcdir@/kernel" \
+ --image-dir="@abs_top_builddir@"
+GST = ./gst $(GST_ARGUMENTS)
+GST_PACKAGE = GST=./gst GSTARGS='$(GST_ARGUMENTS)' ./gst-package --srcdir="$(srcdir)" -I gst.im

###########################################################
@@ -55,8 +62,7 @@ nodist_pkgconfig_DATA = gnu-smalltalk.pc
pkglib_DATA = libc.la
noinst_DATA = gst.im
dist_noinst_DATA += smalltalk-mode.el.in gst-mode.el.in .gdbinit \
- kernel/stamp-classes blox-tk/stamp-classes tcp/stamp-classes \
- i18n/stamp-classes scripts/Finish.st scripts/GenLibDoc.st \
+ scripts/Finish.st scripts/GenLibDoc.st \
scripts/GenBaseDoc.st scripts/Convert.st gsticon.ico

if WITH_EMACS
@@ -99,7 +105,6 @@ endif

# By default, we do not build the installed VM as a shared library: it is
# a bit slower, and on x86 we also exchange the PIC register for the frame
-# which makes the VM undebuggable except with very recent (3.4) gcc.
gst_LDFLAGS = -export-dynamic -static

nodist_noinst_HEADERS = config.h
@@ -110,11 +115,51 @@ gsticon.o: gsticon.ico
echo ProgramIcon ICON `$(CYGPATH_W) gsticon.ico` | windres -o gsticon.o

gst.im: $(bin_PROGRAMS) $(srcdir)/kernel/stamp-classes
- ./gst --no-user-files --kernel-dir="@abs_top_srcdir@/kernel" \
- --image-dir="@abs_top_builddir@" -iQ /dev/null
+ $(GST) -iQ /dev/null

all-local:

+
+###########################################################
+#
+# Stamp classes for various packages
+#
+# Used for building the image and the documentation
+#
+###########################################################
+
+CLASS_STAMP = $(srcdir)/blox/stamp-classes $(srcdir)/tcp/stamp-classes $ \
+ $(srcdir)/i18n/stamp-classes $(srcdir)/kernel/stamp-classes
+
+blox_PACKAGE=BloxTK
+tcp_PACKAGE=TCP
+i18n_PACKAGE=I18N
+kernel_PACKAGE=Kernel
+
+-include $(srcdir)/blox/stamp-classes
+-include $(srcdir)/kernel/stamp-classes
+-include $(srcdir)/i18n/stamp-classes
+-include $(srcdir)/tcp/stamp-classes
+
+all-local: $(CLASS_STAMP)
+
+# The slow rule for building the stamp-classes files uses gst-package, and
+# depends on packages.xml in order to run# when the list of files in the
+# package might have changed. The fast rule just touches the file. We
+# could actually do without double-colon rules by using another stamp file
+# which depends on packages.xml and rebuilds all the stamp-classes files.
+
+$(CLASS_STAMP):: packages.xml.in
+
+$(srcdir)/%/stamp-classes: packages.xml.in
+ dir=$*; package=$($*_PACKAGE); \
+ (echo '$@:: \'; \
+ $(GST_PACKAGE) --list-files $$package packages.xml | \
+ tr -d \\r | tr \\n ' '; \
+ echo; \
+ echo ' touch $@') > $@
+
+
###########################################################
#
# Rules for distributing the superops program
@@ -149,15 +194,20 @@ dist-hook: gst-package
-e "s/@$NCURSES_DISABLED$@/disabled-/" \
-e "s/@$VERSION$@/@VERSION@/" \
$(srcdir)/packages.xml.in > $(distdir)/packages.xml
- ./gst-package --distdir="$(distdir)" --srcdir="$(srcdir)" \
- --dist $(distdir)/packages.xml
+ $(GST_PACKAGE) --dist --distdir="$(distdir)" packages.xml
+ @for i in $(CLASS_STAMP); do \
+ dir=`dirname $$i`; dir=`basename $$dir`; \
+ echo cp -p $$i $(distdir)/$$dir/stamp-classes; \
+ cp -p $$i $(distdir)/$$dir/stamp-classes; \
+ done

# Build an image after installing the data; install-data runs after
# install-exec, so the gst executable is already in bindir.
install-data-hook: gst-package
rm -f $(DESTDIR)$(pkgdatadir)/packages.xml
- ./gst-package --srcdir="$(srcdir)" --no-load --destdir="$(DESTDIR)" \
- --target-dir="$(pkgdatadir)" packages.xml
+ $(GST_PACKAGE) \
+ --no-load --destdir="$(DESTDIR)" --target-dir="$(pkgdatadir)" \
+ packages.xml
$(mkdir_p) $(DESTDIR)$(imagedir)
rm -f $(DESTDIR)$(imagedir)/gst.im
cd $(DESTDIR)$(imagedir) && \
@@ -168,6 +218,8 @@ install-data-hook: gst-package
"$(pkgdatadir)" "$(imagedir)" $(MODULES)

uninstall-local:: gst-package
- ./gst-package --uninstall --destdir="$(DESTDIR)" packages.xml
+ $(GST_PACKAGE) \
+ --uninstall --destdir="$(DESTDIR)" --target-dir="$(pkgdatadir)" \
+ packages.xml
-rm -f $(DESTDIR)$(pkgdatadir)/packages.xml
-rm -f $(DESTDIR)$(imagedir)/gst.im

--- orig/configure.ac
+++ mod/configure.ac
@@ -369,30 +369,14 @@ AC_CONFIG_FILES(packages.xml)
AC_CONFIG_FILES(libc.la)

dnl Master Makefile
-AC_CONFIG_FILES(Makefile, [
- echo 'Makefile: packages.xml' >> Makefile
- for i in blox-tk:BloxTK tcp:TCP i18n:I18N kernel:Kernel; do
- package=`echo $i | sed s/.*://`
- dir=`echo $i | sed s/:.*//`
-
- echo
- echo "all-local: \$(top_srcdir)/$dir/stamp-classes"
- echo "\$(top_srcdir)/$dir/stamp-classes: \\"
-
- ./gst-package --list-files $package packages.xml | \
- sed -n 's,.*\.st$,& \\,p'
-
- echo
- echo " echo timestamp > \$(top_srcdir)/$dir/stamp-classes"
- done >> Makefile
-])
+AC_CONFIG_FILES(Makefile)

dnl VM makefiles
AC_CONFIG_FILES(doc/Makefile lib-src/Makefile libgst/Makefile)
AC_CONFIG_FILES(opcode/Makefile lightning/Makefile tests/Makefile)

dnl Modules makefiles
-AC_CONFIG_FILES(blox-tk/Makefile examples/Makefile)
+AC_CONFIG_FILES(blox/tk/Makefile examples/Makefile)
AC_CONFIG_FILES(i18n/Makefile tcp/Makefile)
AC_CONFIG_FILES(gtk/Makefile)

--- orig/doc/Makefile.am
+++ mod/doc/Makefile.am
@@ -39,7 +39,7 @@ $(srcdir)/gst.1: $(top_srcdir)/libgst/li

PUBLISHED_NAMESPACES = Smalltalk SystemExceptions NetClients VFS

-$(srcdir)/blox.texi: $(top_srcdir)/blox-tk/stamp-classes
+$(srcdir)/blox.texi: $(top_srcdir)/blox/stamp-classes
rm -f $(srcdir)/blox.texi
cd $(srcdir) && @abs_top_builddir@/gst -I @abs_top_builddir@/gst.im \
-f ../scripts/GenLibDoc.st BLOX BloxTK blox.texi Blox.st

--- orig/gst-package.in
+++ mod/gst-package.in
@@ -1,4 +1,5 @@
#! /bin/sh
+
#######################################################################
#
# Smalltalk package installer
@@ -9,47 +10,49 @@

#######################################################################
#
-# Copyright 1999,2000,2001,2002
-# Free Software Foundation, Inc.
+# Copyright 2007 Free Software Foundation, Inc.
# Written by Paolo Bonzini.
#
-# This file is part of GNU Smalltalk
+# This file is part of GNU Smalltalk.
#
-# GNU Smalltalk is free software; you can redistribute it
-# and/or modify it under the terms of the GNU General Public License
-# as published by the Free Software Foundation; either version 2, or (at
-# your option) any later version.
+# GNU Smalltalk is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2, or (at your option) any later version.
#
-# The GNU Smalltalk is distributed in the hope that it will be
-# useful, but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-# General Public License for more details.
+# GNU Smalltalk is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
+# details.
#
-# You should have received a copy of the GNU General Public License
-# along with the GNU Smalltalk; see the file COPYING.
-# If not, write to the Free Software Foundation, 59 Temple Place - Suite
-# 330, Boston, MA 02110-1301, USA.
-#
-#######################################################################"
+# You should have received a copy of the GNU General Public License along with
+# GNU Smalltalk; see the file COPYING. If not, write to the Free Software
+# Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
+#
+########################################################################
+
+OPTIONS='-h|--help --version --no-load --no-install --uninstall --dist
+ -t|--target-directory: --list-files: --list-packages
+ --srcdir: --distdir|--destdir:
+ -n|--dry-run -I|--image-file:'
+
+prefix=@prefix@
+exec_prefix=@exec_prefix@
+: ${GST=@bindir@/gst}

-
-: ${prefix:=@prefix@}
-: ${exec_prefix:=@exec_prefix@}
-: ${datarootdir:=@datarootdir@}
-: ${AWK:=gawk}
-: ${GST_LOAD:=${exec_prefix}/bin/gst-load}
: ${INSTALL=@INSTALL@}
+: ${LN_S=@LN_S@}
+ mkdir_p='mkdir -p'

case "$INSTALL" in
*/install-sh | *"/install-sh -c" | \
*/install.sh | *"/install.sh -c" | \
install-sh | "install-sh -c" | \
install.sh | "install.sh -c")
- display_install=install
+ display_INSTALL=install
INSTALL=func_install
;;
*)
- display_install="$INSTALL"
+ display_INSTALL="$INSTALL"
;;
esac

@@ -101,310 +104,77 @@ mkdir_p ()
return "$errstatus"
}

-error () {
- echo "$0": "$@" >&2
- exit 1
+show_command () {
+ save_INSTALL=$INSTALL
+ INSTALL=$display_INSTALL
+ mkdir_p='mkdir -p'
+ eval echo "$cmd"
+ INSTALL=$save_INSTALL
+ mkdir_p='mkdir_p'
}

-if test -n "$SMALLTALK_IMAGE" && test -d "$SMALLTALK_IMAGE"; then
- install_dir=$SMALLTALK_IMAGE
-else
- install_dir="@datadir@/@PACKAGE@"
-fi
-
-request_help=false
-request_version=false
-options_error=false
-load=:
-install=:
-dist=false
-list_files=
-uninstall=false
-dry_run=false
-DESTDIR=
-srcdir=.
-files=
-
-# Command line parsing.
-
-while [ -n "$1" ]; do
- case $1 in
- --v | --ve | --ver | --vers | --versi | --versio | \
- --version) request_version=: ;;
-
- --h | --he | --hel | \
- --help) request_help=: ;;
-
- --no-l | --no-lo | --no-loa | \
- --no-load) load=false ;;
-
- --no-i | --no-in | --no-ins | --no-inst | \
- --no-insta | --no-instal | \
- --no-install) install=false ;;
-
- --u | --un | --uni | --unin | --unins | --uninst | \
- --uninsta | --uninstal | \
- --uninstall) load=false; uninstall=: ;;
-
- --di | --dis | \
- --dist) load=false; dist=: ;;
-
- -t | --t | --ta | --tar | --targ | --targe | --target | --target- | \
- --target-d | --target-di | --target-dir | --target-dire | \
- --target-direc | --target-direct | --target-directo | \
- --target-director | --target-directory)
- shift; install_dir="$1" ;;
-
- --t=* | --ta=* | --tar=* | --targ=* | --targe=* | --target=* | \
- --target-=* | --target-d=* | --target-di=* | --target-dir=* | \
- --target-dire=* | --target-direc=* | --target-direct=* | \
- --target-directo=* | --target-director=* | --target-directory=*)
- install_dir="`echo $1 | sed s/^[^=]*=//`" ;;
-
- -t*)
- install_dir="`echo $1 | sed s/^-t//`" ;;
-
- --l=* | --li=* | --lis=* | --list=* | --list-=* | \
- --list-f=* | --list-fi=* | --list-fil=* | --list-file=* | \
- --list-files=*) list_files="$list_files `echo $1 | sed s/.*=//`"
- ;;
-
- --l | --li | --lis | --list | --list- | \
- --list-f | --list-fi | --list-fil | --list-file | \
- --list-files) shift; list_files="$list_files $1" ;;
-
- --s | --sr | --src | --srcd | --srcdi | \
- --srcdir) shift; srcdir="$1" ;;
-
- --s=* | --sr=* | --src=* | --srcd=* | --srcdi=* | \
- --srcdir=*) srcdir="`echo $1 | sed s/.*=//`" ;;
-
- --distd | --distdi | --distdir | \
- --de | --des | --dest | --destd | --destdi | \
- --destdir) shift; DESTDIR="$1" ;;
-
- --distd=* | --distdi=* | --distdir=* | \
- --de=* | --des=* | --dest=* | --destd=* | --destdi=* | \
- --destdir=*) DESTDIR="`echo $1 | sed s/.*=//`" ;;
-
- -n | --dr | --dry | --dry- | --dry-r | --dry-ru | \
- --dry-run) dry_run=: ;;
+# The same shell functions used in gst-load and gst-sunit.

- -*) options_error=: ;;
-
- *) files="$files $1" ;;
- esac
+gst () {
+ script=$1
shift
-done
-
-# Do --help and --version.
-
-if [ -z "$files" ] || $request_help || $options_error; then
- cat <<EOF
-Syntax: gst-package [OPTION]... FILES...
-
- -n, --dry-run print commands rather than running them
- --no-load don't load the Smalltalk files in the image
- --no-install don't copy the files
- --uninstall remove the packages mentioned in the FILES
- --dist create symbolic links of non-built files
- --list-files PKG just output the list of files in the package
- --srcdir DIR look for non-built files in directory DIR
- --distdir DIR for --dist, place files in directory DIR
- --destdir DIR prefix the destination directory with DIR
- --target-directory DIR install the files in DIR (unused for --dist)
-
- --help display this message and exit
- --version print version information and exit
-
-Except in uninstall and list files mode, gst-package requires write
-access to the \`packages.xml' file in the GNU Smalltalk image directory,
-and merges the XML package files on the command line with that file.
-
-The default target directory is $install_dir.
-
-EOF
- # Unless --help was passed, return an error.
- $request_help && exit 0
- exit 1
-fi
-
-if $request_version; then
- echo GNU Smalltalk package installer, version @VERSION@
- exit 0
-fi
-
-# Process --list-files now, then exit.
-
-if [ -n "$list_files" ]; then
- for pkg in $list_files; do
- dir="`sed -ne '/<name>'"$pkg"'<.name>/,/<.*package>/!d' \
- -e 's,.*<directory>$[^<]*$<.directory>,\1,p' $files | sed 1q`"
-
- sed -ne '/<name>'"$pkg"'<.name>/,/<.*package>/!d' \
- -e 's,.*<built-file>$[^<]*[^/]$<.built-file>,\1,p' \
- -e 's,.*<file>$[^<]*[^/]$<.file>,\1,p' $files | while read file; do
- case $file in
- /*) echo "$file" ;;
- *) echo "$dir/$file" ;;
- esac
- done
- done
- exit 0
-fi
-
-# Create the installation directory.
-
-if $dist; then
- install_dir=
- if test -z "$DESTDIR"; then
- error Using --dist without specifying --distdir
+ if test x${image_file:+set} = xset; then
+ eval \"\$GST\" "$GSTARGS" -I \"\$image_file\" -qK \"\$script\" -a \"\$@\"
else
- mkdir_p "$DESTDIR"
+ eval \"\$GST\" "$GSTARGS" -qK \"\$script\" -a \"\$@\"
fi
-else
- case $install_dir in
- /*)
- mkdir_p "$DESTDIR$install_dir"
- ;;
- *)
- if test -z "$DESTDIR"; then
- mkdir_p "$install_dir"
- (cd "$install_dir" 2> /dev/null && install_dir=`pwd`)
- else
- error Target directory must be absolute when DESTDIR is used
- fi
- ;;
- esac
-fi
-
-
-# Extract the name of the packages to be (un)installed.
-
-pkgs=`sed -e '/<name>/!d' \
- -e 's,.*<name>$[^<]*$<.name>,\1 ,' $files `
-
-if $uninstall; then
- for pkg in $pkgs; do
- dir="`sed -ne '/<name>'"$pkg"'<.name>/,/<.*package>/!d' \
- -e 's,.*<directory>$[^<]*$<.directory>,\1,p' $files | sed 1q`"
-
- sed -ne '/<name>'"$pkg"'<.name>/,/<.*package>/!d' \
- -e 's,.*<built-file>$[^<]*[^/]$<.built-file>,\1,p' \
- -e 's,.*<file>$[^<]*[^/]$<.file>,\1,p' $files | while read file; do
- case $file in
- /*) dest=$DESTDIR$file ;;
- *) dest="$DESTDIR$install_dir/$dir/$file" ;;
- esac
+}

- echo "rm -f $dest"
- $dry_run || rm -f "$dest"
- done
- done
- exit 0
-fi
+show_help () {
+ eval \"\$GST\" "$GSTARGS" -qK scripts/Package.st -a \$1
+ exit $?
+}

-# If we are installing, add packages.xml to the list
-# and merge the supplied packages files with it
+getopt () {
+ eval \"\$GST\" "$GSTARGS" -qK scripts/Getopt.st -a \"\$OPTIONS\" \"\$@\"
+}

-if $dist; then
- :
-else
- base="$DESTDIR$install_dir/packages.xml"
- if test -f $base; then
- merged_files="$base"
- for file in $files; do
- test $file -ef $base || merged_files="$merged_files $file"
- done
- else
- merged_files="$files"
- fi
+getopt "$@" | {
+ load_dry_run=
+ load_test=
+ list=false
+ run_cmd=eval
+ files=
+ srcdir=
+ while read opt arg; do
+ case $opt in
+ ERROR) show_help --bad ;;
+ --help) show_help --help ;;
+ --dist | --uninstall | --no-load) load_dry_run=-n ;;
+ --test) load_test=--test ;;
+ --dry-run) run_cmd=: ;;
+ --list-files) list=: ;;
+ --list-packages) list=: ;;
+ --srcdir) srcdir=$arg ;;
+ --image-file)
+ test x${image_file:+set} = xset && show_help --bad
+ image_file=$arg ;;
+ --) files="$files '$arg'" ;;
+ esac
+ done

- echo "Merging $files into $base..."
- $dry_run || {
- sed -e '$i\
-</packages>' -e '/<.packages>/,/<packages>/d' $merged_files > packages.tmp
-
- mv packages.tmp $DESTDIR$install_dir/packages.xml
- }
-fi
-
-if $install; then
- for pkg in $pkgs; do
- dir="`sed -ne '/<name>'"$pkg"'<.name>/,/<.*package>/!d' \
- -e 's,.*<directory>$[^<]*$<.directory>,\1,p' $files | sed 1q`"
- dirs="`sed -ne '/<name>'"$pkg"'<.name>/,/<.*package>/!d' \
- -e 's,.*<built-file>$[^<]*$/<.built-file>,\1,p' \
- -e 's,.*<file>$[^<]*$/<.file>,\1,p' $files `"
-
- for subdir in . $dirs; do
- case $subdir in
- /*) dest=$DESTDIR$subdir ;;
- *) dest=$DESTDIR$install_dir/$dir/$subdir ;;
- esac
+ set -e

- mkdir_p "$dest"
+ if $list; then
+ gst scripts/Package.st "$@"
+ else
+ gst scripts/Package.st "$@" | while read cmd; do
+ show_command "$cmd"
+ $run_cmd "$cmd"
done

- if $dist; then
- wd=`cd $srcdir && pwd`
- sed -ne '/<name>'"$pkg"'<.name>/,/<.*package>/!d' \
- -e 's,.*<file>$[^<]*[^/]$<.file>,\1,p' $files | while read file; do
- case $file in
- /*)
- dest=$DESTDIR$file
- orig_file=$file ;;
- *)
- dest="$DESTDIR/$dir/$file"
- file=$dir/$file
- orig_file=$file
- if test -f $file; then file=`pwd`/$file; else file=$wd/$file; fi ;;
- esac
-
- test -f "$file" || {
- echo gst-package: "$orig_file" not found
- exit 1
- }
-
- echo "@LN_S@ -f $file $dest"
- $dry_run || @LN_S@ -f "$file" "$dest"
- done
-
- else
- sed -ne '/<name>'"$pkg"'<.name>/,/<.*package>/!d' \
- -e 's,.*<built-file>$[^<]*[^/]$<.built-file>,\1,p' \
- -e 's,.*<file>$[^<]*[^/]$<.file>,\1,p' $files | while read file; do
- case "$file" in
- /*)
- dest="$DESTDIR$file"
- orig_file=$file ;;
- *)
- dest="$DESTDIR$install_dir/$dir/$file"
- file=$dir/$file
- orig_file=$file
- test -f "$file" || file=$srcdir/$file ;;
- esac
-
- test -f "$file" || {
- echo gst-package: "$orig_file" not found
- exit 1
- }
-
- if test -x "$file"; then
- echo "$display_install -m 755 $file $dest"
- $dry_run || $INSTALL -m 755 "$file" "$dest"
- else
- echo "$display_install -m 644 $file $dest"
- $dry_run || $INSTALL -m 644 "$file" "$dest"
- fi
- done
+ if test "$run_cmd" = eval && test "$load_test,$load_dry_run" != ,-n; then
+ packages=`eval gst scripts/Package.st \
+ ${srcdir:+"--srcdir=$srcdir"} \
+ --list-packages "$files" `
+ "@bindir@/gst-load" \
+ ${image_file:+"--image-file=$image_file"} \
+ $load_dry_run $load_test $packages
fi
- done
-fi
-
-if $load && [ -n "$pkgs" ]; then
- echo ${GST_LOAD} $pkgs
- $dry_run || ${GST_LOAD} $pkgs
-fi
-
-exit 0
+ fi
+}

--- orig/kernel/PkgLoader.st
+++ mod/kernel/PkgLoader.st
@@ -33,6 +33,20 @@

Namespace current: Kernel!

+Notification subclass: #PackageSkip
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Language-Packaging'
+!
+
+Exception subclass: #PackageNotAvailable
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Language-Packaging'
+!
+
Object subclass: #PackageGroup
instanceVariableNames: ''
classVariableNames: ''
@@ -96,7 +110,7 @@ XML.'!
Namespace current: Smalltalk!

Kernel.PackageInfo subclass: #Package
- instanceVariableNames: 'features prerequisites builtFiles files fileIns directory libraries modules callouts namespace sunitScripts test'
+ instanceVariableNames: 'features prerequisites builtFiles files fileIns relativeDirectory baseDirectories libraries modules callouts namespace sunitScripts test'
classVariableNames: ''
poolDictionaries: ''
category: 'Language-Packaging'
@@ -107,6 +121,22 @@ Package comment:
information on a Smalltalk package, and can output my description in
XML.'!

+Namespace current: Kernel!
+
+Package subclass: #DisabledPackage
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Language-Packaging'
+!
+
+DisabledPackage comment:
+'I am not part of a standard Smalltalk system. I store internally the
+information on a Smalltalk package, and can output my description in
+XML.'!
+
+Namespace current: Smalltalk!
+
Object subclass: #PackageLoader
instanceVariableNames: ''
classVariableNames: ''
@@ -132,7 +162,7 @@ printOn: aStream
self
do: [ :each |
aStream space: 2.
- each printOn: aStream tag: 'package' indent: 2.
+ each printOn: aStream indent: 2.
aStream nl ]
separatedBy: [ aStream nl ].
aStream nextPutAll: '</packages>'
@@ -222,6 +252,12 @@ new
^super new initialize
! !

+!Kernel.PackageDirectories methodsFor: 'copying'!
+
+postCopy
+ dirs := dirs copy
+! !
+
!Kernel.PackageDirectories methodsFor: 'accessing'!

add: aDirectory
@@ -317,21 +353,38 @@ refresh
"Private - Process the XML source in the packages file, creating
Package objects along the way."

- | cdata file stack ch tag package allDirs |
+ packages := LookupTable new.
+ self refreshPackageList.
+ self refreshStarList
+!
+
+refreshPackageList
+ | file allDirs |
allDirs := Smalltalk imageLocal
ifTrue: [ { Directory image }, baseDirectories ]
ifFalse: [ baseDirectories ].
+
allDirs isEmpty ifTrue: [ ^self ].

file := [ FileStream open: fileName mode: FileStream read ]
on: Error
do: [ :ex | ^self ].

- packages := LookupTable new.
- [ self parse: file baseDirectories: allDirs ]
+ [
+ [ self parse: file baseDirectories: allDirs ]
+ on: PackageNotAvailable
+ do: [ :ex | ex resignalAs: PackageSkip new ] ]
ensure: [ file close ].

- (Directory name: (File pathFor: fileName))
+ packages := packages reject: [ :each | each isDisabled ]
+!
+
+refreshStarList
+ | dir |
+ dir := Directory name: (File pathFor: fileName).
+ dir exists ifFalse: [ ^self].
+
+ dir
namesMatching: '*.star'
do: [ :starName |
| package |
@@ -362,13 +415,25 @@ parse: file baseDirectories: baseDirs
open
ifFalse: [
tag := file upTo: $>.
- tag = 'packages' ifFalse: [ ^self error: 'expected packages tag' ].
+ tag = 'packages' ifFalse: [
+ ^self error: 'expected packages tag' ].
+ tag = 'package' ifTrue: [
+ package := Package new parse: file tag: 'package' ].
open := true ]
ifTrue: [
file skip: -1.
- package := Package parse: file.
- (package notNil and: [ package baseDirectories: baseDirs ])
- ifTrue: [ packages at: package name put: package ] ] ] ]
+ package := Package parse: file ].
+
+ package notNil ifTrue: [
+ package name isNil ifTrue: [
+ ^self error: 'missing package name in ', fileName ].
+
+ [
+ package baseDirectories: baseDirs.
+ packages at: package name put: package ]
+ on: PackageSkip
+ do: [ :ex | ex return ] ].
+ package := nil ] ]
! !

@@ -397,7 +462,11 @@ printXmlOn: aStream collection: aCollect
]!

printOn: aStream
- self printOn: aStream tag: 'package' indent: 0
+ self printOn: aStream indent: 0
+!
+
+printOn: aStream indent: indent
+ self printOn: aStream tag: 'package' indent: indent
!

printOn: aStream tag: tag indent: indent
@@ -466,11 +535,11 @@ printOn: aStream tag: tag indent: indent
collection: self modules asSortedCollection
tag: 'module'
indent: indent.
- self directory isNil
+ self relativeDirectory isNil
ifFalse: [
aStream
nextPutAll: ' <directory>';
- nextPutAll: self directory;
+ nextPutAll: self relativeDirectory;
nextPutAll: '</directory>';
nl; space: indent ].

@@ -557,6 +626,11 @@ callouts
modules are loaded so that you can do a kind of versioning."
self subclassResponsibility!

+relativeDirectory
+ "Answer the directory from which to load the package, relative to the package
+ file."
+ self subclassResponsibility!
+
directory
"Answer the base directory from which to load the package."
self subclassResponsibility!
@@ -627,6 +701,9 @@ callouts
modules are loaded so that you can do a kind of versioning."
^self loadedPackage callouts!

+relativeDirectory
+ ^'.'!
+
directory
^fileName, '#uzip'!

@@ -649,6 +726,7 @@ loadedPackage
package isNil ifTrue: [
^self error: 'invalid disabled-package tag inside a star file' ].

+ package relativeDirectory: self relativeDirectory.
package baseDirectories: { self directory }.
package name isNil
ifTrue: [ package name: self name ]
@@ -677,29 +755,39 @@ parse: file

ch isAlphaNumeric ifTrue: [
tag := file upTo: $>.
- tag = 'package' ifTrue: [ ^Package new parse: file tag: tag ].
- tag = 'disabled-package' ifTrue: [ Package new parse: file tag: tag. ^nil ].
+ tag = 'package'
+ ifTrue: [ ^Package new parse: file tag: tag ].
+ tag = 'disabled-package'
+ ifTrue: [ ^DisabledPackage new parse: file tag: tag ].
]
] repeat
! !

!Package methodsFor: 'accessing'!

+isDisabled
+ ^false
+!
+
test
"Answer the test sub-package."
^test!

test: aPackage
"Set the test sub-package to be aPackage."
- aPackage test isNil ifFalse: [
- self error: 'test packages must not be nested' ].
- aPackage name isNil ifFalse: [
- self error: 'test package must not have names' ].
+ aPackage test isNil
+ ifFalse: [ self error: 'test packages must not be nested' ].
+ aPackage name isNil
+ ifFalse: [ self error: 'test package must not have names' ].
+
aPackage prerequisites add: 'SUnit'; add: self name.
- aPackage directory isNil ifTrue: [
- aPackage directory: self directory ].
- aPackage namespace isNil ifTrue: [
- aPackage namespace: self namespace ].
+ aPackage namespace isNil
+ ifTrue: [ aPackage namespace: self namespace ].
+ aPackage relativeDirectory isNil
+ ifTrue: [ aPackage relativeDirectory: self relativeDirectory ].
+
+ self baseDirectories isNil ifFalse: [
+ aPackage baseDirectories: self baseDirectories ].
test := aPackage!

namespace
@@ -764,12 +852,17 @@ callouts
callouts isNil ifTrue: [ callouts := Set new ].
^callouts!

-baseDirectories: baseDirectories
- "Resolve the names in the package according to the base directories
- in baseDirectories, which depend on where the packages.xml is found:
- the three possible places are 1) the system kernel directory's parent
- directory, 2) the local kernel directory's parent directory, 3) the
- local image directory (in order of decreasing priority).
+baseDirectories
+ ^baseDirectories
+!
+
+baseDirectories: aCollection
+ "Check if it's possible to resolve the names in the package according to
+ the base directories in baseDirectories, which depend on where
+ the packages.xml is found: the three possible places are 1) the
+ system kernel directory's parent directory, 2) the local kernel
+ directory's parent directory, 3) the local image directory (in
+ order of decreasing priority).

For a packages.xml found in the system kernel directory's parent
directory, all three directories are searched. For a packages.xml
@@ -777,56 +870,62 @@ baseDirectories: baseDirectories
directories 2 and 3 are searched. For a packages.xml directory in
the local image directory, instead, only directory 3 is searched."

- files := self findBaseDirs: baseDirectories for: self files.
- fileIns := self findBaseDirs: baseDirectories for: self fileIns.
- builtFiles := self findBaseDirs: baseDirectories for: self builtFiles.
-
- (self test notNil and: [ (self test baseDirectories: baseDirectories) not ])
- ifTrue: [ ^false ].
-
- files isNil | fileIns isNil | builtFiles isNil ifTrue: [ ^false ].
-
- self directory isNil ifFalse: [
- baseDirectories
- do: [ :dir || name |
- name := Directory append: self directory to: dir.
- name := Directory append: self directory to: dir.
- (Directory exists: name) ifTrue: [ directory := name. ^true ] ] ].
+ baseDirectories := aCollection.
+ self findPathsFor: self files.
+ "self findPathsFor: self fileIns."
+ "self findPathsFor: self builtFiles."
+ self directory.

- ^false
+ self test notNil ifTrue: [ self test baseDirectories: aCollection ].
!

-findBaseDirs: baseDirectories for: aCollection
+findPathsFor: aCollection
"Resolve the names in aCollection according to the base directories
in baseDirectories, and return the collection with the full filenames, or
nil if no directory was found for one or more file in aCollection."
^aCollection collect: [ :fileName || name |
- name := self findBaseDirs: baseDirectories forFile: fileName.
- name isNil ifTrue: [ ^nil ] ifFalse: [ name ]]
+ name := self findPathFor: fileName ]
!

-findBaseDirs: baseDirectories forFile: fileName
+findPathFor: fileName
"Try appending 'self directory' and fileName to each of the directory
in baseDirectories, and return the path to the first tried filename that
exists. Return nil if no directory is found that contains the file."
| name |
baseDirectories do: [ :dir |
name := dir.
- self directory isNil ifFalse: [
- name := Directory append: self directory to: dir ].
+ self relativeDirectory isNil ifFalse: [
+ name := Directory append: self relativeDirectory to: dir ].
name := Directory append: fileName to: name.
(File exists: name) ifTrue: [ ^name ] ].
- ^nil
+
+ "TODO: should put the name and baseDirectories into the exception."
+ "name printNl. baseDirectories printNl."
+ PackageNotAvailable signal: self
!

directory
"Answer the base directory from which to load the package."
- ^directory!

-directory: dir
- "Set the base directory from which to load the package to dir."
- directory := dir!
+ self relativeDirectory isNil ifTrue: [ ^nil ].
+
+ self baseDirectories
+ do: [ :dir || name |
+ name := Directory append: self relativeDirectory to: dir.
+ (Directory exists: name) ifTrue: [ ^name ] ].
+
+ PackageNotAvailable signal: self!
+
+relativeDirectory
+ "Answer the directory, relative to the packages file, from which to load
+ the package."
+ ^relativeDirectory!
+
+relativeDirectory: dir
+ "Set the directory, relative to the packages file, from which to load
+ the package, to dir."
+ relativeDirectory := dir!

createNamespace
"Private - Create the path of namespaces indicated by our
@@ -847,12 +946,14 @@ loaded
primFileIn
"Private - File in the given package without paying attention at
dependencies and C callout availability"
- | dir namespace |

+ | dir namespace |
self loaded ifTrue: [ ^self ].
+
+ dir := Directory working.
+ namespace := Namespace current.
[
- dir := Directory working.
- namespace := Namespace current.
+ | loadedFiles |
Namespace current: self createNamespace.
self directory isNil ifFalse: [ Directory working: self directory ].
self libraries do: [ :each | DLD addLibrary: each ].
@@ -863,7 +964,8 @@ primFileIn
(CFunctionDescriptor isFunction: func)
ifFalse: [ ^self error: 'C callout not available: ', func ]]].

- self fileIns do: [ :each | FileStream fileIn: each ].
+ loadedFiles := self findPathsFor: self fileIns.
+ loadedFiles do: [ :each | FileStream fileIn: each ].
self name isNil ifFalse: [ Smalltalk addFeature: self name ].
self features do: [ :each | Smalltalk addFeature: each ].
] ensure: [
@@ -897,7 +999,7 @@ parse: file tag: openingTag
tag = 'prereq' ifTrue: [ self prerequisites add: cdata ] ifFalse: [
tag = 'provides' ifTrue: [ self features add: cdata ] ifFalse: [
tag = 'module' ifTrue: [ self modules add: cdata ] ifFalse: [
- tag = 'directory' ifTrue: [ self directory: cdata ] ifFalse: [
+ tag = 'directory' ifTrue: [ self relativeDirectory: cdata ] ifFalse: [
tag = 'name' ifTrue: [ self name: cdata ] ifFalse: [
tag = 'namespace' ifTrue: [ self namespace: cdata ] ifFalse: [
tag = 'library' ifTrue: [ self libraries add: cdata ] ifFalse: [
@@ -930,6 +1032,16 @@ parse: file tag: openingTag
]
! !

+!Kernel.DisabledPackage methodsFor: 'accessing'!
+
+printOn: aStream indent: indent
+ self printOn: aStream tag: 'disabled-package' indent: indent
+!
+
+isDisabled
+ ^true
+! !
+

!PackageLoader class methodsFor: 'accessing'!

--- orig/packages.xml.in
+++ mod/packages.xml.in
@@ -55,8 +55,8 @@
<filein>BloxText.st</filein>
<filein>BloxExtend.st</filein>
<filein>Blox.st</filein>
- <filein>../browser/test.st</filein>
- <directory>blox-gtk</directory>
+ <filein>../../browser/test.st</filein>
+ <directory>blox/gtk</directory>

<file>Blox.st</file>
<file>BloxBasic.st</file>
@@ -76,9 +76,9 @@
<filein>BloxCanvas.st</filein>
<filein>BloxExtend.st</filein>
<filein>Blox.st</filein>
- <filein>../browser/test.st</filein>
+ <filein>../../browser/test.st</filein>
<module>blox-tk</module>
- <directory>blox-tk</directory>
+ <directory>blox/tk</directory>

<file>Blox.st</file>
<file>BloxBasic.st</file>
@@ -642,7 +642,6 @@
<file>LazyCollection.st</file>
<file>Man.st</file>
<file>Tetris.st</file>
- <file>Generator.st</file>
<file>Gen2.st</file>
<file>Lisp.st</file>
<file>Queens.st</file>
@@ -791,7 +790,6 @@
<file>Regex.st</file>
<file>StreamOps.st</file>

- <file>../vfs/</file>
<file>../vfs/README</file>
<file>../vfs/deb</file>
<file>../vfs/lslR</file>
@@ -812,6 +810,7 @@

<file>Test.st</file>
<file>Load.st</file>
+ <file>Package.st</file>
<file>Getopt.st</file>
</disabled-package>

* added files

--- /dev/null
+++ mod/scripts/Package.st
@@ -0,0 +1,248 @@
+"======================================================================
+|
+| Smalltalk package installer
+|
+|
+ ======================================================================"
+
+
+"======================================================================
+|
+| Copyright 2007 Free Software Foundation, Inc.
+| Written by Paolo Bonzini.
+|
+| This file is part of GNU Smalltalk.
+|
+| GNU Smalltalk is free software; you can redistribute it and/or modify it
+| under the terms of the GNU General Public License as published by the Free
+| Software Foundation; either version 2, or (at your option) any later version.
+|
+| GNU Smalltalk is distributed in the hope that it will be useful, but WITHOUT
+| ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+| FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
+| details.
+|
+| You should have received a copy of the GNU General Public License along with
+| GNU Smalltalk; see the file COPYING. If not, write to the Free Software
+| Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
+|
+ ======================================================================"
+
+
+Kernel.PackageDirectory subclass: PackageFile [
+ refreshStarList []
+
+ refreshPackageList [
+ | file |
+ file := FileStream open: fileName mode: FileStream read.
+ [ self parse: file baseDirectories: baseDirectories ]
+ ensure: [ file close ].
+ ]
+]
+
+Kernel.PackageDirectories subclass: PackageFiles [
+ | srcdir |
+
+ addAllFiles: aCollection [
+ aCollection do: [ :each | self addFile: each ]
+ ]
+
+ addFile: fileName [
+ | packageFile |
+ packageFile := PackageFile
+ on: fileName
+ baseDirectories: (self baseDirsFor: fileName).
+
+ packageFile refresh.
+ self add: packageFile.
+ ]
+
+ baseDirsFor: fileName [
+ ^self srcdir isNil
+ ifTrue: [ { (File name: fileName) path } ]
+ ifFalse: [ { (File name: fileName) path. srcdir } ]
+ ]
+
+ srcdir [
+ ^srcdir
+ ]
+
+ srcdir: aString [
+ srcdir := aString
+ ]
+]
+
+File extend [
+ emitRemove [
+ ('rm -f %1' bindWith: self) displayNl
+ ]
+
+ emitSymlink: dest [
+ self isDirectory ifTrue: [ ^(Directory name: dest) emitMkdir ].
+
+ ('cp -pf %1 %2'
+ bindWith: self
+ with: (File name: dest)) displayNl
+ ]
+
+ emitInstall: dest [
+ | mode |
+ mode := self isExecutable ifTrue: [ 8r755 ] ifFalse: [ 8r644 ].
+ ('$INSTALL -m %1 %2 %3'
+ bindWith: (mode printString: 8)
+ with: self
+ with: (File name: dest)) displayNl
+ ]
+]
+
+Directory extend [
+ emitMkdir [
+ ('$mkdir_p %1' bindWith: self) displayNl
+ ]
+]
+
+| installDir mode listFiles destdir files packageFiles helpString |
+
+mode := #install.
+listFiles := OrderedCollection new.
+installDir := Directory image.
+destdir := ''.
+packageFiles := OrderedCollection new.
+packages := PackageFiles new.
+
+helpString :=
+'Usage:
+ gst-package [OPTION]... FILES...
+
+ -n, --dry-run print commands rather than running them
+ --test run unit tests after merging
+ --no-load don''t load the Smalltalk files in the image
+ --uninstall remove the packages mentioned in the FILES
+ --dist create symbolic links of non-built files
+ --list-files PKG just output the list of files in the package
+ --list-packages just output the list of packages in the files
+ --srcdir DIR look for non-built files in directory DIR
+ --distdir DIR for --dist, place files in directory DIR
+ --destdir DIR prefix the destination directory with DIR
+ --target-directory DIR install the files in DIR (unused for --dist)
+
+ --help display this message and exit
+ --version print version information and exit
+
+Except in uninstall and list files mode, gst-package requires write
+access to the GNU Smalltalk image directory, and merges the XML package
+files on the command line with that file.
+
+The default target directory is $install_dir.'.
+
+[
+ Smalltalk
+ "--no-load, --image-file, --dry-run are processed by gst-package."
+ arguments: '-h|--help --no-load --uninstall --dist
+ -t|--target-directory: --list-files: --list-packages
+ --srcdir: --distdir|--destdir: -n|--dry-run -I|--image-file:'
+
+ do: [ :opt :arg |
+ opt = 'help' ifTrue: [
+ helpString displayOn: stderr.
+ ObjectMemory quit: 0 ].
+
+ opt = 'uninstall' ifTrue: [ mode := #uninstall ].
+ opt = 'dist' ifTrue: [ mode := #dist ].
+ opt = 'target-directory' ifTrue: [ installDir := arg ].
+ opt = 'list-files' ifTrue: [ listFiles add: arg ].
+ opt = 'list-packages' ifTrue: [ mode := #list ].
+ opt = 'srcdir' ifTrue: [ packages srcdir: arg ].
+ opt = 'destdir' ifTrue: [ destdir := arg ].
+
+ opt isNil ifTrue: [ packageFiles add: arg ] ].
+
+ "Validate the installation and source directory."
+ mode = #dist
+ ifTrue: [
+ destdir isEmpty ifTrue: [
+ self error: 'using --dist without specifying --distdir' ].
+ installDir := '' ]
+ ifFalse: [
+ ((Directory name: installDir) name ~= installDir
+ and: [ destdir notEmpty ]) ifTrue: [
+ self error: '--destdir used with relative target directory' ] ].
+
+ packages addAllFiles: packageFiles.
+
+ "Process --uninstall, --list-packages, --list-files now, then exit."
+ mode = #uninstall ifTrue: [
+ packages do: [ :each || baseDir |
+ baseDir := Directory append: each relativeDirectory to: installDir.
+ each allFiles do: [ :file || destName |
+ destName := destdir, (Directory append: file to: baseDir).
+ (File name: destName) emitRemove ] ].
+
+ ObjectMemory quit ].
+
+ mode = #list ifTrue: [
+ packages do: [ :each | each name displayNl ].
+ ObjectMemory quit ].
+
+ listFiles isEmpty ifFalse: [
+ listFiles do: [ :each || package |
+ package := packages at: each.
+ package allFiles do: [ :file |
+ (package findPathFor: file) displayNl ] ].
+ ObjectMemory quit ].
+
+
+ "Create the installation directory. Then, if we are installing, add
+ packages.xml to the list and merge the supplied packages files with it.
+ This is temporary, as installation will create .star packages later on."
+
+ installDir := destdir, installDir.
+ (Directory name: installDir) emitMkdir.
+
+ "This is also temporary. To merge the packages.xml file, we need to
+ really create the file. This screws up --dry-run but, again, it's
+ temporary."
+ ((Directory name: installDir) name subStrings: $/)
+ inject: (Directory name: '/')
+ into: [ :old :each || dir |
+ dir := old directoryAt: each.
+ dir exists ifFalse: [ dir := Directory create: dir name ].
+ dir ].
+
+ mode = #dist ifFalse: [
+ | destFile mergeResult |
+ destFile := File name: installDir, '/packages.xml'.
+ mergeResult := packages copy.
+ destFile exists ifTrue: [
+ "In this case, we can pass problematic packages through."
+ [ mergeResult addFile: destFile name ]
+ on: Kernel.PackageNotAvailable
+ do: [ :ex | ex resume ] ].
+
+ destFile withWriteStreamDo: [ :s | mergeResult printOn: s ] ].
+
+ packages do: [ :each || dirs files baseDir |
+ files := mode = #dist
+ ifTrue: [ each files ]
+ ifFalse: [ each allFiles ].
+
+ dirs := files collect: [ :file |
+ Directory append: (File pathFor: file) to: each relativeDirectory ].
+
+ dirs asSet asSortedCollection do: [ :dir |
+ destName := Directory append: dir to: installDir.
+ (Directory name: destName) emitMkdir ].
+
+ baseDir := Directory append: each relativeDirectory to: installDir.
+ files do: [ :file || srcFile destName |
+ srcFile := File name: (each findPathFor: file).
+ destName := Directory append: file to: baseDir.
+
+ mode = #dist
+ ifTrue: [ srcFile emitSymlink: destName ]
+ ifFalse: [ srcFile emitInstall: destName ] ] ]
+]
+ on: Error
+ do: [ :ex |
+ ('gst-package: ', ex messageText) displayOn: stderr.
+ "ex pass." ObjectMemory quit: 1 ].

_______________________________________________
help-smalltalk mailing list
[hidden email]
http://lists.gnu.org/mailman/listinfo/help-smalltalk