Loose changes
This commit is contained in:
Ian Keane
parent
1cb167b597
commit
612c72bae1
57 changed files with 8904 additions and 80 deletions
|
|
@ -0,0 +1,121 @@
|
|||
Version 0.7.6
|
||||
2019-07-28
|
||||
Clisp has renamed ext:delete-dir to ext:delete-directory.
|
||||
Fix get-default-temporary-directory on lispworks.
|
||||
|
||||
Version 0.7.5
|
||||
2017-12-10
|
||||
Fix FILE-EXISTS-P to return directory truename in CLISP (chaitanyagupta)
|
||||
Added support for Common Lisp implementation CLASP. (dg1sbg)
|
||||
|
||||
Version 0.7.4
|
||||
2016-07-10
|
||||
Merge pull request #13 from vibs29/master (Hans Hübner)
|
||||
Make copy-stream work for CMUCL Gray Streams (vibs29)
|
||||
|
||||
Version 0.7.3
|
||||
2014-11-28
|
||||
remove version from cl-fad-test system (Hans Huebner)
|
||||
update support information (Hans Huebner)
|
||||
|
||||
Version 0.7.2
|
||||
2013-07-03
|
||||
Fix documentation glitch (inconsistent download link) (Luís Oliveira)
|
||||
|
||||
Version 0.7.1
|
||||
2013-02-18
|
||||
Fix for LispWorks (R. Wilker)
|
||||
Add :description to .asd file
|
||||
|
||||
Version 0.7.0
|
||||
2013-01-23
|
||||
Tests, pathname manipulation functions (Marco Baringer)
|
||||
Temporary files (merged by Marco Baringer)
|
||||
Fix symlink behaviour for some platforms (Mihai Bazon and Janis Dzerins)
|
||||
|
||||
Version 0.6.4
|
||||
2010-11-18
|
||||
Adapt to newer ClozureCL version (patch from Zach Beane, thanks to Chun Tian and Ralph Moritz as well)
|
||||
|
||||
Version 0.6.3
|
||||
2009-09-30
|
||||
Removed dependency on :SB-EXECUTABLE (thanks to Attila Lendvai and Tobias Rittweiler)
|
||||
|
||||
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
|
||||
|
|
@ -0,0 +1,26 @@
|
|||
;;; 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.
|
||||
|
|
@ -0,0 +1,38 @@
|
|||
Complete documentation for CL-FAD can be found in the 'docs'
|
||||
directory or at <https://edicl.github.io/cl-fad/>.
|
||||
|
||||
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).
|
||||
|
||||
1.4. Via QuickLisp:
|
||||
|
||||
(ql:quickload :cl-fad)
|
||||
|
||||
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).
|
||||
|
|
@ -0,0 +1,50 @@
|
|||
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
|
||||
;;; $Header: /usr/local/cvsrep/cl-fad/cl-fad.asd,v 1.21 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 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)
|
||||
|
||||
(asdf:defsystem #:cl-fad
|
||||
:version "0.7.6"
|
||||
:description "Portable pathname library"
|
||||
:serial t
|
||||
:license "BSD-2-Clause"
|
||||
:components ((:file "packages")
|
||||
#+:cormanlisp (:file "corman")
|
||||
#+:openmcl (:file "openmcl")
|
||||
(:file "fad")
|
||||
(:file "path" :depends-on ("fad"))
|
||||
(:file "temporary-files" :depends-on ("fad")))
|
||||
:depends-on (#+sbcl :sb-posix :bordeaux-threads :alexandria))
|
||||
|
||||
(asdf:defsystem #:cl-fad-test
|
||||
:serial t
|
||||
:components ((:file "packages.test")
|
||||
(:file "fad.test" :depends-on ("packages.test"))
|
||||
(:file "temporary-files.test" :depends-on ("packages.test")))
|
||||
:depends-on (:cl-fad :unit-test :cl-ppcre))
|
||||
|
|
@ -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"))))
|
||||
|
|
@ -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)
|
||||
|
|
@ -0,0 +1,700 @@
|
|||
<!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, h5 { 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> <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> <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="#querying">Querying files, directories and pathnames</a>
|
||||
<ol>
|
||||
<li><a href="#directory-exists-p"><code>directory-exists-p</code> [function]</a>
|
||||
<li><a href="#directory-pathname-p"><code>directory-pathname-p</code> [function]</a>
|
||||
<li><a href="#file-exists-p"><code>file-exists-p</code> [function]</a>
|
||||
<li><a href="#pathname-absolute-p"><code>pathname-absolute-p</code> [function]</a>
|
||||
<li><a href="#pathname-equal"><code>pathname-equal</code> [function]</a>
|
||||
<li><a href="#pathname-relative-p"><code>pathname-relative-p</code> [function]</a>
|
||||
<li><a href="#pathname-root-p"><code>pathname-root-p</code> [function]</a>
|
||||
</ol> </li>
|
||||
<li><a href="#manipulating">Manipulating pathnames</a>
|
||||
<ol>
|
||||
<li><a href="#canonical-pathname"><code>canonical-pathname</code> [function]</a>
|
||||
<li><a href="#merge-pathnames-as-directory"><code>merge-pathnames-as-directory</code> [function]</a>
|
||||
<li><a href="#merge-pathnames-as-file"><code>merge-pathnames-as-file</code> [function]</a>
|
||||
<li><a href="#pathname-as-directory"><code>pathname-as-directory</code> [function]</a>
|
||||
<li><a href="#pathname-as-file"><code>pathname-as-file</code> [function]</a>
|
||||
<li><a href="#pathname-directory-pathname"><code>pathname-directory-pathname</code> [function]</a>
|
||||
<li><a href="#pathname-parent-directory"><code>pathname-parent-directory</code> [function]</a>
|
||||
</ol> </li>
|
||||
<li><a href="#traversing">Traversing directories</a>
|
||||
<ol>
|
||||
<li><a href="#list-directory"><code>list-directory</code> [function]</a>
|
||||
<li><a href="#walk-directory"><code>walk-directory</code> [function]</a>
|
||||
</ol> </li>
|
||||
<li><a href="#temporary-files">Temporary Files</a>
|
||||
<ol>
|
||||
<li><a href="#open-temporary"><code>open-temporary</code> [function]</a>
|
||||
<li><a href="#with-output-to-temporary-file"><code>with-output-to-temporary-file</code> [macro]</a>
|
||||
<li><a href="#with-open-temporary-file"><code>with-open-temporary-file</code> [macro]</a>
|
||||
<li><a href="#star-default-template-star"><code>*default-template*</code> [variable]</a>
|
||||
<li><a href="#cannot-create-temporary-file"><code>cannot-create-temporary-file</code> [condition]</a>
|
||||
<li><a href="#invalid-temporary-pathname-template"><code>invalid-temporary-pathname-template</code> [condition]</a>
|
||||
<li><a href="#missing-temp-environment-variable"><code>missing-temp-environment-variable</code> [condition]</a>
|
||||
<li><a href="#lp-host-temporary-files"><code>temporary-files</code> [logical pathname host]</a>
|
||||
</ol>
|
||||
</li>
|
||||
<li><a href="#modifying">Modifying the file system</a>
|
||||
<ol>
|
||||
<li><a href="#copy-file"><code>copy-file</code> [function]</a>
|
||||
<li><a href="#copy-stream"><code>copy-stream</code> [function]</a>
|
||||
<li><a href="#delete-directory-and-files"><code>delete-directory-and-files</code> [function]</a>
|
||||
</ol> </li>
|
||||
<li><a href="#package-path"><code>path</code> [package]</a>
|
||||
</ol>
|
||||
<li><a href="#ack">Acknowledgements</a>
|
||||
</ol>
|
||||
|
||||
|
||||
|
||||
<br> <br><h3><a class=none name="download">Download and installation</a></h3>
|
||||
|
||||
CL-FAD together with this documentation can be downloaded from <a
|
||||
href="https://github.com/edicl/cl-fad/releases/latest">https://github.com/edicl/cl-fad/releases/latest</a>. The
|
||||
current version is 0.7.6.
|
||||
<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 "cl-fad")</code> - or <code>(asdf:oos 'asdf:load-op :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&searchon=names&subword=1&version=all&release=all">Debian Linux</a> thanks to René 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>
|
||||
The latest version of the source code lives in the github repository <a href="https://github.com/edicl/cl-fad">edicl/cl-fad</a>.
|
||||
|
||||
If you want to send patches,
|
||||
please <a href="http://weitz.de/patches.html">read this first</a>.
|
||||
Please submit your changes
|
||||
as <a href="https://github.com/edicl/cl-fad/pulls">GitHub pull
|
||||
request"</a>.
|
||||
|
||||
<br> <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> <br><h3><a class=none name="dictionary">The CL-FAD dictionary</a></h3>
|
||||
|
||||
<h4><a class=none name="querying">Querying files, directories and pathnames</a></h4>
|
||||
|
||||
<p><br>[Function]
|
||||
<br><a class=none name="directory-exists-p"><b>directory-exists-p</b> <i> pathspec </i> => <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="directory-pathname-p"><b>directory-pathname-p</b> <i> pathspec </i> => <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="file-exists-p"><b>file-exists-p</b> <i> pathspec </i> => <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='pathname-absolute-p'><b>pathname-absolute-p</b> <i>a</i> => <i>result</i></a>
|
||||
<blockquote>
|
||||
<p>Returns true if <code><i>a</i></code> is an absolute pathname. This simply
|
||||
tests if <code><i>a</i></code>'s directory list starts with <code>:ABSOLUTE</code></p>
|
||||
</blockquote>
|
||||
|
||||
<p><br>[Function]<br><a class=none name='pathname-equal'><b>pathname-equal</b> <i>a b</i> => <i>result</i></a>
|
||||
<blockquote>
|
||||
|
||||
<p>Returns <em>true</em> if <code><i>a</i></code> and <code><i>b</i></code>
|
||||
represent the same pathname. This function does not access the
|
||||
filesystem, it only looks at the components of the two pathnames to
|
||||
test if they are the same (though by passing both <code><i>a</i></code>
|
||||
and <code><i>b</i></code> to probe-file one can make this function test for
|
||||
file 'sameness'.</p>
|
||||
|
||||
<p>Equality is defined as:</p>
|
||||
|
||||
<ul>
|
||||
<li>strings that are <code>string=</code>
|
||||
<li>symbols (including <code>nil</code> and keywords) which are <code>eql</code>
|
||||
<li>lists of the same length with equal (as per these rules) elements.
|
||||
</ul>
|
||||
|
||||
<p>If any of these tree conditions is false for any of the components in
|
||||
<code><i>a</i></code> and <code><i>b</i></code> then <code><i>a</i></code>
|
||||
and <code><i>b</i></code> are different, otherwise they are the same.</p>
|
||||
|
||||
<p><em>NB:</em> This function does not convert name strings to pathnames. So
|
||||
"foo.txt" and #P"foo.txt" are different pathnames.</p>
|
||||
|
||||
</blockquote>
|
||||
|
||||
<p><br>[Function]<br><a class=none name='pathname-relative-p'><b>pathname-relative-p</b> <i>a</i> => <i>result</i></a>
|
||||
<blockquote>
|
||||
<p>Returns true if <code><i>a</i></code> is a relative pathname. This simply
|
||||
tests if <code><i>a</i></code>'s directory starts
|
||||
with <code>:RELATIVE</code>.</p>
|
||||
</blockquote>
|
||||
|
||||
<p><br>[Function]<br><a class=none name='pathname-root-p'><b>pathname-root-p</b> <i>a</i> => <i>result</i></a>
|
||||
<blockquote>
|
||||
<p>Returns <em>true</em> if <code><i>pathname</i></code> is the root
|
||||
directory (in other words, a directory which is its own parent).</p>
|
||||
</blockquote>
|
||||
|
||||
<h4><a class=none name="manipulating">Manipulating pathnames</a></h4>
|
||||
|
||||
<p><br>[Function]<br><a class=none name='canonical-pathname'><b>canonical-pathname</b> <i>pathname</i> => <i>result</i></a>
|
||||
<blockquote>
|
||||
<p>Remove redundant information from PATHNAME.</p>
|
||||
|
||||
<p>This simply walks down <code>PATHNAME</code>'s
|
||||
pathname-directory and drops "." directories, removes :back
|
||||
and its preceding element.</p>
|
||||
|
||||
<p>NB: This function does not access the filesystem, it only looks at the
|
||||
values in the pathname and works on their known (or assumed)
|
||||
meanings.</p>
|
||||
|
||||
<p>NB: Since this function does not access the filesystem it will only
|
||||
remove <code>:BACK</code> elements from the path (not <code>:UP</code>
|
||||
elements). Since some lisps, ccl/sbcl/clisp convert ".." in
|
||||
pathnames to <code>:UP</code>, and not <code>:BACK</code>, the actual
|
||||
utility of the function is limited.</p>
|
||||
</blockquote>
|
||||
|
||||
<p><br>[Function]<br><a class=none name='merge-pathnames-as-directory'><b>merge-pathnames-as-directory</b> <i><tt>&rest</tt> pathnames</i> => <i>result</i></a>
|
||||
<blockquote>
|
||||
<p>Given a list of (probably relative) pathnames, this returns a single
|
||||
directory pathname containing the logical concatenation of them all.</p>
|
||||
|
||||
<p>The returned value is the current directory if one were to cd into
|
||||
each of <code><i>pathnames</i></code> in order. For this reason an
|
||||
absolute pathname will, effectively, cancel the affect of any previous
|
||||
relative pathnames.</p>
|
||||
|
||||
<p>The returned value's defaults are taken from the first element of
|
||||
<code><i>pathnames</i></code> (host, version and device).</p>
|
||||
|
||||
<p><em>NB:</em> Since this function only looks at directory names the name and
|
||||
type of the elements of <code><i>pathnames</i></code> are ignored. Make sure to properly
|
||||
use either trailing #\/s, or <a href="#pathname-as-directory">pathname-as-directory</a>, to get the
|
||||
expected results.</p>
|
||||
|
||||
<p>Examples:</p>
|
||||
|
||||
<pre>
|
||||
(merge-pathnames-as-directory #P"foo/" #P"bar/") == #P"foo/bar/"
|
||||
|
||||
(merge-pathnames-as-directory #P"foo/" #P"./bar/") == #P"foo/./bar/"
|
||||
|
||||
(merge-pathnames-as-directory #P"foo/" #P"/bar/") == #P"/bar/"
|
||||
|
||||
(merge-pathnames-as-directory #P"foo/" #P"/bar/" #P'quux/file.txt) == #P"/bar/quux/"
|
||||
</pre>
|
||||
|
||||
</blockquote>
|
||||
|
||||
<p><br>[Function]<br><a class=none name='merge-pathnames-as-file'><b>merge-pathnames-as-file</b> <i><tt>&rest</tt> pathnames</i> => <i>result</i></a>
|
||||
<blockquote>
|
||||
<p>Given a list of, probably relative, pathnames returns a single
|
||||
filename pathname containing the logical concatenation of them all.</p>
|
||||
|
||||
<p>The returned value's defaults are taken from the first element of
|
||||
<code><i>pathnames</i></code> (host, version and device). The returned
|
||||
values's name, type and version are taken from the last element
|
||||
of <code><i>pathnames</i></code>. The intervening elements are used only for
|
||||
their pathname-directory values.</p>
|
||||
|
||||
Examples:
|
||||
|
||||
<pre>
|
||||
(merge-pathnames-as-file #P"foo/" #P"bar.txt") == #P"foo/bar.txt"
|
||||
|
||||
(merge-pathnames-as-file #P"foo/" #P"./bar.txt") == #P"foo/./bar.txt"
|
||||
|
||||
(merge-pathnames-as-file #P"foo/" #P"/bar/README") == #P"/bar/README"
|
||||
|
||||
(merge-pathnames-as-file #P"/foo/" #P"/bar/" #P'quux/file.txt) == #P"/bar/quux/file.txt"
|
||||
</pre>
|
||||
|
||||
</blockquote>
|
||||
|
||||
<p><br>[Function]
|
||||
<br><a class=none name="pathname-as-directory"><b>pathname-as-directory</b> <i> pathspec </i> => <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> => <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='pathname-directory-pathname'><b>pathname-directory-pathname</b> <i>pathname</i> => <i>result</i></a>
|
||||
<blockquote>
|
||||
<p>Returns a complete pathname representing the directory of
|
||||
<code><i>pathname</i></code>. If <code><i>pathname</i></code> is
|
||||
already a directory pathname
|
||||
(<code>name</code> <code>nil</code>, <code>type</code>
|
||||
<code>nil</code>) returns a pathname equal (as
|
||||
per <a href="#pathname-equal">pathname-equal</a>) to it.</p>
|
||||
</blockquote>
|
||||
|
||||
<p><br>[Function]<br><a class=none name='pathname-parent-directory'><b>pathname-parent-directory</b> <i>pathname</i> => <i>result</i></a>
|
||||
<blockquote>
|
||||
|
||||
<p>Returns a pathname which would, by name at least,
|
||||
contain <code><i>pathname</i></code> as one of its direct
|
||||
children. Symlinks can make the parent/child relationship a like
|
||||
opaque, but generally speaking the value returned by this function is
|
||||
a directory name which contains <code><i>pathname</i></code>.</p>
|
||||
|
||||
<p>The root directory, #P"/", is its own parent. The parent
|
||||
directory of a filename is the parent of the filename's
|
||||
dirname.</p>
|
||||
|
||||
</blockquote>
|
||||
|
||||
<h4><a class=none name="traversing">Traversing directories</a></h4>
|
||||
|
||||
<p><br>[Function]
|
||||
<br><a class=none name="list-directory"><b>list-directory</b> <i> dirname <tt>&key</tt> follow-symlinks</i> => <i> list</i></a>
|
||||
|
||||
<blockquote><br>
|
||||
<p>
|
||||
Returns a <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#fresh">fresh</a> list of pathnames corresponding 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>. The pathnames of sub-directories are returned in
|
||||
<em>directory form</em> - see <a href="#pathname-as-directory"><code>PATHNAME-AS-DIRECTORY</code></a>.
|
||||
</p>
|
||||
<p>
|
||||
If <code><i>follow-symlinks</i></code> is true (which is the
|
||||
default), then the returned list contains truenames (symlinks will
|
||||
be resolved) which essentially means that it might also return files
|
||||
from <b>outside</b> the directory. This works on all platforms.
|
||||
</p>
|
||||
<p>
|
||||
When <code><i>follow-symlinks</i></code> is <code>NIL</code>, it should return the actual directory
|
||||
contents, which might include symlinks. (This is currently implemented only on SBCL and CCL.)
|
||||
</p>
|
||||
</blockquote>
|
||||
|
||||
<p><br>[Function]
|
||||
<br><a class=none name="walk-directory"><b>walk-directory</b> <i> dirname fn <tt>&key</tt> directories if-does-not-exist test follow-symlinks</i> => |</a>
|
||||
|
||||
<blockquote><br>
|
||||
<p>
|
||||
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.
|
||||
</p>
|
||||
<p>
|
||||
If <code><i>follow-symlinks</i></code> is true (which is
|
||||
the default), then your callback will receive truenames. Otherwise
|
||||
you should get the actual directory contents, which might include
|
||||
symlinks. This might not be supported on all platforms. See
|
||||
<a href="#list-directory"><code>LIST-DIRECTORY</code></a>.
|
||||
</p>
|
||||
</blockquote>
|
||||
|
||||
<h4><a class=none name="temporary-files">Temporary Files</a></h4>
|
||||
|
||||
<h5>Synopsis</h5>
|
||||
|
||||
<p>
|
||||
Create a temporary file and return its name:
|
||||
<pre>CL-USER> (temporary-file:<code xmlns=""><a href="#with-output-to-temporary-file">with-output-to-temporary-file</a></code> (foo)
|
||||
(print "hello" foo))
|
||||
#P"/var/folders/Yu/YuNMNBNPGoqs9G-1Wmj1dk+++TI/-Tmp-/temp-yjck024x"</pre>
|
||||
</p>
|
||||
<p>
|
||||
Create a temporary file, read and write it, have it be deleted
|
||||
automatically:
|
||||
<pre>CL-USER> (temporary-file:<code xmlns=""><a href="#with-open-temporary-file">with-open-temporary-file</a></code> (foo :direction :io)
|
||||
(print "hello" foo)
|
||||
(file-position foo 0)
|
||||
(read foo))
|
||||
"hello"</pre>
|
||||
</p>
|
||||
|
||||
<h5><a class="none" name="default-temporary-directory">Default temporary file directory</a></h5>
|
||||
By default, temporary files are created in a system specific
|
||||
directory that defaults based on operating system conventions. On
|
||||
Unix and Unix-like systems, the directory <tt>/tmp/</tt> is used
|
||||
by default. It can be overridden by setting the <tt>TMPDIR</tt>
|
||||
environment variable. On Windows, the value of the environment
|
||||
variable <tt>TEMP</tt> is used. If it is not set, temporary file
|
||||
creation will fail.
|
||||
|
||||
<h5><a class="none" name="defining-temporary-directory">Defining the temporary file directory</a></h5>
|
||||
<p>
|
||||
The Lisp application can set the default directory in which
|
||||
temporary files are created by the way of the
|
||||
<code xmlns=""><a href="#temporary-files">temporary-files</a></code> logical pathname host:
|
||||
|
||||
<pre>(setf (<a xmlns="" href="http://www.lispworks.com/documentation/HyperSpec/Body/f_logica.htm">logical-pathname-translations</a> "<code xmlns=""><a href="#temporary-files">temporary-files</a></code>") '(("*.*.*" "/var/tmp/")))</pre>
|
||||
|
||||
This would set the directory for temporary files to
|
||||
<tt>/var/tmp/</tt>. For more information about logical
|
||||
pathnames, please refer to <a href="http://www.cs.cmu.edu/afs/cs/project/ai-repository/ai/html/cltl/clm/node208.html#SECTION002715000000000000000">Common
|
||||
Lisp the Language, 2nd Edition</a> and the <a href="http://clhs.lisp.se/Body/19_.htm">Common Lisp
|
||||
HyperSpec</a>.
|
||||
</p>
|
||||
<p>
|
||||
Physical path names have restrictions regarding the permitted
|
||||
character in file names. If these restrictions conflict with
|
||||
your desired naming scheme, you can pass a physical pathname as
|
||||
TEMPLATE parameter to the temporary file generation function.
|
||||
</p>
|
||||
<p>
|
||||
Here are a few examples:
|
||||
<pre>CL-USER> (<a xmlns="" href="http://www.lispworks.com/documentation/HyperSpec/Body/f_logica.htm">logical-pathname-translations</a> "temporary-files")
|
||||
(("*.*.*" #P"/var/folders/Yu/YuNMNBNPGoqs9G-1Wmj1dk+++TI/-Tmp-/"))
|
||||
CL-USER> (temporary-file:<code xmlns=""><a href="#with-open-temporary-file">with-open-temporary-file</a></code> (foo)
|
||||
(<a xmlns="" href="http://www.lispworks.com/documentation/HyperSpec/Body/f_pn.htm">pathname</a> foo))
|
||||
#P"/var/folders/Yu/YuNMNBNPGoqs9G-1Wmj1dk+++TI/-Tmp-/temp-6rdqdkd1"</pre>
|
||||
|
||||
This used the temporary directory established in the TMPDIR
|
||||
environment variable, by the way of the definition of the
|
||||
temporary-files logical host definition.
|
||||
|
||||
<pre>CL-USER> (temporary-file:<code xmlns=""><a href="#with-open-temporary-file">with-open-temporary-file</a></code> (foo :template "/tmp/file.with.dots.in.name.%.txt")
|
||||
(<a xmlns="" href="http://www.lispworks.com/documentation/HyperSpec/Body/f_pn.htm">pathname</a> foo))
|
||||
#P"/tmp/file.with.dots.in.name.2EF04KUJ.txt"</pre>
|
||||
|
||||
Here, a physical pathname was used for the
|
||||
<code xmlns=""><i>:template</i></code> keyword argument so that a
|
||||
filename containing multiple dots could be generated.
|
||||
|
||||
<pre>CL-USER> (temporary-file:<code xmlns=""><a href="#with-open-temporary-file">with-open-temporary-file</a></code> (foo :template "temporary-files:blah-%.txt")
|
||||
(<a xmlns="" href="http://www.lispworks.com/documentation/HyperSpec/Body/f_pn.htm">pathname</a> foo))
|
||||
#P"/var/folders/Yu/YuNMNBNPGoqs9G-1Wmj1dk+++TI/-Tmp-/blah-72mj450d.txt"</pre>
|
||||
|
||||
This used the temporary-files logical pathname host, but changed
|
||||
the filename slightly.
|
||||
|
||||
<pre>CL-USER> *default-pathname-defaults*
|
||||
#P"/Users/hans/"
|
||||
CL-USER> (temporary-file:<code xmlns=""><a href="#with-open-temporary-file">with-open-temporary-file</a></code> (foo :template "blah-%.txt")
|
||||
(<a xmlns="" href="http://www.lispworks.com/documentation/HyperSpec/Body/f_pn.htm">pathname</a> foo))
|
||||
#P"/Users/hans/blah-5OEJELG2.txt"</pre>
|
||||
|
||||
Here, a relative pathname was used in the template, which
|
||||
caused the file to be generated in the directory established
|
||||
by <a xmlns="" href="http://www.lispworks.com/documentation/HyperSpec/Body/v_defaul.htm">*default-pathname-defaults*</a>.
|
||||
</p>
|
||||
<p>
|
||||
Alternatively, the <code xmlns=""><a href="#*default-template*">*default-template*</a></code>
|
||||
special variable can be set to define a custom default template
|
||||
for generating names.
|
||||
</p>
|
||||
|
||||
<h5 xmlns=""><a class="none" name="security">Security</a></h5>
|
||||
The TEMPORARY-FILE library does not directly address security
|
||||
issues. The application that uses it needs to take additional
|
||||
measures if it is important that files created by one process
|
||||
cannot be accessed by other, unrelated processes. This can be
|
||||
done by using the system dependent security mechanisms like
|
||||
default file permissions or access control lists.
|
||||
|
||||
<h5>Dictionary</h5>
|
||||
|
||||
|
||||
<p xmlns="">[Function]<br><a class="none" name="open-temporary"><b>open-temporary</b> <i><clix:lambda-list xmlns:clix="http://bknr.net/clixdoc"><tt>&rest</tt> open-arguments <tt>&key</tt> template generate-random-string max-tries <tt>&allow-other-keys</tt></clix:lambda-list></i>
|
||||
=>
|
||||
<i>stream</i></a><blockquote><clix:description xmlns:clix="http://bknr.net/clixdoc">
|
||||
<p xmlns="http://www.w3.org/1999/xhtml">
|
||||
Create a file with a randomly generated name and return the
|
||||
opened stream. The resulting pathname is generated from
|
||||
<code xmlns=""><i>template</i></code>, which is a string
|
||||
representing a pathname template. A percent sign (%) in
|
||||
that string is replaced by a randomly generated string to
|
||||
make the filename unique. The default for
|
||||
<code xmlns=""><i>template</i></code> places temporary files in the
|
||||
<code xmlns=""><a href="#temporary-files">temporary-files</a></code> logical pathname host,
|
||||
which is automatically set up in a system specific manner.
|
||||
The file name generated from <code xmlns=""><i>template</i></code>
|
||||
is merged with <a xmlns="" href="http://www.lispworks.com/documentation/HyperSpec/Body/v_defaul.htm">*default-pathname-defaults*</a>,
|
||||
so random pathnames relative to that directory can be
|
||||
generated by not specifying a directory in
|
||||
<code xmlns=""><i>template</i></code>.
|
||||
</p>
|
||||
<p xmlns="http://www.w3.org/1999/xhtml">
|
||||
<code xmlns=""><i>generate-random-string</i></code> can be passed to
|
||||
override the default function that generates the random name
|
||||
component. It should return a random string consisting of
|
||||
characters that are permitted in a pathname (logical or
|
||||
physical, depending on <code xmlns=""><i>template</i></code>).
|
||||
</p>
|
||||
<p xmlns="http://www.w3.org/1999/xhtml">
|
||||
The name of the temporary file can be accessed calling the
|
||||
<a xmlns="" href="http://www.lispworks.com/documentation/HyperSpec/Body/f_pn.htm">pathname</a>
|
||||
function on <code xmlns=""><i>stream</i></code>. For convenience,
|
||||
the temporary file is opened on the physical pathname,
|
||||
i.e. if the <code xmlns=""><i>template</i></code> designate a
|
||||
logical pathname the translation to a physical pathname is
|
||||
performed before opening the stream.
|
||||
</p>
|
||||
<p xmlns="http://www.w3.org/1999/xhtml">
|
||||
In order to create a unique file name,
|
||||
<code xmlns=""><a href="#open-temporary">open-temporary</a></code> may loop internally up
|
||||
to <code xmlns=""><i>max-tries</i></code> times before giving up and
|
||||
signalling a
|
||||
<code xmlns=""><a href="#cannot-create-temporary-file">cannot-create-temporary-file</a></code> condition.
|
||||
</p>
|
||||
<p xmlns="http://www.w3.org/1999/xhtml">
|
||||
Any unrecognized keyword arguments are passed to the call to
|
||||
<a xmlns="" href="http://www.lispworks.com/documentation/HyperSpec/Body/f_open.htm">open</a>.
|
||||
</p>
|
||||
</clix:description></blockquote></p>
|
||||
<p xmlns="">[Macro]<br><a class="none" name="with-output-to-temporary-file"><b>with-output-to-temporary-file</b> <i><clix:lambda-list xmlns:clix="http://bknr.net/clixdoc">(stream <tt>&rest</tt> args) <tt>&body</tt> body</clix:lambda-list></i>
|
||||
=>
|
||||
<i>pathname</i></a><blockquote><clix:description xmlns:clix="http://bknr.net/clixdoc">
|
||||
Create a temporary file using
|
||||
<code xmlns=""><a href="#open-temporary">open-temporary</a></code> with
|
||||
<code xmlns=""><i>args</i></code> and run <code xmlns=""><i>body</i></code>
|
||||
with <code xmlns=""><i>stream</i></code> bound to the temporary file
|
||||
stream. Returns the pathname of the file that has been
|
||||
created. See <code xmlns=""><a href="#open-temporary">open-temporary</a></code> for
|
||||
permitted options.
|
||||
</clix:description></blockquote></p>
|
||||
<p xmlns="">[Macro]<br><a class="none" name="with-open-temporary-file"><b>with-open-temporary-file</b> <i><clix:lambda-list xmlns:clix="http://bknr.net/clixdoc">(stream <tt>&rest</tt> args <tt>&key</tt> keep <tt>&allow-other-keys</tt>) <tt>&body</tt> body</clix:lambda-list></i>
|
||||
=>
|
||||
<i>values</i></a><blockquote><clix:description xmlns:clix="http://bknr.net/clixdoc">
|
||||
Create a temporary file using
|
||||
<code xmlns=""><a href="#open-temporary">open-temporary</a></code> with
|
||||
<code xmlns=""><i>args</i></code> and run <code xmlns=""><i>body</i></code>
|
||||
with <code xmlns=""><i>stream</i></code> bound to the temporary file
|
||||
stream. Returns the values returned by
|
||||
<code xmlns=""><i>body</i></code>. By default, the file is deleted
|
||||
when <code xmlns=""><i>body</i></code> is exited. If a true value is
|
||||
passed in <code xmlns=""><i>keep</i></code>, the file is not deleted
|
||||
when the body is exited. See
|
||||
<code xmlns=""><a href="#open-temporary">open-temporary</a></code> for more permitted
|
||||
options.
|
||||
</clix:description></blockquote></p>
|
||||
<p xmlns="">
|
||||
[Special variable]<br><a class="none" name="*default-template*"><b>*default-template*</b></a><blockquote><clix:description xmlns:clix="http://bknr.net/clixdoc">
|
||||
This variable can be set to a string representing the desired
|
||||
default template for temporary file name generation. See
|
||||
<code xmlns=""><a href="#open-temporary">open-temporary</a></code> for a description of the
|
||||
template string format.
|
||||
</clix:description></blockquote></p>
|
||||
<p xmlns="">
|
||||
[Condition type]<br><a class="none" name="cannot-create-temporary-file"><b>cannot-create-temporary-file</b></a><blockquote><clix:description xmlns:clix="http://bknr.net/clixdoc">
|
||||
Signalled when an attempt to create unique temporary file name
|
||||
failed after the established number of retries.
|
||||
</clix:description></blockquote></p>
|
||||
<p xmlns="">
|
||||
[Condition type]<br><a class="none" name="invalid-temporary-pathname-template"><b>invalid-temporary-pathname-template</b></a><blockquote><clix:description xmlns:clix="http://bknr.net/clixdoc">
|
||||
Signalled when the <code xmlns=""><i>template</i></code> argument to
|
||||
<code xmlns=""><a href="#open-temporary">open-temporary</a></code> does not contain a valid
|
||||
template string. The template string must contain a percent
|
||||
sign, which is replaced by the generated random string to
|
||||
yield the filename.
|
||||
</clix:description></blockquote></p>
|
||||
<p xmlns="">
|
||||
[Condition type]<br><a class="none" name="missing-temp-environment-variable"><b>missing-temp-environment-variable</b></a><blockquote><clix:description xmlns:clix="http://bknr.net/clixdoc">
|
||||
(Windows only) Signalled when the TEMP environment variable is
|
||||
not set.
|
||||
</clix:description></blockquote></p>
|
||||
<p xmlns="">
|
||||
[Logical Pathname Host]<br><a class="none" name="lp-host-temporary-files"><b>temporary-files</b></a><blockquote><clix:description xmlns:clix="http://bknr.net/clixdoc">
|
||||
This logical pathname host defines where temporary files are
|
||||
stored by default. It is initialized in a suitable system
|
||||
specific fashion: On Unix and Unix-like systems, the directory
|
||||
specified in the TMPDIR environment variable is used. If that
|
||||
variable is not set, /tmp is used as the default. On Windows,
|
||||
the directory specified in the TEMP environment variable is
|
||||
used. If it is not set, a
|
||||
<code xmlns=""><a href="#missing-temp-environment-variable">missing-temp-environment-variable</a></code> error
|
||||
is signalled.
|
||||
</clix:description></blockquote></p>
|
||||
|
||||
|
||||
<h4><a class=none name="modifying">Modifying the file system</a></h4>
|
||||
|
||||
<p><br>[Function]
|
||||
<br><a class=none name="copy-file"><b>copy-file</b> <i> from to <tt>&key</tt> overwrite</i> => |</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 designated 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>&optional</tt> checkp</i> => |</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>
|
||||
<p><br>[Function]
|
||||
<br><a class=none name="delete-directory-and-files"><b>delete-directory-and-files</b> <i> dirname <tt>&key</tt> if-does-not-exist</i> => |</a>
|
||||
|
||||
<blockquote><br>
|
||||
<p>
|
||||
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.
|
||||
</p>
|
||||
<p>
|
||||
<b>Warning:</b> this function <em>might</em> remove files from outside the
|
||||
directory, if the directory that you are deleting contains links to
|
||||
external files. This is currently fixed for SBCL and CCL.
|
||||
</p>
|
||||
</blockquote>
|
||||
|
||||
<h4>The <code>PATH</code> package</h4>
|
||||
|
||||
<p><br>[Package]
|
||||
<br><a class=none name="package-path">(defpackage <b>path</b>)</a>
|
||||
|
||||
<blockquote>
|
||||
Provides a set of short names for commonly used pathname manipulation
|
||||
functions (these are all functions from the <code>cl-fad</code>
|
||||
package which are being exported under different names):
|
||||
<dl>
|
||||
<dt><code>dirname</code></dt> <dd><a href="#pathname-as-directory">pathname-as-directory</a></dd>
|
||||
<dt><code>basename</code></dt> <dd><code>cl:file-namestring</code></dd>
|
||||
<dt><code>-e</code></dt> <dd><a href="#file-exists-p">file-exists-p</a></dd>
|
||||
<dt><code>-d</code></dt> <dd><a href="#directory-exists-p">directory-exists-p</a></dd>
|
||||
<dt><code>catfile</code></dt> <dd><a href="#merge-pathnames-as-file">merge-pathnames-as-file</a></dd>
|
||||
<dt><code>catdir</code></dt> <dd><a href="#merge-pathnames-as-directory">merge-pathnames-as-directory</a></dd>
|
||||
<dt><code>rm-r</code></dt> <dd><a href="#delete-directory-and-files">delete-directory-and-files</a></dd>
|
||||
<dt><code>=</code></dt> <dd><a href="#pathname-equal">pathname-equal</a></dd>
|
||||
<dt><code>absolute-p</code></dt> <dd><a href="#pathname-absolute-p">pathname-absolute-p</a></dd>
|
||||
<dt><code>relative-p</code></dt> <dd><a href="#pathname-relative-p">pathname-relative-p</a></dd>
|
||||
<dt><code>root-p</code></dt> <dd><a href="#pathname-root-p">pathname-root-p</a></dd>
|
||||
</dl>
|
||||
</blockquote>
|
||||
|
||||
|
||||
<br> <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 CL.
|
||||
|
||||
<p>
|
||||
$Header: /usr/local/cvsrep/cl-fad/doc/index.html,v 1.33 2009/09/30 14:23:12 edi Exp $
|
||||
<p><a href="http://weitz.de/index.html">BACK TO MY HOMEPAGE</a>
|
||||
|
||||
</body>
|
||||
</html>
|
||||
|
||||
|
|
@ -0,0 +1,570 @@
|
|||
;;; -*- 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 :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 &key (follow-symlinks t))
|
||||
"Returns a fresh list of pathnames corresponding to 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.
|
||||
|
||||
If FOLLOW-SYMLINKS is true, then the returned list contains
|
||||
truenames (symlinks will be resolved) which essentially means that it
|
||||
might also return files from *outside* the directory. This works on
|
||||
all platforms.
|
||||
|
||||
When FOLLOW-SYMLINKS is NIL, it should return the actual directory
|
||||
contents, which might include symlinks. Currently this works on SBCL
|
||||
and CCL."
|
||||
(declare (ignorable follow-symlinks))
|
||||
(when (wild-pathname-p dirname)
|
||||
(error "Can only list concrete directory names."))
|
||||
#+(or :ecl :clasp)
|
||||
(let ((dir (pathname-as-directory dirname)))
|
||||
(concatenate 'list
|
||||
(directory (merge-pathnames (pathname "*/") dir))
|
||||
(directory (merge-pathnames (pathname "*.*") dir))))
|
||||
#-(or :ecl :clasp)
|
||||
(let ((wildcard (directory-wildcard dirname)))
|
||||
#+:abcl (system::list-directory dirname)
|
||||
#+:sbcl (directory wildcard :resolve-symlinks follow-symlinks)
|
||||
#+(or :cmu :scl :lispworks) (directory wildcard)
|
||||
#+(or :openmcl :digitool) (directory wildcard :directories t :follow-links follow-symlinks)
|
||||
#+: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 :clasp)
|
||||
(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 clasp) (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)
|
||||
(truename directory-form))))
|
||||
(ignore-errors
|
||||
(probe-file (pathname-as-file pathspec))))
|
||||
#-(or :sbcl :cmu :scl :lispworks :openmcl :allegro :clisp :cormanlisp :ecl :abcl :digitool :clasp)
|
||||
(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))
|
||||
(follow-symlinks 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. If FOLLOW-SYMLINKS is T, then your
|
||||
callback will receive truenames. Otherwise you should get the actual
|
||||
directory contents, which might include symlinks. This might not be
|
||||
supported on all platforms. See LIST-DIRECTORY."
|
||||
(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 :follow-symlinks follow-symlinks))
|
||||
(walk file)))
|
||||
((eql directories :breadth-first)
|
||||
(when (funcall test name)
|
||||
(funcall fn name)
|
||||
(dolist (file (list-directory name :follow-symlinks follow-symlinks))
|
||||
(walk file))))
|
||||
;; :DEPTH-FIRST is implicit
|
||||
(t (dolist (file (list-directory name :follow-symlinks follow-symlinks))
|
||||
(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 #-:clisp (read-sequence buf from)
|
||||
#+:clisp (ext:read-byte-sequence buf from :no-hang 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 designated 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.
|
||||
|
||||
NOTE: this function is dangerous if the directory that you are
|
||||
removing contains symlinks to files outside of it - the target files
|
||||
might be removed instead! This is currently fixed for SBCL and CCL."
|
||||
|
||||
#+:allegro (excl.osi:delete-directory-and-files dirname
|
||||
:if-does-not-exist if-does-not-exist)
|
||||
|
||||
#+:sbcl
|
||||
(if (directory-exists-p dirname)
|
||||
(sb-ext:delete-directory dirname :recursive t)
|
||||
(ecase if-does-not-exist
|
||||
(:error (error "~S is not a directory" dirname))
|
||||
(:ignore nil)))
|
||||
|
||||
#+:ccl-has-delete-directory
|
||||
(if (directory-exists-p dirname)
|
||||
(ccl:delete-directory dirname)
|
||||
(ecase if-does-not-exist
|
||||
(:error (error "~S is not a directory" dirname))
|
||||
(:ignore nil)))
|
||||
|
||||
#-(or :allegro :sbcl :ccl-has-delete-directory)
|
||||
(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))))
|
||||
#+:clisp (ext:delete-directory file)
|
||||
#+:openmcl (cl-fad-ccl:delete-directory file)
|
||||
#+:cormanlisp (win32:delete-directory file)
|
||||
#+:ecl (si:rmdir file)
|
||||
#+:clasp (core:rmdir file)
|
||||
#+(or :abcl :digitool) (delete-file file))
|
||||
(t (delete-file file))))
|
||||
:follow-symlinks nil
|
||||
:directories t
|
||||
:if-does-not-exist if-does-not-exist)
|
||||
(values))
|
||||
|
||||
(defun pathname-directory-pathname (pathname)
|
||||
"Returns a complete pathname representing the directory of
|
||||
PATHNAME. If PATHNAME is already a directory pathname (name NIL, type
|
||||
NIL) returns a pathname equal (as per pathname=) to it."
|
||||
(make-pathname :defaults pathname
|
||||
:name nil :type nil))
|
||||
|
||||
(defun pathname-parent-directory (pathname)
|
||||
"Returns a pathname which would, by name at least, contain PATHNAME
|
||||
as one of its direct children. Symlinks can make the parent/child
|
||||
relationship a like opaque, but generally speaking the value returned
|
||||
by this function is a directory name which contains PATHNAME.
|
||||
|
||||
The root directory, #P\"/\", is its own parent. The parent directory
|
||||
of a filename is the parent of the filename's dirname."
|
||||
(canonical-pathname
|
||||
(make-pathname :defaults pathname
|
||||
:directory (if (pathname-root-p pathname)
|
||||
(list :absolute)
|
||||
(append (or (pathname-directory pathname)
|
||||
(list :relative))
|
||||
(list :back))))))
|
||||
|
||||
(defun canonical-pathname (pathname)
|
||||
"Remove redundant information from PATHNAME.
|
||||
|
||||
This simply walks down PATHNAME's pathname-directory and drops \".\"
|
||||
directories, removes :back and its preceding element.
|
||||
|
||||
NB: This function does not access the filesystem, it only looks at the
|
||||
values in the pathname and works on their known (or assumed)
|
||||
meanings.
|
||||
|
||||
NB: Since this function does not access the filesystem it will only
|
||||
remove :BACK elements from the path (not :UP elements). Since some
|
||||
lisps, ccl/sbcl/clisp convert \"..\" in pathnames to :UP, and
|
||||
not :BACK, the actual utility of the function is limited."
|
||||
(let ((pathname (pathname pathname))) ;; just make sure to get a pathname object
|
||||
(loop
|
||||
with full-dir = (or (pathname-directory pathname)
|
||||
(list :relative))
|
||||
with canon-dir = (if (member (first full-dir) '(:relative :absolute))
|
||||
(list (pop full-dir))
|
||||
(list :relative))
|
||||
while full-dir
|
||||
do (cond
|
||||
((string= "." (first full-dir))
|
||||
(pop full-dir))
|
||||
((eql :back (second full-dir))
|
||||
(pop full-dir)
|
||||
(pop full-dir))
|
||||
(t (push (pop full-dir) canon-dir)))
|
||||
finally (return (make-pathname :defaults pathname :directory (nreverse canon-dir))))))
|
||||
|
||||
(defun merge-pathnames-as-directory (&rest pathnames)
|
||||
"Given a list of (probably relative) pathnames, this returns a single
|
||||
directory pathname containing the logical concatenation of them all.
|
||||
|
||||
The returned value is the current directory if one were to cd into
|
||||
each of PATHNAMES in order. For this reason an absolute pathname will,
|
||||
effectively, cancel the affect of any previous relative pathnames.
|
||||
|
||||
The returned value's defaults are taken from the first element of
|
||||
PATHNAMES (host, version and device).
|
||||
|
||||
NB: Since this function only looks at directory names the name and
|
||||
type of the elements of PATHNAMES are ignored. Make sure to properly
|
||||
use either trailing #\\/s, or pathname-as-directory, to get the
|
||||
expected results.
|
||||
|
||||
Examples:
|
||||
|
||||
(merge-pathnames-as-directory #P\"foo/\" #P\"bar/\") == #P\"foo/bar/\"
|
||||
(merge-pathnames-as-directory #P\"foo/\" #P\"./bar/\") == #P\"foo/./bar/\"
|
||||
(merge-pathnames-as-directory #P\"foo/\" #P\"/bar/\") == #P\"/bar/\"
|
||||
(merge-pathnames-as-directory #P\"foo/\" #P\"/bar/\" #P\"quux/file.txt\") == #P\"/bar/quux/\"
|
||||
"
|
||||
(if pathnames
|
||||
(let* ((pathnames (mapcar #'pathname pathnames))
|
||||
(defaults (first pathnames))
|
||||
(dir (pathname-directory defaults)))
|
||||
(loop for pathname in (rest pathnames)
|
||||
for directory = (pathname-directory pathname)
|
||||
do (ecase (first directory)
|
||||
;; this is equivalent to (:relative) == ".", so,
|
||||
;; for this function, just do nothing.
|
||||
((nil))
|
||||
(:absolute
|
||||
(setf dir directory))
|
||||
(:relative
|
||||
(setf dir (append dir (rest directory))))))
|
||||
(make-pathname :defaults defaults :directory dir :name nil :type nil))
|
||||
(make-pathname)))
|
||||
|
||||
(defun merge-pathnames-as-file (&rest pathnames)
|
||||
"Given a list of, probably relative, pathnames returns a single
|
||||
filename pathname containing the logical concatenation of them all.
|
||||
|
||||
The returned value's defaults are taken from the first element of
|
||||
PATHNAMES (host, version and device). The returned values's name, type
|
||||
and version are taken from the last element of PATHNAMES. The
|
||||
intervening elements are used only for their pathname-directory
|
||||
values.
|
||||
|
||||
Examples:
|
||||
|
||||
(merge-pathnames-as-file #P\"foo/\" #P\"bar.txt\") == #P\"foo/bar.txt\"
|
||||
(merge-pathnames-as-file #P\"foo/\" #P\"./bar.txt\") == #P\"foo/./bar.txt\"
|
||||
(merge-pathnames-as-file #P\"foo/\" #P\"/bar/README\") == #P\"/bar/README\"
|
||||
(merge-pathnames-as-file #P\"/foo/\" #P\"/bar/\" #P\"quux/file.txt\") == #P\"/bar/quux/file.txt\"
|
||||
"
|
||||
(cond ((null pathnames)
|
||||
(make-pathname))
|
||||
((null (cdr pathnames))
|
||||
(pathname-as-file (first pathnames)))
|
||||
(t
|
||||
(let ((file-name-part (first (last pathnames))))
|
||||
(make-pathname :defaults (apply #'merge-pathnames-as-directory pathnames)
|
||||
:name (pathname-name file-name-part)
|
||||
:type (pathname-type file-name-part)
|
||||
:version (pathname-version file-name-part))))))
|
||||
|
||||
(defmacro with-component-testers ((a b key) &body body)
|
||||
(let ((k (gensym)))
|
||||
`(let* ((,k ,key)
|
||||
(,a (funcall ,k ,a))
|
||||
(,b (funcall ,k ,b)))
|
||||
(labels ((components-are (test)
|
||||
(and (funcall test ,a) (funcall test ,b)))
|
||||
(components-are-member (values)
|
||||
(and (member ,a values :test #'eql)
|
||||
(member ,b values :test #'eql)
|
||||
(eql ,a ,b)))
|
||||
(components-are-string= ()
|
||||
(and (stringp ,a) (stringp ,b) (string= ,a ,b)))
|
||||
(components-are-every (test)
|
||||
(and (consp ,a)
|
||||
(consp ,b)
|
||||
(every test ,a ,b))))
|
||||
(declare (ignorable #'components-are #'components-are-member
|
||||
#'components-are-string= #'components-are-every))
|
||||
(if (or ,@body)
|
||||
(values t ,a ,b)
|
||||
nil)))))
|
||||
|
||||
(defun pathname-host-equal (a b)
|
||||
(with-component-testers (a b #'pathname-host)
|
||||
(eq a b)
|
||||
(components-are-member '(nil :unspecific))
|
||||
(components-are-string=)
|
||||
(components-are-every #'string=)))
|
||||
|
||||
(defun pathname-device-equal (a b)
|
||||
(with-component-testers (a b #'pathname-device)
|
||||
(components-are-member '(nil :unspecific))
|
||||
(components-are-string=)))
|
||||
|
||||
(defun pathname-directory-equal (a b)
|
||||
(with-component-testers (a b #'pathname-directory)
|
||||
(and (null a) (null b))
|
||||
(and (= (length a) (length b))
|
||||
(every (lambda (a b)
|
||||
(or (and (stringp a) (stringp b) (string= a b))
|
||||
(and (null a) (null b))
|
||||
(and (keywordp a) (keywordp b) (eql a b))))
|
||||
a b))))
|
||||
|
||||
(defun pathname-name-equal (a b)
|
||||
(with-component-testers (a b #'pathname-name)
|
||||
(components-are-member '(nil :wild :unspecific))
|
||||
(components-are-string=)))
|
||||
|
||||
(defun pathname-type-equal (a b)
|
||||
(with-component-testers (a b #'pathname-type)
|
||||
(components-are-member '(nil :wild :unspecific))
|
||||
(components-are-string=)))
|
||||
|
||||
(defun pathname-version-equal (a b)
|
||||
(with-component-testers (a b #'pathname-version)
|
||||
(and (null a) (null b))
|
||||
(components-are-member '(:wild :newest :unspecific))
|
||||
(and (integerp a) (integerp b) (= a b))))
|
||||
|
||||
(defun pathname-equal (a b)
|
||||
"Returns T if A and B represent the same pathname. This function
|
||||
does not access the filesystem, it only looks at the components of the
|
||||
two pathnames to test if they are the same (though by
|
||||
passing both A and B to probe-file one can make this function test for file 'sameness'.
|
||||
|
||||
Equality is defined as:
|
||||
|
||||
- strings that are string equal
|
||||
- symbol (including nil) or keywords which are eql
|
||||
- lists of the same length with equal (as per these rules) elements.
|
||||
|
||||
if any of these tree conditions is false for any of the components in
|
||||
A and B then A and B are different, otherwise they are the same.
|
||||
|
||||
NB: This function does not convert name strings to pathnames. So
|
||||
\"foo.txt\" and #P\"foo.txt\" are different pathnames."
|
||||
(if (and a b)
|
||||
(if (and (pathname-host-equal a b)
|
||||
(pathname-device-equal a b)
|
||||
(pathname-directory-equal a b)
|
||||
(pathname-name-equal a b)
|
||||
(pathname-type-equal a b)
|
||||
(pathname-version-equal a b))
|
||||
(values t a b)
|
||||
(values nil))
|
||||
(values nil)))
|
||||
|
||||
(defun pathname-absolute-p (a)
|
||||
"Returns true if A is an absolute pathname.
|
||||
|
||||
This simply tests if A's directory list starts with :ABSOLUTE"
|
||||
(eql :absolute (first (pathname-directory (pathname a)))))
|
||||
|
||||
(defun pathname-relative-p (a)
|
||||
"Returns true if A is a relative pathname.
|
||||
|
||||
This simply tests if A's directory starts with :RELATIVE."
|
||||
(let ((dir (pathname-directory (pathname a))))
|
||||
(or (null dir) (eql :relative (first dir)))))
|
||||
|
||||
(defun pathname-root-p (a)
|
||||
(let ((dir (pathname-directory (pathname a))))
|
||||
(and (eql :absolute (first dir))
|
||||
(= 1 (length dir)))))
|
||||
|
||||
(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))))
|
||||
|
|
@ -0,0 +1,157 @@
|
|||
;;; -*- 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 #: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)
|
||||
|
||||
(assert* (path:= (path:catdir) #P""))
|
||||
(assert* (path:= (path:catdir #P"/") #P"/"))
|
||||
(assert* (path:= (path:catdir #P"a/" #P"b/") #P"a/b/"))
|
||||
(assert* (path:= (path:catdir #P"/a/" #P"/b/" #P"c/" #P"./d/" #P"e" #P"f/") #P"/b/c/./d/f/"))
|
||||
|
||||
(assert* (path:= (path:catfile) #P""))
|
||||
(assert* (path:= (path:catfile #P"R.txt") #P"R.txt"))
|
||||
(assert* (path:= (path:catfile #P"a/" #P"/b/" #P"R.txt") #P"/b/R.txt"))
|
||||
|
||||
|
||||
(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,0 +1,62 @@
|
|||
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
|
||||
;;; $Header: /usr/local/cvsrep/cl-fad/load.lisp,v 1.9 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)
|
||||
|
||||
(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)))))
|
||||
|
|
@ -0,0 +1,72 @@
|
|||
;;; -*- 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 :cl-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 :cl-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 :cl-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.
|
||||
;;;
|
||||
;;; Except this legacy definition is not recursive, hence this function is
|
||||
;;; used only if there is no :CCL-HAS-DELETE-DIRECTORY feature.
|
||||
|
||||
#-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))))))
|
||||
|
||||
|
|
@ -0,0 +1,87 @@
|
|||
;;; -*- 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 :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
|
||||
:pathname-directory-pathname
|
||||
:pathname-equal
|
||||
:pathname-parent-directory
|
||||
:pathname-absolute-p
|
||||
:pathname-relative-p
|
||||
:pathname-root-p
|
||||
|
||||
:canonical-pathname
|
||||
:merge-pathnames-as-directory
|
||||
:merge-pathnames-as-file
|
||||
|
||||
:walk-directory
|
||||
|
||||
:open-temporary
|
||||
:with-output-to-temporary-file
|
||||
:with-open-temporary-file
|
||||
:*default-template*
|
||||
:invalid-temporary-pathname-template
|
||||
:cannot-create-temporary-file
|
||||
#+win32 #:missing-temp-environment-variable))
|
||||
|
||||
(defpackage :path
|
||||
(:use)
|
||||
(:documentation "Rexporting certain functions from the cl-fad package with shorter names.
|
||||
|
||||
This package provides no functionality, it serves only to make file
|
||||
system intensive code easier to read (for unix people at least).")
|
||||
(:export #:dirname
|
||||
#:basename
|
||||
#:-e
|
||||
#:-d
|
||||
#:catfile
|
||||
#:catdir
|
||||
#:rm-r
|
||||
#:=
|
||||
|
||||
#:absolute-p
|
||||
#:relative-p
|
||||
#:root-p))
|
||||
|
|
@ -0,0 +1,5 @@
|
|||
(in-package :common-lisp-user)
|
||||
|
||||
(defpackage :cl-fad-test
|
||||
(:use :cl :cl-fad :unit-test)
|
||||
(:export :test))
|
||||
|
|
@ -0,0 +1,32 @@
|
|||
(in-package :cl-fad)
|
||||
|
||||
(defmacro defalias (name args realname)
|
||||
`(progn
|
||||
(defun ,name ,args
|
||||
,(if (eql '&rest (first args))
|
||||
`(apply #',realname ,(second args))
|
||||
`(,realname ,@args)))
|
||||
(define-compiler-macro ,name (&rest args)
|
||||
(list* ',realname args))))
|
||||
|
||||
(defalias path:dirname (pathname) cl-fad:pathname-directory-pathname)
|
||||
|
||||
(defun path:basename (pathname) (pathname (file-namestring pathname)))
|
||||
|
||||
(defalias path:-e (pathname) cl-fad:file-exists-p)
|
||||
|
||||
(defalias path:-d (directory) cl-fad:directory-exists-p)
|
||||
|
||||
(defalias path:catfile (&rest pathnames) cl-fad:merge-pathnames-as-file)
|
||||
|
||||
(defalias path:catdir (&rest pathnames) cl-fad:merge-pathnames-as-directory)
|
||||
|
||||
(defalias path:= (a b) cl-fad:pathname-equal)
|
||||
|
||||
(defalias path:absolute-p (pathname) cl-fad:pathname-absolute-p)
|
||||
|
||||
(defalias path:relative-p (pathname) cl-fad:pathname-relative-p)
|
||||
|
||||
(defalias path:root-p (pathname) cl-fad:pathname-root-p)
|
||||
|
||||
(defalias path:rm-r (pathname) cl-fad:delete-directory-and-files)
|
||||
|
|
@ -0,0 +1,173 @@
|
|||
(in-package :cl-fad)
|
||||
|
||||
(defparameter *default-template* "TEMPORARY-FILES:TEMP-%")
|
||||
|
||||
(defparameter *max-tries* 10000)
|
||||
|
||||
(defvar *name-random-state* (make-random-state t))
|
||||
|
||||
;; from XCVB
|
||||
(eval-when (:load-toplevel :execute)
|
||||
(defun getenv (x)
|
||||
"Query the libc runtime environment. See getenv(3)."
|
||||
(declare (ignorable x))
|
||||
#+(or abcl clisp xcl) (ext:getenv x)
|
||||
#+allegro (sys:getenv x)
|
||||
#+clozure (ccl:getenv x)
|
||||
#+(or cmu scl) (cdr (assoc x ext:*environment-list* :test #'string=))
|
||||
#+cormanlisp
|
||||
(let* ((buffer (ct:malloc 1))
|
||||
(cname (ct:lisp-string-to-c-string x))
|
||||
(needed-size (win:getenvironmentvariable cname buffer 0))
|
||||
(buffer1 (ct:malloc (1+ needed-size))))
|
||||
(prog1 (if (zerop (win:getenvironmentvariable cname buffer1 needed-size))
|
||||
nil
|
||||
(ct:c-string-to-lisp-string buffer1))
|
||||
(ct:free buffer)
|
||||
(ct:free buffer1)))
|
||||
#+ecl (si:getenv x)
|
||||
#+gcl (system:getenv x)
|
||||
#+lispworks (lispworks:environment-variable x)
|
||||
#+mcl (ccl:with-cstrs ((name x))
|
||||
(let ((value (_getenv name)))
|
||||
(unless (ccl:%null-ptr-p value)
|
||||
(ccl:%get-cstring value))))
|
||||
#+sbcl (sb-ext:posix-getenv x)
|
||||
#+clasp (ext:getenv x)
|
||||
#-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl lispworks mcl sbcl scl xcl clasp)
|
||||
(error "~S is not supported on your implementation" 'getenv))
|
||||
|
||||
(defun directory-from-environment (environment-variable-name)
|
||||
(let ((string (getenv environment-variable-name)))
|
||||
(when (plusp (length string))
|
||||
(pathname-as-directory string))))
|
||||
|
||||
#+win32
|
||||
(define-condition missing-temp-environment-variable (error)
|
||||
()
|
||||
(:report (lambda (condition stream)
|
||||
(declare (ignore condition))
|
||||
(format stream "the TEMP environment variable has not been found, cannot continue"))))
|
||||
|
||||
#+win32
|
||||
(defun get-default-temporary-directory ()
|
||||
(or (directory-from-environment "TEMP")
|
||||
(error 'missing-temp-environment-variable)))
|
||||
|
||||
#-win32
|
||||
(defun get-default-temporary-directory ()
|
||||
(or (directory-from-environment "TMPDIR")
|
||||
(and #-clisp (probe-file #P"/tmp/")
|
||||
#+clisp (ext:probe-directory #P"/tmp/")
|
||||
#P"/tmp/")))
|
||||
|
||||
(handler-case
|
||||
(logical-pathname-translations "TEMPORARY-FILES")
|
||||
(error ()
|
||||
(alexandria:if-let (default-temporary-directory (get-default-temporary-directory))
|
||||
(setf (logical-pathname-translations "TEMPORARY-FILES") `(("*.*.*" ,default-temporary-directory)))
|
||||
(warn "could not automatically determine a default mapping for TEMPORARY-FILES")))))
|
||||
|
||||
;; locking for multi-threaded operation with unsafe random function
|
||||
|
||||
(defvar *create-file-name-lock* (bordeaux-threads:make-lock "Temporary File Name Creation Lock"))
|
||||
|
||||
(defmacro with-file-name-lock-held (() &body body)
|
||||
`(bordeaux-threads:with-lock-held (*create-file-name-lock*)
|
||||
,@body))
|
||||
|
||||
(defun generate-random-string ()
|
||||
(with-file-name-lock-held ()
|
||||
(format nil "~:@(~36,8,'0R~)" (random (expt 36 8) *name-random-state*))))
|
||||
|
||||
(define-condition invalid-temporary-pathname-template (error)
|
||||
((string :initarg :string))
|
||||
(:report (lambda (condition stream)
|
||||
(with-slots (string) condition
|
||||
(format stream "invalid temporary file name template ~S, must contain a percent sign that is to be replaced by a random string" string)))))
|
||||
|
||||
(defun generate-random-pathname (template random-string-generator)
|
||||
(let ((percent-position (or (position #\% template)
|
||||
(error 'invalid-temporary-pathname-template :string template))))
|
||||
(merge-pathnames (concatenate 'string
|
||||
(subseq template 0 percent-position)
|
||||
(funcall random-string-generator)
|
||||
(subseq template (1+ percent-position))))))
|
||||
|
||||
(define-condition cannot-create-temporary-file (error)
|
||||
((template :initarg :template)
|
||||
(max-tries :initarg :max-tries))
|
||||
(:report (lambda (condition stream)
|
||||
(with-slots (template max-tries) condition
|
||||
(format stream "cannot create temporary file with template ~A, giving up after ~D attempt~:P"
|
||||
template max-tries)))))
|
||||
|
||||
(defun open-temporary (&rest open-arguments
|
||||
&key
|
||||
(template *default-template*)
|
||||
(generate-random-string 'generate-random-string)
|
||||
(max-tries *max-tries*)
|
||||
(direction :output)
|
||||
&allow-other-keys)
|
||||
"Create a file with a randomly generated name and return the opened
|
||||
stream. The resulting pathname is generated from TEMPLATE, which
|
||||
is a string representing a pathname template. A percent sign (%)
|
||||
in that string is replaced by a randomly generated string to make
|
||||
the filename unique. The default for TEMPLATE places temporary
|
||||
files in the TEMPORARY-FILES logical pathname host, which is
|
||||
automatically set up in a system specific manner. The file name
|
||||
generated from TEMPLATE is merged with *DEFAULT-PATHNAME-DEFAULTS*,
|
||||
so random pathnames relative to that directory can be generated by
|
||||
not specifying a directory in TEMPLATE.
|
||||
|
||||
GENERATE-RANDOM-STRING can be passed to override the default
|
||||
function that generates the random name component. It should
|
||||
return a random string consisting of characters that are permitted
|
||||
in a pathname (logical or physical, depending on TEMPLATE).
|
||||
|
||||
The name of the temporary file can be accessed calling the PATHNAME
|
||||
function on STREAM. For convenience, the temporary file is opened
|
||||
on the physical pathname, i.e. if the TEMPLATE designate a logical
|
||||
pathname the translation to a physical pathname is performed before
|
||||
opening the stream.
|
||||
|
||||
In order to create a unique file name, OPEN-TEMPORARY may loop
|
||||
internally up to MAX-TRIES times before giving up and signalling a
|
||||
CANNOT-CREATE-TEMPORARY-FILE condition."
|
||||
(loop thereis (apply #'open
|
||||
(translate-logical-pathname (generate-random-pathname template generate-random-string))
|
||||
:direction direction
|
||||
:if-exists nil
|
||||
(alexandria:remove-from-plist open-arguments :template :generate-random-string :max-tries))
|
||||
repeat max-tries
|
||||
finally (error 'cannot-create-temporary-file
|
||||
:template template
|
||||
:max-tries max-tries)))
|
||||
|
||||
(defmacro with-output-to-temporary-file ((stream &rest args) &body body)
|
||||
"Create a temporary file using OPEN-TEMPORARY with ARGS and run BODY
|
||||
with STREAM bound to the temporary file stream. Returns the
|
||||
pathname of the file that has been created. See OPEN-TEMPORARY for
|
||||
permitted options."
|
||||
`(with-open-stream (,stream (open-temporary ,@args))
|
||||
,@body
|
||||
(pathname ,stream)))
|
||||
|
||||
(defmacro with-open-temporary-file ((stream &rest args &key keep &allow-other-keys) &body body)
|
||||
"Create a temporary file using OPEN-TEMPORARY with ARGS and run BODY
|
||||
with STREAM bound to the temporary file stream. Returns the values
|
||||
returned by BODY. By default, the file is deleted when BODY is
|
||||
exited. If a true value is passed in KEEP, the file is not deleted
|
||||
when the body is exited. See OPEN-TEMPORARY for more permitted
|
||||
options."
|
||||
`(with-open-stream (,stream (open-temporary ,@(alexandria:remove-from-plist args :keep)))
|
||||
#+sbcl
|
||||
(declare (sb-ext:muffle-conditions sb-ext:code-deletion-note))
|
||||
,(if (and (constantp keep)
|
||||
keep)
|
||||
`(progn ,@body)
|
||||
`(unwind-protect
|
||||
(progn ,@body)
|
||||
(unless ,keep
|
||||
(close ,stream)
|
||||
(delete-file (pathname ,stream)))))))
|
||||
|
|
@ -0,0 +1,49 @@
|
|||
(in-package :cl-fad-test)
|
||||
|
||||
(deftest 'temporary-file 'with-output-to-temporary-file ()
|
||||
(let ((pathname (with-output-to-temporary-file (f)
|
||||
(write-string "hello" f))))
|
||||
(test-assert (probe-file pathname))
|
||||
(test-equal (alexandria:read-file-into-string pathname) "hello")
|
||||
(delete-file pathname)))
|
||||
|
||||
(deftest 'temporary-file 'with-open-temporary-file-keep ()
|
||||
|
||||
(let ((pathname (with-open-temporary-file (f :keep nil)
|
||||
(pathname f))))
|
||||
(test-assert (null (probe-file pathname))))
|
||||
(let ((pathname (with-open-temporary-file (f :keep t)
|
||||
(pathname f))))
|
||||
(test-assert (probe-file pathname))
|
||||
(delete-file pathname))
|
||||
|
||||
(let* ((keep nil)
|
||||
(pathname (with-open-temporary-file (f :keep keep)
|
||||
(pathname f))))
|
||||
(test-assert (null (probe-file pathname))))
|
||||
(let* ((keep t)
|
||||
(pathname (with-open-temporary-file (f :keep keep)
|
||||
(pathname f))))
|
||||
(test-assert (probe-file pathname))
|
||||
(delete-file pathname)))
|
||||
|
||||
(deftest 'temporary-file 'template-tests ()
|
||||
;; error is signalled when template does not contain a percent sign.
|
||||
(let ((*default-template* "foo"))
|
||||
(test-condition (with-open-temporary-file (f :keep nil))
|
||||
'invalid-temporary-pathname-template))
|
||||
;; file name template occurs in generated file name (for logical path name)
|
||||
(let* ((*default-template* "temporary-files:bla%.txt")
|
||||
(pathname (with-open-temporary-file (f :keep nil)
|
||||
(pathname f))))
|
||||
(test-assert (cl-ppcre:scan "(?i)bla.*\\.txt$" (namestring pathname))))
|
||||
;; file name template occurs in generated file name (for pysical path name)
|
||||
(let* ((*default-template* (concatenate 'string
|
||||
(namestring (translate-logical-pathname "temporary-files:"))
|
||||
"bla%.txt"))
|
||||
(pathname (with-open-temporary-file (f :keep nil)
|
||||
(pathname f))))
|
||||
(test-assert (cl-ppcre:scan "(?i)bla.*\\.txt$" (namestring pathname)))))
|
||||
|
||||
|
||||
|
||||
Loading…
Add table
Add a link
Reference in a new issue