Permalink
Browse files

more version number removals

git-svn-id: svn://bknr.net/svn/trunk/thirdparty/cl-fad@4378 4281704c-cde7-0310-8518-8e2dc76b1ff0
  • Loading branch information...
0 parents commit fad8525688ae2b1d0b08a36dcd44747653657bab @hanshuebner hanshuebner committed Apr 12, 2009
Showing with 1,153 additions and 0 deletions.
  1. +78 −0 CHANGELOG
  2. +34 −0 README
  3. +40 −0 cl-fad.asd
  4. +48 −0 cl-fad.system
  5. +86 −0 corman.lisp
  6. +243 −0 doc/index.html
  7. +315 −0 fad.lisp
  8. +62 −0 load.lisp
  9. +48 −0 openmcl.lisp
  10. +53 −0 packages.lisp
  11. +146 −0 test.lisp
78 CHANGELOG
@@ -0,0 +1,78 @@
+Version 0.6.2
+2008-03-12
+Never version of OpenMCL have %RMDIR (thanks to Dmitri Hrapof)
+
+Version 0.6.1
+2007-12-29
+Integrated CLISP patch for LIST-DIRECTORY sent by Dan Muller
+
+Version 0.6.0
+2007-05-28
+Support for Scieneer CL (patch from Douglas Crosher)
+
+Version 0.5.2
+2007-05-15
+Fix for (newer versions of) ECL (patch from Dustin Long)
+
+Version 0.5.1
+2006-08-11
+Added CHECKP to COPY-STREAM
+
+Version 0.5.0
+2006-04-21
+Added :BREADTH-FIRST option to WALK-DIRECTORY (thanks to Mac Chan)
+
+Version 0.4.3
+2006-03-15
+For CMUCL use TRUENAME with UNIX-RMDIR to cope with search lists (reported by Pawel Ostrowski)
+
+Version 0.4.2
+2006-01-04
+WALK-DIRECTORY now catches circular symbolic links (thanks to Gary King)
+
+Version 0.4.1
+2006-01-03
+Be more careful in DIRECTORY-WILDCARD (thanks to Gary King)
+Patches for MCL (thanks to Gary King)
+
+Version 0.4.0
+2005-12-10
+Exported COPY-STREAM (suggested by Chris Dean)
+
+Version 0.3.3
+2005-11-14
+Fixed %RMDIR for newer versions of OpenMCL (thanks to James Bielman)
+
+Version 0.3.2
+2005-09-11
+Fixed docs (correct name DELETE-DIRECTORY-AND-FILES)
+Fixed docs (OVERWRITE was missing in COPY-FILE signature)
+Added Debian link
+
+Version 0.3.1
+2005-06-02
+Fixed typo in fad.lisp (thanks to Jack D. Unrue)
+
+Version 0.3.0
+2005-06-01
+Support for ABCL (thanks to Jack D. Unrue)
+
+Version 0.2.0
+2005-05-29
+Support for ECL (thanks to Maciek Pasternacki)
+
+Version 0.1.3
+2005-04-27
+Changed implementation of DIRECTORY-EXISTS-P for LispWorks
+
+Version 0.1.2
+2005-03-17
+Fixed typo in cl-fad.system (tanks to Andrew Philpot)
+
+Version 0.1.1
+2005-01-22
+Fixed typos and versioning
+
+Version 0.1.0
+2005-01-22
+Initial release
34 README
@@ -0,0 +1,34 @@
+Complete documentation for CL-FAD can be found in the 'doc'
+directory.
+
+CL-FAD also supports Nikodemus Siivola's HYPERDOC, see
+<http://common-lisp.net/project/hyperdoc/> and
+<http://www.cliki.net/hyperdoc>.
+
+1. Installation
+
+1.1. Probably the easiest way is
+
+ (load "/path/to/cl-fad/load.lisp")
+
+ This should compile and load CL-FAD on most Common Lisp
+ implementations.
+
+1.2. With MK:DEFSYSTEM you can make a symbolic link from
+ 'cl-fad.system' and 'cl-fad-test.system' to your central registry
+ (which by default is in '/usr/local/lisp/Registry/') and then issue
+ the command
+
+ (mk:compile-system "cl-fad")
+
+ Note that this relies on TRUENAME returning the original file a
+ symbolic link is pointing to. This will only work with AllegroCL
+ 6.2 if you've applied all patches with (SYS:UPDATE-ALLEGRO).
+
+1.3. You can also use ASDF instead of MK:DEFSYSTEM in a similar way
+ (use the .asd files instead of the .system files).
+
+2. Test
+
+CL-FAD comes with a small test suite. To start it just load the file
+"test.lisp" and evaluate (CL-FAD-TEST:TEST).
40 cl-fad.asd
@@ -0,0 +1,40 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/cl-fad/cl-fad.asd,v 1.19 2008/03/12 00:10:43 edi Exp $
+
+;;; Copyright (c) 2004-2008, 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.
+
+#+:allegro (cl:require :osi)
+#+:sbcl (cl:require :sb-executable)
+#+:sbcl (cl:require :sb-posix)
+
+(asdf:defsystem #:cl-fad
+ :version "0.6.2"
+ :serial t
+ :components ((:file "packages")
+ #+:cormanlisp (:file "corman")
+ #+:openmcl (:file "openmcl")
+ (:file "fad")))
48 cl-fad.system
@@ -0,0 +1,48 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/cl-fad/cl-fad.system,v 1.8 2008/03/12 00:10:43 edi Exp $
+
+;;; Copyright (c) 2005-2008, 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)
+
+(defparameter *cl-fad-base-directory*
+ (make-pathname :name nil :type nil :version nil
+ :defaults (parse-namestring *load-truename*)))
+
+#+:allegro (require :osi)
+#+:sbcl (require :sb-executable)
+#+:sbcl (require :sb-posix)
+
+(mk:defsystem #:cl-fad
+ :source-pathname *cl-fad-base-directory*
+ :source-extension "lisp"
+ :components ((:file "packages")
+ #+:cormanlisp (:file "corman" :depends-on ("packages"))
+ #+:openmcl (:file "openmcl" :depends-on ("packages"))
+ (:file "fad" :depends-on ("packages"
+ #+:cormanlisp "corman"
+ #+:openmcl "openmcl"))))
86 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.4 2008/03/12 00:10:43 edi Exp $
+
+;;; Copyright (c) 2004-2008, 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)
243 doc/index.html
@@ -0,0 +1,243 @@
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">
+<html>
+
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
+ <title>CL-FAD - A portable pathname library for Common Lisp</title>
+ <style type="text/css">
+ pre { padding:5px; background-color:#e0e0e0 }
+ h3, h4 { text-decoration: underline; }
+ a { text-decoration: none; padding: 1px 2px 1px 2px; }
+ a:visited { text-decoration: none; padding: 1px 2px 1px 2px; }
+ a:hover { text-decoration: none; padding: 1px 1px 1px 1px; border: 1px solid #000000; }
+ a:focus { text-decoration: none; padding: 1px 2px 1px 2px; border: none; }
+ a.none { text-decoration: none; padding: 0; }
+ a.none:visited { text-decoration: none; padding: 0; }
+ a.none:hover { text-decoration: none; border: none; padding: 0; }
+ a.none:focus { text-decoration: none; border: none; padding: 0; }
+ a.noborder { text-decoration: none; padding: 0; }
+ a.noborder:visited { text-decoration: none; padding: 0; }
+ a.noborder:hover { text-decoration: none; border: none; padding: 0; }
+ a.noborder:focus { text-decoration: none; border: none; padding: 0; }
+ pre.none { padding:5px; background-color:#ffffff }
+ </style>
+</head>
+
+<body bgcolor=white>
+
+<h2>CL-FAD - A portable pathname library for Common Lisp</h2>
+
+<blockquote>
+<br>&nbsp;<br><h3><a name=abstract class=none>Abstract</a></h3>
+
+CL-FAD (for "<font color=red>F</font>iles <font color=red>a</font>nd
+<font color=red>D</font>irectories") is a thin layer atop Common
+Lisp's standard pathname functions. It is intended to provide some
+unification between current CL implementations on Windows, OS X,
+Linux, and Unix. Most of the code was written by Peter Seibel for his book <a href="http://www.gigamonkeys.com/book/"><em>Practical Common Lisp</em></a>.
+
+<p>
+
+CL-FAD comes with a <a
+href="http://www.opensource.org/licenses/bsd-license.php">BSD-style
+license</a> so you can basically do with it whatever you want.
+
+<p>
+<font color=red>Download shortcut:</font> <a href="http://weitz.de/files/cl-fad.tar.gz">http://weitz.de/files/cl-fad.tar.gz</a>.
+
+</blockquote>
+
+<br>&nbsp;<br><h3><a class=none name="contents">Contents</a></h3>
+<ol>
+ <li><a href="#download">Download and installation</a>
+ <li><a href="#implementations">Supported Lisp implementations</a>
+ <li><a href="#dictionary">The CL-FAD dictionary</a>
+ <ol>
+ <li><a href="#directory-pathname-p"><code>directory-pathname-p</code></a>
+ <li><a href="#pathname-as-directory"><code>pathname-as-directory</code></a>
+ <li><a href="#pathname-as-file"><code>pathname-as-file</code></a>
+ <li><a href="#file-exists-p"><code>file-exists-p</code></a>
+ <li><a href="#directory-exists-p"><code>directory-exists-p</code></a>
+ <li><a href="#list-directory"><code>list-directory</code></a>
+ <li><a href="#walk-directory"><code>walk-directory</code></a>
+ <li><a href="#delete-directory-and-files"><code>delete-directory-and-files</code></a>
+ <li><a href="#copy-file"><code>copy-file</code></a>
+ <li><a href="#copy-stream"><code>copy-stream</code></a>
+ </ol>
+ <li><a href="#ack">Acknowledgements</a>
+</ol>
+
+
+
+<br>&nbsp;<br><h3><a class=none name="download">Download and installation</a></h3>
+
+CL-FAD together with this documentation can be downloaded from <a
+href="http://weitz.de/files/cl-fad.tar.gz">http://weitz.de/files/cl-fad.tar.gz</a>. The
+current version is 0.6.2.
+<p>
+CL-FAD comes with simple system definitions for <a
+href="http://www.cliki.net/mk-defsystem">MK:DEFSYSTEM</a> and <a
+href="http://www.cliki.net/asdf">asdf</a> so you can either adapt it
+to your needs or just unpack the archive and from within the CL-FAD
+directory start your Lisp image and evaluate the form
+<code>(mk:compile-system&nbsp;&quot;cl-fad&quot;)</code> - or <code>(asdf:oos&nbsp;'asdf:load-op&nbsp;:cl-fad)</code> for asdf - which should compile and load the whole
+system.
+Installation via <a
+href="http://www.cliki.net/asdf-install">asdf-install</a> should as well
+be possible. Plus, there are ports
+for <a href="http://www.gentoo.org/proj/en/common-lisp/index.xml">Gentoo Linux</a> thanks to Matthew Kennedy
+and for <a href="http://packages.debian.org/cgi-bin/search_packages.pl?keywords=cl-fad&amp;searchon=names&amp;subword=1&amp;version=all&amp;release=all">Debian Linux</a> thanks to Ren&eacute; van Bevern.
+<p>
+If for some reason you can't or don't want to use MK:DEFSYSTEM or asdf you
+can just <code>LOAD</code> the file <code>load.lisp</code>.
+<p>
+Lu&iacute;s Oliveira maintains a <a href="http://darcs.net/">darcs</a>
+repository of CL-FAD
+at <a
+href="http://common-lisp.net/~loliveira/ediware/">http://common-lisp.net/~loliveira/ediware/</a>.
+<p>
+If you want to send patches, please <a href="http://weitz.de/patches.html">read this first</a>.
+
+<br>&nbsp;<br><h3><a class=none name="implementations">Supported Lisp implementations</a></h3>
+
+<p>
+The following Common Lisp implementations are currently supported:
+<ul>
+<li><a href="http://armedbear.org/abcl.html">Armed Bear Common Lisp</a>
+<li><a href="http://www.cons.org/cmucl/">CMUCL</a>
+<li><a href="http://www.cormanlisp.com/">Corman Common Lisp</a>
+<li><a href="http://ecls.sf.net/">ECL</a>
+<li><a href="http://www.franz.com/products/allegrocl/">Franz AllegroCL</a>
+<li><a href="http://clisp.cons.org/">GNU CLISP</a>
+<li><a href="http://www.lispworks.com/">LispWorks</a>
+<li><a href="http://www.digitool.com/">Macintosh Common Lisp</a>
+<li><a href="http://openmcl.clozure.com/">OpenMCL</a>
+<li><a href="http://www.scieneer.com/scl/">Scieneer Common Lisp</a>
+<li><a href="http://sbcl.sourceforge.net/">Steel Bank Common Lisp</a>
+</ul>
+
+I'll gladly accepts patches to make CL-FAD work on other platforms.
+
+
+<br>&nbsp;<br><h3><a class=none name="dictionary">The CL-FAD dictionary</a></h3>
+
+<p><br>[Function]
+<br><a class=none name="directory-pathname-p"><b>directory-pathname-p</b> <i> pathspec </i> =&gt; <i> generalized-boolean</i></a>
+
+<blockquote><br>
+Returns <code>NIL</code> if <code><i>pathspec</i></code> (a <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#pathname_designator">pathname designator</a>) does not designate
+a directory, <code><i>pathspec</i></code> otherwise. It is irrelevant whether the file or
+directory designated by <code><i>pathspec</i></code> does actually exist.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="pathname-as-directory"><b>pathname-as-directory</b> <i> pathspec </i> =&gt; <i> pathname</i></a>
+<blockquote><br>
+Converts the <em>non-wild</em> <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#pathname_designator">pathname designator</a> <code><i>pathspec</i></code> to <em>directory form</em>, i.e. it returns a <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#pathname">pathname</a> which would return a <em>true</em> value if fed to <a href="#directory-pathname-p"><code>DIRECTORY-PATHNAME-P</code></a>.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="pathname-as-file"><b>pathname-as-file</b> <i> pathspec </i> =&gt; <i> pathname</i></a>
+
+<blockquote><br>
+Converts the <em>non-wild</em> <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#pathname_designator">pathname designator</a> <code><i>pathspec</i></code> to <em>file form</em>, i.e. it returns a <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#pathname">pathname</a> which would return a <code>NIL</code> value if fed to <a href="#directory-pathname-p"><code>DIRECTORY-PATHNAME-P</code></a>.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="file-exists-p"><b>file-exists-p</b> <i> pathspec </i> =&gt; <i> generalized-boolean</i></a>
+
+<blockquote><br>
+Checks whether the file named by the <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#pathname_designator">pathname designator</a> <code><i>pathspec</i></code>
+exists and returns its <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_t.htm#truename">truename</a> if this is the case, <code>NIL</code> otherwise.
+The truename is returned in "canonical" form, i.e. the truename of a
+directory is returned in <em>directory form</em> as if by <a href="#pathname-as-directory"><code>PATHNAME-AS-DIRECTORY</code></a>.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="directory-exists-p"><b>directory-exists-p</b> <i> pathspec </i> =&gt; <i> generalized-boolean</i></a>
+
+<blockquote><br>
+Checks whether the file named by the <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#pathname_designator">pathname designator</a> <code><i>pathspec</i></code>
+exists and if it is a directory. Returns its <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_t.htm#truename">truename</a> if this is the
+case, <code>NIL</code> otherwise. The truename is returned in <em>directory form</em> as if
+by <a href="#pathname-as-directory"><code>PATHNAME-AS-DIRECTORY</code></a>.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="list-directory"><b>list-directory</b> <i> dirname </i> =&gt; <i> list</i></a>
+
+<blockquote><br>
+Returns a <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#fresh">fresh</a> list of pathnames corresponding to the truenames of
+all files within the directory named by the non-wild <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#pathname_designator">pathname designator</a> <code><i>dirname</i></code>. The pathnames of sub-directories are returned in
+<em>directory form</em> - see <a href="#pathname-as-directory"><code>PATHNAME-AS-DIRECTORY</code></a>.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="walk-directory"><b>walk-directory</b> <i> dirname fn <tt>&amp;key</tt> directories if-does-not-exist test</i> =&gt; |</a>
+
+<blockquote><br>
+ Recursively applies the function designated by the <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#function_designator">function
+ designator</a> <code><i>fn</i></code> to all files within the directory named
+ by the non-wild <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#pathname_designator">pathname
+ designator</a> <code><i>dirname</i></code> and all of its sub-directories. <code><i>fn</i></code>
+ will only be applied to files for which the function <code><i>test</i></code>
+ returns a <em>true</em> value. (The default value for <code><i>test</i></code>
+ always returns <em>true</em>.) If <code><i>directories</i></code> is not <code>NIL</code>,
+ <code><i>fn</i></code> and <code><i>test</i></code> are applied to directories
+ as well. If <code><i>directories</i></code> is <code>:DEPTH-FIRST</code>, <code><i>fn</i></code>
+ will be applied to the directory's contents first. If <code><i>directories</i></code>
+ is <code>:BREADTH-FIRST</code> and <code><i>test</i></code> returns <code>NIL</code>, the
+ directory's content will be skipped. <code><i>if-does-not-exist</i></code> must
+ be one of <code>:ERROR</code> or <code>:IGNORE</code> where <code>:ERROR</code>
+ (the default) means that an error will be signaled if the directory <code><i>dirname</i></code>
+ does not exist. </blockquote>
+
+<p><br>[Function]
+<br><a class=none name="delete-directory-and-files"><b>delete-directory-and-files</b> <i> dirname<tt>&amp;key</tt> if-does-not-exist</i> =&gt; |</a>
+
+<blockquote><br>
+Recursively deletes all files and directories within the directory
+designated by the non-wild <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#pathname_designator">pathname designator</a> <code><i>dirname</i></code> including
+<code><i>dirname</i></code> itself. <code><i>if-does-not-exist</i></code> must be one of <code>:ERROR</code> or <code>:IGNORE</code>
+where <code>:ERROR</code> (the default) means that an error will be signaled if the directory
+<code><i>dirname</i></code> does not exist.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="copy-file"><b>copy-file</b> <i> from to <tt>&amp;key</tt> overwrite</i> =&gt; |</a>
+
+<blockquote><br>
+Copies the file designated by the non-wild <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#pathname_designator">pathname designator</a> <code><i>from</i></code> to the
+file designated by the non-wild <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#pathname_designator">pathname designator</a> <code><i>to</i></code>. If <code><i>overwrite</i></code> is <em>true</em> (the default is <code>NIL</code>)
+overwrites the file designtated by <code><i>to</i></code> if it exists.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="copy-stream"><b>copy-stream</b> <i> from to <tt>&amp;optional</tt> checkp</i> =&gt; |</a>
+
+<blockquote><br> Copies into <code><i>to</i></code> (a stream)
+from <code><i>from</i></code> (also a stream) until the end
+of <code><i>from</i></code> is reached. The streams should have the
+same <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/f_stm_el.htm">element
+type</a> unless they are bivalent. If <code><i>checkp</i></code> is
+true (which is the default), the function will signal an error if the
+element types aren't the same.
+</blockquote>
+
+<br>&nbsp;<br><h3><a class=none name="ack">Acknowledgements</a></h3>
+
+The original code for this library was written by Peter Seibel for his
+book <a href="http://www.gigamonkeys.com/book/"><em>Practical Common
+Lisp</em></a>. I added some stuff and made sure it worked properly on
+Windows, specifically with CCL. Thanks to James Bielman, Maciek
+Pasternacki, Jack D. Unrue, Gary King, and Douglas Crosher who sent
+patches for OpenMCL, ECL, ABCL, MCL, and Scieneer&nbsp;CL.
+
+<p>
+$Header: /usr/local/cvsrep/cl-fad/doc/index.html,v 1.32 2008/03/12 00:10:45 edi Exp $
+<p><a href="http://weitz.de/index.html">BACK TO MY HOMEPAGE</a>
+
+</body>
+</html>
+
315 fad.lisp
@@ -0,0 +1,315 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-FAD; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/cl-fad/fad.lisp,v 1.33 2008/03/12 00:10:43 edi Exp $
+
+;;; Copyright (c) 2004, Peter Seibel. All rights reserved.
+;;; Copyright (c) 2004-2008, 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-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)))
+
+#-:sbcl
+(defvar *stream-buffer-size* 8192)
+#-:sbcl
+(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))
+
+#+:sbcl
+(declaim (inline copy-stream))
+#+:sbcl
+(defun copy-stream (from to)
+ "Copies into TO \(a stream) from FROM \(also a stream) until the end
+of FROM is reached. The streams should have the same element type."
+ (sb-executable:copy-stream from to)
+ (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 (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))
+
+(pushnew :cl-fad *features*)
+
+;; stuff for Nikodemus Siivola's HYPERDOC
+;; see <http://common-lisp.net/project/hyperdoc/>
+;; and <http://www.cliki.net/hyperdoc>
+;; also used by LW-ADD-ONS
+
+#-:abcl
+(defvar *hyperdoc-base-uri* "http://weitz.de/cl-fad/")
+
+#-:abcl
+(let ((exported-symbols-alist
+ (loop for symbol being the external-symbols of :cl-fad
+ collect (cons symbol
+ (concatenate 'string
+ "#"
+ (string-downcase symbol))))))
+ (defun hyperdoc-lookup (symbol type)
+ (declare (ignore type))
+ (cdr (assoc symbol
+ exported-symbols-alist
+ :test #'eq))))
62 load.lisp
@@ -0,0 +1,62 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/cl-fad/load.lisp,v 1.8 2008/03/12 00:10:43 edi Exp $
+
+;;; Copyright (c) 2004-2008, 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)
+
+(defparameter *cl-fad-base-directory*
+ (make-pathname :name nil :type nil :version nil
+ :defaults (parse-namestring *load-truename*)))
+
+#+:allegro (require :osi)
+#+:sbcl (require :sb-executable)
+#+:sbcl (require :sb-posix)
+
+(let ((cl-fad-base-directory
+ (make-pathname :name nil :type nil :version nil
+ :defaults (parse-namestring *load-truename*))))
+ (let (must-compile)
+ #+:cormanlisp (declare (ignore must-compile))
+ (dolist (file '("packages"
+ #+:cormanlisp "corman"
+ #+:openmcl "openmcl"
+ "fad"))
+ (let ((pathname (make-pathname :name file :type "lisp" :version nil
+ :defaults cl-fad-base-directory)))
+ ;; don't use COMPILE-FILE in Corman Lisp, it's broken - LOAD
+ ;; will yield compiled functions anyway
+ #-:cormanlisp
+ (let ((compiled-pathname (compile-file-pathname pathname)))
+ (unless (and (not must-compile)
+ (probe-file compiled-pathname)
+ (< (file-write-date pathname)
+ (file-write-date compiled-pathname)))
+ (setq must-compile t)
+ (compile-file pathname))
+ (setq pathname compiled-pathname))
+ (load pathname)))))
48 openmcl.lisp
@@ -0,0 +1,48 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CCL; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/cl-fad/openmcl.lisp,v 1.5 2008/03/12 00:10:43 edi Exp $
+
+;;; Copyright (c) 2004-2008, 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 :ccl)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (let ((%rmdir-symbol (find-symbol "%RMDIR" :ccl)))
+ (unless (and %rmdir-symbol (fboundp %rmdir-symbol))
+ (pushnew :no-%rmdir *features*))))
+
+#+:no-%rmdir
+(defun %rmdir (name)
+ (with-cstrs ((n name))
+ (#_rmdir n)))
+
+(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))))))
+
+(export 'delete-directory)
53 packages.lisp
@@ -0,0 +1,53 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/cl-fad/packages.lisp,v 1.11 2008/03/12 00:10:43 edi Exp $
+
+;;; Copyright (c) 2004-2008, 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 :cl-fad
+ (:nicknames :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 :cl-fad-test
+ (:use :cl :cl-fad)
+ (:export :test))
146 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.11 2008/03/12 00:10:43 edi Exp $
+
+;;; Copyright (c) 2004-2008, 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-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.~%"))

0 comments on commit fad8525

Please sign in to comment.