cl-fad-0.7.4/0000755000004100000410000000000012740517010012675 5ustar www-datawww-datacl-fad-0.7.4/LICENSE0000644000004100000410000000260612740517010013706 0ustar www-datawww-data;;; 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. cl-fad-0.7.4/packages.lisp0000644000004100000410000000603212740517010015345 0ustar www-datawww-data;;; -*- 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)) cl-fad-0.7.4/cl-fad.asd0000644000004100000410000000430012740517010014511 0ustar www-datawww-data;;; -*- 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.4" :description "Portable pathname library" :serial t :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)) cl-fad-0.7.4/doc/0000755000004100000410000000000012740517010013442 5ustar www-datawww-datacl-fad-0.7.4/doc/index.html0000644000004100000410000011406512740517010015446 0ustar www-datawww-data CL-FAD - A portable pathname library for Common Lisp

CL-FAD - A portable pathname library for Common Lisp


 

Abstract

CL-FAD (for "Files and Directories") 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 Practical Common Lisp.

CL-FAD comes with a BSD-style license so you can basically do with it whatever you want.

Download shortcut: http://weitz.de/files/cl-fad.tar.gz.


 

Contents

  1. Download and installation
  2. Supported Lisp implementations
  3. The CL-FAD dictionary
    1. Querying files, directories and pathnames
      1. directory-exists-p [function]
      2. directory-pathname-p [function]
      3. file-exists-p [function]
      4. pathname-absolute-p [function]
      5. pathname-equal [function]
      6. pathname-relative-p [function]
      7. pathname-root-p [function]
    2. Manipulating pathnames
      1. canonical-pathname [function]
      2. merge-pathnames-as-directory [function]
      3. merge-pathnames-as-file [function]
      4. pathname-as-directory [function]
      5. pathname-as-file [function]
      6. pathname-directory-pathname [function]
      7. pathname-parent-directory [function]
    3. Traversing directories
      1. list-directory [function]
      2. walk-directory [function]
    4. Temporary Files
      1. open-temporary [function]
      2. with-output-to-temporary-file [macro]
      3. with-open-temporary-file [macro]
      4. *default-template* [variable]
      5. cannot-create-temporary-file [condition]
      6. invalid-temporary-pathname-template [condition]
      7. missing-temp-environment-variable [condition]
      8. temporary-files [logical pathname host]
    5. Modifying the file system
      1. copy-file [function]
      2. copy-stream [function]
      3. delete-directory-and-files [function]
    6. path [package]
  4. Acknowledgements

 

Download and installation

CL-FAD together with this documentation can be downloaded from http://weitz.de/files/cl-fad.tar.gz. The current version is 0.7.2.

CL-FAD comes with simple system definitions for MK:DEFSYSTEM and asdf 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 (mk:compile-system "cl-fad") - or (asdf:oos 'asdf:load-op :cl-fad) for asdf - which should compile and load the whole system. Installation via asdf-install should as well be possible. Plus, there are ports for Gentoo Linux thanks to Matthew Kennedy and for Debian Linux thanks to René van Bevern.

If for some reason you can't or don't want to use MK:DEFSYSTEM or asdf you can just LOAD the file load.lisp.

The latest version of the source code lives in the github repository edicl/cl-fad. If you want to send patches, please read this first. Please submit your changes as GitHub pull request".
 

Supported Lisp implementations

The following Common Lisp implementations are currently supported:

I'll gladly accepts patches to make CL-FAD work on other platforms.
 

The CL-FAD dictionary

Querying files, directories and pathnames


[Function]
directory-exists-p pathspec => generalized-boolean


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.


[Function]
directory-pathname-p pathspec => generalized-boolean


Returns NIL if pathspec (a pathname designator) does not designate a directory, pathspec otherwise. It is irrelevant whether the file or directory designated by pathspec does actually exist.


[Function]
file-exists-p pathspec => generalized-boolean


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 in directory form as if by PATHNAME-AS-DIRECTORY.


[Function]
pathname-absolute-p a => result

Returns true if a is an absolute pathname. This simply tests if a's directory list starts with :ABSOLUTE


[Function]
pathname-equal a b => result

Returns true 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:

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.


[Function]
pathname-relative-p a => result

Returns true if a is a relative pathname. This simply tests if a's directory starts with :RELATIVE.


[Function]
pathname-root-p a => result

Returns true if pathname is the root directory (in other words, a directory which is its own parent).

Manipulating pathnames


[Function]
canonical-pathname pathname => result

Remove reduntant 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.


[Function]
merge-pathnames-as-directory &rest pathnames => result

Given a list of, probably relative, pathnames 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/"


[Function]
merge-pathnames-as-file &rest pathnames => result

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"


[Function]
pathname-as-directory pathspec => pathname


Converts the non-wild pathname designator pathspec to directory form, i.e. it returns a pathname which would return a true value if fed to DIRECTORY-PATHNAME-P.


[Function]
pathname-as-file pathspec => pathname


Converts the non-wild pathname designator pathspec to file form, i.e. it returns a pathname which would return a NIL value if fed to DIRECTORY-PATHNAME-P.


[Function]
pathname-directory-pathname pathname => result

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-equal) to it.


[Function]
pathname-parent-directory pathname => result

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.

Traversing directories


[Function]
list-directory dirname &key follow-symlinks => list


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 (which is the default), 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. (This is currently implemented only on SBCL and CCL.)


[Function]
walk-directory dirname fn &key directories if-does-not-exist test follow-symlinks => |


Recursively applies the function designated by the function designator 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. (The default value for test always returns true.) 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 (the default) means that an error will be signaled if the directory dirname does not exist.

If follow-symlinks 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 LIST-DIRECTORY.

Temporary Files

Synopsis

Create a temporary file and return its name: 

CL-USER> (temporary-file:with-output-to-temporary-file (foo)
           (print "hello" foo))
#P"/var/folders/Yu/YuNMNBNPGoqs9G-1Wmj1dk+++TI/-Tmp-/temp-yjck024x"

Create a temporary file, read and write it, have it be deleted automatically: 

CL-USER> (temporary-file:with-open-temporary-file (foo :direction :io)
           (print "hello" foo)
           (file-position foo 0)
           (read foo))
"hello"

Default temporary file directory
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 /tmp/ is used by default. It can be overridden by setting the TMPDIR environment variable. On Windows, the value of the environment variable TEMP is used. If it is not set, temporary file creation will fail.
Defining the temporary file directory

The Lisp application can set the default directory in which temporary files are created by the way of the temporary-files logical pathname host: 

(setf (logical-pathname-translations "temporary-files") '(("*.*.*" "/var/tmp/")))
This would set the directory for temporary files to /var/tmp/. For more information about logical pathnames, please refer to Common Lisp the Language, 2nd Edition and the Common Lisp HyperSpec.

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.

Here are a few examples: 

CL-USER> (logical-pathname-translations "temporary-files")
(("*.*.*" #P"/var/folders/Yu/YuNMNBNPGoqs9G-1Wmj1dk+++TI/-Tmp-/"))
CL-USER> (temporary-file:with-open-temporary-file (foo)
           (pathname foo))
#P"/var/folders/Yu/YuNMNBNPGoqs9G-1Wmj1dk+++TI/-Tmp-/temp-6rdqdkd1"
This used the temporary directory established in the TMPDIR environment variable, by the way of the definition of the temporary-files logical host definition. 
CL-USER> (temporary-file:with-open-temporary-file (foo :template "/tmp/file.with.dots.in.name.%.txt")
           (pathname foo))
#P"/tmp/file.with.dots.in.name.2EF04KUJ.txt"
Here, a physical pathname was used for the :template keyword argument so that a filename containing multiple dots could be generated. 
CL-USER> (temporary-file:with-open-temporary-file (foo :template "temporary-files:blah-%.txt")
           (pathname foo))
#P"/var/folders/Yu/YuNMNBNPGoqs9G-1Wmj1dk+++TI/-Tmp-/blah-72mj450d.txt"
This used the temporary-files logical pathname host, but changed the filename slightly. 
CL-USER> *default-pathname-defaults*
#P"/Users/hans/"
CL-USER> (temporary-file:with-open-temporary-file (foo :template "blah-%.txt")
           (pathname foo))
#P"/Users/hans/blah-5OEJELG2.txt"
Here, a relative pathname was used in the template, which caused the file to be generated in the directory established by *default-pathname-defaults*.

Alternatively, the *default-template* special variable can be set to define a custom default template for generating names.

Security
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.
Dictionary

[Function]
open-temporary &rest open-arguments &key template generate-random-string max-tries &allow-other-keys => stream

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.

Any unrecognized keyword arguments are passed to the call to open.

[Macro]
with-output-to-temporary-file (stream &rest args) &body body => pathname

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.

[Macro]
with-open-temporary-file (stream &rest args &key keep &allow-other-keys) &body body => values

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.

[Special variable]
*default-template*

This variable can be set to a string representing the desired default template for temporary file name generation. See open-temporary for a description of the template string format.

[Condition type]
cannot-create-temporary-file

Signalled when an attempt to create unique temporary file name failed after the established number of retries.

[Condition type]
invalid-temporary-pathname-template

Signalled when the template argument to open-temporary 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.

[Condition type]
missing-temp-environment-variable

(Windows only) Signalled when the TEMP environment variable is not set.

[Logical Pathname Host]
temporary-files

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 missing-temp-environment-variable error is signalled.

Modifying the file system


[Function]
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 (the default is NIL) overwrites the file designtated by to if it exists.


[Function]
copy-stream from to &optional checkp => |


Copies into to (a stream) from from (also a stream) until the end of from is reached. The streams should have the same element type unless they are bivalent. If checkp is true (which is the default), the function will signal an error if the element types aren't the same.


[Function]
delete-directory-and-files dirname&key if-does-not-exist => |


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 (the default) means that an error will be signaled if the directory dirname does not exist.

Warning: this function might 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.

The PATH package


[Package]
(defpackage path)

Provides a set of short names for commonly used pathname manipulation functions (these are all functions from the cl-fad package which are being exported under different names):
dirname
pathname-as-directory
basename
cl:file-namestring
-e
file-exists-p
-d
directory-exists-p
catfile
merge-pathnames-as-file
catdir
merge-pathnames-as-directory
rm-r
delete-directory-and-files
=
pathname-equal
absolute-p
pathname-absolute-p
relative-p
pathname-relative-p
root-p
pathname-root-p

 

Acknowledgements

The original code for this library was written by Peter Seibel for his book Practical Common Lisp. 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.

$Header: /usr/local/cvsrep/cl-fad/doc/index.html,v 1.33 2009/09/30 14:23:12 edi Exp $

BACK TO MY HOMEPAGE cl-fad-0.7.4/README0000644000004100000410000000211112740517010013550 0ustar www-datawww-dataComplete documentation for CL-FAD can be found in the 'doc' directory. CL-FAD also supports Nikodemus Siivola's HYPERDOC, see and . 1. Installation 1.1. Probably the easiest way is (load "/path/to/cl-fad/load.lisp") This should compile and load CL-FAD on most Common Lisp implementations. 1.2. With MK:DEFSYSTEM you can make a symbolic link from 'cl-fad.system' and 'cl-fad-test.system' to your central registry (which by default is in '/usr/local/lisp/Registry/') and then issue the command (mk:compile-system "cl-fad") Note that this relies on TRUENAME returning the original file a symbolic link is pointing to. This will only work with AllegroCL 6.2 if you've applied all patches with (SYS:UPDATE-ALLEGRO). 1.3. You can also use ASDF instead of MK:DEFSYSTEM in a similar way (use the .asd files instead of the .system files). 2. Test CL-FAD comes with a small test suite. To start it just load the file "test.lisp" and evaluate (CL-FAD-TEST:TEST). cl-fad-0.7.4/packages.test.lisp0000644000004100000410000000015412740517010016322 0ustar www-datawww-data(in-package :common-lisp-user) (defpackage :cl-fad-test (:use :cl :cl-fad :unit-test) (:export :test)) cl-fad-0.7.4/load.lisp0000644000004100000410000000537612740517010014520 0ustar www-datawww-data;;; -*- 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))))) cl-fad-0.7.4/fad.lisp0000644000004100000410000006237712740517010014337 0ustar www-datawww-data;;; -*- 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.")) #+:ecl (let ((dir (pathname-as-directory dirname))) (concatenate 'list (directory (merge-pathnames (pathname "*/") dir)) (directory (merge-pathnames (pathname "*.*") dir)))) #-:ecl (let ((wildcard (directory-wildcard dirname))) #+:abcl (system::list-directory dirname) #+: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) (error "LIST-DIRECTORY not implemented")) (defun pathname-as-file (pathspec) "Converts the non-wild pathname designator PATHSPEC to file form." (let ((pathname (pathname pathspec))) (when (wild-pathname-p pathname) (error "Can't reliably convert wild pathnames.")) (cond ((directory-pathname-p pathspec) (let* ((directory (pathname-directory pathname)) (name-and-type (pathname (first (last directory))))) (make-pathname :directory (butlast directory) :name (pathname-name name-and-type) :type (pathname-type name-and-type) :defaults pathname))) (t pathname)))) (defun file-exists-p (pathspec) "Checks whether the file named by the pathname designator PATHSPEC exists and returns its truename if this is the case, NIL otherwise. The truename is returned in `canonical' form, i.e. the truename of a directory is returned as if by PATHNAME-AS-DIRECTORY." #+(or :sbcl :lispworks :openmcl :ecl :digitool) (probe-file pathspec) #+:allegro (or (excl:probe-directory (pathname-as-directory pathspec)) (probe-file pathspec)) #+(or :cmu :scl :abcl) (or (probe-file (pathname-as-directory pathspec)) (probe-file pathspec)) #+:cormanlisp (or (and (ccl:directory-p pathspec) (pathname-as-directory pathspec)) (probe-file pathspec)) #+:clisp (or (ignore-errors (let ((directory-form (pathname-as-directory pathspec))) (when (ext:probe-directory directory-form) directory-form))) (ignore-errors (probe-file (pathname-as-file pathspec)))) #-(or :sbcl :cmu :scl :lispworks :openmcl :allegro :clisp :cormanlisp :ecl :abcl :digitool) (error "FILE-EXISTS-P not implemented")) (defun directory-exists-p (pathspec) "Checks whether the file named by the pathname designator PATHSPEC exists and if it is a directory. Returns its truename if this is the case, NIL otherwise. The truename is returned in directory form as if by PATHNAME-AS-DIRECTORY." #+:allegro (and (excl:probe-directory pathspec) (pathname-as-directory (truename pathspec))) #+:lispworks (and (lw:file-directory-p pathspec) (pathname-as-directory (truename pathspec))) #-(or :allegro :lispworks) (let ((result (file-exists-p pathspec))) (and result (directory-pathname-p result) result))) (defun walk-directory (dirname fn &key directories (if-does-not-exist :error) (test (constantly t)) (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 designtated by TO if it exists." #+:allegro (excl.osi:copy-file from to :overwrite overwrite) #-:allegro (let ((element-type #-:cormanlisp '(unsigned-byte 8) #+:cormanlisp 'unsigned-byte)) (with-open-file (in from :element-type element-type) (with-open-file (out to :element-type element-type :direction :output :if-exists (if overwrite :supersede #-:cormanlisp :error #+:cormanlisp nil)) #+:cormanlisp (unless out (error (make-condition 'file-error :pathname to :format-control "File already exists."))) (copy-stream in out)))) (values)) (defun delete-directory-and-files (dirname &key (if-does-not-exist :error)) "Recursively deletes all files and directories within the directory designated by the non-wild pathname designator DIRNAME including DIRNAME itself. IF-DOES-NOT-EXIST must be one of :ERROR or :IGNORE where :ERROR means that an error will be signaled if the directory DIRNAME does not exist. 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 "~@" file (unix:get-unix-error-msg errno)))) #+:clisp (ext:delete-dir file) #+:openmcl (cl-fad-ccl:delete-directory file) #+:cormanlisp (win32:delete-directory file) #+:ecl (si: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 reduntant 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 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/\" " (when (null pathnames) (return-from merge-pathnames-as-directory (make-pathname :defaults *default-pathname-defaults* :directory nil :name nil :type nil))) (let* ((pathnames (mapcar #'pathname pathnames))) (loop with defaults = (first pathnames) with dir = (pathname-directory defaults) for pathname in (rest pathnames) for type = (first (pathname-directory pathname)) do (ecase type ((nil) ;; this is equivalent to (:relative) == ".", so, for this function, just do nothing. ) (:absolute (setf dir (pathname-directory pathname))) (:relative (setf dir (append dir (rest (pathname-directory pathname)))))) finally (return (make-pathname :defaults defaults :directory dir :name nil :type nil))))) (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\" " (case (length pathnames) (0 (when (null pathnames) (make-pathname :defaults *default-pathname-defaults* :directory nil :name nil :type nil))) (1 (pathname-as-file (first pathnames))) (t (let* ((defaults (pop pathnames)) (file-name-part (first (last pathnames))) (file-name-directory (make-pathname :defaults file-name-part :name nil :type nil)) (pathnames (butlast pathnames))) (make-pathname :defaults (apply #'merge-pathnames-as-directory (append (list defaults) pathnames (list file-name-directory))) :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)))) (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=) (and (consp a) (consp b) (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 ;; and ;; 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)))) cl-fad-0.7.4/corman.lisp0000644000004100000410000000643112740517010015051 0ustar www-datawww-data;;; -*- 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) cl-fad-0.7.4/openmcl.lisp0000644000004100000410000000551612740517010015232 0ustar www-datawww-data;;; -*- 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)))))) cl-fad-0.7.4/cl-fad.system0000644000004100000410000000417712740517010015302 0ustar www-datawww-data;;; -*- 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")))) cl-fad-0.7.4/path.lisp0000644000004100000410000000175612740517010014533 0ustar www-datawww-data(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) cl-fad-0.7.4/CHANGELOG0000644000004100000410000000471512740517010014116 0ustar www-datawww-dataVersion 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 cl-fad-0.7.4/temporary-files.lisp0000644000004100000410000001702112740517010016711 0ustar www-datawww-data(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) #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl lispworks mcl sbcl scl xcl) (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") #-clisp (probe-file #P"/tmp/") #+clisp (and (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))))))) cl-fad-0.7.4/temporary-files.test.lisp0000644000004100000410000000412412740517010017667 0ustar www-datawww-data(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))))) cl-fad-0.7.4/fad.test.lisp0000644000004100000410000001612612740517010015304 0ustar www-datawww-data;;; -*- 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.~%"))