From c30c8345ac4715218fab975c8bd8c4c4d8449c48 Mon Sep 17 00:00:00 2001 From: Anthony Carrico Date: Thu, 11 Mar 2004 19:01:40 +0000 Subject: [PATCH] Added files. --- scsh/scsh-packages/AUTHORS | 1 + scsh/scsh-packages/BLURB | 2 + scsh/scsh-packages/NEWS | 2 + scsh/scsh-packages/doc/latex/proposal.tex | 650 ++++++++++++++ scsh/scsh-packages/pkg-def.scm | 13 + .../scheme/install-lib/configure.scm | 27 + .../scheme/install-lib/install-lib-module.scm | 52 ++ .../scheme/install-lib/install-lib.scm | 812 ++++++++++++++++++ .../scheme/install-lib/install-pkg | 3 + 9 files changed, 1562 insertions(+) create mode 100644 scsh/scsh-packages/AUTHORS create mode 100644 scsh/scsh-packages/BLURB create mode 100644 scsh/scsh-packages/NEWS create mode 100644 scsh/scsh-packages/doc/latex/proposal.tex create mode 100644 scsh/scsh-packages/pkg-def.scm create mode 100644 scsh/scsh-packages/scheme/install-lib/configure.scm create mode 100644 scsh/scsh-packages/scheme/install-lib/install-lib-module.scm create mode 100755 scsh/scsh-packages/scheme/install-lib/install-lib.scm create mode 100755 scsh/scsh-packages/scheme/install-lib/install-pkg diff --git a/scsh/scsh-packages/AUTHORS b/scsh/scsh-packages/AUTHORS new file mode 100644 index 0000000..9ff94f6 --- /dev/null +++ b/scsh/scsh-packages/AUTHORS @@ -0,0 +1 @@ +Copyright (c) 2004 Michel Schinz diff --git a/scsh/scsh-packages/BLURB b/scsh/scsh-packages/BLURB new file mode 100644 index 0000000..cab35cf --- /dev/null +++ b/scsh/scsh-packages/BLURB @@ -0,0 +1,2 @@ +scsh-packages: A standard for the packaging, distribution, +installation, use and removal of libraries for scsh. diff --git a/scsh/scsh-packages/NEWS b/scsh/scsh-packages/NEWS new file mode 100644 index 0000000..60edf75 --- /dev/null +++ b/scsh/scsh-packages/NEWS @@ -0,0 +1,2 @@ +version 0.0 +* Imported from upstream Sourceforge CVS module "scsh-packages". diff --git a/scsh/scsh-packages/doc/latex/proposal.tex b/scsh/scsh-packages/doc/latex/proposal.tex new file mode 100644 index 0000000..0569ee1 --- /dev/null +++ b/scsh/scsh-packages/doc/latex/proposal.tex @@ -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{.pdf} where \file{} 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{.ps} where \file{} + 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{/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{} 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{} \\ + \location{active} & \file{.} \\ + \location{scheme} & \file{/scheme} \\ + \location{lib} & \file{/lib} \\ + \location{doc} & \file{/doc} \\ + \location{misc-shared} & \file{} \\ + \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/} \\ + \layout{active} & \file{share/scsh/modules} \\ + \layout{scheme} & \file{share/scsh/modules//scheme} \\ + \layout{lib} & \file{lib/scsh/modules/} \\ + \layout{doc} & \file{share/doc/} \\ + \layout{misc-shared} & \file{share/scsh/modules/} \\ + \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} \ No newline at end of file diff --git a/scsh/scsh-packages/pkg-def.scm b/scsh/scsh-packages/pkg-def.scm new file mode 100644 index 0000000..1d1c1b5 --- /dev/null +++ b/scsh/scsh-packages/pkg-def.scm @@ -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)) diff --git a/scsh/scsh-packages/scheme/install-lib/configure.scm b/scsh/scsh-packages/scheme/install-lib/configure.scm new file mode 100644 index 0000000..9e7ebf1 --- /dev/null +++ b/scsh/scsh-packages/scheme/install-lib/configure.scm @@ -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)))))) diff --git a/scsh/scsh-packages/scheme/install-lib/install-lib-module.scm b/scsh/scsh-packages/scheme/install-lib/install-lib-module.scm new file mode 100644 index 0000000..35827d9 --- /dev/null +++ b/scsh/scsh-packages/scheme/install-lib/install-lib-module.scm @@ -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=? + + (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)) diff --git a/scsh/scsh-packages/scheme/install-lib/install-lib.scm b/scsh/scsh-packages/scheme/install-lib/install-lib.scm new file mode 100755 index 0000000..7956ae1 --- /dev/null +++ b/scsh/scsh-packages/scheme/install-lib/install-lib.scm @@ -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) '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 #< specify directory where files are installed + --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 of platform for which to build + --layout-from load layout of installation directory from file + --layout-to output layout to given file + --install-prefix 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)))) diff --git a/scsh/scsh-packages/scheme/install-lib/install-pkg b/scsh/scsh-packages/scheme/install-lib/install-pkg new file mode 100755 index 0000000..58023dd --- /dev/null +++ b/scsh/scsh-packages/scheme/install-lib/install-pkg @@ -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" "$@" +!#