Package.st

"======================================================================
|
|   Smalltalk package installer
|
|
 ======================================================================"


"======================================================================
|
| Copyright 2007, 2008 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.
|
 ======================================================================"


Package extend [
    srcdir [
	^self baseDirectories last
    ]

    isStarPackageBody [
	^self baseDirectories first isKindOf: VFS.ArchiveFile
    ]

    starFileName [
	| dir |
	self isStarPackageBody ifFalse: [ self halt ].
	^self baseDirectories first asString
    ]

    runCommand: aCommand [
	self isStarPackageBody
	    ifTrue: [ aCommand runOnStar: self ]
	    ifFalse: [ aCommand runOnPackage: self ]
    ]
]

Kernel.PackageDirectory subclass: StarPackageFile [
    refreshStarList: dir [
	| package |
	package := Kernel.StarPackage file: self file.
        packages at: package name put: package loadedPackage
    ]

    refreshPackageList []
]

Kernel.PackageDirectory subclass: PackageFile [
    refreshStarList: dir []

    refreshPackageList [
        | file |
	self file withReadStreamDo: [ :fileStream |
	    self parse: fileStream ]
    ]
]

Kernel.PackageDirectories subclass: PackageFiles [
    | srcdir |

    addAllFiles: aCollection [
	aCollection do: [ :each | self addFile: each ]
    ]

    parse: fileName [
	| file packageFile |
	file := File name: fileName.
	packageFile := ('*.star' match: fileName)
	    ifFalse: [
		PackageFile
		    on: file
		    baseDirectories: [ self baseDirsFor: file ] ]
	    ifTrue: [
		StarPackageFile
		    on: file
		    baseDirectories: [ {(File name: fileName) zip} ] ].

	packageFile refresh.
	^packageFile
    ]

    addFile: fileName [
	self add: (self parse: fileName).
    ]

    baseDirsFor: file [
	| srcdirFile builddirPrefix |
	self srcdir isNil ifTrue: [ ^{ file path } ].

	"See if the file is in srcdir or builddir.  In any case, we want to
	 look for files first in the builddir, and secondarily in srcdir."
	srcdirFile := file pathFrom: self srcdir.
	builddirPrefix := Directory working pathFrom: self srcdir.
	^(srcdirFile startsWith: builddirPrefix, Directory pathSeparatorString)
	    ifFalse: [ {
		"file is in srcdir."
		(File name: srcdirFile) parent.
		file parent } ]
	    ifTrue: [ {
		"file is in builddir."
		file parent.
		(self srcdir / (file pathFrom: Directory working)) parent } ]
    ]

    filesDo: aBlock [
	(dirs collect: [ :each | each fileName ]) asSet do: aBlock
    ]

    srcdir [
	^srcdir
    ]

    srcdir: aString [
	srcdir := aString
    ]
]

File extend [
    emitZipDir: dir [
	| saveDir |
	self emitRemove.
	('cd %1 && %2 -n .st:.xml -qr %3 .' % { dir. Command zip. self }) displayNl.
        saveDir := Directory working.
	Command
	    execute: [
	        Directory working: dir name.
		Smalltalk system: '%1 -n .st:.xml -qr %2 .' % { Command zip. self }
	    ]
	    ensure: [ Directory working: saveDir ]
    ]

    emitRemove [
	('rm -f %1' % { self }) displayNl.
	Command execute: [
	    self exists ifTrue: [ self remove ] ].
    ]

    emitSymlink: dest [
	| destFile |
	('%1 -f %2 %3' % { Command symLink. self. dest }) displayNl.
	Command execute: [
	    destFile := File name: dest.
	    destFile exists ifTrue: [ destFile remove ].
	    self symlinkAs: dest ].
    ]

    emitInstall: dest [
	| destFile srcStream destStream mode |
	mode := self isExecutable ifTrue: [ 8r755 ] ifFalse: [ 8r644 ].
	destFile := File name: dest.
	('%1 -m %2 %3 %4' % {
	    Command install. mode printString: 8. self. destFile })
		displayNl.
	Command
	    execute: [
	        destFile exists ifTrue: [ destFile remove ].
	        srcStream := self readStream.
		destStream := destFile writeStream.
	        destStream nextPutAll: srcStream.
	    ]
	    ensure: [
		destStream isNil ifFalse: [ destStream close ].
		srcStream isNil ifFalse: [ srcStream close ].
		destFile mode: mode
	    ].
    ]

    emitMkdir [
	| doThat |
	self exists ifTrue: [ ^self ].
	Command execute: [ self parent emitMkdir ].
	('mkdir %1' % { self }) displayNl.
	Command execute: [ Directory create: self name ].
    ]
]

Object subclass: Command [
    | packages installDir options |

    DryRun := false.
    Command class >> execute: aBlock [
	DryRun ifFalse: [ aBlock value ]
    ]
    Command class >> execute: aBlock ensure: ensureBlock [
	DryRun ifFalse: [ aBlock ensure: ensureBlock ]
    ]
    Command class >> dryRun [
	^DryRun
    ]
    Command class >> dryRun: aBoolean [
	DryRun := aBoolean
    ]

    Command class >> zip [
	^(Smalltalk getenv: 'XZIP') ifNil: [ 'zip' ]
    ]
    Command class >> install [
	^(Smalltalk getenv: 'INSTALL') ifNil: [ 'install' ]
    ]
    Command class >> symLink [
	^(Smalltalk getenv: 'LN_S') ifNil: [ 'ln -s' ]
    ]

    options: aSet [
	options := aSet.
	aSet do: [ :each |
	    (self validOptions includes: each) ifFalse: [
		self error: ('option %1 invalid for this mode' % {each}) ] ]
    ]
    validOptions [ ^#() ]
    isOption: aString [ ^options includes: aString ]

    validateDestDir: destdir installDir: instDir [ 
	instDir isNil ifTrue: [ ^self ].
	((File name: instDir) name ~= instDir
	    and: [ destdir notEmpty ]) ifTrue: [
		self error: '--destdir used with relative target directory' ]
    ]

    destDir: destdir installDir: instDir [
	self validateDestDir: destdir installDir: instDir.
	installDir :=
	    File name: destdir, (instDir ifNil: [ self defaultInstallDir ])
    ]

    defaultInstallDir [ ^Directory image ]
    installDir [ ^installDir ]

    packages [
	packages isNil ifTrue: [ packages := PackageFiles new ].
	^packages 
    ]

    srcdir [
	^self packages srcdir ifNil: [ '.' ]
    ]
    srcdir: aString [
	(aString = '.' or: [ (File fullNameFor: aString) = Directory working ])
	    ifTrue: [ self packages srcdir: nil ]
	    ifFalse: [ self packages srcdir: aString ]
    ]

    addAllFiles: aCollection [ self packages addAllFiles: aCollection ]

    prolog [ ]
    run [ self packages do: [ :pkg | pkg runCommand: self ] ]
    runOnStar: aStarPackage [ self runOnPackage: aStarPackage ]
    runOnPackage: aPackage [ ]

    listFiles: listFiles [
	| base vpathBase vpath source test |
	vpath := self isOption: 'vpath'.
	source := self isOption: 'load'.
	test := self isOption: 'test'.
	base := self installDir.
	vpathBase := File name: self srcdir.

        listFiles do: [ :each || package files |
	    package := self packages at: each.
	    files := source
		ifFalse: [ package allFiles ]
		ifTrue: [ package fileIns ].

	    (test and: [ source and: [ package test notNil ]])
		ifTrue: [ files := files, package test fileIns ].

	    files do: [ :file |
		| path relativePath |
		path := package fullPathOf: file.
		relativePath := base pathTo: path.
		(vpath and: [ (relativePath indexOfSubCollection: '../') > 0 ])
		    ifTrue: [ relativePath := vpathBase pathTo: path ].

		relativePath displayNl ] ]
    ]
]

Command subclass: PkgDist [
    validateDestDir: destdir installDir: instDir [ 
	(destdir isEmpty and: [ instDir isNil ]) ifTrue: [
	    self error: 'using --dist without specifying --distdir' ].
    ]

    defaultInstallDir [ ^'' ]
    run [
	super run.

	"Distribute package files, unless they are automatically generated
	 from autoconf."
	packages filesDo: [ :each |
	    | destName autoconfName srcdir |
	    destName := File stripPathFrom: each.
	    srcdir := self srcdir / (File pathFor: each).
	    autoconfName := destName, '.in'.
	    (srcdir includes: autoconfName)
		ifFalse: [
		    self distribute: (File name: each)
			as: destName
			in: nil ] ]
    ]

    validOptions [ ^#('all-files' 'copy') ]

    distribute: srcFile as: file in: dir [
	| destName baseDir |
	baseDir := self installDir.
	dir isNil ifFalse: [ baseDir := baseDir / dir ].
	destName := baseDir nameAt: file.
	(self isOption: 'copy')
	    ifTrue: [ srcFile emitInstall: destName ]
	    ifFalse: [ srcFile emitSymlink: destName ]
    ]

    runOnPackage: aPackage [
	| dirs files baseDir |
	files := (self isOption: 'all-files')
	    ifTrue: [ aPackage allFiles ]
	    ifFalse: [ aPackage allDistFiles ].

        dirs := files collect: [ :file | File pathFor: file ].
	dirs := dirs asSet remove: '' ifAbsent: [ ]; asSortedCollection.

	baseDir := self installDir.
	aPackage relativeDirectory isNil ifFalse: [
	    baseDir := baseDir / aPackage relativeDirectory ].

	baseDir emitMkdir.
        dirs do: [ :dir | (baseDir / dir) emitMkdir ].

        files do: [ :file || srcFile destName |
	    srcFile := aPackage fullPathOf: file.
	    self distribute: srcFile as: file in: aPackage relativeDirectory ]
    ]
    runOnStar: aPackage [
	self error: 'cannot distribute sources from .star file'
    ]
]

Command subclass: PkgInstall [
    | tmpDir |
    validOptions [ ^#('load' 'test') ]

    run [
        "Create the installation directory."
        self installDir emitMkdir.
	[ super run ] ensure: [
	    tmpDir isNil ifFalse: [ tmpDir all remove ] ].

	(Command dryRun not and: [ self isOption: 'load' ])
	    ifTrue: [ ^self loadPackages ].

	(self isOption: 'test') ifTrue: [ self runTests ]
    ]

    runTests [
	"Run SUnit tests, used unless --load is given too."
	| script result |
	script := ''.
	self packages do: [ :each || pkg |
	    pkg := each.
            script := script, ' ', pkg sunitScript.
            pkg test notNil ifTrue: [
                pkg := pkg test.
                script := script, ' ', pkg sunitScript ].
            pkg fileIn ].

	(PackageLoader packageAt: #SUnit) loaded ifFalse: [ ^self ].
	script isEmpty ifTrue: [ ^self ].

	result := TestSuitesScripter run: script quiet: false verbose: false.
	result runCount = result passedCount
	    ifFalse: [ ObjectMemory quit: 1 ]
    ]

    loadPackages [
	"Call gst-load, needed because we added our code to the image."
	| gstPackage execDir gstLoad pat packageList |
	gstPackage := File executable.
	gstPackage stripPath = 'gst-tool'
	    ifTrue: [
		gstLoad := gstPackage.
		pat := '%1 gst-load -I %2 --kernel-directory %3 %4 %5' ]
	    ifFalse: [
		gstLoad := gstPackage directory / 'gst-load'.
		pat := '%1 -I %2 --kernel-directory %3 %4 %5' ].

	packageList := ''.
	self packages
	    do: [ :each | packageList := packageList, ' ', each name ].

	Smalltalk system: (pat % {
	    gstLoad.
	    File image.
	    Directory kernel.
	    (self isOption: 'test') ifTrue: [ '--test' ] ifFalse: [ '' ].
	    packageList })
    ]

    tmpDir [
	tmpDir isNil ifTrue: [
            tmpDir := Directory createTemporary: Directory temporary / 'gstar-'.
            ('mkdir %1' % { tmpDir }) displayNl ].
	^tmpDir
    ]

    runOnPackage: aPackage [
	| pkg destFile dirs files baseDir |
	baseDir := self tmpDir / aPackage name.
	pkg := aPackage copy.
	pkg relativeDirectory: nil.

	baseDir emitMkdir.
	Command
	    execute: [
	        (baseDir / 'package.xml') withWriteStreamDo: [ :s |
	            pkg printOn: s ].

	        files := pkg allFiles.
                dirs := files collect: [ :file | File pathFor: file ].
	        (dirs asSet remove: '' ifAbsent: []; asSortedCollection)
		    do: [ :dir | (baseDir / dir) emitMkdir ].

                files do: [ :file || srcFile |
	            srcFile := (aPackage fullPathOf: file).
	            srcFile emitSymlink: (baseDir nameAt: file) ].

	        (self installDir / aPackage name, '.star')
		    emitZipDir: baseDir
	    ]
	    ensure: [ baseDir all remove ].
    ]

    runOnStar: aPackage [
	| destFile |
	destFile := self installDir nameAt: aPackage name, '.star'.
	(File name: aPackage starFileName) emitInstall: destFile.
    ]
]

Command subclass: PkgUninstall [
    run [
        super run.
        packages filesDo: [ :each | (File name: each) emitRemove ]
    ]

    runOnPackage: aPackage [
	| baseDir |
	baseDir := self installDir.
	aPackage relativeDirectory isNil ifFalse: [
	    baseDir := baseDir / aPackage relativeDirectory ].

	aPackage allFiles do: [ :file |
	    (baseDir / file) emitRemove ]
    ]

    runOnStar: aPackage [ ]
]

Command subclass: PkgList [
    validOptions [ ^#('list-files' 'vpath' 'load') ]
    validateDestDir: destdir installDir: installDir [
	destdir = ''
	    ifFalse: [ self error: '--destdir not needed with --list-files' ].
	installDir isNil
	    ifFalse: [ self error: '--target-directory not needed with --list-files' ]
    ]
    defaultInstallDir [ ^'.' ]
]

PkgList subclass: PkgPackageList [
    runOnPackage: aPackage [ aPackage name displayNl ]
]

Command subclass: PkgPrepare [
    | srcFile |
    validateDestDir: destdir installDir: installDir [
	destdir = ''
	    ifFalse: [ self error: '--destdir not needed with --prepare' ].
	installDir isNil
	    ifFalse: [ self error: '--target-directory not needed with --prepare' ]
    ]

    addAllFiles: aCollection [
	| f |
	aCollection isEmpty ifTrue: [
	    (File exists: self srcdir, '/package.xml')
		ifTrue: [ srcFile := 'package.xml' ].
	    (File exists: self srcdir, '/package.xml.in')
		ifTrue: [ srcFile := 'package.xml.in' ].
	    ^super addAllFiles: { srcFile } ].

	srcFile isNil ifTrue: [
	    f := self srcdir / aCollection first.
            (File exists: f)
	        ifTrue: [ srcFile := (File name: self srcdir) pathTo: f ].

	    f := f, '.in'.
            (File exists: f)
	        ifTrue: [ srcFile := (File name: self srcdir) pathTo: f ]
	].

	super addAllFiles: aCollection.
    ]

    run [
        | base configureAC makefileAM gstIN |
	base := File name: self srcdir.
	configureAC := base at: 'configure.ac'.
	makefileAM := base at: 'Makefile.am'.
	gstIN := base at: 'gst.in'.

	configureAC exists ifFalse: [
	    'creating configure.ac' displayNl.
	    Command dryRun ifFalse: [
	        configureAC withWriteStreamDo: [ :ws | self writeConfigure: ws ] ] ].
	gstIN exists ifFalse: [
	    'creating gst.in' displayNl.
	    Command dryRun ifFalse: [
	        gstIN withWriteStreamDo: [ :ws | self writeGstIn: ws ] ] ].
	makefileAM exists ifFalse: [
	    'creating Makefile.am' displayNl.
	    Command dryRun ifFalse: [
	        makefileAM withWriteStreamDo: [ :ws | self writeMakefile: ws ] ] ]
    ]

    writeGstIn: ws [
	ws nextPutAll:
'#! /bin/sh
abs_top_builddir=@abs_top_builddir@
: ${LIBTOOL=$abs_top_builddir/libtool}

exec $LIBTOOL --mode=execute @PACKAGE_DLOPEN_FLAGS@ @GST@ ${1+"$@"}
'
    ]

    writeConfigure: ws [
	| numPackages pkgName tarName |
	numPackages := 0.
	self packages do: [ :each |
	    pkgName := each name.
	    numPackages := numPackages + 1 ].

	numPackages = 1 ifFalse: [ pkgName := 'XYZ' ].

        tarName := 'gst-',
	    (pkgName asLowercase copyReplacingAllRegex: '[-_ ]+' with: '-').

	ws nextPutAll: ('AC_PREREQ(2.59)
AC_INIT([GNU Smalltalk package %1], [0.0], , %2)
AC_CONFIG_SRCDIR([%3])

AM_INIT_AUTOMAKE

AM_PATH_GST([2.95c], , [AC_MSG_ERROR([GNU Smalltalk not found])])
' % { pkgName. tarName. srcFile }).

	packages filesDo: [ :each |
	    self writeConfigureEntry: each to: ws ].

	ws nextPutAll: '
AC_CONFIG_FILES([Makefile])
AC_CONFIG_FILES([gst], [chmod +x gst])
AC_OUTPUT
'
    ]

    writeConfigureEntry: each to: ws [
	| pkgName buildPath srcPath pkgSrcDir relPkgSrcDir generated |
	buildPath := Directory working pathTo: each.
	srcPath := (File name: self srcdir) pathTo: each.

	pkgSrcDir := srcPath size < buildPath size
	    ifTrue: [ File pathFor: srcPath ifNone: [ self srcdir ] ]
	    ifFalse: [ File append: (File pathFor: buildPath) to: self srcdir ].

	relPkgSrcDir := (File name: self srcdir) pathTo: pkgSrcDir.

	('*.in' match: each)
	    ifTrue: [
		srcPath := srcPath allButLast: 3.
		buildPath := buildPath allButLast: 3.
		generated := true ]
	    ifFalse: [
		generated := (File name: srcPath, '.in') exists ].

	(File name: each) withReadStreamDo: [ :rs |
	    | pkg |
	    [ pkg := Package parse: rs ]
	        on: Kernel.PackageNotAvailable
	        do: [ :ex | ex resume ].
	    pkgName := pkg name ].

	ws nextPutAll: ('GST_PACKAGE_ENABLE([%1], [%2]' % {
	    pkgName. relPkgSrcDir }).

	generated ifTrue: [
	    ws nextPutAll: (', , , [%1]' % {
		(File name: relPkgSrcDir) pathTo: srcPath }) ].

	ws nextPutAll: ')'; nl.
    ]

    writeMakefile: ws [
	ws nextPutAll:
'AUTOMAKE_OPTIONS = foreign
AM_CPPFLAGS = $(GST_CFLAGS)

## Example:
##
## gst_module_ldflags = -rpath $(gstlibdir) -module \
##        -no-undefined -export-symbols-regex gst_initModule
##
## noinst_HEADERS = md5.h sha1.h
## gstlib_LTLIBRARIES = digest.la
## digest_la_SOURCES = digest.c md5.c sha1.c
## digest_la_LDFLAGS = $(gst_module_ldflags)


### -------------------------------------- ###
### Rules completed by GST_PACKAGE_ENABLE. ###
### -------------------------------------- ###

DISTCLEANFILES = pkgrules.tmp
all-local:
clean-local::
install-data-hook::
dist-hook::
uninstall-local::

@PACKAGE_RULES@
'
    ]
]

| srcdir installDir mode listFiles destdir packageFiles helpString options |

mode := nil.
listFiles := OrderedCollection new.
installDir := nil.
destdir := ''.
srcdir := '.'.
options := Set new.
packageFiles := OrderedCollection new.
packages := PackageFiles new.

helpString := 
'Usage:
    gst-package [OPTION]... FILES...

Operation modes:
        --install               make or install STAR packages (default)
        --uninstall             remove the packages mentioned in the FILES
        --dist                  copy files instead of creating STAR files.
        --prepare               create configure.ac or Makefile.am
        --list-files PKG        just output the list of files in the package
        --list-packages         just output the list of packages in the files
	--help                  display this message and exit
	--version               print version information and exit

Common suboptions:
    -n, --dry-run               print commands without running them
	--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)
    -I, --image-file=FILE       load into the specified image
        --kernel-dir=PATH       use the specified kernel directory

--install suboptions:
	--test                  run unit tests after merging
	--load                  also load the Smalltalk files in the image

--list-files suboptions:
	--load                  only list files that are filed in when loading
	--test                  with --load, also include unit test files
	--vpath			Omit path to srcdir for files that are there

--dist suboptions:
        --all-files             Process all files, not just non-built ones
        --copy                  Do not create symbolic links

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 ', Directory image name, '

'.

[
    Smalltalk
        "--kenrel-directory and --image-file are processed by gst-tool.
	 --no-load present for backwards compatibility, it is now the default.
	 --no-install is also present for backwards compatibility."
        arguments: '-h|--help --no-load --test --load --no-install --uninstall
            --dist -t|--target-directory: --list-files: --list-packages
            --prepare --srcdir: --distdir|--destdir: -n|--dry-run --all-files
	    --vpath --copy -I|--image-file: --kernel-directory: --version'

        do: [ :opt :arg |
	    opt = 'help' ifTrue: [
		helpString displayOn: stdout.
		ObjectMemory quit: 0 ].

	    opt = 'version' ifTrue: [
		('gst-package - %1' % {Smalltalk version}) displayNl.
		ObjectMemory quit: 0 ].

            opt = 'uninstall' ifTrue: [
		mode isNil ifFalse: [ self error: 'multiple modes specified' ].
		mode := PkgUninstall ].
            opt = 'dist' ifTrue: [
		mode isNil ifFalse: [ self error: 'multiple modes specified' ].
		mode := PkgDist ].
            opt = 'list-packages' ifTrue: [
		mode isNil ifFalse: [ self error: 'multiple modes specified' ].
		mode := PkgPackageList ].
            opt = 'no-install' ifTrue: [
		mode isNil ifFalse: [ self error: 'multiple modes specified' ].
		mode := PkgList ].
            opt = 'prepare' ifTrue: [
		mode isNil ifFalse: [ self error: 'multiple modes specified' ].
		mode := PkgPrepare ].
            opt = 'list-files' ifTrue: [
		(mode isNil or: [ mode = PkgList ])
		     ifFalse: [ self error: 'multiple modes specified' ].
		listFiles add: arg.
		mode := PkgList ].

            opt = 'target-directory' ifTrue: [ installDir := arg ].

            opt = 'srcdir' ifTrue: [ srcdir := arg ].
            opt = 'destdir' ifTrue: [ destdir := arg ].
            opt = 'dry-run' ifTrue: [ Command dryRun: true ].
            opt = 'test' ifTrue: [ options add: opt ].
            opt = 'load' ifTrue: [ options add: opt ].
            opt = 'all-files' ifTrue: [ options add: opt ].
            opt = 'copy' ifTrue: [ options add: opt ].
            opt = 'vpath' ifTrue: [ options add: opt ].

            opt isNil ifTrue: [ packageFiles add: arg ] ]
        ifError: [
            helpString displayOn: stderr.
            ObjectMemory quit: 1 ].

    mode isNil ifTrue: [ mode := PkgInstall ].

    "Validate the installation and source directory."
    mode new
        destDir: destdir installDir: installDir;
	srcdir: srcdir;
	addAllFiles: packageFiles;
	options: options;
	prolog;
	run;
	listFiles: listFiles
]
    on: Error
    do: [ :ex |
	('gst-package: ', ex messageText, '
') displayOn: stderr.
	"ex pass." ObjectMemory quit: 1 ].