Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Initial commit

  • Loading branch information...
commit 353201051c453ca9a0dbde99a38d09a7fcbf49a4 0 parents
@dochang authored
1  .gitignore
@@ -0,0 +1 @@
+*.html
19 LICENSE
@@ -0,0 +1,19 @@
+Copyright (c) 2010 Desmond O. Chang
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in
+all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
+THE SOFTWARE.
12 Makefile
@@ -0,0 +1,12 @@
+.PHONY: all clean
+
+all: index.html asia.html
+
+index.html: README.asciidoc
+ asciidoc -b html4 -o $@ $?
+
+asia.html: asia.asciidoc
+ asciidoc -b html4 -o $@ $?
+
+clean:
+ rm -f index.html asia.html
72 README.asciidoc
@@ -0,0 +1,72 @@
+ASIA - ASDF2 Software Installation Assistant
+============================================
+
+
+ASIA is a trivial Common Lisp projects installer. It acts like an
+ASDF2 extension and installs the projects without dependencies.
+Dependency analysis is done by ASDF2. It's released under MIT
+License.
+
+
+Tutorial
+--------
+
+The complete documentation is link:asia.html[*here*].
+
+For default configuration on Debian, in the shell:
+
+----------------------------------------------------------------------
+
+# 1. Download & install ASIA like other ASDF loadable libraries, e.g.,
+$ git clone git://github.com/dochang/asia.git ~/.local/share/common-lisp/source/asia/
+
+# 2. prepare manifest files...
+# You can download a template here, e.g.,
+$ git clone git://github.com/dochang/repo51.git ~/.local/share/repo51/
+
+----------------------------------------------------------------------
+
+Then in the REPL:
+
+----------------------------------------------------------------------
+
+;; 1. Load ASIA
+;; Put it into ~/.sbclrc, ~/.ccl-init.lisp and so on!
+> (asdf:load-system :asia)
+
+;; 2. You can put this into $XDG_CONFIG_HOME/asia.lisp !
+> (cl:pushnew 'asia:sysdef-asia-search asdf:*system-definition-search-functions*)
+
+;; 3. ASDF will install hunchentoot and its dependencies automatically!
+> (asdf:load-system :hunchentoot)
+;...Installing...OK!
+;...All the systems loaded!
+
+----------------------------------------------------------------------
+
+
+Why another installer?
+----------------------
+
+I don't like all existing installers. That's why I wrote my own one.
+
+My ideal installer *should*:
+
+- just install the project itself.
+- install the project into a userspace directory.
+- work with various VCS backends.
+- work with archive files like tarball.
+- work with a plain, easy-to-edit database format.
+
+Also, *should not*:
+
+- analyse dependency.
+- force user to install an upstream version or a modified version.
+- use a centralized project manifest database.
+- mix its code with manifest data.
+
+
+Support and Mailing lists
+-------------------------
+
+All you need is asia-devel@common-lisp.net !
281 asia.asciidoc
@@ -0,0 +1,281 @@
+ASIA Manual
+===========
+
+
+Introduction
+------------
+
+ASIA is ASDF2 Software Installation Assistant. Unlike its
+competitors, ASIA only installs a project itself without its
+dependencies. Dependency analysis is done by ASDF2.
+
+ASIA is released under MIT License.
+
+
+Download & Installation
+-----------------------
+
+The source code is at `git://github.com/dochang/asia.git`. It's a
+regular ASDF loadable libraries, put it into any directory where ASDF
+can load it.
+
+ASIA uses a project manifest database to download projects. There is
+an "official" version at `git://github.com/dochang/repo51.git`. By
+default, it should be downloaded at `$XDG_DATA_HOME/repo51/` or
+`C:\repo51\`.
+
+Of cource, you can create you own version, See <<Configuration>> for
+details.
+
+
+Basic Usage
+-----------
+
+`ASIA:SYSDEF-ASIA-SEARCH` is the bridge between ASDF & ASIA.
+
+For example, if you want to install hunchentoot:
+
+----------------------------------------------------------------------
+> (cl:pushnew 'asia:sysdef-asia-search asdf:*system-definition-search-functions*)
+> (asdf:load-system :hunchentoot)
+----------------------------------------------------------------------
+
+Then ASIA will install hunchentoot and all its dependencies. After
+all the projects installed, they are loaded by ASDF.
+
+If you want to install hunchentoot without its dependencies, use:
+
+----------------------------------------------------------------------
+> (asia:install-project :hunchentoot)
+----------------------------------------------------------------------
+
+To delete hunchentoot, use:
+
+----------------------------------------------------------------------
+> (asia:delete-project :hunchentoot)
+----------------------------------------------------------------------
+
+NOTE: This doesn't delete dependencies.
+
+
+[[Configuration]]
+Configuration
+-------------
+
+ASIA will load the first file found by ASIA:
+
+1. `$XDG_CONFIG_HOME/common-lisp/asia.lisp`
+2. `$XDG_CONFIG_DIRS/common-lisp/asia.lisp`
+3. For Windows, `%APPDATA%/common-lisp/config/asia.lisp`
+4. `$HOME/.config/common-lisp/asia.lisp`
+
+Typically, the content of the config file is:
+
+----------------------------------------------------------------------
+(in-package :asia)
+(pushnew 'sysdef-asia-search *system-definition-search-functions*)
+----------------------------------------------------------------------
+
+
+Project Manifest Location
+~~~~~~~~~~~~~~~~~~~~~~~~~
+
+`*PROJECT-MANIFEST*` controls where the project manifest is. It must
+be a pathname. Default value is `$XDG_DATA_HOME/repo51/` or
+`~/.local/share/repo51/` on *nix, and `C:\repo51\` on Windows.
+
+
+Source Location
+~~~~~~~~~~~~~~~
+
+`*SOURCE-LOCATION*` controls where the downloaded projects is. It
+must be a pathname or NIL (default). NIL means the subdirectory
+`source` in `*PROJECT-MANIFEST*`.
+
+Function SOURCE-LOCATION returns the current location. Do not use
+this variable directly unless you're binding it.
+
+
+Temporary Directory
+~~~~~~~~~~~~~~~~~~~
+
+`*TEMPORARY-DIRECTORY*` is used to store temporary files such as the
+files downloaded by cURL. It must be a pathname. Default value is
+`$TMPDIR` or `/tmp/` on *nix and `C:\Temp\` on Windows.
+
+
+FIXME: About the pathnames which have whitespace characters
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Currently all the pathnames used in ASIA must not have whitespace
+characters. That means you can't use directories like `Documents and
+Settings`.
+
+It's because of Clozure has a "feature" that changes filename to
+`name\\.tar.gz`. We have to put all the filenames without the quote
+character in `RUN-SHELL-COMMAND`, so that the shell command such as
+Bash can interpret `name\\.tar.gz` correctly.
+
+
+Concepts in ASIA
+~~~~~~~~~~~~~~~~
+
+Before we describe the project manifest database, we must introduce
+some concepts used in ASIA.
+
+Project::
+
+In ASIA, a project does not mean its code, but its meta information.
+A project should be installed into a directory whose name is
+_project-name_. A project usually has a system file
++_project-name_.asd+ in its top directory. Currently a project object
+in ASIA is just its name, all other info can be computed from it.
+
+Project Name::
+
+A string or a symbol except NIL. If it's a symbol, it represents the
+downcase form of its symbol-name.
+
+Pathname Specifier::
+
+A portable form of pathname from ASDF. You can use pathname specifier
+to tell ASIA where the system pathname is. A pathname specifier must
+represent a relative pathname. The function `PATHSPEC` translates a
+pathname specifier to a pathname. See ASDF manual 5.3.4 for details.
+
+Pathname Location Designator::
+
+A list DSL that indicate a pathname from ASDF. The function
+`LOCATION` translates a location designator to a pathname. See ASDF
+manual 7.4 & 8.3 for details.
+
+
+How to create project manifest database
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Although ASIA provides a official database called 'repo51', you can
+even use your own database.
+
+The database is like a key-value filesystem database. For example,
+the url of a project is in the file +projects/_project-name_/url+ in
+the directory `*PROJECT-MANIFEST*`; also, the project name of a system
+is in the file +systems/_system-name_/project+. You can easily get
+the absolute pathname using +(MANIFEST-PATHNAME "projects"
+_project-name_ "url")+.
+
+Project Information
+^^^^^^^^^^^^^^^^^^^
+
+In most cases, the only file you must provide for a project is `url`.
+Its value is a url for VCS command or download tool, such as:
+
+- `git://example.com/project.git`
+- `http://example.com/project.tar.gz`
+
+ASIA handles the url according to the following patterns:
+
+[separator="!"]
+|=====================================================================
+!Git !`^(git|git\+ssh|ssh\+git)://|/git(/|$)|\.git/?$`
+!SVN !`^svn://`
+!Darcs !`/darcs(/|$)`
+!CVS* !`^:pserver:`
+!cURL !`^(https?|ftps?|sftp|file)://`
+|=====================================================================
+
+CVS url has two parts: cvsroot and module name. ASIA uses a special
+form like `cvsroot#module`. If `module` is omitted, the project name
+is used, and the sharpsign `#` is optional. That means, ASIA handles
+`:pserver:cvsroot#module` by using `cvs -d :pserver:cvsroot co
+module`, and handles `:pserver:cvsroot` by using +cvs -d
+:pserver:cvsroot co _project-name_+.
+
+If ASIA cannot determine the backend, the url is considered as a local
+pathname.
+
+System Information
+^^^^^^^^^^^^^^^^^^
+
+Several projects have more than one system files, like cffi and
+postmodern. Some projects have a system file whose name is different
+from the project's name, like cl-sqlite. Some projects have a system
+file which is not in the toplevel directory. We must let ASIA search
+asd files in a different way.
+
+To specify the project name of a system, put the name into the file
++systems/_system-name_/project+ in the directory `*PROJECT-MANIFEST*`,
+e.g., put `cffi` into `systems/cffi-grovel/project`.
+
+To specify the pathname of a system, put the pathname specifier into
+the file +systems/_system-name_/pathname+, e.g., if you want to use
+the uffi wrapper in cffi, put `uffi-compat/uffi.asd` into
+`systems/uffi/pathname` and put `cffi` into `systems/uffi/project`.
+
+Ignoring Projects
+^^^^^^^^^^^^^^^^^
+
+Sometimes you want to manually install a project into another place.
+You can use the file +projects/_project-name_/ignore+ to make ASIA
+ignore it. The content can be anything, even empty.
+
+ASIA has ignored many internal projects coming with implementations,
+such as `sb-posix`.
+
+
+Advanced Usage
+--------------
+
+
+Custom Installer
+~~~~~~~~~~~~~~~~
+
+Sometimes you need a custom installation method. You can use the file
++projects/_project-name_/installer.lisp+. This file should contain a
+lambda expression. ASIA reads it as a list, then coerce it to a
+closure. All the symbols in the closure is in a temporary package
+which uses the package COMMON-LISP, ASDF and ASIA. When it's being
+evaluated, `*DEFAULT-PATHNAME-DEFAULTS*` is bound to
++/_database-dir_/projects/_project-name_/+.
+
+ASIA tries to use `installer.lisp` first. If it doesn't exist, then
+use `url`. If `url` doesn't exist too, ASIA raises an error.
+
+
+Quickly install using `INSTALL-PROJECT`
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+If you want to install a project from a different url and you don't
+want to modify the 'url' file temporarily, use the keyword parameter
+`url` of `INSTALL-PROJECT`. See the documentation of
+`INSTALL-PROJECT`.
+
+
+Index
+-----
+
+Here is a list of all exported symbols from package ASIA, please see
+their documentations for details:
+
+- `pathspec`
+- `location`
+- `*project-manifest*`
+- `*source-location*`
+- `*temporary-directory*`
+- `make-temp-pathname`
+- `manifest-pathname`
+- `source-location`
+- `project-name`
+- `project-directory`
+- `project-installed-p`
+- `install-project`
+- `delete-project`
+- `sysdef-asia-search`
+
+
+Support and mailing lists
+-------------------------
+
+If you have questions, bug reports, feature requests and patches, send
+your email to asia-devel@common-lisp.net. Please visit:
+
+http://common-lisp.net/cgi-bin/mailman/listinfo/asia-devel
42 asia.asd
@@ -0,0 +1,42 @@
+(in-package :cl-user)
+
+(defpackage :asia-asdf
+ (:use :cl :asdf))
+
+(in-package :asia-asdf)
+
+(defsystem :asia
+ :author "Desmond O. Chang <dochang+asia@gmail.com>"
+ :maintainer "Desmond O. Chang <dochang+asia@gmail.com>"
+ :license "MIT"
+ :description "ASDF2 Software Installation Assistant"
+ :long-description "ASIA installs Common Lisp projects automatically."
+ :depends-on (:asdf #+sbcl :sb-posix)
+ :serial t
+ :pathname "src/"
+ :components ((:module "fad"
+ :serial t
+ :components ((:file "packages")
+ #+:cormanlisp (:file "corman")
+ #+:openmcl (:file "openmcl")
+ (:file "fad")
+ (:file "test")))
+ (:module "pregexp"
+ :components ((:file "pregexp")))
+ (:file "package")
+ (:file "utils")
+ (:file "specials")
+ (:file "base")
+ (:file "project")
+ (:file "installer")
+ (:file "asdf")
+ (:file "test")))
+
+(defmethod perform :after ((op load-op) (c (eql (find-system :asia))))
+ (pushnew :asia *features*)
+ (let* ((rcfile (asdf::in-user-configuration-directory "asia.lisp")))
+ (when rcfile
+ (load rcfile))))
+
+(defmethod perform ((op test-op) (c (eql (find-system :asia))))
+ (funcall (intern "TEST" :asia)))
28 src/asdf.lisp
@@ -0,0 +1,28 @@
+(in-package :asia)
+
+(defun system-project (system)
+ "Returns the project which contains SYSTEM."
+ (let* ((system-name (asdf:coerce-name system)))
+ (or (with-system-file (in system-name "project")
+ (read-line in nil nil))
+ system-name)))
+
+(defun system-pathname (system &optional project)
+ "Returns SYSTEM's pathname."
+ (let* ((system-name (asdf:coerce-name system)))
+ (merge-pathnames*
+ (or (with-system-file (in system-name "pathname")
+ (let* ((x (read-line in nil nil)))
+ (and x (pathspec x))))
+ (pathspec system-name :type "asd"))
+ (project-directory (or project (system-project system))))))
+
+(defun sysdef-asia-search (system)
+ "ASIA system definition search function. You should put this
+function into ASDF:*SYSTEM-DEFINITION-SEARCH-FUNCTIONS* manually."
+ (when system
+ (let* ((project (system-project system)))
+ (and project
+ (or (ignore-errors (install-project project))
+ (project-installed-p project))
+ (probe-file (system-pathname system project))))))
41 src/base.lisp
@@ -0,0 +1,41 @@
+(in-package :asia)
+
+(defun make-temp-name ()
+ (format nil "ASIA-~A-~A-~A-~A"
+ (implementation-identifier) (getpid)
+ (get-universal-time) (random #xFFFF)))
+
+(defun make-temp-package ()
+ (flet ((%try ()
+ (make-package (make-temp-name) :use '(:cl :asdf :asia))))
+ (loop :for package := (ignore-errors (%try))
+ :when package
+ :return package)))
+
+(defun make-temp-pathname (&key type defaults)
+ "Generates a unique temporary pathname. Keyword parameters are the
+same as PATHSPEC."
+ (location (list *temporary-directory*
+ #+(and (or win32 windows mswindows mingw32) (not cygwin))
+ "asia"
+ #-(and (or win32 windows mswindows mingw32) (not cygwin))
+ (format nil "asia~A" (get-uid))
+ (pathspec (make-temp-name) :type type :defaults defaults))))
+
+(defun manifest-pathname (prefix name pathspec)
+ (location (list *project-manifest* prefix name (pathspec pathspec))))
+
+(defmacro with-manifest-file ((stream prefix name pathspec) &body body)
+ (with-unique-names (fname)
+ `(let* ((,fname (manifest-pathname ,prefix ,name ,pathspec)))
+ (when (probe-file ,fname)
+ (with-open-file (,stream ,fname)
+ ,@body)))))
+
+(defmacro with-system-file ((stream system-name pathspec) &body body)
+ `(with-manifest-file (,stream "systems" ,system-name ,pathspec)
+ ,@body))
+
+(defmacro with-project-file ((stream project-name pathspec) &body body)
+ `(with-manifest-file (,stream "projects" ,project-name ,pathspec)
+ ,@body))
1  src/fad/README
@@ -0,0 +1 @@
+FAD comes from cl-fad. I changed the package name to ASIA-FAD.
86 src/fad/corman.lisp
@@ -0,0 +1,86 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/cl-fad/corman.lisp,v 1.5 2009/09/30 14:23:09 edi Exp $
+
+;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;; * Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+
+;;; * Redistributions in binary form must reproduce the above
+;;; copyright notice, this list of conditions and the following
+;;; disclaimer in the documentation and/or other materials
+;;; provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :cl)
+
+(defun wild-pathname-p (pathspec &optional field)
+ (unless (pathnamep pathspec)
+ (setq pathspec (pathname pathspec)))
+ (labels ((name-wild-p (name)
+ (or (eq :wild name)
+ (and (stringp name)
+ (string= "*" name))))
+ (dir-wild-p (dir)
+ (or (find :wild dir)
+ (find :wild-inferiors dir)
+ (find "*" dir :test #'string=))))
+ (case field
+ ((:name)
+ (name-wild-p (pathname-name pathspec)))
+ ((:type)
+ (name-wild-p (pathname-type pathspec)))
+ ((:directory)
+ (dir-wild-p (pathname-directory pathspec)))
+ ((nil)
+ (or (name-wild-p (pathname-name pathspec))
+ (name-wild-p (pathname-type pathspec))
+ (dir-wild-p (pathname-directory pathspec))))
+ (t nil))))
+
+(defun file-namestring (pathspec)
+ (flet ((string-list-for-component (component)
+ (cond ((eq component :wild)
+ (list "*"))
+ (component
+ (list component))
+ (t nil))))
+ (let* ((pathname (pathname pathspec))
+ (name (pathnames::pathname-internal-name pathname))
+ (type (pathnames::pathname-internal-type pathname)))
+ (format nil "~{~A~}~{.~A~}"
+ (string-list-for-component name)
+ (string-list-for-component type)))))
+
+(in-package :win32)
+
+(defwinapi RemoveDirectory
+ ((lpPathName LPCSTR))
+ :return-type BOOL
+ :library-name "Kernel32"
+ :entry-name "RemoveDirectoryA"
+ :linkage-type :pascal)
+
+(defun delete-directory (pathspec)
+ "Deletes the empty directory denoted by the pathname designator
+PATHSPEC. Returns true if successful, NIL otherwise."
+ (win:RemoveDirectory
+ (ct:lisp-string-to-c-string
+ (namestring (pathname pathspec)))))
+
+(export 'delete-directory)
282 src/fad/fad.lisp
@@ -0,0 +1,282 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-FAD; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/cl-fad/fad.lisp,v 1.35 2009/09/30 14:23:10 edi Exp $
+
+;;; Copyright (c) 2004, Peter Seibel. All rights reserved.
+;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;; * Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+
+;;; * Redistributions in binary form must reproduce the above
+;;; copyright notice, this list of conditions and the following
+;;; disclaimer in the documentation and/or other materials
+;;; provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :asia-fad)
+
+(defun component-present-p (value)
+ "Helper function for DIRECTORY-PATHNAME-P which checks whether VALUE
+is neither NIL nor the keyword :UNSPECIFIC."
+ (and value (not (eql value :unspecific))))
+
+(defun directory-pathname-p (pathspec)
+ "Returns NIL if PATHSPEC \(a pathname designator) does not designate
+a directory, PATHSPEC otherwise. It is irrelevant whether file or
+directory designated by PATHSPEC does actually exist."
+ (and
+ (not (component-present-p (pathname-name pathspec)))
+ (not (component-present-p (pathname-type pathspec)))
+ pathspec))
+
+(defun pathname-as-directory (pathspec)
+ "Converts the non-wild pathname designator PATHSPEC to directory
+form."
+ (let ((pathname (pathname pathspec)))
+ (when (wild-pathname-p pathname)
+ (error "Can't reliably convert wild pathnames."))
+ (cond ((not (directory-pathname-p pathspec))
+ (make-pathname :directory (append (or (pathname-directory pathname)
+ (list :relative))
+ (list (file-namestring pathname)))
+ :name nil
+ :type nil
+ :defaults pathname))
+ (t pathname))))
+
+(defun directory-wildcard (dirname)
+ "Returns a wild pathname designator that designates all files within
+the directory named by the non-wild pathname designator DIRNAME."
+ (when (wild-pathname-p dirname)
+ (error "Can only make wildcard directories from non-wildcard directories."))
+ (make-pathname :name #-:cormanlisp :wild #+:cormanlisp "*"
+ :type #-(or :clisp :cormanlisp) :wild
+ #+:clisp nil
+ #+:cormanlisp "*"
+ :defaults (pathname-as-directory dirname)))
+
+#+:clisp
+(defun clisp-subdirectories-wildcard (wildcard)
+ "Creates a wild pathname specifically for CLISP such that
+sub-directories are returned by DIRECTORY."
+ (make-pathname :directory (append (pathname-directory wildcard)
+ (list :wild))
+ :name nil
+ :type nil
+ :defaults wildcard))
+
+(defun list-directory (dirname)
+ "Returns a fresh list of pathnames corresponding to the truenames of
+all files within the directory named by the non-wild pathname
+designator DIRNAME. The pathnames of sub-directories are returned in
+directory form - see PATHNAME-AS-DIRECTORY."
+ (when (wild-pathname-p dirname)
+ (error "Can only list concrete directory names."))
+ #+:ecl
+ (let ((dir (pathname-as-directory dirname)))
+ (concatenate 'list
+ (directory (merge-pathnames (pathname "*/") dir))
+ (directory (merge-pathnames (pathname "*.*") dir))))
+ #-:ecl
+ (let ((wildcard (directory-wildcard dirname)))
+ #+:abcl (system::list-directory dirname)
+ #+(or :sbcl :cmu :scl :lispworks) (directory wildcard)
+ #+(or :openmcl :digitool) (directory wildcard :directories t)
+ #+:allegro (directory wildcard :directories-are-files nil)
+ #+:clisp (nconc (directory wildcard :if-does-not-exist :keep)
+ (directory (clisp-subdirectories-wildcard wildcard)))
+ #+:cormanlisp (nconc (directory wildcard)
+ (cl::directory-subdirs dirname)))
+ #-(or :sbcl :cmu :scl :lispworks :openmcl :allegro :clisp :cormanlisp :ecl :abcl :digitool)
+ (error "LIST-DIRECTORY not implemented"))
+
+(defun pathname-as-file (pathspec)
+ "Converts the non-wild pathname designator PATHSPEC to file form."
+ (let ((pathname (pathname pathspec)))
+ (when (wild-pathname-p pathname)
+ (error "Can't reliably convert wild pathnames."))
+ (cond ((directory-pathname-p pathspec)
+ (let* ((directory (pathname-directory pathname))
+ (name-and-type (pathname (first (last directory)))))
+ (make-pathname :directory (butlast directory)
+ :name (pathname-name name-and-type)
+ :type (pathname-type name-and-type)
+ :defaults pathname)))
+ (t pathname))))
+
+(defun file-exists-p (pathspec)
+ "Checks whether the file named by the pathname designator PATHSPEC
+exists and returns its truename if this is the case, NIL otherwise.
+The truename is returned in `canonical' form, i.e. the truename of a
+directory is returned as if by PATHNAME-AS-DIRECTORY."
+ #+(or :sbcl :lispworks :openmcl :ecl :digitool) (probe-file pathspec)
+ #+:allegro (or (excl:probe-directory (pathname-as-directory pathspec))
+ (probe-file pathspec))
+ #+(or :cmu :scl :abcl) (or (probe-file (pathname-as-directory pathspec))
+ (probe-file pathspec))
+ #+:cormanlisp (or (and (ccl:directory-p pathspec)
+ (pathname-as-directory pathspec))
+ (probe-file pathspec))
+ #+:clisp (or (ignore-errors
+ (let ((directory-form (pathname-as-directory pathspec)))
+ (when (ext:probe-directory directory-form)
+ directory-form)))
+ (ignore-errors
+ (probe-file (pathname-as-file pathspec))))
+ #-(or :sbcl :cmu :scl :lispworks :openmcl :allegro :clisp :cormanlisp :ecl :abcl :digitool)
+ (error "FILE-EXISTS-P not implemented"))
+
+(defun directory-exists-p (pathspec)
+ "Checks whether the file named by the pathname designator PATHSPEC
+exists and if it is a directory. Returns its truename if this is the
+case, NIL otherwise. The truename is returned in directory form as if
+by PATHNAME-AS-DIRECTORY."
+ #+:allegro
+ (and (excl:probe-directory pathspec)
+ (pathname-as-directory (truename pathspec)))
+ #+:lispworks
+ (and (lw:file-directory-p pathspec)
+ (pathname-as-directory (truename pathspec)))
+ #-(or :allegro :lispworks)
+ (let ((result (file-exists-p pathspec)))
+ (and result
+ (directory-pathname-p result)
+ result)))
+
+(defun walk-directory (dirname fn &key directories
+ (if-does-not-exist :error)
+ (test (constantly t)))
+ "Recursively applies the function FN to all files within the
+directory named by the non-wild pathname designator DIRNAME and all of
+its sub-directories. FN will only be applied to files for which the
+function TEST returns a true value. If DIRECTORIES is not NIL, FN and
+TEST are applied to directories as well. If DIRECTORIES is :DEPTH-FIRST,
+FN will be applied to the directory's contents first. If
+DIRECTORIES is :BREADTH-FIRST and TEST returns NIL, the
+directory's content will be skipped. IF-DOES-NOT-EXIST must be
+one of :ERROR or :IGNORE where :ERROR means that an error will be
+signaled if the directory DIRNAME does not exist."
+ (labels ((walk (name)
+ (cond
+ ((directory-pathname-p name)
+ ;; the code is written in a slightly awkward way for
+ ;; backward compatibility
+ (cond ((not directories)
+ (dolist (file (list-directory name))
+ (walk file)))
+ ((eql directories :breadth-first)
+ (when (funcall test name)
+ (funcall fn name)
+ (dolist (file (list-directory name))
+ (walk file))))
+ ;; :DEPTH-FIRST is implicit
+ (t (dolist (file (list-directory name))
+ (walk file))
+ (when (funcall test name)
+ (funcall fn name)))))
+ ((funcall test name)
+ (funcall fn name)))))
+ (let ((pathname-as-directory (pathname-as-directory dirname)))
+ (case if-does-not-exist
+ ((:error)
+ (cond ((not (file-exists-p pathname-as-directory))
+ (error "File ~S does not exist."
+ pathname-as-directory))
+ (t (walk pathname-as-directory))))
+ ((:ignore)
+ (when (file-exists-p pathname-as-directory)
+ (walk pathname-as-directory)))
+ (otherwise
+ (error "IF-DOES-NOT-EXIST must be one of :ERROR or :IGNORE."))))
+ (values)))
+
+(defvar *stream-buffer-size* 8192)
+
+(defun copy-stream (from to &optional (checkp t))
+ "Copies into TO \(a stream) from FROM \(also a stream) until the end
+of FROM is reached, in blocks of *stream-buffer-size*. The streams
+should have the same element type. If CHECKP is true, the streams are
+checked for compatibility of their types."
+ (when checkp
+ (unless (subtypep (stream-element-type to) (stream-element-type from))
+ (error "Incompatible streams ~A and ~A." from to)))
+ (let ((buf (make-array *stream-buffer-size*
+ :element-type (stream-element-type from))))
+ (loop
+ (let ((pos #-(or :clisp :cmu) (read-sequence buf from)
+ #+:clisp (ext:read-byte-sequence buf from :no-hang nil)
+ #+:cmu (sys:read-n-bytes from buf 0 *stream-buffer-size* nil)))
+ (when (zerop pos) (return))
+ (write-sequence buf to :end pos))))
+ (values))
+
+(defun copy-file (from to &key overwrite)
+ "Copies the file designated by the non-wild pathname designator FROM
+to the file designated by the non-wild pathname designator TO. If
+OVERWRITE is true overwrites the file designtated by TO if it exists."
+ #+:allegro (excl.osi:copy-file from to :overwrite overwrite)
+ #-:allegro
+ (let ((element-type #-:cormanlisp '(unsigned-byte 8)
+ #+:cormanlisp 'unsigned-byte))
+ (with-open-file (in from :element-type element-type)
+ (with-open-file (out to :element-type element-type
+ :direction :output
+ :if-exists (if overwrite
+ :supersede
+ #-:cormanlisp :error
+ #+:cormanlisp nil))
+ #+:cormanlisp
+ (unless out
+ (error (make-condition 'file-error
+ :pathname to
+ :format-control "File already exists.")))
+ (copy-stream in out))))
+ (values))
+
+(defun delete-directory-and-files (dirname &key (if-does-not-exist :error))
+ "Recursively deletes all files and directories within the directory
+designated by the non-wild pathname designator DIRNAME including
+DIRNAME itself. IF-DOES-NOT-EXIST must be one of :ERROR or :IGNORE
+where :ERROR means that an error will be signaled if the directory
+DIRNAME does not exist."
+ #+:allegro (excl.osi:delete-directory-and-files dirname
+ :if-does-not-exist if-does-not-exist)
+ #-:allegro (walk-directory dirname
+ (lambda (file)
+ (cond ((directory-pathname-p file)
+ #+:lispworks (lw:delete-directory file)
+ #+:cmu (multiple-value-bind (ok err-number)
+ (unix:unix-rmdir (namestring (truename file)))
+ (unless ok
+ (error "Error number ~A when trying to delete ~A"
+ err-number file)))
+ #+:scl (multiple-value-bind (ok errno)
+ (unix:unix-rmdir (ext:unix-namestring (truename file)))
+ (unless ok
+ (error "~@<Error deleting ~S: ~A~@:>"
+ file (unix:get-unix-error-msg errno))))
+ #+:sbcl (sb-posix:rmdir file)
+ #+:clisp (ext:delete-dir file)
+ #+:openmcl (asia-fad-ccl:delete-directory file)
+ #+:cormanlisp (win32:delete-directory file)
+ #+:ecl (si:rmdir file)
+ #+(or :abcl :digitool) (delete-file file))
+ (t (delete-file file))))
+ :directories t
+ :if-does-not-exist if-does-not-exist)
+ (values))
69 src/fad/openmcl.lisp
@@ -0,0 +1,69 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CCL; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/cl-fad/openmcl.lisp,v 1.6 2009/09/30 14:23:10 edi Exp $
+
+;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;; * Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+
+;;; * Redistributions in binary form must reproduce the above
+;;; copyright notice, this list of conditions and the following
+;;; disclaimer in the documentation and/or other materials
+;;; provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :asia-fad)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (flet ((ccl-function-feature (symbol-name feature)
+ (let ((symbol (find-symbol symbol-name :ccl)))
+ (when (and symbol (fboundp symbol))
+ (pushnew feature *features*)))))
+ (ccl-function-feature "%RMDIR" :ccl-has-%rmdir)
+ (ccl-function-feature "DELETE-DIRECTORY" :ccl-has-delete-directory)))
+
+(defpackage :asia-fad-ccl
+ (:use :cl)
+ (:export delete-directory)
+ (:import-from :ccl
+ :%realpath
+ :signal-file-error
+ :native-translated-namestring
+ :with-cstrs)
+ #+ccl-has-%rmdir
+ (:import-from :ccl :%rmdir)
+ #+ccl-has-delete-directory
+ (:import-from :ccl :delete-directory))
+
+(in-package :asia-fad-ccl)
+
+#-ccl-has-%rmdir
+(defun %rmdir (name)
+ (with-cstrs ((n name))
+ (#_rmdir n)))
+
+;;; ClozureCL 1.6 introduced ccl:delete-directory with semantics that
+;;; are acceptably similar to this "legacy" definition.
+
+#-ccl-has-delete-directory
+(defun delete-directory (path)
+ (let* ((namestring (native-translated-namestring path)))
+ (when (%realpath namestring)
+ (let* ((err (%rmdir namestring)))
+ (or (eql 0 err) (signal-file-error err path))))))
+
52 src/fad/packages.lisp
@@ -0,0 +1,52 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/cl-fad/packages.lisp,v 1.12 2009/09/30 14:23:10 edi Exp $
+
+;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;; * Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+
+;;; * Redistributions in binary form must reproduce the above
+;;; copyright notice, this list of conditions and the following
+;;; disclaimer in the documentation and/or other materials
+;;; provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package #:cl-user)
+
+(defpackage :asia-fad
+ (:use :cl)
+ #+:allegro
+ (:shadow :copy-file
+ :delete-directory-and-files)
+ #+:abcl
+ (:shadow :list-directory)
+ (:export :copy-file
+ :copy-stream
+ :delete-directory-and-files
+ :directory-exists-p
+ :directory-pathname-p
+ :file-exists-p
+ :list-directory
+ :pathname-as-directory
+ :pathname-as-file
+ :walk-directory))
+
+(defpackage :asia-fad-test
+ (:use :cl :asia-fad)
+ (:export :test))
146 src/fad/test.lisp
@@ -0,0 +1,146 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-FAD-TEST; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/cl-fad/test.lisp,v 1.12 2009/09/30 14:23:10 edi Exp $
+
+;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;; * Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+
+;;; * Redistributions in binary form must reproduce the above
+;;; copyright notice, this list of conditions and the following
+;;; disclaimer in the documentation and/or other materials
+;;; provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package #:asia-fad-test)
+
+(defparameter *tmp-dir*
+ #+(or :win32 :mswindows :windows) "c:\\tmp\\"
+ #-(or :win32 :mswindows :windows) "/tmp/")
+
+(defvar *test-counter* 0)
+
+(defmacro assert* (form)
+ `(progn
+ (format t "Trying to assert ~A~%" ',form)
+ (assert ,form)
+ (format t "Test ~A passed.~%" (incf *test-counter*))))
+
+(defun test ()
+ (setq *test-counter* 0)
+ (let ((fad-dir (merge-pathnames (pathname-as-directory "fad-test")
+ *tmp-dir*)))
+ (delete-directory-and-files fad-dir :if-does-not-exist :ignore)
+ (assert* (directory-pathname-p fad-dir))
+ (assert* (directory-pathname-p (pathname *tmp-dir*)))
+ (let ((foo-file (merge-pathnames "foo.lisp"
+ fad-dir)))
+ (assert* (not (directory-pathname-p foo-file)))
+ (assert* (not (file-exists-p foo-file)))
+ (assert* (not (file-exists-p fad-dir)))
+ (with-open-file (out (ensure-directories-exist foo-file)
+ :direction :output
+ :if-does-not-exist :create)
+ (write-string "NIL" out))
+ (assert* (file-exists-p foo-file))
+ (assert* (not (directory-exists-p foo-file)))
+ (assert* (file-exists-p fad-dir))
+ (assert* (directory-exists-p fad-dir))
+ (assert* (equal fad-dir
+ (pathname-as-directory fad-dir)))
+ (assert* (equal foo-file
+ (pathname-as-file foo-file)))
+ (assert* (not (equal fad-dir
+ (pathname-as-file fad-dir))))
+ (assert* (not (equal foo-file
+ (pathname-as-directory foo-file))))
+ (dolist (name '("bar" "baz"))
+ (let ((dir (merge-pathnames (pathname-as-directory name)
+ fad-dir)))
+ (dolist (name '("foo.text" "bar.lisp"))
+ (let ((file (merge-pathnames name dir)))
+ (with-open-file (out (ensure-directories-exist file)
+ :direction :output
+ :if-does-not-exist :create)
+ (write-string "NIL" out))))))
+ ;; /tmp/fad-test/foo.lisp
+ ;; /tmp/fad-test/bar/bar.lisp
+ ;; /tmp/fad-test/bar/foo.text
+ ;; /tmp/fad-test/baz/bar.lisp
+ ;; /tmp/fad-test/baz/foo.text
+ ;; files : 5
+ ;; dirs : 3
+ (let ((file-counter 0)
+ (file-and-dir-counter 0)
+ (bar-counter 0))
+ (walk-directory fad-dir
+ (lambda (file)
+ (declare (ignore file))
+ (incf file-counter)))
+ ;; file-counter => 5
+ (walk-directory fad-dir
+ (lambda (file)
+ (declare (ignore file))
+ (incf file-and-dir-counter))
+ :directories t)
+ ;; file-and-dir-counter => 5 + 3
+ (walk-directory fad-dir
+ (lambda (file)
+ (declare (ignore file))
+ (incf bar-counter))
+ :test (lambda (file)
+ (string= (pathname-name file)
+ "bar"))
+ :directories t)
+ ;; do not traverse the baz directory
+ (walk-directory fad-dir
+ (lambda (file)
+ (declare (ignore file))
+ (incf file-and-dir-counter))
+ :test (lambda (file)
+ (not (and (directory-pathname-p file)
+ (string= (first (last (pathname-directory file)))
+ "baz"))))
+ :directories :breadth-first)
+ ;; file-and-dir-counter => 5 + 3 + 2 dirs + 3 files
+ (assert* (= 5 file-counter))
+ (assert* (= 13 file-and-dir-counter))
+ (assert* (= 2 bar-counter)))
+ (let ((bar-file (merge-pathnames "bar.lisp" fad-dir)))
+ (copy-file foo-file bar-file)
+ (assert* (file-exists-p bar-file))
+ (with-open-file (foo-stream foo-file :element-type '(unsigned-byte 8))
+ (with-open-file (bar-stream bar-file :element-type '(unsigned-byte 8))
+ (assert* (= (file-length foo-stream)
+ (file-length bar-stream)))
+ (loop for foo-byte = (read-byte foo-stream nil nil)
+ for bar-byte = (read-byte bar-stream nil nil)
+ while (and foo-byte bar-byte)
+ do (assert* (eql foo-byte bar-byte))))))
+ (let ((baz-dir (merge-pathnames (pathname-as-directory "baz")
+ fad-dir))
+ (list (mapcar #'namestring (list-directory fad-dir))))
+ (assert* (find (namestring (truename foo-file)) list :test #'string=))
+ (assert* (find (namestring (truename baz-dir)) list :test #'string=))
+ (assert* (not (find (namestring (pathname-as-file baz-dir))
+ list
+ :test #'string=)))))
+ (delete-directory-and-files fad-dir :if-does-not-exist :error)
+ (assert* (not (file-exists-p fad-dir)))
+ (assert* (not (directory-exists-p fad-dir))))
+ (format t "All tests passed.~%"))
161 src/installer.lisp
@@ -0,0 +1,161 @@
+(in-package :asia)
+
+(defun git-install (url project)
+ ;; Debian Git 1:1.5.6.5-3+lenny3 has a bug causes we can't use
+ ;; project-directory since it has a trailing slash.
+ (run-shell-command "git clone '~A' ~A" url
+ (pathname-as-file (project-directory project))))
+
+(defun svn-install (url project)
+ (run-shell-command "svn checkout '~A' ~A" url (project-directory project)))
+
+(defun darcs-install (url project)
+ (run-shell-command "darcs get '~A' ~A" url (project-directory project)))
+
+(defun cvs-install (url project)
+ (let* ((name (project-name project))
+ (fmt "cd ~A && cvs -d '~A' checkout -d '~A' '~A'")
+ (pos (position #\# url :from-end t)))
+ (multiple-value-bind (cvsroot module)
+ (cond ((null pos) (values url name))
+ ((= pos (1- (length url))) (values (subseq url 0 pos) name))
+ (t (values (subseq url 0 pos) (subseq url (1+ pos)))))
+ (run-shell-command fmt (source-location) cvsroot name module))))
+
+(defun tarbomb-p (filename &optional options)
+ (rest
+ (remove-duplicates
+ (with-input-from-string
+ (in (with-output-to-string (*verbose-out*)
+ (run-shell-command "tar t ~@[~A~] -f ~A" options filename)))
+ (read-line in nil nil)
+ (loop :for name := (read-line in nil nil)
+ :while name
+ :collect (let* ((pos (position #\/ name)))
+ (if pos (subseq name 0 pos) name))))
+ :test 'equal)))
+
+(defun tar-install (filename project &optional options)
+ (run-shell-command "tar x ~:[--strip-components=1~;~] ~@[~A~] -f ~A -C ~A"
+ (tarbomb-p filename) options filename
+ (ensure-directories-exist (project-directory project))))
+
+(defun directory-install (dirname project)
+ (let* ((tarfile (make-temp-pathname :type "tar"))
+ (dir (pathname-directory dirname))
+ (parent (make-pathname :directory (butlast dir) :defaults dirname)))
+ (run-shell-command "tar c -C ~A -f ~A ~A" parent tarfile (first (last dir)))
+ (tar-install tarfile project)))
+
+(defun local-install (filename project)
+ (let* ((type (pathname-type filename))
+ (name (pathname-name filename)))
+ (cond ((directory-pathname-p filename)
+ (directory-install filename project))
+ ((and type (string= "tar" type))
+ (tar-install filename project))
+ ((or (and type (string= "tgz" type))
+ (and type (string= "gz" type)
+ name (pregexp-match "\\.tar$" name)))
+ (tar-install filename project "-z"))
+ ((or (and type (pregexp-match "^(tbz2|tbz|tb2)$" type))
+ (and type (pregexp-match "^(bz2|bz)$" type)
+ name (pregexp-match "\\.tar$" name)))
+ (tar-install filename project "-j")))))
+
+(defun curl-install (url project)
+ (let* ((tmpdir (make-temp-pathname :type :directory)))
+ (delete-directory-and-files tmpdir :if-does-not-exist :ignore)
+ (ensure-directories-exist tmpdir)
+ (run-shell-command "cd ~A && curl -s -J -O '~A'" tmpdir url)
+ (local-install (first (list-directory tmpdir)) project)))
+
+(defun git-url-p (url)
+ (pregexp-match "^(git|git\\+ssh|ssh\\+git)://|/git(/|$)|\\.git/?$" url))
+
+(defun svn-url-p (url)
+ (pregexp-match "^svn://" url))
+
+(defun darcs-url-p (url)
+ (pregexp-match "/darcs(/|$)" url))
+
+(defun cvs-url-p (url)
+ (pregexp-match "^:pserver:" url))
+
+(defun curl-url-p (url)
+ (pregexp-match "^(https?|ftps?|sftp|file)://" url))
+
+(defun guess-backend (url)
+ "Guesses the backend name based on URL's pattern."
+ (cond ((git-url-p url) 'git-install)
+ ((svn-url-p url) 'svn-install)
+ ((darcs-url-p url) 'darcs-install)
+ ((cvs-url-p url) 'cvs-install)
+ ((curl-url-p url) 'curl-install)
+ (t 'local-install)))
+
+(defun generic-install (url project)
+ (cond ((null url) (error "url cannot be NIL.~%"))
+ ((null project) (error "project cannot be NIL.~%"))
+ ((or (functionp url) (symbolp url)) (funcall url))
+ ((pathnamep url) (local-install url project))
+ ((stringp url) (funcall (guess-backend url) url project))
+ (t (error 'type-error :datum url
+ :expected-type '(or function pathname string (and symbol (not null)))))))
+
+(defun make-installer (url project)
+ (lambda () (generic-install url project)))
+
+(defun project-installed-p (project)
+ "Returns true if PROJECT is installed; otherwise, returns false."
+ (directory-exists-p (project-directory project)))
+
+(defun %install-project (project url)
+ (let* ((*verbose-out* *standard-output*)
+ (project-name (project-name project))
+ (loc (list *project-manifest* "projects" project-name))
+ (*default-pathname-defaults* (location loc :directory t)))
+ (funcall (cond (url (make-installer url project))
+ ((with-project-file (in project-name "installer.lisp")
+ (with-standard-io-syntax
+ (let ((package (make-temp-package)))
+ (unwind-protect
+ (let* ((*package* package)
+ (form (read in nil nil)))
+ (and form (coerce form 'function)))
+ (delete-package package))))))
+ ((with-project-file (in project-name "url")
+ (let* ((url (read-line in nil nil)))
+ (and url (make-installer url project)))))))))
+
+(defun install-project (project &key url)
+ "Installs PROJECT. If URL is a function, use it to install; if URL
+is a string or pathname, use a standard installer; if URL is NIL, this
+function will look up the manifest file to get a url or installer.
+Returns true if PROJECT is installed; otherwise, returns false."
+ (unless project
+ (error "Project is NIL.~%"))
+ (let* ((name (project-name project))
+ (dir (project-directory project))
+ (installed nil))
+ (when (project-ignored-p project)
+ (error "Project ~A is ignored.~%" name))
+ (when (project-installed-p project)
+ (error "Project ~A is installed.~%" name))
+ (loop
+ (unwind-protect
+ (with-simple-restart (retry "Reinstall ~A." name)
+ (%install-project project url)
+ (return (setf installed (project-installed-p project))))
+ (unless installed
+ (delete-directory-and-files dir :if-does-not-exist :ignore))))))
+
+(defun delete-project (project)
+ "Deletes PROJECT's directory."
+ (unless project
+ (error "Project is NIL.~%"))
+ (let* ((name (project-name project))
+ (dir (project-directory project)))
+ (when (project-ignored-p project)
+ (error "Project ~A is ignored.~%" name))
+ (delete-directory-and-files dir :if-does-not-exist :ignore)))
46 src/package.lisp
@@ -0,0 +1,46 @@
+(in-package :cl-user)
+
+(defpackage :asia
+ (:documentation "Usage:
+;; install manually
+> (asia:install-package _PROJECT_)
+;; delete an installed project
+> (asia:delete-package _PROJECT_)
+;; install automatically when loading systems
+> (pushnew 'asia:sysdef-asia-search asdf:*system-definition-search-functions*)
+")
+ (:use :cl :asdf :asia-fad :asia-pregexp)
+ (:shadowing-import-from :asia-fad
+ :directory-pathname-p)
+ (:import-from :asdf
+ :probe-file*
+ :delete-file-if-exists
+ :get-uid
+ :implementation-identifier
+ :merge-component-name-type
+ :resolve-location
+ :*verbose-out*)
+ (:import-from :asia-fad-test
+ :*test-counter*
+ :assert*)
+ (:export
+ ;; utilities
+ :pathspec
+ :location
+ ;; special variables
+ :*project-manifest*
+ :*source-location*
+ :*temporary-directory*
+ ;; base
+ :make-temp-pathname
+ :manifest-pathname
+ ;; project
+ :source-location
+ :project-name
+ :project-directory
+ ;; installer
+ :project-installed-p
+ :install-project
+ :delete-project
+ ;; asdf
+ :sysdef-asia-search))
9 src/pregexp/COPYING
@@ -0,0 +1,9 @@
+Copyright (c) 1999-2005, Dorai Sitaram.
+All rights reserved.
+
+Permission to copy, modify, distribute, and use this work or
+a modified copy of this work, for any purpose, is hereby
+granted, provided that the copy includes this copyright
+notice, and in the case of a modified copy, also includes a
+notice of modification. This work is provided as is, with
+no warranty of any kind.
2  src/pregexp/README
@@ -0,0 +1,2 @@
+PREGEXP comes from http://evalwhen.com/pregexp/index.html. I added
+the package definition.
650 src/pregexp/pregexp.lisp
@@ -0,0 +1,650 @@
+;Portable regular expressions for Common Lisp
+;Dorai Sitaram
+(in-package :cl-user)
+
+(defpackage :asia-pregexp
+ (:use :cl)
+ (:export :pregexp
+ :pregexp-match-positions
+ :pregexp-match
+ :pregexp-split
+ :pregexp-replace
+ :pregexp-replace*
+ :pregexp-quote))
+
+(in-package :asia-pregexp)
+
+(defparameter *pregexp-version* 20090325) ;last change
+
+(defparameter *pregexp-comment-char* #\;)
+
+(defparameter *pregexp-space-sensitive-p* t)
+
+(defmacro pregexp-recur (name varvals &rest body)
+ `(labels ((,name ,(mapcar #'first varvals) ,@body))
+ (,name ,@(mapcar #'second varvals))))
+
+(defun pregexp-read-pattern (s i n)
+ (if (>= i n) (values `(:or (:seq)) i)
+ (let ((branches '()))
+ (loop
+ (when (or (>= i n)
+ (char= (char s i) #\)))
+ (return (values (cons :or (nreverse branches)) i)))
+ (multiple-value-bind (branch1 i1)
+ (pregexp-read-branch
+ s (if (char= (char s i) #\|) (+ i 1) i) n)
+ (push branch1 branches)
+ (setq i i1))))))
+
+(defun pregexp-read-branch (s i n)
+ (let ((pieces '()))
+ (loop
+ (cond ((or (>= i n)
+ (member (char s i) '(#\| #\))))
+ (return (values (cons :seq (nreverse pieces)) i)))
+ (t (multiple-value-bind (pc i-new)
+ (pregexp-read-piece s i n)
+ (push pc pieces)
+ (setq i i-new)))))))
+
+(defun pregexp-read-piece (s i n)
+ (let ((c (char s i))) (incf i)
+ (case c
+ (#\^ (values :bos i))
+ (#\$ (values :eos i))
+ (#\. (pregexp-wrap-quantifier-if-any :any s i n))
+ (#\[ (let ((negp nil))
+ (when (and (< i n)
+ (char= (char s i) #\^))
+ (incf i)
+ (setq negp t))
+ (when (< i n)
+ (multiple-value-bind (chars i1)
+ (pregexp-read-char-list s i n)
+ (pregexp-wrap-quantifier-if-any
+ (if negp (list :neg-char chars) chars)
+ s i1 n)))))
+ (#\( (multiple-value-bind (re i1)
+ (pregexp-read-subpattern s i n)
+ (pregexp-wrap-quantifier-if-any
+ re s i1 n)))
+ (#\\ (multiple-value-bind (m i1)
+ (pregexp-read-escaped-number s i n)
+ (if m
+ (pregexp-wrap-quantifier-if-any
+ (list :backref m) s i1 n)
+ (multiple-value-bind (c i1)
+ (pregexp-read-escaped-char s i)
+ (if c
+ (pregexp-wrap-quantifier-if-any c s i1 n)
+ (error "pregexp-read-piece: backslash"))))))
+ (t (if (or *pregexp-space-sensitive-p*
+ (and (not (pregexp-whitespacep c))
+ (not (char= c *pregexp-comment-char*))))
+ (pregexp-wrap-quantifier-if-any c s i n)
+ (let ((in-comment-p nil))
+ (loop
+ (cond (in-comment-p
+ (when (char= c #\newline)
+ (setq in-comment-p nil)))
+ ((pregexp-whitespacep c) t)
+ ((char= c *pregexp-comment-char*)
+ (setq in-comment-p t))
+ (t (decf i) (return (values :empty i))))
+ (when (>= i n) (return (values :empty i)))
+ (setq c (char s i))
+ (incf i))))))))
+
+(defun pregexp-read-escaped-number (s i n)
+ (let ((r '()) (c nil))
+ (loop
+ (when (or (>= i n)
+ (not (digit-char-p (setq c (char s i)))))
+ (return r))
+ (incf i)
+ (push c r))
+ (when r
+ (values (read-from-string (concatenate 'string (nreverse r)))
+ i))))
+
+(defun pregexp-read-escaped-char (s i)
+ (let ((c (char s i)))
+ (values
+ (case c
+ (#\b :wbdry)
+ (#\B :not-wbdry)
+ (#\d :digit)
+ (#\D (list :neg-char :digit))
+ (#\n #\newline)
+ (#\r #\return)
+ (#\s :space)
+ (#\S (list :neg-char :space))
+ (#\t #\tab)
+ (#\w :word)
+ (#\W (list :neg-char :word))
+ (t c))
+ (+ i 1))))
+
+(defun pregexp-read-posix-char-class (s i n)
+ (let ((r '()) (negp nil))
+ (loop
+ (when (>= i n) (error "pregexp-read-posix-char-class"))
+ (let ((c (char s i))) (incf i)
+ (cond ((char= c #\^) (setq negp t))
+ ((alpha-char-p c) (push c r))
+ ((char= c #\:)
+ (when (or (>= i n)
+ (not (char= (char s i) #\])))
+ (error "pregexp-read-posix-char-class"))
+ (incf i)
+ (return))
+ (t (error "pregexp-read-posix-char-class")))))
+ (let ((posix-class
+ (intern (string-upcase (concatenate 'string (nreverse r)))
+ :keyword)))
+ (values
+ (if negp (list :neg-char posix-class) posix-class)
+ i))))
+
+(defun pregexp-read-cluster-type (s i)
+ (let ((c (char s i))) (incf i)
+ (case c
+ (#\?
+ (setq c (char s i)) (incf i)
+ (case c
+ (#\: (values '() i))
+ (#\= (values `(:lookahead) i))
+ (#\! (values `(:neg-lookahead) i))
+ (#\> (values `(:no-backtrack) i))
+ (#\< (setq c (char s i)) (incf i)
+ (case c
+ (#\= (values `(:lookbehind) i))
+ (#\! (values `(:neg-lookbehind) i))
+ (t (error "pregexp-read-cluster-type"))))
+ (t (let ((r '()) (invp nil))
+ (loop
+ (case c
+ (#\- (setq invp t))
+ (#\i (push (if invp :case-sensitive
+ :case-insensitive) r)
+ (setq invp nil))
+ (#\x (setq *pregexp-space-sensitive-p* invp)
+ (setq invp nil))
+ (#\: (return (values (nreverse r) i)))
+ (t (error "pregexp-read-cluster-type")))
+ (setq c (char s i))
+ (incf i))))))
+ (t (decf i) (values '(:sub) i)))))
+
+(defun pregexp-read-subpattern (s i n)
+ (let ((remember-space-sensitive-p *pregexp-space-sensitive-p*))
+ (multiple-value-bind (ctyp i1)
+ (pregexp-read-cluster-type s i)
+ (multiple-value-bind (re i2)
+ (pregexp-read-pattern s i1 n)
+ (setq *pregexp-space-sensitive-p* remember-space-sensitive-p)
+ (cond ((and (< i2 n)
+ (char= (char s i2) #\)))
+ (incf i2)
+ (dolist (ct ctyp)
+ (setq re (list ct re)))
+ (values re i2))
+ (t (error "pregexp-read-subpattern")))))))
+
+(defun pregexp-wrap-quantifier-if-any (re s i n)
+ (loop
+ (when (>= i n) (return (values re i)))
+ (let ((c (char s i))) (incf i)
+ (if (and (pregexp-whitespacep c) (not *pregexp-space-sensitive-p*)) t
+ (case c
+ ((#\* #\+ #\? #\{)
+ (let* ((new-re (list :between nil 1 1 re)))
+ ; (:between non-greedy at-least at-most re)
+ (case c
+ (#\* (setf (third new-re) 0
+ (fourth new-re) nil))
+ (#\+ (setf (fourth new-re) nil))
+ (#\? (setf (third new-re) 0))
+ (#\{ (multiple-value-bind (p q i1)
+ (pregexp-read-nums s i n)
+ (setf (third new-re) p
+ (fourth new-re) q
+ i i1))))
+ (loop
+ (when (>= i n) (return))
+ (let ((c (char s i))) (incf i)
+ (cond ((and (pregexp-whitespacep c)
+ (not *pregexp-space-sensitive-p*)) t)
+ ((char= c #\?)
+ (setf (second new-re) t)
+ (return))
+ (t (decf i) (return)))))
+ (return (values new-re i))))
+ (t (decf i) (return (values re i))))))))
+
+(defun pregexp-whitespacep (c)
+ (or (char= c #\space) (char= c #\tab)
+ (not (graphic-char-p c))))
+
+(defun pregexp-read-nums (s i n)
+ (let ((p '()) (q '()) (reading 1))
+ (loop
+ (when (>= i n) (error "pregexp-read-nums: unmatched left brace"))
+ (let ((c (char s i)))
+ (cond ((digit-char-p c)
+ (if (= reading 1)
+ (push c p)
+ (push c q))
+ (incf i))
+ ((and (pregexp-whitespacep c) (not *pregexp-space-sensitive-p*))
+ (incf i))
+ ((and (char= c #\,) (= reading 1))
+ (incf i) (incf reading))
+ ((char= c #\})
+ (incf i)
+ (setq p (read-from-string (concatenate 'string (nreverse p)) nil)
+ q (read-from-string (concatenate 'string (nreverse q)) nil))
+ (return
+ (cond ((and (not p) (= reading 1)) (values 0 nil i))
+ ((= reading 1) (values p p i))
+ (t (values p q i)))))
+ (t (error "pregexp-read-nums: left brace must be followed by number")))))))
+
+(defun pregexp-read-char-list (s i n)
+ (let ((r '()))
+ (loop
+ (when (>= i n) (error "pregexp-read-char-list: char class ended too soon"))
+ (let ((c (char s i))) (incf i)
+ (case c
+ (#\] (if (null r)
+ (progn (push c r) (incf i))
+ (return r)))
+ (#\\ (multiple-value-bind (c2 i2)
+ (pregexp-read-escaped-char s i)
+ (when (not c2)
+ (error "pregexp-read-char-list: backslash"))
+ (push c2 r)
+ (setq i i2)))
+ (#\- (if (or (null r)
+ (and (< i n)
+ (char= (char s i) #\])))
+ (push #\- r)
+ (let ((c-1 (car r)))
+ (if (characterp c-1)
+ (progn
+ (pop r)
+ (push `(:char-range ,c-1 ,(char s i)) r)
+ (incf i))
+ (push #\- r)))))
+ (#\[ (if (char= (char s i) #\:)
+ (multiple-value-bind (c i1)
+ (pregexp-read-posix-char-class s (1+ i) n)
+ (push c r)
+ (setq i i1))
+ (push #\[ r)))
+ (t (push c r)))))
+ (values (cons :one-of-chars
+ (nreverse r))
+ i)))
+
+(defun pregexp-string-match (s1 s i n sk fk)
+ (let ((n1 (length s1)))
+ (if (> n1 n) (funcall fk)
+ (let ((j 0) (k i) (failp nil))
+ (loop
+ (cond ((>= j n1) (return))
+ ((>= k n) (return (setq failp t)))
+ ((char= (char s1 j) (char s k))
+ (incf j) (incf k))
+ (t (return (setq failp t)))))
+ (if failp (funcall fk)
+ (funcall sk k))))))
+
+(defun pregexp-char-word? (c)
+ (or (alpha-char-p c) (digit-char-p c) (char= c #\_)))
+
+(defun pregexp-at-word-boundary-p (s i n)
+ (or (= i 0)
+ (>= i n)
+ (let* ((c-i (char s i))
+ (c-i-minus-1 (char s (- i 1)))
+ (c-i-is-word-p (pregexp-check-if-in-char-class-p c-i :word))
+ (c-i-minus-1-is-word-p (pregexp-check-if-in-char-class-p c-i-minus-1 :word)))
+ (or (and c-i-is-word-p (not c-i-minus-1-is-word-p))
+ (and (not c-i-is-word-p) c-i-minus-1-is-word-p)))))
+
+(defun pregexp-check-if-in-char-class-p (c char-class) ;check thoroughly
+ (case char-class
+ (:any (not (char= c #\newline)))
+ (:alnum (or (alpha-char-p c) (digit-char-p c)))
+ (:alpha (alpha-char-p c))
+ (:ascii (< (char-code c) 128))
+ (:blank (or (char= c #\space) (char= c #\tab)))
+ (:cntrl (< (char-code c) 32))
+ (:digit (digit-char-p c))
+ (:graph (and (pregexp-check-if-in-char-class-p c :print)
+ (not (pregexp-whitespacep c))))
+ (:lower (lower-case-p c))
+ (:print (>= (char-code c) 32))
+ (:punct (and (pregexp-check-if-in-char-class-p c :print)
+ (not (or (pregexp-whitespacep c)
+ (alpha-char-p c)
+ (digit-char-p c)))))
+ (:space (pregexp-whitespacep c))
+ (:upper (upper-case-p c))
+ (:word (or (alpha-char-p c) (digit-char-p c) (char= c #\_)))
+ (:xdigit (or (digit-char-p c)
+ (member c '(#\a #\b #\c #\d #\e #\f) :test #'char-equal)))
+ (t (error "pregexp-check-if-in-char-class-p"))))
+
+(defun pregexp-make-backref-list (re)
+ (if (consp re)
+ (let ((re1 (car re))
+ (rest-backrefs (pregexp-make-backref-list (cdr re))))
+ (if (eq re1 :sub)
+ (cons (cons re nil) rest-backrefs)
+ (append (pregexp-make-backref-list re1) rest-backrefs)))
+ '()))
+
+(defun pregexp-match-positions-aux (re s sn start n i)
+ (let* ((backrefs (pregexp-make-backref-list re))
+ (case-sensitive-p t))
+ (flet ((char=1 (c1 c2)
+ (if case-sensitive-p
+ (char= c1 c2)
+ (char-equal c1 c2)))
+ (char<=1 (c1 c2 c3)
+ (if case-sensitive-p
+ (char<= c1 c2 c3)
+ (char-not-greaterp c1 c2 c3))))
+ (pregexp-recur
+ match-loop ((re re) (i i) (sk #'identity) (fk (lambda () nil)))
+ (cond ((eq re :bos)
+ (if (= i start) (funcall sk i) (funcall fk)))
+ ((eq re :eos)
+ (if (>= i n) (funcall sk i) (funcall fk)))
+ ((eq re :empty) (funcall sk i))
+ ((eq re :wbdry)
+ (if (pregexp-at-word-boundary-p s i n)
+ (funcall sk i)
+ (funcall fk)))
+ ((eq re :not-wbdry)
+ (if (pregexp-at-word-boundary-p s i n)
+ (funcall fk)
+ (funcall sk i)))
+ ((and (characterp re) (< i n))
+ (if (char=1 (char s i) re)
+ (funcall sk (1+ i))
+ (funcall fk)))
+ ((and (not (consp re)) (< i n))
+ (if (pregexp-check-if-in-char-class-p (char s i) re)
+ (funcall sk (1+ i))
+ (funcall fk)))
+ ((consp re)
+ (case (car re)
+ (:char-range
+ (if (>= i n) (funcall fk)
+ (if (char<=1 (second re) (char s i) (third re))
+ (funcall sk (1+ i))
+ (funcall fk))))
+ (:one-of-chars
+ (if (>= i n) (funcall fk)
+ (pregexp-recur
+ one-of-chars-loop ((chars (rest re)))
+ (if (null chars) (funcall fk)
+ (match-loop (first chars) i sk
+ (lambda ()
+ (one-of-chars-loop (rest chars))))))))
+ (:neg-char
+ (if (>= i n) (funcall fk)
+ (match-loop (second re) i
+ (lambda (i1)
+ (declare (ignore i1))
+ (funcall fk))
+ (lambda () (funcall sk (1+ i))))))
+ (:seq
+ (pregexp-recur
+ seq-loop ((res (rest re)) (i i))
+ (if (null res) (funcall sk i)
+ (match-loop (first res) i
+ (lambda (i1) (seq-loop (rest res) i1))
+ fk))))
+ (:or
+ (pregexp-recur
+ or-loop ((res (rest re)))
+ (if (null res) (funcall fk)
+ (match-loop (first res) i
+ (lambda (i1)
+ (or (funcall sk i1)
+ (or-loop (rest res))))
+ (lambda ()
+ (or-loop (cdr res)))))))
+ (:backref
+ (let* ((cell (nth (second re) backrefs))
+ (backref
+ (cond (cell (cdr cell))
+ (t (error "pregexp-match-positions-aux: non-existent backref ~s" re)
+ ;FIXME
+ nil))))
+ (if backref
+ (pregexp-string-match
+ (subseq s (car backref) (cdr backref))
+ s i n sk fk)
+ (funcall sk i))))
+ (:sub
+ (match-loop (second re) i
+ (lambda (i1)
+ (setf (cdr (assoc re backrefs)) (cons i i1))
+ (funcall sk i1))
+ fk))
+ (:lookahead
+ (let ((found-it-p
+ (match-loop (second re) i
+ #'identity
+ (lambda () nil))))
+ (if found-it-p (funcall sk i) (funcall fk))))
+ (:neg-lookahead
+ (let ((found-it-p
+ (match-loop (second re) i
+ #'identity
+ (lambda () nil))))
+ (if found-it-p (funcall fk) (funcall sk i))))
+ (:lookbehind
+ (let ((n-actual n) (sn-actual sn))
+ (setq n i sn i)
+ (let ((found-it-p
+ (match-loop `(:seq (:between nil 0 nil :any)
+ ,(second re) :eos)
+ 0
+ #'identity
+ (lambda () nil))))
+ (setq n n-actual sn sn-actual)
+ (if found-it-p (funcall sk i) (funcall fk)))))
+ (:neg-lookbehind
+ (let ((n-actual n) (sn-actual sn))
+ (setq n i sn i)
+ (let ((found-it-p
+ (match-loop `(:seq (:between nil 0 nil :any)
+ ,(second re) :eos)
+ 0
+ #'identity
+ (lambda () nil))))
+ (setq n n-actual sn sn-actual)
+ (if found-it-p (funcall fk) (funcall sk i)))))
+ (:no-backtrack
+ (let ((found-it-p
+ (match-loop (second re) i #'identity (lambda () nil))))
+ (if found-it-p
+ (funcall sk found-it-p)
+ (funcall fk))))
+ ((:case-sensitive :case-insensitive)
+ (let ((old-case-sensitive-p case-sensitive-p))
+ (setq case-sensitive-p
+ (eq (first re) :case-sensitive))
+ (match-loop (second re) i
+ (lambda (i1)
+ (setq case-sensitive-p old-case-sensitive-p)
+ (funcall sk i1))
+ (lambda ()
+ (setq case-sensitive-p old-case-sensitive-p)
+ (funcall fk)))))
+ (:between
+ (let* ((non-greedy-p (second re))
+ (p (third re))
+ (q (fourth re))
+ (re (fifth re))
+ (could-loop-infinitely-p
+ (and (not non-greedy-p) (not q)))
+ (q (and q (- q p))))
+ (pregexp-recur
+ p-loop ((k 0) (i i))
+ (if (< k p)
+ (match-loop re i
+ (lambda (i1)
+ (if (and could-loop-infinitely-p
+ (= i1 i))
+ (error "pregexp-match-positions-aux: greedy quantifier operand could be empty")
+ (p-loop (1+ k) i1)))
+ fk)
+ (pregexp-recur
+ q-loop ((k 0) (i i))
+ (let ((fk (lambda () (funcall sk i))))
+ (if (and q (>= k q)) (funcall fk)
+ (if (not non-greedy-p)
+ (match-loop re i
+ (lambda (i1)
+ (if (and could-loop-infinitely-p
+ (= i1 i))
+ (error "pregexp-match-positions-aux greedy quantifier operand could be empty"))
+ (or (q-loop (1+ k) i1)
+ (funcall fk)))
+ fk)
+ (or (funcall fk)
+ (match-loop re i
+ (lambda (i1)
+ (q-loop (1+ k) i1))
+ fk))))))))))
+ (t (error "pregexp-match-positions-aux"))))
+ ((>= i n) (funcall fk))
+ (t (error "pregexp-match-positions-aux")))))
+ (setq backrefs (mapcar #'cdr backrefs))
+ (and (car backrefs) backrefs)))
+
+(defun pregexp-replace-aux (str ins n backrefs)
+ (let ((r "") (i 0))
+ (loop
+ (when (>= i n) (return r))
+ (let ((c (char ins i)))
+ (incf i)
+ (if (char= c #\\)
+ (multiple-value-bind (m i1)
+ (pregexp-read-escaped-number ins i n)
+ (when (and (not i1) (char= (char str i) #\&))
+ (setq m 0)
+ (setq i1 (1+ i)))
+ (cond (m (let ((backref (nth m backrefs)))
+ (when backref
+ (setq r (concatenate 'string r
+ (subseq str (car backref) (cdr backref)))))
+ (setq i i1)))
+ (t (let ((c2 (char ins i)))
+ (incf i)
+ (unless (char= c2 #\$)
+ (setq r (concatenate 'string r (string c2))))))))
+ (setq r (concatenate 'string r (string c))))))))
+
+(defun pregexp (s)
+ (setq *pregexp-space-sensitive-p* t) ;in case it got corrupted
+ (list :sub (pregexp-read-pattern s 0 (length s))))
+
+(defun pregexp-match-positions (pat str &optional start end)
+ (when (stringp pat) (setq pat (pregexp pat)))
+ (unless (consp pat)
+ (error "pregexp-match-positions: pattern ~s must be compiled or string regexp"
+ pat))
+ (let ((str-len (length str)))
+ (when (not start) (setq start 0))
+ (when (or (not end) (> end str-len)) (setq end str-len))
+ (let ((i start))
+ (loop
+ (unless (<= i end) (return nil))
+ (let ((res (pregexp-match-positions-aux
+ pat str str-len start end i)))
+ (if res (return res)
+ (incf i)))))))
+
+(defun pregexp-match (pat str &optional start end)
+ (let ((index-pairs
+ (pregexp-match-positions pat str start end)))
+ (and index-pairs
+ (mapcar
+ (lambda (index-pair)
+ (and index-pair
+ (subseq str (car index-pair) (cdr index-pair))))
+ index-pairs))))
+
+(defun pregexp-split (pat str)
+ ;split str into substrings, using pat as delim
+ (let ((r '()) (n (length str)) (i 0) (picked-up-one-undelimited-char-p nil) it)
+ (loop
+ (cond ((>= i n) (return (nreverse r)))
+ ((setq it (car (pregexp-match-positions pat str i n)))
+ (let ((j (car it)) (k (cdr it)))
+ (cond ((= j k) (push (subseq str i (1+ j)) r)
+ (setq i (1+ k))
+ (setq picked-up-one-undelimited-char-p t))
+ ((and (= j i) picked-up-one-undelimited-char-p)
+ (setq i k)
+ (setq picked-up-one-undelimited-char-p nil))
+ (t (push (subseq str i j) r)
+ (setq i k)
+ (setq picked-up-one-undelimited-char-p nil)))))
+ (t (push (subseq str i n) r)
+ (setq i n))))))
+
+(defun pregexp-replace (pat str ins)
+ (let* ((n (length str))
+ (pp (pregexp-match-positions pat str 0 n)))
+ (if (not pp) str
+ (let ((ins-len (length ins))
+ (m-i (caar pp))
+ (m-n (cdar pp)))
+ (concatenate 'string
+ (subseq str 0 m-i)
+ (pregexp-replace-aux str ins ins-len pp)
+ (subseq str m-n n))))))
+
+(defun pregexp-replace* (pat str ins)
+ ;return str with every occurrence of pat replaced by ins
+ (when (stringp pat) (setq pat (pregexp pat)))
+ (let ((n (length str))
+ (ins-len (length ins))
+ (i 0)
+ (r ""))
+ (loop
+ ;i = index in str to start replacing from
+ ;r = already calculated prefix of answer
+ (when (>= i n) (return r))
+ (let ((pp (pregexp-match-positions pat str i n)))
+ (when (not pp)
+ (return
+ (if (= i 0)
+ ;this implies pat didn't match str at all,
+ ;so let's return original str
+ str
+ (concatenate 'string r (subseq str i n)))))
+ (setq r (concatenate 'string r
+ (subseq str i (caar pp))
+ (pregexp-replace-aux str ins ins-len pp)))
+ (setq i (cdar pp))))))
+
+(defun pregexp-quote (s)
+ (let ((i (- (length s) 1)) (r '()))
+ (loop
+ (when (< i 0) (return (concatenate 'string r)))
+ (let ((c (char s i)))
+ (push c r)
+ (when (member c '(#\\ #\. #\? #\* #\+ #\| #\^ #\$
+ #\[ #\] #\{ #\} #\( #\)))
+ (push #\\ r))))))
33 src/project.lisp
@@ -0,0 +1,33 @@
+(in-package :asia)
+
+(defun source-location ()
+ "Returns the real location of the installed source code. If
+*SOURCE-LOCATION* is not nil, returns *SOURCE-LOCATION*; otherwise,
+returns the \"source\" subdirectory of *PROJECT-MANIFEST*."
+ (or *source-location*
+ (location (list *project-manifest* "source") :directory t)))
+
+(defun project-name (project)
+ "Returns PROJECT's name. For a string, returns itself; for a
+symbol, returns downcase symbol name; for NIL, singals an error."
+ (etypecase project
+ (null (error "Project cannot be NIL."))
+ (string project)
+ (symbol (string-downcase (symbol-name project)))))
+
+(defun project-directory (project)
+ "Returns PROJECT's directory."
+ (location (list (source-location) (project-name project)) :directory t))
+
+(defun project-ignored-p (project)
+ "Tests whether PROJECT is ignored by ASIA."
+ (let* ((name (project-name project)))
+ (or (probe-file (manifest-pathname "projects" name "ignore"))
+ (find name
+ (append
+ #+sbcl
+ '("sb-aclrepl" "sb-bsd-sockets" "sb-cltl2" "sb-concurrency"
+ "sb-cover" "sb-grovel" "sb-introspect" "sb-md5" "sb-posix"
+ "sb-queue" "sb-rotate-byte" "sb-rt" "sb-simple-streams")
+ '("asia" "asdf"))
+ :key 'project-name :test 'string=))))
29 src/specials.lisp
@@ -0,0 +1,29 @@
+(in-package :asia)
+
+(defvar *project-manifest*
+ #+(and (or win32 windows mswindows mingw32) (not cygwin))
+ (pathname "C:\\repo51\\")
+ #-(and (or win32 windows mswindows mingw32) (not cygwin))
+ (let* ((env (getenv "XDG_DATA_HOME"))
+ (def (location (list :home ".local" "share") :directory t)))
+ (location (list (or env def) "repo51") :directory t))
+ "Location of the projects information database.")
+
+(defvar *source-location* nil
+ "Location of the installed source code.")
+
+;; For windows user: why not use %TEMP% ?
+;;
+;; Clozure has a "feature" that changes filename to name\\.tar.gz. We
+;; have to put all the filenames without the quote character in
+;; RUN-SHELL-COMMAND. That means we cannot use any filename which has
+;; whitespaces.
+
+(defvar *temporary-directory*
+ #+(and (or win32 windows mswindows mingw32) (not cygwin))
+ (pathname "C:\\Temp\\")
+ #-(and (or win32 windows mswindows mingw32) (not cygwin))
+ (location (list (or (getenv "TMPDIR") "/tmp/")) :directory t)
+ "Temporary directory. If it is NIL, uses default value. On
+windows, default is C:\\Temp\\ ; otherwise, default is the value of
+environment variable TMPDIR, if TMPDIR is NIL, default is /tmp/ .")
137 src/test.lisp
@@ -0,0 +1,137 @@
+(in-package :asia)
+
+(defun test ()
+ (format t "~%;;;; Testing ASIA FAD module...~%")
+ (asia-fad-test:test)
+ (format t "~%;;;; All FAD module tests passed.~%")
+
+ (setf *test-counter* 0)
+ (format t "~%;;;; Testing ASIA...~%")
+
+ (format t "~&;;; Utils~%")
+
+ (format t "~&;; with-unique-names~%")
+ (let* ((*gensym-counter* 0)
+ (syms (with-unique-names (foo bar quux)
+ (list foo bar quux))))
+ (assert* (null (some 'symbol-package syms)))
+ (assert* (equal (mapcar 'symbol-name syms) '("FOO0" "BAR1" "QUUX2"))))
+ (let* ((*gensym-counter* 0)
+ (syms (with-unique-names ((foo "_foo_") (bar -bar-) (quux #\q))
+ (list foo bar quux))))
+ (assert* (null (some 'symbol-package syms)))
+ (assert* (equal (mapcar 'symbol-name syms) '("_foo_0" "-BAR-1" "q2"))))
+
+ (format t "~&;; emptyp~%")
+ (assert* (not (emptyp '(1))))
+ (assert* (not (emptyp (let* ((cycle (list 1))) (nconc cycle cycle)))))
+ (assert* (emptyp '()))
+ (assert* (emptyp #()))
+ (assert* (not (emptyp #(1))))
+
+ (format t "~&;;; Base~%")
+
+ (format t "~&;; manifest-pathname~%")
+ (let* ((*project-manifest* (make-pathname :directory '(:absolute "tmp")))
+ (p (manifest-pathname "systems" "uffi" "a/project")))
+ (assert* (equal (pathname-directory p) '(:absolute "tmp" "systems" "uffi" "a")))
+ (assert* (equal (pathname-name p) "project"))
+ ;; See SPLIT-NAME-TYPE in asdf.lisp
+ (assert* (eq (pathname-type p) (or #+(or ccl ecl gcl lispworks sbcl) :unspecific))))
+
+ (format t "~&;;; Project~%")
+
+ (format t "~&;; source-location~%")
+ (let* ((*source-location* (make-pathname :directory '(:absolute "tmp")))
+ (*project-manifest* nil))
+ (assert* (equal (source-location) *source-location*)))
+ (let* ((*source-location* nil)
+ (*project-manifest* (make-pathname :directory '(:absolute "tmp")))
+ (p (make-pathname :directory '(:absolute "tmp" "source"))))
+ (assert* (equal (source-location) p)))
+
+ (format t "~&;; project-name~%")
+ (multiple-value-bind (value error) (ignore-errors (project-name nil))
+ (assert* (null value))
+ (assert* (typep error 'error)))
+ (assert* (string= (project-name t) "t"))
+ (assert* (string= (project-name "t") "t"))
+ (assert* (string= (project-name "nil") "nil"))
+ (assert* (string= (project-name "cl-fad") "cl-fad"))
+ (assert* (string= (project-name "drakma") "drakma"))
+ (assert* (string= (project-name :t) "t"))
+ (assert* (string= (project-name :nil) "nil"))
+ (assert* (string= (project-name :cl-fad) "cl-fad"))
+ (assert* (string= (project-name :drakma) "drakma"))
+
+ (format t "~&;; project-directory~%")
+ (let* ((*source-location* (make-pathname :directory '(:absolute "tmp")))
+ (p (make-pathname :directory '(:absolute "tmp" "cl-fad"))))
+ (assert* (equal (project-directory "cl-fad") p)))
+ (let* ((*source-location* nil)
+ (*project-manifest* (make-pathname :directory '(:absolute "tmp")))
+ (p (make-pathname :directory '(:absolute "tmp" "source" "cl-fad"))))
+ (assert* (equal (project-directory "cl-fad") p)))
+
+ (format t "~&;;; Installer~%")
+
+ (format t "~&;; guess-backend~%")
+ (assert* (git-url-p "git://example.com/path"))
+ (assert* (git-url-p "git+ssh://example.com/path"))
+ (assert* (git-url-p "ssh+git://example.com/path"))
+ (assert* (git-url-p "http://example.com/git/path"))
+ (assert* (git-url-p "/git/path"))
+ (assert* (git-url-p "/root/git/path"))
+ (assert* (git-url-p "/path/project/git"))
+ (assert* (git-url-p "/path/project/git/"))
+ (assert* (git-url-p "http://example.com/path.git"))
+ (assert* (git-url-p "http://example.com/path.git/"))
+ (assert* (git-url-p "https://example.com/path.git"))
+ (assert* (git-url-p "https://example.com/path.git/"))
+ (assert* (git-url-p "ssh://example.com/path.git"))
+ (assert* (git-url-p "ssh://example.com/path.git/"))
+ (assert* (git-url-p "file:///path/project.git"))
+ (assert* (git-url-p "file:///path/project.git/"))
+ (assert* (git-url-p "/path/project.git"))
+ (assert* (git-url-p "/path/project.git/"))
+ (assert* (svn-url-p "svn://example.com/path"))
+ (assert* (darcs-url-p "http://example.com/path/project/darcs"))
+ (assert* (darcs-url-p "https://example.com/path/project/darcs"))
+ (assert* (darcs-url-p "ssh://example.com/path/project/darcs"))
+ (assert* (darcs-url-p "http://example.com/path/project/darcs/"))
+ (assert* (darcs-url-p "https://example.com/path/project/darcs/"))
+ (assert* (darcs-url-p "ssh://example.com/path/project/darcs/"))
+ (assert* (darcs-url-p "http://example.com/path/darcs/project"))
+ (assert* (darcs-url-p "https://example.com/path/darcs/project"))
+ (assert* (darcs-url-p "ssh://example.com/path/darcs/project"))
+ (assert* (cvs-url-p ":pserver:username:password@example.com:/path"))
+ (assert* (curl-url-p "http://example.com/path/project.tar.gz"))
+ (assert* (curl-url-p "https://example.com/path/project.tar.gz"))
+ (assert* (curl-url-p "ftp://example.com/path/project.tar.gz"))
+ (assert* (curl-url-p "ftps://example.com/path/project.tar.gz"))
+ (assert* (curl-url-p "sftp://example.com/path/project.tar.gz"))
+ (assert* (curl-url-p "file://example.com/path/project.tar.gz"))
+
+ (format t "~&;; project manifest test~%")
+ (let* ((*project-manifest* (system-relative-pathname :asia "t/manifest/" :type :directory))
+ (*source-location* nil))
+ (format t "~&;;; project-ignored-p~%")
+ (assert* (project-ignored-p :asdf))
+ (assert* (project-ignored-p :asia))
+ (assert* (project-ignored-p :ignored))
+ (format t "~&;;; project-installed-p~%")
+ (let* ((*source-location* (system-relative-pathname :asia "t/source/" :type :directory)))
+ (assert* (project-installed-p :asia-foo)))
+ (format t "~&;;; install-project~%")
+ (delete-directory-and-files (source-location) :if-does-not-exist :ignore)
+ (assert* (not (install-project "null-project" :url (lambda ()))))
+ (assert* (install-project "installer-test"))
+ (let* ((tmpdir (make-temp-pathname :type :directory))
+ (archive (location (list tmpdir (pathspec "asia-test-archive.tar" :type "gz")))))
+ (delete-directory-and-files tmpdir :if-does-not-exist :ignore)
+ (ensure-directories-exist tmpdir)
+ (run-shell-command "tar c -z -f ~A -C ~A asia-test-archive" archive
+ (system-relative-pathname :asia "t/" :type :directory))
+ (assert* (install-project "asia-test-archive" :url archive))))
+
+ (format t "~%;;;; All tests passed.~%"))
148 src/utils.lisp
@@ -0,0 +1,148 @@
+(in-package :asia)
+
+(defmacro with-unique-names (names &body forms)
+ "Binds each variable named by a symbol in NAMES to a unique symbol around
+FORMS. Each of NAMES must either be either a symbol, or of the form:
+
+ (symbol string-designator)
+
+Bare symbols appearing in NAMES are equivalent to:
+
+ (symbol symbol)
+
+The string-designator is used as the argument to GENSYM when constructing the
+unique symbol the named variable will be bound to."
+ (flet ((%trans (name)
+ (multiple-value-bind (symbol string)
+ (etypecase name
+ (symbol
+ (values name (symbol-name name)))
+ ((cons symbol (cons (or symbol string character) null))
+ (values (first name) (string (second name)))))
+ `(,symbol (gensym ,string)))))
+ (let ((entries (mapcar #'%trans names)))
+ `(let ,entries
+ ,@forms))))
+
+(defun emptyp (sequence)
+ "Returns true if SEQUENCE is an empty sequence. Signals an error if
+SEQUENCE is not a sequence"
+ (etypecase sequence
+ (list (null sequence))
+ (sequence (zerop (length sequence)))))
+
+(defun pathspec (name &key type defaults)
+ "This implements the concept of ASDF \"pathname specifier\".
+
+If NAME is a pathname designator except a symbol or string, returns
+itself; if NAME is a symbol, treat it as the downcase form of its
+symbol-name; if NAME is a string, treat it as the \"pathname
+specifier\".
+
+If TYPE is :DIRECTORY or NAME ends with a slash, returns a directory
+pathname; if TYPE is a string, it will be the new type component of
+the specifier.
+
+The specifier will use the host and device components from DEFAULTS or
+*DEFAULT-PATHNAME-DEFAULTS* (if DEFAULTS is NIL).
+
+See ASDF manual 5.3.4 for details."
+ (if (typep name '(or pathname symbol string))
+ (merge-component-name-type name :type type :defaults defaults)
+ (pathspec (pathname name) :type type :defaults defaults)))
+
+(defun location-designator-p (location-designator)
+ "Tests whether LOCATION-DESIGNATOR is available.
+
+NOTE: Although NIL and T are available in ASDF, they are unavailable
+in ASIA."
+ (and (asdf::location-designator-p location-designator)
+ (not (typep location-designator 'boolean))))
+
+(defun location (location-designator &key directory wilden)
+ "This implements the concept of ASDF location DSL.
+
+If DIRECTORY is true, LOCATION-DESIGNATOR will be treated as a
+directory.
+
+If WILDEN is true, LOCATION-DESIGNATOR can be a wildcard.
+
+See ASDF manual 7.4 & 8.3 for the details of LOCATION-DESIGNATOR."
+ (if (location-designator-p location-designator)
+ (resolve-location location-designator :directory directory :wilden wilden)
+ (error "Invalid location designator ~S~%" location-designator)))
+
+#+clisp
+(let ((getpid (or (find-symbol "PROCESS-ID" :system)
+ ;; old name prior to 2005-03-01, clisp <= 2.33.2
+ (find-symbol "PROGRAM-ID" :system)
+ #+win32 ; integrated into the above since 2005-02-24
+ (and (find-package :win32) ; optional modules/win32
+ (find-symbol "GetCurrentProcessId" :win32)))))
+ (defun %getpid () ; a required interface
+ (cond
+ (getpid (funcall getpid))
+ #+win32 ((ext:getenv "PID")) ; where does that come from?
+ (t -1))))
+
+#+lispworks
+(defun %getpid ()
+ #+win32
+ (win32:get-current-process-id)
+ #-win32
+ (system::getpid))
+
+#+abcl
+(defun %getpid ()
+ (handler-case
+ (let* ((runtime
+ (java:jstatic "getRuntime" "java.lang.Runtime"))
+ (command
+ (java:jnew-array-from-array
+ "java.lang.String" #("sh" "-c" "echo $PPID")))
+ (runtime-exec-jmethod
+ ;; Complicated because java.lang.Runtime.exec() is
+ ;; overloaded on a non-primitive type (array of
+ ;; java.lang.String), so we have to use the actual
+ ;; parameter instance to get java.lang.Class
+ (java:jmethod "java.lang.Runtime" "exec"
+ (java:jcall
+ (java:jmethod "java.lang.Object" "getClass")
+ command)))
+ (process
+ (java:jcall runtime-exec-jmethod runtime command))
+ (output
+ (java:jcall (java:jmethod "java.lang.Process" "getInputStream")
+ process)))
+ (java:jcall (java:jmethod "java.lang.Process" "waitFor")
+ process)
+ (loop :with b
+ :do (setq b
+ (java:jcall (java:jmethod "java.io.InputStream" "read")
+ output))
+ :until (member b '(-1 #x0a)) ; Either EOF or LF
+ :collecting (code-char b) :into result
+ :finally (return
+ (parse-integer (coerce result 'string)))))
+ (t () 0)))
+
+(defun getpid ()
+ (or
+ #+sbcl
+ (sb-posix:getpid)
+ #+clozure
+ (ccl::getpid)
+ #+clisp
+ (%getpid)
+ #+ecl
+ (si:getpid)
+ #+cmucl
+ (unix:unix-getpid)
+ #+lispworks
+ (%getpid)
+ #+allegro
+ (excl::getpid)
+ #+abcl
+ (%getpid)
+ #-(or sbcl clozure clisp ecl cmucl lispworks allegro abcl)
+ -1))
2  t/asia-test-archive/asia-test-archive.asd
@@ -0,0 +1,2 @@
+(asdf:defsystem :asia-test-archive
+ :components ((:file "asia-test-archive")))
10 t/asia-test-archive/asia-test-archive.lisp
@@ -0,0 +1,10 @@
+(in-package :cl-user)
+
+(defpackage :asia-test-archive
+ (:use :cl)
+ (:export :foo))
+
+(in-package :asia-test-archive)
+
+(defun foo ()
+ (print "A archive test project for ASIA."))
1  t/manifest/.gitignore
@@ -0,0 +1 @@
+source
0  t/manifest/projects/ignored/ignore
No changes.
2  t/manifest/projects/installer-test/installer.lisp
@@ -0,0 +1,2 @@
+(lambda ()
+ (ensure-directories-exist (project-directory "installer-test")))
2  t/source/asia-foo/asia-foo.asd
@@ -0,0 +1,2 @@
+(asdf:defsystem :asia-foo
+ :components ((:file "asia-foo")))
10 t/source/asia-foo/asia-foo.lisp
@@ -0,0 +1,10 @@
+(in-package :cl-user)
+
+(defpackage :asia-foo
+ (:use :cl)
+ (:export :foo))
+
+(in-package :asia-foo)
+
+(defun foo ()
+ (print "A test project for ASIA."))
Please sign in to comment.