scsh-conservatory
/
sunterlib
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Added files.

This commit is contained in:
Anthony Carrico 2004-03-11 19:01:40 +00:00
parent fece670ed4
commit c30c8345ac
9 changed files with 1562 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
scsh/scsh-packages/AUTHORS Normal file
View File

@ -0,0 +1 @@
Copyright (c) 2004 Michel Schinz

2
scsh/scsh-packages/BLURB Normal file
View File

@ -0,0 +1,2 @@
scsh-packages: A standard for the packaging, distribution,
installation, use and removal of libraries for scsh.

2
scsh/scsh-packages/NEWS Normal file
View File

@ -0,0 +1,2 @@
version 0.0
* Imported from upstream Sourceforge CVS module "scsh-packages".

650
scsh/scsh-packages/doc/latex/proposal.tex Normal file
View File

@ -0,0 +1,650 @@
%% $Id: proposal.tex,v 1.1 2004/03/11 19:01:40 acarrico Exp $
%% TODO
%% - clean up permissions mess
\documentclass[a4paper,12pt]{article}
\usepackage[latin1]{inputenc}
\usepackage{a4wide, palatino, url, hyperref}
\newcommand{\file}{\begingroup \urlstyle{tt}\Url}
\newcommand{\envvar}[1]{\texttt{#1}}
\newcommand{\cloption}[1]{\texttt{#1}}
\newcommand{\package}[1]{\texttt{#1}}
\newcommand{\layout}[1]{\texttt{#1}}
\newcommand{\location}[1]{\texttt{#1}}
\newcommand{\ident}[1]{\texttt{#1}}
\newcommand{\define}[3]{%
\noindent%
(\texttt{#1} \textit{#2})\hfill\textit{(#3)}\\[0.5em]%
}
\newcommand{\definep}[2]{\define{#1}{#2}{procedure}}
\newcommand{\defines}[2]{\define{#1}{#2}{syntax}}
\newcommand{\param}[1]{\emph{#1}}
\newenvironment{rationale}%
{\begin{quotation}\noindent\textbf{Rationale}}%
{\end{quotation}}
\newenvironment{example}%
{\begin{quotation}\noindent\textbf{Example}}%
{\end{quotation}}
\begin{document}
\title{A proposal for scsh packages}
\author{Michel Schinz}
\maketitle
\section{Introduction}
\label{sec:introduction}
The aim of the following proposal is to define a standard for the
packaging, distribution, installation, use and removal of libraries
for scsh. Such packaged libraries are called \emph{scsh packages} or
simply \emph{packages} below.
This proposal attempts to cover both libraries containing only Scheme
code and libraries containing additional C code. It does not try to
cover applications written in scsh, which are currently considered to
be outside of its scope.
\subsection{Package identification and naming}
Packages are identified by a globally-unique name. This name should
start with an ASCII letter (a-z or A-Z) and should consist only of
ASCII letters, digits or underscore characters `\verb|_|'. Package
names are case-sensitive, but there should not be two packages with
names which differ only by their capitalisation.
\begin{rationale}
This restriction on package names ensures that they can be used to
name directories on current operating systems.
\end{rationale}
Several versions of a given package can exist. A version is identified
by a sequence of non-negative integers. Versions are ordered
lexicographically.
A version has a printed representation which is obtained by separating
(the printed representation of) its components by dots. For example,
the printed representation of a version composed of the integer 1
followed by the integer 2 is the string \texttt{1.2}. Below, versions
are usually represented using their printed representation for
simplicity, but it is important to keep in mind that versions are
sequences of integers, not strings.
A specific version of a package is therefore identified by a name and
a version. The \emph{full name} of a version of a package is obtained
by concatenating:
\begin{itemize}
\item the name of the package,
\item a hyphen `\texttt{-}',
\item the printed representation of the version.
\end{itemize}
In what follows, the term \emph{package} is often used to designate a
specific version of a package, but this should be clear from the
context.
\section{Distributing packages}
Packages are distributed in \texttt{tar} archives, which can
optionally be compressed by \texttt{gzip} or \texttt{bzip2}. The name
of the archive is composed by appending:
\begin{itemize}
\item the full name of the package,
\item the string \texttt{.tar} indicating that it's a \texttt{tar}
archive,
\item either the string \texttt{.gz} if the archive is compressed
using \texttt{gzip}, or the string \texttt{.bz2} if the archive is
compressed using \texttt{bzip2}, or nothing if the archive is not
compressed.
\end{itemize}
\subsection{Archive contents}
The archive is organised so that it contains one top-level directory
whose name is the full name of the package. This directory is called
the \emph{package unpacking directory}. All the files belonging to the
package are stored below it.
The unpacking directory contains at least the following files:
\begin{description}
\item[\file{install-pkg}] a script performing the installation of the
package,
\item[\file{README}] a textual file containing a short description of
the package,
\item[\file{COPYING}] a textual file containing the license of the
package.
\end{description}
\section{Downloading and installing packages}
A package can be installed on a target machine by downloading its
archive, expanding it and finally running the installation script
located in the unpacking directory.
\subsection{Layouts}
The installation script installs files according to some given
\emph{layout}. A layout maps abstract \emph{locations} to concrete
directories on the target machine. For example, a layout could map the
abstract location \location{doc}, where documentation is stored, to
the directory \file{/usr/local/share/doc/my_package}.
Currently, the following abstract locations are defined:
\begin{description}
\item[\location{base}] The ``base'' location of a package, where the
package loading script \file{load.scm} resides.
\item[\location{active}] Location containing a symbolic link, with the
same name as the package (excluding the version), pointing to the
base location of the package. This link is used to designate the
\emph{active} version of a package\,---\,the one to load when a
package is requested by giving only its name, without an explicit
version.
\item[\location{scheme}] Location containing all Scheme code. If the
package comes with some examples showing its usage, they are put in
a sub-directory called \file{examples} of this location.
\item[\location{lib}] Location containing platform-dependent files,
like shared libraries. This location contains one sub-directory per
platform for which packages have been installed, and nothing else.
\item[\location{doc}] Location containing all the package
documentation. This location contains one or more sub-directories,
one per format in which the documentation is available. The contents
of these sub-directories is standardised as follows, to make it easy
for users to find the document they need:
\begin{description}
\item[\file{html}] Directory containing the HTML documentation of
the package, if any; this directory should at least contain one
file called \file{index.html} serving as an entry point to the
documentation.
\item[\file{pdf}] Directory containing the PDF documentation of the
package, if any; this directory should contain at least one file
called \file{<package_name>.pdf} where \file{<package_name>} is
the name of the package.
\item[\file{ps}] Directory containing the PostScript documentation
of the package, if any; this directory should contain at least one
file called \file{<package_name>.ps} where \file{<package_name>}
is the name of the package.
\item[\file{text}] Directory containing the raw textual
documentation of the package, if any.
\end{description}
\item[\location{misc-shared}] Location containing miscellaneous data
which does not belong to any directory above, and which is
platform-independant.
\end{description}
The directories to which a layout maps these abstract locations are
not absolute directories, but rather relative ones. They are relative
to a \emph{prefix}, specified at installation time using the
\cloption{--prefix} option, as explained in section
\ref{sec:inst-proc}.
\begin{example}
Let's imagine that a user is installing version 1.2 of a package
called \package{foo}. This package contains a file called
\file{COPYING} which has to be installed in sub-directory
\file{license} of the \location{doc} location. If the user chooses
to use the default layout, which maps \location{doc} to directory
\file{<package_full_name>/doc} (see §~\ref{sec:scsh-layout}), and
specifies \file{/usr/local/share/scsh/modules} as a prefix, then the
\file{COPYING} file will end up in:
\[
\underbrace{\mathtt{/usr/local/share/scsh/modules/}}_{1}%
\underbrace{\mathtt{foo-1.2/doc/}}_{2}%
\underbrace{\mathtt{license/COPYING}}_{3}
\]
Part 1 is the prefix, part 2 is the layout's mapping for the
\location{doc} location, and part 3 is the file name relative to the
location.
\end{example}
\subsubsection{Predefined layouts}
\label{sec:predefined-layouts}
Every installation script comes with a set of predefined layouts which
serve different aims. They are described below.
\paragraph{The \layout{scsh} layout}
\label{sec:scsh-layout}
The \layout{scsh} layout is the default layout. It maps all locations
to sub-directories of a single directory, called the package
installation directory, which contains nothing but the files of the
package being installed. Its name is simply the full name of the
package in question, and it resides in the \file{prefix} directory.
The \layout{scsh} layout maps locations as given in the following
table, where \file{<package_full_name>} stands for the full name of
the package:
\begin{center}
\begin{tabular}{|l|l|}
\hline
\textbf{Location} & \textbf{Directory (relative to prefix)}\\
\hline
\location{base} & \file{<package_full_name>} \\
\location{active} & \file{.} \\
\location{scheme} & \file{<package_full_name>/scheme} \\
\location{lib} & \file{<package_full_name>/lib} \\
\location{doc} & \file{<package_full_name>/doc} \\
\location{misc-shared} & \file{<package_full_name>} \\
\hline
\end{tabular}
\end{center}
This layout is well suited for installations performed without the
assistance of an additional package manager, because it makes many
common operations easy. For example, finding to which package a file
belongs is trivial, as is the removal of an installed package.
\paragraph{The \layout{fhs} layout}
\label{sec:fhs-layout}
The \layout{fhs} layout maps locations according to the File Hierarchy
Standard (FHS, see \href{http://www.pathname.com/fhs/}%
{http://www.pathname.com/fhs/}), as follows:
\begin{center}
\begin{tabular}{|l|l|}
\hline
\textbf{Location} & \textbf{Directory (relative to prefix)}\\
\hline
\layout{base} & \file{share/scsh/modules/<package_full_name>} \\
\layout{active} & \file{share/scsh/modules} \\
\layout{scheme} & \file{share/scsh/modules/<package_full_name>/scheme} \\
\layout{lib} & \file{lib/scsh/modules/<package_full_name>} \\
\layout{doc} & \file{share/doc/<package_full_name>} \\
\layout{misc-shared} & \file{share/scsh/modules/<package_full_name>} \\
\hline
\end{tabular}
\end{center}
The main advantage of this layout is that it adheres to the FHS
standard, and is therefore compatible with several packaging policies,
like \href{http://www.debian.org/}{Debian}'s,
\href{http://fink.sourceforge.net/}{Fink}'s and others. Its main
drawback is that files belonging to a given package are scattered, and
therefore hard to find when removing or upgrading a package. Its use
should therefore be considered only if third-party tools are available
to track files belonging to a package.
%% \subsection{File permissions}
%% TODO
\subsection{Installation procedure}
\label{sec:inst-proc}
Packages are installed using the \file{install-pkg} script located in
the package archive. This script must be given the name of the prefix
using the \cloption{--prefix} option. It also accepts the following
options:
\begin{center}
\begin{tabular}{lp{.6\textwidth}}
\cloption{--layout} name & Specifies the layout to use (see §~\ref{sec:predefined-layouts}). \\
\cloption{--verbose} & Print messages about what is being done. \\
\cloption{--dry-run} & Print what actions would be performed to install the package, but do not perform them. \\
\cloption{--inactive} & Do not activate package after installing it. \\
\cloption{--non-shared-only} & Only install platform-dependent files, if any. \\
\cloption{--force} & Overwrite existing files during installation. \\
\cloption{--no-user-defaults} & Don't read user defaults in \file{.scsh-pkg-defaults} (see §~\ref{sec:user-preferences}). \\
\end{tabular}
\end{center}
\subsubsection{User preferences}
\label{sec:user-preferences}
Users can store default values for the options passed to the
installation script by storing them in a file called
\file{.scsh-pkg-defaults.scm} residing in their home directory. This
file must contain exactly one Scheme expression whose value is an
association list. The keys of this list, which must be symbols,
identify options and the values specify the default value for these
options. The contents of this file is implicitely quasi-quoted.
The values stored in this file override the default values of the
options, but they are in turn overriden by the values specified on the
command line of the installation script. Furthermore, it is possible
to ask for this file to be completely ignored by passing the
\cloption{--no-user-defaults} option to the installation script.
\begin{example}
A \file{.scsh-pkg-defaults} file containing the following:
\begin{verbatim}
;; Default values for scsh packages installation
((layout . "fhs")
(prefix . "/usr/local/share/scsh/modules")
(verbose . #t))
\end{verbatim}
specifies default values for the \cloption{--layout},
\cloption{--prefix} and \cloption{--verbose} options.
\end{example}
%% \subsection{Creating images}
%% TODO (my current idea is to add support to install-lib to easily
%% create an image containing the package being installed, and maybe some
%% structures opened. Then, at install time, users could say that they
%% want an image to be created, and the install script would do that).
\section{Using packages}
To use a package, its \emph{loading script} must be loaded in
Scheme~48's exec package. The loading script for a package is a file
written in the Scheme 48 exec language, whose name is \file{load.scm}
and which resides in the \location{base} location.
To load this file, one typically uses scsh's \cloption{-lel} option
along with a properly defined \envvar{SCSH\_LIB\_DIRS} environment
variable.
Scsh has a list of directories, called the library directories, in
which it looks for files to load when the options \cloption{-ll} or
\cloption{-lel} are used. This list can be given a default value
during scsh's configuration, and this value can be overridden by
setting the environment variable \envvar{SCSH\_LIB\_DIRS} before running
scsh.
In order for scsh to find the package loading scripts, one must make
sure that scsh's library search path contains the names of all
\location{active} locations which containing packages.
The names of these directories should not end with a slash `\verb|/|',
as this forces scsh to search them recursively. This could
\emph{drastically} slow down scsh when looking for packages.
\begin{example}
Let's imagine a machine on which the system administrator installs
scsh packages according to the \layout{fhs} layout in prefix
directory \file{/usr/local}. The \location{active} location for
these packages corresponds to the directory
\file{/usr/local/share/scsh/modules}, according to section
\ref{sec:fhs-layout}.
Let's also imagine that there is a user called \texttt{john} on this
machine, who installs additional scsh packages for himself in his
home directory, using \file{/home/john/scsh-packages} as a prefix.
To ease their management, he uses the \layout{scsh} layout. The
\location{active} location for these packages corresponds to the
directory \file{/home/john/scsh-packages}, according to section
\ref{sec:scsh-layout}.
In order to be able to use scsh packages installed both by the
administrator and by himself, user \texttt{john} needs to put both
active directories in his \envvar{SCSH\_LIB\_DIRS} environment
variable. The value of this variable will therefore be:
\begin{small}
\begin{verbatim}
"/usr/local/share/scsh/modules" "/home/john/scsh-packages"
\end{verbatim}
\end{small}
Now, in order to use packages \package{foo} and \package{bar} in one
of his script, user \texttt{john} just needs to load their loading
script using the \cloption{-lel} option when invoking scsh, as
follows:
\begin{verbatim}
-lel foo/load.scm -lel bar/load.scm
\end{verbatim}
\end{example}
\section{Authoring packages}
Once the Scheme and/or C code for a package has been written, the last
step in turning it into a standard package as defined by this proposal
is to write the installation script.
This script could be written fully by the package author, but in order
to simplify this task a small scsh installation framework is provided.
This framework is composed of several files which are meant to be
included in the package archive. These files are:
\begin{description}
\item[\file{install-pkg}] A trivial \texttt{sh} script which launches
scsh on the main function of the installation library, passing it
all the arguments given by the user.
\item[\file{install-lib.scm}] The code for the installation library,
whose public interface is documented below.
\item[\file{install-lib-module.scm}] Scheme 48 interface and structure
definitions for the installation library.
\end{description}
As explained above, when the \file{install-pkg} script is invoked, it
launches scsh on the main function of the installation library, which
does the following:
\begin{enumerate}
\item parse the command line arguments (e.g the \cloption{--prefix}
option),
\item load the package definition file, a (Scheme) file called
\file{pkg-def.scm}, which is supplied by the package author and
which contains one or several package definition statements, and
\item install the packages which were defined in the previous step.
\end{enumerate}
Most package definition files should contain a single package
definition, but the ability to define several packages in one file can
sometimes be useful.
The main job of the package author is therefore to write the package
definition file, \file{pkg-def.scm}. This file is mostly composed of a
package definition statement, which specifies the name, version and
installation code for the package. The package definition statement is
expressed using the \ident{define-package} form, documented in the
next section.
\subsection{Installation library}
\label{sec:install-library}
\subsubsection{Package definition}
\defines{define-package}{name version extension body ...}%
Define a package to be installed. \param{Name} (a string) is the
package name, \param{version} (a list of integers) is its version,
\param{extensions} is a list of extensions (see below), and
\param{body} is the list of statements to be evaluated in order to
install the package.
The installation statements typically use functions of the
installation library in order to install files in their target
location. The available functions are presented below.
\param{Extensions} is currently used only to specify additional
command-line arguments, but in the future it could serve other
purposes. It consists in a list of lists, each one starting with a
symbol identifying the extension, followed by extension-specific
parameters.
\begin{description}
\item[options] enables the script to define additional command-line
options. It accepts nine parameters in total, with the last three
being optional. The description of these parameters follows, in the
order in which they should appear:
\begin{description}
\item[\param{name}] (a symbol) is the name of the option, without
the initial double hyphen (\verb|--|),
\item[\param{help-text}] (a string) describes the option for the
user,
\item[\param{arg-help-text}] (a string) describes the option's
argument (if any) for the user,
\item[\param{required-arg?}] (a boolean) says whether this option
requires an argument or not,
\item[\param{optional-arg?}] (a boolean) says whether this option's
argument can be omitted or not,
\item[\param{default}] (anything) is the default value for the
option,
\item[\param{parser}] (a function from string to anything) parses
the option, i.e. turns its string representation into its internal
value,
\item[\param{unparser}] (a function from anything to string) turns
the internal representation of the option into a string,
\item[\param{transformer}] is a function taking the current value of
the option, the value given by the user and returning its new
value.
\end{description}
By default, \param{parser} and \param{unparser} are the identity
function, and \param{transformer} is a function which takes two
arguments and returns the second (i.e. the current value of the
option is simply replaced by the one given).
\end{description}
\subsubsection{Content installation}
\definep{install-file}{file location [target-dir]}%
Install the given \param{file} in the sub-directory \param{target-dir}
(which must be a relative directory) of the given \param{location}.
\param{Target-dir} is \file{.} by default.
If the directory in which the file is about to be installed does not
exist, it is created along with all its parents, as needed. If
\param{file} is a string, then the installed file will have the same
name as the original one. If \param{file} is a pair, then its first element
specifies the name of the source file, and its second element the name
it will have once installed. The second element must be a simple file
name, without any directory part.
\vspace{1em}
\definep{install-files}{file-list location [target-dir]}%
Like \ident{install-file} but for several files, which are specified
as a list. Each element in the list can be either a simple string or a
pair, as explained above.
\vspace{1em}
\definep{install-directory}{directory location [target-dir]}%
Install the given \param{directory} and all its contents, including
sub-directories, in sub-directory \param{target-dir} of
\param{location}. This is similar to what \param{install-file} does,
but for complete hierarchies.
Notice that \param{directory} will be installed as a sub-directory of
\param{target-dir}.
\vspace{1em}
\definep{install-directories}{dir-list location [target-dir]}%
Install several directories in one go.
\vspace{1em}
\definep{install-directory-contents}{directory location [target-dir]}%
Install the contents of the given \param{directory} in sub-directory
\param{target} of \param{location}.
\vspace{1em}
\definep{install-string}{string location [target-dir]}%
Install the contents of \param{string} in sub-directory
\param{target-dir} of \param{location}.
\subsubsection{Queries}
\definep{get-directory}{location install?}%
Get the absolute name of the directory to which the current layout
maps the abstract \param{location}. If \param{install?} is true, the
directory is the one valid during installation; If it is false, the
directory is the one valid after installation, that is when the
package is later used.
The distinction between installation-time and usage-time directories
is necessary to support staged installation, as performed by package
managers like Debian's APT.
\vspace{1em}
\definep{get-option-value}{option}%
Return the value of the given command-line \param{option} (a symbol).
This can be used to get the value of predefined options (like
\cloption{--dry-run}) or package-specific options.
\subsubsection{Load script generation}
\definep{with-output-to-load-script*}{thunk}%
Evaluate \param{thunk} with the current output opened on the loading
script of the current package. If this script was already existing,
its previous contents is deleted.
\vspace{1em}
\defines{with-output-to-load-script}{body ...}%
Syntactic sugar for \ident{with-output-to-load-script*}.
\vspace{1em}
\definep{write-to-load-script}{s-expression}%
Pretty-print the \param{s-expression} to the loading script of the
current package. If this script was already existing, its previous
contents is deleted.
\begin{example}
A typical package definition file for a simple package called
\package{pkg} whose version is 1.2 could look like this:
\begin{verbatim}
(define-package "pkg" (1 2) ()
(install-file "load.scm" 'base)
(install-directory-contents "scheme" 'scheme)
(install-file ("LICENSE" . "COPYING") 'doc)
(install-directory-contents "doc" 'doc))
\end{verbatim}
With such a definition, invoking the installation script with
\file{/usr/local/} as prefix and \layout{fhs} as layout has the
following effects:
\begin{enumerate}
\item The base directory \file{/usr/local/share/scsh/modules/pkg-1.2}
is created and file \file{load.scm} is copied to it.
\item All the contents of the directory called \file{scheme} is copied
to directory \file{/usr/local/share/scsh/modules/pkg-1.2/scheme}
which is created before, if needed.
\item File \file{LICENSE} is copied to directory
\file{/usr/local/share/doc/pkg-1.2/} with name \file{COPYING}.
\item All the contents of the directory called \file{doc} is copied to
directory \file{/usr/local/share/doc/pkg-1.2/}
\item The package is activated by creating a symbolic link with name
\file{/usr/local/share/scsh/modules/pkg} pointing to
\file{./pkg-1.2}
\end{enumerate}
\end{example}
\subsection{Packages containing C code (for shared libraries)}
Packages containing C code are more challenging to write, since all
the problems related to C's portability and incompatibilities between
the APIs of the various platforms have to be accounted for.
Fortunately, the GNU Autoconf system simplifies the management of
these problems, and authors of scsh packages containing C code are
strongly encouraged to use it.
%% Integrating Autoconf into the installation procedure should not be a
%% major problem thanks to scsh's ability to run separate programs.
\section{Packaging packages}
Most important Unix systems today have one (or several) package
management systems which ease the installation of packages on a
system. In order to avoid confusion between these packages and the
scsh packages discussed above, they will be called \emph{system
packages} in what follows.
It makes perfect sense to provide system packages for scsh packages.
System packages should as much as possible try to use the standard
installation script described above to install scsh packages. This
script currently provides some support for staged installations, which
are required by several packaging systems.
This support is provided through an additional option,
\cloption{--dest-dir}, which specifies the root directory in which to
install files. The files will then have to be moved from this location
to their final location by the system packaging tools.
(The \cloption{--dest-dir} option plays the same role as the
\envvar{DESTDIR} variable which is typically given to \texttt{make
install}, for makefiles which support staging directories).
%% \section{Glossary}
%% TODO define the following terms
%% Version
%% Target machine
%% Package
%% (Package) unpacking directory
%% Layout
%% (Abstract) location
%% Package loading script
\end{document}

13
scsh/scsh-packages/pkg-def.scm Normal file
View File

@ -0,0 +1,13 @@
(define-package "scsh-packages"
(0 0)
()
(install-file "load.scm" 'base)
(install-file "README" 'doc)
(install-file "NEWS" 'doc)
(install-string (COPYING) "COPYING" 'doc)
(install-file "scheme/install-lib/configure.scm" 'scheme)
(install-file "scheme/install-lib/install-lib-module.scm"
'scheme)
(install-file "scheme/install-lib/install-lib.scm" 'scheme)
(install-file "scheme/install-lib/install-pkg" 'scheme)
(install-file "doc/latex/proposal.tex" 'misc-shared))

27
scsh/scsh-packages/scheme/install-lib/configure.scm Normal file
View File

@ -0,0 +1,27 @@
;;; Library to obtain information about the underlying platform.
;;; $Id: configure.scm,v 1.1 2004/03/11 19:01:40 acarrico Exp $
(define-structure configure (export host)
(open scheme-with-scsh
srfi-13)
(begin
(define (canonical-machine uname-record)
(let* ((machine (uname:machine uname-record))
(os (uname:os-name uname-record)))
(cond
((member machine '("i386" "i486" "i586" "i686")) "i386")
((or (string=? machine "Power Macintosh")
(and (string=? os "AIX")
(regexp-search? (rx (: "00" (= 6 digit) any any "00"))
machine)))
"powerpc")
(else machine))))
(define (canonical-os-name uname-record)
(string-downcase (uname:os-name uname-record)))
(define (host)
(let ((uname-record (uname)))
(string-append (canonical-machine uname-record)
"-"
(canonical-os-name uname-record))))))

52
scsh/scsh-packages/scheme/install-lib/install-lib-module.scm Normal file
View File

@ -0,0 +1,52 @@
;;; Installation library for scsh modules.
;;; $Id: install-lib-module.scm,v 1.1 2004/03/11 19:01:40 acarrico Exp $
;;; Interfaces
(define-interface install-interface
(export tmpl-libtool-la-reader
version->string
string->version
version-compare
version<?
version>?
version=?
(define-package :syntax)
load-package-in
install-file
install-files
install-directory
install-directories
install-directory-contents
install-string
install-sub-package
identity
parse-boolean
show-boolean
get-directory
get-option-value
with-output-to-load-script*
(with-output-to-load-script :syntax)
write-to-load-script
install-main))
;;; Structures
(define-structure install install-interface
(open scheme-with-scsh
cells
fluids
let-opt
srfi-1
srfi-9
srfi-13
srfi-37
configure
pp)
(files install-lib))

812
scsh/scsh-packages/scheme/install-lib/install-lib.scm Executable file
View File

@ -0,0 +1,812 @@
;;; Installation library for scsh modules.
;;; $Id: install-lib.scm,v 1.1 2004/03/11 19:01:40 acarrico Exp $
;; TODO
;; - add a "--debug" option
;; - add support for communication between configure and pkg-def.scm
;; - add support for image creation
;; - add support to maintain a documentation index
;;
;; Support code templates
;;
;; These templates are meant to be inserted in package-loading
;; scripts.
;; Template to parse libtool's ".la" files.
(define tmpl-libtool-la-reader
'((define (normalize-la-entry key val)
(let ((left-quotes-rx (rx (: bos #\')))
(right-quotes-rx (rx (: #\' eos)))
(kill-matches
(lambda (rx str)
(regexp-substitute/global #f rx str 'pre 'post))))
(cons (string->symbol key)
(kill-matches left-quotes-rx
(kill-matches right-quotes-rx val)))))
(define add-la-entry
(let ((splitter (infix-splitter (rx #\=)))
(comment-rx (rx (: bos #\#))))
(lambda (line alist)
(cond
((and (not (regexp-search? comment-rx line))
(string-index line #\=))
(let ((lst (splitter line)))
(if (= 2 (length lst))
(cons (apply normalize-la-entry lst) alist)
(error "Could not read la entry" line list))))
(else alist)))))
(define (read-libtool-la file-name)
(call-with-input-file
file-name
(lambda (port)
(let lp ((line (read-line port)) (alist '()))
(if (eof-object? line)
alist
(lp (read-line port) (add-la-entry line alist)))))))))
;;
;; Utilities
;;
(define default-perms-fn
(lambda (name) #o755))
;; Return the name of the parent directory of FNAME.
(define (parent-directory fname)
(file-name-directory (directory-as-file-name fname)))
;; Create directory FNAME and all its parents, as needed.
(define (create-directory&parents fname . rest)
(let-optionals rest ((perms-fn default-perms-fn))
(let ((parent (parent-directory fname)))
(if (not (file-exists? parent))
(apply create-directory&parents parent rest))
(if (not (file-exists? fname))
(-create-directory fname
(perms-fn (absolute-file-name fname)))))))
;; Return the length of the longest prefix common to lists L1 and L2,
;; by comparing elements using PRED (defaults to EQUAL?).
(define (common-prefix-length l1 l2 . rest)
(let-optionals rest ((pred equal?))
(if (or (null? l1) (null? l2) (not (pred (first l1) (first l2))))
0
(+ 1 (apply common-prefix-length (cdr l1) (cdr l2) rest)))))
;; Return the name of file NAME relative to DIR (defaults to current
;; directory).
(define (relative-file-name name . rest)
(let-optionals rest ((dir (cwd)))
(let* ((abs-pl (split-file-name (absolute-file-name name)))
(dir-pl (split-file-name (directory-as-file-name dir)))
(cp-len (common-prefix-length abs-pl dir-pl)))
(path-list->file-name (append (make-list (- (length dir-pl) cp-len) "..")
(drop abs-pl cp-len))))))
;; Return the name of FNAME, which must be absolute, with NEW-ROOT as
;; root.
(define (re-root-file-name fname new-root)
(let ((fname-pl (split-file-name fname))
(new-root-pl (split-file-name new-root)))
(if (string=? (first fname-pl) "")
(path-list->file-name (append new-root-pl (cdr fname-pl)))
(error "no root to replace in relative file name" fname))))
;; If FILE exists, fail if --force was not given, delete it otherwise.
(define (delete-file-or-fail file)
(if (file-exists? file)
(if (get-option-value 'force)
(-delete-file file)
(error "target file exists" file))))
;; Copy file/symlink SOURCE to TARGET. TARGET must be the name of a
;; non-existing file (i.e. it cannot be the name of a directory).
(define (copy-file source target)
(delete-file-or-fail target)
(if (file-symlink? source)
(create-symlink (read-symlink source) target)
(begin
(run (cp ,source ,target))
(set-file-mode target (file-mode source)))))
;; Like "load" but without printing anything.
(define load-quietly
(let ((eval (lambda (expr t) (eval expr (interaction-environment)))))
(lambda (file-name)
(call-with-input-file file-name
(lambda (port) (port-fold port read eval #f))))))
(define (permissions->string perms)
(let ((decode (lambda (mask str)
(if (zero? (bitwise-and perms mask)) "-" str))))
(string-append (decode #o400 "r") (decode #o200 "w") (decode #o100 "x")
(decode #o040 "r") (decode #o020 "w") (decode #o010 "x")
(decode #o004 "r") (decode #o002 "w") (decode #o001 "x"))))
;; Replace all bindings of KEY in ALIST with one binding KEY to DATUM.
(define (alist-replace key datum alist)
(alist-cons key datum (alist-delete key alist)))
;; Add all mappings from ALIST-2 to ALIST-1. If a key is mapped in
;; both lists, the mapping in the first list takes precedence.
(define (alist-combine alist-1 alist-2)
(fold (lambda (key/value result)
(if (assoc (car key/value) result) result (cons key/value result)))
alist-1
alist-2))
;; Return the value associated with KEY in ALIST. If none exists,
;; return DEFAULT, or signal an error if no DEFAULT was given.
(define (alist-get key alist . rest)
(cond ((assoc key alist) => cdr)
((not (null? rest)) (first rest))
(else (error "internal error: cannot find key in alist" key alist))))
;; Convert all arguments to strings using DISPLAY and concatenate the
;; result in a single string which is returned.
(define (as-string . args)
(call-with-string-output-port
(lambda (port) (for-each (lambda (arg) (display arg port)) args))))
;; Return a string of max(M,N) white spaces.
(define (spaces m n) (make-string (max m n) #\space))
;;
;; Support for dry runs / verbose operation.
;;
(define (wrap real-fn info-fn)
(lambda args
(if (or (get-option-value 'verbose) (get-option-value 'dry-run))
(begin (display (apply info-fn args)) (newline)))
(if (not (get-option-value 'dry-run))
(apply real-fn args))))
(define -create-directory
(wrap create-directory
(lambda (fname . rest)
(let-optionals rest ((perms #o777))
(as-string "creating directory " fname
" (perms: " (permissions->string perms) ")")))))
(define -create-symlink
(wrap create-symlink
(lambda (old-name new-name)
(as-string "creating symbolic link " new-name
" pointing to " old-name))))
(define -copy-file
(wrap copy-file
(lambda (source target)
(as-string "copying file " source " to " target))))
(define -delete-file
(wrap delete-file
(lambda (fname) (as-string "deleting file " fname))))
;;
;; Versions
;;
;; Versions are represented as lists of integers, the most significant
;; being at the head.
;; Return the printed representation of VERSION.
(define (version->string version)
(string-join (map number->string version) "."))
;; Convert the printed representation of a version found in
;; VERSION-STRING to the version it represents.
(define string->version
(let ((split-version (infix-splitter ".")))
(lambda (version-string)
(map string->number (split-version version-string)))))
;; Compare two versions lexicographically and return the symbol
;; 'smaller if the first is strictly smaller than the second, 'equal
;; if both are equal, and 'greater otherwise.
(define (version-compare v1 v2)
(cond ((and (null? v1) (null? v2)) 'equal)
((null? v1) 'smaller)
((null? v2) 'greater)
(else (let ((v1h (car v1)) (v2h (car v2)))
(cond ((< v1h v2h) 'smaller)
((> v1h v2h) 'greater)
(else (version-compare (cdr v1) (cdr v2))))))))
(define (version<? v1 v2) (eq? (version-compare v1 v2) 'smaller))
(define (version>? v1 v2) (eq? (version-compare v1 v2) 'greater))
(define (version=? v1 v2) (eq? (version-compare v1 v2) 'equal))
;;
;; Layouts
;;
;; Names of all shared locations (i.e. the ones which do not depend on
;; the platform).
(define shared-locations
'(active base misc-shared scheme doc))
;; Names of all non-shared (i.e. platform-dependent) locations.
(define non-shared-locations
'(lib))
;; All locations defined for a layout.
(define all-locations (append shared-locations non-shared-locations))
;; Return true iff the given location is "active", that is if files
;; should be installed in it.
(define (active-location? location)
(member location (if (get-option-value 'non-shared-only)
non-shared-locations
all-locations)))
;; Parse a layout given as a string of comma-separated bindings. A
;; binding consists of the name of a location, followed by an equal
;; sign and the name of the directory to associate to the location.
;; Return #f if parsing fails.
(define parse-layout
(let ((split-defs (infix-splitter ","))
(split-sides (infix-splitter "=")))
(lambda (str)
(call-with-current-continuation
(lambda (return)
(map (lambda (name&value)
(let ((name/value (split-sides name&value)))
(if (= 2 (length name/value))
(cons (string->symbol (first name/value))
(second name/value))
(return #f))))
(split-defs str)))))))
;; Return an absolute version of LAYOUT by prepending PREFIX to all
;; its components (which must be relative).
(define (absolute-layout layout prefix)
(map (lambda (key/value)
(cons (car key/value) (absolute-file-name (cdr key/value) prefix)))
layout))
;; Return the directory associated with the LOCATION in LAYOUT.
(define (layout-dir layout location)
(alist-get location layout #f))
;; Predefined layouts
(define (scsh-layout platform base)
`((base . ,base)
(misc-shared . ,base)
(scheme . ,(absolute-file-name "scheme" base))
(lib . ,(absolute-file-name "lib" base))
(doc . ,(absolute-file-name "doc" base))))
(define (scsh-layout-1 platform pkg)
(alist-combine '((active . "."))
(scsh-layout platform (package-full-name pkg))))
(define (scsh-layout-2 platform pkg)
(alist-combine
'((active . "active"))
(scsh-layout platform
(path-list->file-name
(list "installed"
(package-name pkg)
(version->string (package-version pkg)))))))
(define (fhs-layout platform pkg)
(let ((base (absolute-file-name (package-full-name pkg)
"share/scsh/modules")))
`((base . ,base)
(misc-shared . ,base)
(scheme . ,(absolute-file-name "scheme" base))
(lib . ,(absolute-file-name (package-full-name pkg)
"lib/scsh/modules"))
(doc . ,(absolute-file-name (package-full-name pkg) "share/doc"))
(active . "share/scsh/modules"))))
(define predefined-layouts
`(("scsh" . ,scsh-layout-1)
("scsh-alt" . ,scsh-layout-2)
("fhs" . ,fhs-layout)))
;; If NAME-OR-LAYOUT refers to a predefined layout, return it.
;; Otherwise, if NAME-OR-LAYOUT is a valid layout definition, parse
;; and return it. Otherwise, return false.
(define (resolve-layout name-or-layout)
(or (alist-get name-or-layout predefined-layouts #f)
(parse-layout name-or-layout)))
;;
;; Packages
;;
(define-record-type package
(make-package name version extensions directory install-thunk)
package?
(name package-name)
(version package-version)
(extensions package-extensions)
(directory package-directory)
(install-thunk package-install-thunk))
;; Return the full name of PKG.
(define (package-full-name pkg)
(string-append
(package-name pkg) "-" (version->string (package-version pkg))))
;; Return the value of extension called EXT for PKG. If such an
;; extension doesn't exist, return #f.
(define (package-extension pkg ext)
(alist-get ext (package-extensions pkg) #f))
;; List of all defined packages
(define *packages* (make-fluid #f))
;; Add PKG to the above list of all defined packages.
(define (add-package pkg)
(cell-set! (fluid *packages*)
(cons pkg (cell-ref (fluid *packages*)))))
(define-syntax define-package
(syntax-rules ()
((define-package name version extensions body ...)
(add-package (make-package name
(quasiquote version)
(quasiquote extensions)
(cwd)
(lambda () body ...))))))
;; Load (and evaluate the contents of) the file "pkg-def.scm" in the
;; current directory and return the packages it defines.
(define (load-packages)
(let-fluid *packages* (make-cell '())
(lambda ()
(load-quietly package-definition-file)
(cell-ref (fluid *packages*)))))
(define (load-package-in dir)
(with-cwd dir (load-quietly package-definition-file)))
;;
;; Package options
;;
(define-record-type pkg-opt
(really-make-pkg-opt key
help
arg-help
required-arg?
optional-arg?
default
parse
show
transform)
pkg-opt?
(key pkg-opt-key)
(help pkg-opt-help)
(arg-help pkg-opt-arg-help)
(required-arg? pkg-opt-required-arg?)
(optional-arg? pkg-opt-optional-arg?)
(default pkg-opt-default)
(parse pkg-opt-parse)
(show pkg-opt-show)
(transform pkg-opt-transform))
(define (make-pkg-opt key help arg-help req-arg? opt-arg? default . rest)
(let-optionals rest ((parse identity)
(show identity)
(transform (lambda (old new) new)))
(really-make-pkg-opt key
help
arg-help
req-arg?
opt-arg?
default
parse
show
transform)))
;; Return the name of PKG-OPT
(define (pkg-opt-name pkg-opt)
(symbol->string (pkg-opt-key pkg-opt)))
;; Convert PKG-OPT into an SRFI-37 option.
(define (pkg-opt->option pkg-opt)
(let ((key (pkg-opt-key pkg-opt))
(transform (pkg-opt-transform pkg-opt))
(parse (pkg-opt-parse pkg-opt)))
(option (list (pkg-opt-name pkg-opt))
(pkg-opt-required-arg? pkg-opt)
(pkg-opt-optional-arg? pkg-opt)
(lambda (opt name arg alist)
(alist-replace key
(transform (alist-get key alist) (parse arg))
alist)))))
;; Return a pair (key, default) which associates the default value of
;; PKG-OPT to its key.
(define (pkg-opt-key&default pkg-opt)
(cons (pkg-opt-key pkg-opt) (pkg-opt-default pkg-opt)))
;; Return the list of all package options of the PACKAGES.
(define (all-package-options packages)
(append-map
(lambda (pkg)
(cond ((package-extension pkg 'options)
=> (lambda (opts)
(map (lambda (args) (apply make-pkg-opt args)) opts)))
(else '())))
packages))
;;
;; Load script handling
;;
;; Evaluate THUNK with CURRENT-OUTPUT-PORT opened on the current
;; package's loading script (in the install directory). During a dry
;; run, or when only non-shared data has to be installed, do nothing.
(define (with-output-to-load-script* thunk)
(let* ((dir (get-directory 'base #t))
(file (absolute-file-name "load.scm" dir)))
(create-directory&parents dir)
(if (not (or (get-option-value 'dry-run)
(get-option-value 'non-shared-only)))
(begin
(delete-file-or-fail file)
(with-output-to-file file thunk)))))
;; Sugar for with-output-to-load-script*.
(define-syntax with-output-to-load-script
(syntax-rules ()
((with-output-to-load-script body ...)
(with-output-to-load-script* (lambda () body ...)))))
;; Pretty-print all the elements of s-exps, one after the other, to
;; the current package's loading script (in the install directory).
(define (write-to-load-script s-exps)
(with-output-to-load-script (for-each p s-exps)))
;;
;; Actions
;;
;; Perform all actions required to make the given version of the
;; package active (i.e. the default version for that package).
(define (activate-package layout pkg)
(let ((lnk-name (absolute-file-name (package-name pkg)
(layout-dir layout 'active))))
(if (and (file-exists? lnk-name) (file-symlink? lnk-name))
(-delete-file lnk-name))
(-create-symlink (relative-file-name (layout-dir layout 'base)
(file-name-directory lnk-name))
lnk-name)))
(define (install-thing% layout name-or-pair location target-rel-dir perms-fn)
(let* ((target-dir (absolute-file-name target-rel-dir
(layout-dir layout location)))
(source (if (pair? name-or-pair) (car name-or-pair) name-or-pair))
(target-name (file-name-nondirectory (if (pair? name-or-pair)
(cdr name-or-pair)
name-or-pair)))
(target (absolute-file-name target-name target-dir)))
(if (not ((get-option-value 'exclude) source))
(begin
(create-directory&parents target-dir perms-fn)
(cond ((or (file-regular? source) (file-symlink? source))
(-copy-file source target))
((file-directory? source)
(-create-directory target (file-mode source))
(install-directory-contents% layout
source
location
(absolute-file-name
target-name
target-rel-dir)
perms-fn))
(else (error "cannot install file-system object" source)))))))
(define (install-directory-contents% layout
name
location
target-rel-dir
perms-fn)
(for-each (lambda (thing)
(install-thing% layout thing location target-rel-dir perms-fn))
(map (lambda (f) (absolute-file-name f name))
(directory-files name #t))))
(define (install-thing name-or-pair location . rest)
(if (active-location? location)
(let-optionals rest ((target-rel-dir ".") (perms-fn default-perms-fn))
(install-thing% (fluid *install-layout*)
name-or-pair
location
target-rel-dir
perms-fn))))
(define (install-things names-or-pairs . rest)
(for-each (lambda (name-or-pair)
(apply install-thing name-or-pair rest))
names-or-pairs))
(define install-file install-thing)
(define install-files install-things)
(define install-directory install-thing)
(define install-directories install-things)
(define (install-directory-contents name location . rest)
(if (active-location? location)
(let-optionals rest ((target-rel-dir ".") (perms-fn default-perms-fn))
(install-directory-contents% (fluid *install-layout*)
name
location
target-rel-dir
perms-fn))))
(define (install-string% layout str target-name location target-rel-dir)
(let* ((target-dir (absolute-file-name target-rel-dir
(layout-dir layout location)))
(target-full-name (absolute-file-name target-name target-dir)))
(create-directory&parents target-dir)
(delete-file-or-fail target-full-name)
(call-with-output-file target-full-name
(lambda (port) (write-string str port)))))
(define (install-string str target-name location . rest)
(let-optionals rest ((target-rel-dir "."))
(if (active-location? location)
(install-string% (fluid *install-layout*)
str
target-name
location
target-rel-dir))))
(define *layout* (make-fluid #f))
(define *install-layout* (make-fluid #f))
;; Return the directory identified by LOCATION in the current layout.
;; If INSTALL? is true, return the directory valid during the
;; installation of the package, otherwise return the directory valid
;; after installation (i.e. during package use).
(define (get-directory location install?)
(layout-dir (fluid (if install? *install-layout* *layout*)) location))
;; Perform all actions to install PKG in INSTALL-LAYOUT. If LAYOUT is
;; not the same as INSTALL-LAYOUT, assume that some external tool will
;; move the installed files so that they are laid out according to
;; LAYOUT.
(define (install-package layout install-layout pkg)
(with-cwd (package-directory pkg)
(let-fluids *layout* layout
*install-layout* install-layout
(package-install-thunk pkg))))
;; Install all PACKAGES with the given OPTIONS-VALUES.
(define (install-packages packages options-values)
(let* ((prefix (alist-get 'prefix options-values))
(dest-dir (alist-get 'dest-dir options-values))
(dest-prefix (and prefix (re-root-file-name prefix dest-dir)))
(layout-fn (resolve-layout (alist-get 'layout options-values)))
(layout-to (alist-get 'layout-to options-values))
(build (alist-get 'build options-values))
(non-shared-only? (alist-get 'non-shared-only options-values))
(activate? (not (alist-get 'inactive options-values))))
(let-fluids *options-values* options-values
(lambda ()
(for-each
(lambda (pkg)
(let* ((rel-layout (layout-fn build pkg))
(layout (absolute-layout rel-layout prefix))
(i-layout (absolute-layout rel-layout dest-prefix)))
(if layout-to
(call-with-output-file
(string-append layout-to "_" (package-full-name pkg))
(lambda (port)
(write rel-layout port) (newline port))))
(install-package layout i-layout pkg)
(if (and activate? (not non-shared-only?))
(activate-package i-layout pkg))))
packages)))))
(define (install-sub-package dir . rest)
(let-optionals rest ((options-diff '()))
(with-cwd dir
(install-packages
(load-packages)
(fold (lambda (diff options)
(cond ((pair? diff)
(cons diff (alist-delete (car diff) options)))
((symbol? diff)
(alist-delete diff options))
(else
(error "invalid option difference" diff))))
(fluid *options-values*)
options-diff)))))
;;
;; Error handling
;;
;; Display all the MSGS on the error port, then exit with an error
;; code of 1.
(define (display-error-and-exit . msgs)
(for-each display (cons "Error: " msgs))
(newline)
(exit 1))
(define usage #<<END
Usage: ~a [options]
options:
-h, --help display this help message, then exit
--prefix <dir> specify directory where files are installed
--layout <layout> specify layout of installation directory
(predefined: ~a)
--dry-run don't do anything, print what would have been done
--verbose print messages about what is being done
--inactive don't activate package after installing it
--non-shared-only only install platform-dependent files, if any
--force overwrite existing files during installation
advanced options:
--build <name> name of platform for which to build
--layout-from <file> load layout of installation directory from file
--layout-to <file> output layout to given file
--install-prefix <dir> specify prefix to used during installation
(to be used only during staged installations)
END
)
(define usage-descr-col 26)
;; Complete the above USAGE string to include information about the
;; package options PKG-OPTS.
(define (complete-usage! pkg-opts)
(let ((usage-port (make-string-output-port)))
(write-string usage usage-port)
(write-string "\npackage-specific options:\n" usage-port)
(for-each
(lambda (pkg-opt)
(let ((option/arg (format #f "--~a ~a"
(pkg-opt-name pkg-opt)
(pkg-opt-arg-help pkg-opt))))
(format usage-port
" ~a~a~a [~a]\n"
option/arg
(spaces 2 (- usage-descr-col (string-length option/arg)))
(pkg-opt-help pkg-opt)
((pkg-opt-show pkg-opt) (pkg-opt-default pkg-opt)))))
pkg-opts)
(set! usage (string-output-port-output usage-port))))
;; Display the usage string, then all MSGS on the standard output
;; port, then exit with an error code of 1.
(define (display-usage-and-exit . msgs)
(format #t
usage
(car (command-line))
(string-join (map car predefined-layouts) ", "))
(for-each display msgs)
(newline)
(exit 1))
;;
;; Command line parsing
;;
;; Predefined parsers/unparsers
(define (parse-boolean s)
(cond ((string=? s "yes") #t)
((string=? s "no") #f)
(else (display-error-and-exit
"unknown boolean value '"s"'. Use 'yes' or 'no'."))))
(define (show-boolean b)
(if b "yes" "no"))
;; The identity function, sometimes useful for parsers/unparsers.
(define (identity x) x)
;; Fluid containing the value of all options.
(define *options-values* (make-fluid #f))
(define package-definition-file "pkg-def.scm")
(define (get-option-value key)
(alist-get key (fluid *options-values*)))
(define options
(let ((alist-arg-updater (lambda (key)
(lambda (opt name arg alist)
(alist-replace key arg alist))))
(alist-boolean-updater (lambda (key)
(lambda (opt name arg alist)
(alist-replace key #t alist)))))
(list
(option '(#\h "help") #f #f
(lambda args (display-usage-and-exit)))
(option '("prefix") #t #f (alist-arg-updater 'prefix))
(option '("dest-dir") #t #f (alist-arg-updater 'dest-dir))
(option '("layout") #t #f (alist-arg-updater 'layout))
(option '("layout-from") #t #f
(lambda (opt name arg alist)
(alist-replace 'layout
(let ((layout (call-with-input-file arg read)))
(lambda args layout))
alist)))
(option '("layout-to") #t #f (alist-arg-updater 'layout-to))
(option '("build") #t #f (alist-arg-updater 'build))
(option '("non-shared-only") #f #f
(alist-boolean-updater 'non-shared-only))
(option '("inactive") #f #f (alist-boolean-updater 'inactive))
(option '("dry-run") #f #f (alist-boolean-updater 'dry-run))
(option '("verbose") #f #f (alist-boolean-updater 'verbose))
(option '("force") #f #f (alist-boolean-updater 'force)))))
(define no-user-defaults-option "--no-user-defaults")
(define (parse-options args options defaults)
(args-fold args
options
(lambda (option name . rest)
(display-usage-and-exit "Unknown option "name))
(lambda (operand . rest)
(display-usage-and-exit "Don't know what to do with " operand))
defaults))
;; Return user-specific defaults.
(define (read-user-defaults)
(let ((file (expand-file-name "~/.scsh-pkg-defaults.scm")))
(if (file-exists? file)
(call-with-input-file file
(lambda (port)
(let ((defaults (read port)))
(if (or (eof-object? defaults))
(display-error-and-exit "no valid defaults found in "file))
(if (not (eof-object? (read port)))
(display-error-and-exit
"more than one expression found in "file))
(eval (list 'quasiquote defaults) (interaction-environment)))))
'())))
(define options-defaults
`((prefix . #f)
(dest-dir . "/")
(layout . "scsh")
(layout-to . #f)
(build . ,(host))
(non-shared-only . #f)
(inactive . #f)
(dry-run . #f)
(verbose . #f)
(force . #f)
(exclude . ,(lambda args #f))))
(define (install-main cmd-line)
(if (not (file-exists? package-definition-file))
(display-error-and-exit "cannot find package definition file"
"("package-definition-file")"))
(let* ((packages (load-packages))
(all-pkg-opts (all-package-options packages)))
(if (not (null? all-pkg-opts))
(complete-usage! all-pkg-opts))
(let* ((all-opts (append options (map pkg-opt->option all-pkg-opts)))
(all-dfts (append (alist-combine
(if (member no-user-defaults-option cmd-line)
'()
(read-user-defaults))
options-defaults)
(map pkg-opt-key&default all-pkg-opts)))
(options-values (parse-options (delete no-user-defaults-option
(cdr cmd-line))
all-opts
all-dfts))
(prefix (alist-get 'prefix options-values))
(layout (alist-get 'layout options-values)))
(if (not prefix)
(display-error-and-exit "no prefix specified (use --prefix option)"))
(if (not (file-name-absolute? prefix))
(display-error-and-exit "prefix must be an absolute path"))
(if (not (resolve-layout layout))
(display-error-and-exit "invalid layout "layout))
(install-packages packages options-values))))

3
scsh/scsh-packages/scheme/install-lib/install-pkg Executable file
View File

@ -0,0 +1,3 @@
#!/bin/sh
exec scsh -lm configure.scm -lm install-lib-module.scm -o pp -o configure -o install -e install-main -s "$0" "$@"
!#