Loose changes
This commit is contained in:
Ian Keane
parent
1cb167b597
commit
612c72bae1
57 changed files with 8904 additions and 80 deletions
BIN
sbcl/.quicklisp/dists/quicklisp/archives/cl-fad-20190813-git.tgz
Normal file
BIN
sbcl/.quicklisp/dists/quicklisp/archives/cl-fad-20190813-git.tgz
Normal file
Binary file not shown.
Binary file not shown.
BIN
sbcl/.quicklisp/dists/quicklisp/archives/quickproject-1.4.1.tgz
Normal file
BIN
sbcl/.quicklisp/dists/quicklisp/archives/quickproject-1.4.1.tgz
Normal file
Binary file not shown.
|
|
@ -0,0 +1 @@
|
|||
dists/quicklisp/software/cl-fad-20190813-git/
|
||||
|
|
@ -0,0 +1 @@
|
|||
dists/quicklisp/software/html-template-20171227-git/
|
||||
|
|
@ -0,0 +1 @@
|
|||
dists/quicklisp/software/quickproject-1.4.1/
|
||||
|
|
@ -0,0 +1 @@
|
|||
dists/quicklisp/software/cl-fad-20190813-git/cl-fad.asd
|
||||
|
|
@ -0,0 +1 @@
|
|||
dists/quicklisp/software/html-template-20171227-git/html-template.asd
|
||||
|
|
@ -0,0 +1 @@
|
|||
dists/quicklisp/software/quickproject-1.4.1/quickproject.asd
|
||||
|
|
@ -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)))))
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,71 @@
|
|||
Version 0.9.2
|
||||
2015-05-21
|
||||
Fixed bug in READ-UNTIL (thanks to Michael Malis)
|
||||
Fixed typo in documentation (thanks to Atif Haider)
|
||||
|
||||
Version 0.9.1
|
||||
2007-11-16
|
||||
Fixed bug in SKIP-LEADING-WHITESPACE (thanks to Chaitanya Gupta)
|
||||
|
||||
Version 0.9.0
|
||||
2007-03-09
|
||||
Hand down external format to included files (suggested by Igor Plekhov)
|
||||
|
||||
Version 0.8.0
|
||||
2006-12-12
|
||||
Added TMPL_CALL (thanks to Marijn Haverbeke)
|
||||
|
||||
Version 0.7.0
|
||||
2006-09-30
|
||||
Added TMPL_REPEAT
|
||||
|
||||
Version 0.6.0
|
||||
2006-09-14
|
||||
Changed default for *VALUE-ACCESS-FUNCTION*
|
||||
Added *STRING-MODIFIER*
|
||||
Added ESCAPE-xxx functions (from CL-WHO)
|
||||
Fixed docs for hyperdoc support
|
||||
General documentation enhancements
|
||||
Fixed test.lisp w.r.t. *FORMAT-NON-STRINGS*
|
||||
|
||||
Version 0.5.0
|
||||
2006-09-08
|
||||
Added *FORMAT-NON-STRINGS*
|
||||
|
||||
Version 0.4.0
|
||||
2006-04-03
|
||||
Added TMPL_UNLESS (requested by Igor Plekhov)
|
||||
|
||||
Version 0.3.1
|
||||
2005-08-05
|
||||
Introduced *FORCE-DEFAULT*
|
||||
|
||||
Version 0.3.0
|
||||
2005-07-03
|
||||
Introduced *TEMPLATE-OUTPUT* so template printers don't interfer with *STANDARD-OUTPUT* (proposed by Norman Werner)
|
||||
Small enhancements to docs
|
||||
|
||||
Version 0.2.0
|
||||
2005-06-09
|
||||
Added :DO-NOT-CACHE option to CREATE-TEMPLATE-PRINTER
|
||||
Added clever DEFMETHOD trick by Peter Seibel
|
||||
Fixed bug in READ-UNTIL which doesn't affect HTML-TEMPLATE
|
||||
Better example in docs inspired by Bruce R. Lewis' critique on lisp-web
|
||||
Mention asdf-install in docs
|
||||
Added hyperdoc support
|
||||
Added :HTML-TEMPLATE to *FEATURES*
|
||||
|
||||
Version 0.1.2
|
||||
2003-07-15
|
||||
Argh, typo in index.html... :(
|
||||
|
||||
Version 0.1.1
|
||||
2003-07-15
|
||||
Cleaner use of restarts thanks to James Anderson and Kent M. Pitman
|
||||
Updated docs accordingly (removed stuff about OTHER-VALUE)
|
||||
Removed ECL specific stuff (no longer necessary due to recent ECL fixes by Juan Jose Garcia Ripoll)
|
||||
Corrected date of 0.1.0 release in CHANGELOG (don't laugh!)
|
||||
|
||||
Version 0.1.0
|
||||
2003-07-15
|
||||
Initial release
|
||||
|
|
@ -0,0 +1,33 @@
|
|||
Installation of HTML-TEMPLATE
|
||||
|
||||
1. Probably the easiest way is
|
||||
|
||||
(load "/path/to/html-template/load.lisp")
|
||||
|
||||
This should compile and load HTML-TEMPLATE on most Common Lisp
|
||||
implementations.
|
||||
|
||||
2. With MK:DEFSYSTEM you can make a symlink from 'html-template.system'
|
||||
to your central registry and then issue the command
|
||||
|
||||
(mk:compile-system "html-template")
|
||||
|
||||
Note that this relies on TRUENAME returning the original file a
|
||||
symbolic link is pointing to. With AllegroCL 6.2 this will only
|
||||
work if you've applied all patches with (SYS:UPDATE-ALLEGRO).
|
||||
|
||||
3. You can also use ASDF instead of MK:DEFSYSTEM in a similar way:
|
||||
|
||||
(asdf:operate 'asdf:compile-op :html-template)
|
||||
(asdf:operate 'asdf:load-op :html-template)
|
||||
|
||||
After installing HTML-TEMPLATE you can LOAD the file "test.lisp" to
|
||||
check if everything works as expected.
|
||||
|
||||
Complete documentation for HTML-TEMPLATE can be found in the 'doc'
|
||||
directory.
|
||||
|
||||
HTML-TEMPLATE also supports Nikodemus Siivola's HYPERDOC, see
|
||||
<http://common-lisp.net/project/hyperdoc/> and
|
||||
<http://www.cliki.net/hyperdoc>.
|
||||
|
||||
|
|
@ -0,0 +1,21 @@
|
|||
---------------------------------------------------
|
||||
HTML-TEMPLATE - Use HTML templates from Common Lisp
|
||||
---------------------------------------------------
|
||||
|
||||
HTML-TEMPLATE is a portable library for Common Lisp which can be used
|
||||
to fill templates with arbitrary (string) values at runtime.
|
||||
(Actually, it doesn't matter whether the result is HTML. It's just
|
||||
very likely that this will be what the library is mostly used for.)
|
||||
|
||||
It is loosely modeled after the Perl module HTML::Template and
|
||||
partially compatible with a its syntax, though both libraries contain
|
||||
some extensions that the other does not support.
|
||||
|
||||
HTML-TEMPLATE translates templates into efficient closures which can
|
||||
be re-used as often as needed. It uses an intelligent cache mechanism
|
||||
so you can nevertheless update templates while your program is running
|
||||
and have the changes take effect immediately.
|
||||
|
||||
Complete documentation for HTML-TEMPLATE can be found in the `docs`
|
||||
directory or at the [project documentation
|
||||
site](https://edicl.github.io/html-template/).
|
||||
|
|
@ -0,0 +1,160 @@
|
|||
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HTML-TEMPLATE; Base: 10 -*-
|
||||
;;; $Header: /usr/local/cvsrep/html-template/api.lisp,v 1.22 2007-03-09 13:09:16 edi Exp $
|
||||
|
||||
;;; Copyright (c) 2003-2007, 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 #:html-template)
|
||||
|
||||
(defgeneric create-template-printer (template
|
||||
&key force
|
||||
element-type
|
||||
if-does-not-exist
|
||||
external-format)
|
||||
(:documentation "Creates a template printer from TEMPLATE which is
|
||||
an open input stream, a string, or a pathname. If FORCE is true a
|
||||
printer will be newly created no matter what the state of the cache
|
||||
is. If FORCE is :DO-NOT-CACHE the newly created printer won't be
|
||||
cached. Other keyword arguments will be given to WITH-OPEN-FILE.
|
||||
Keyword arguments will only be accepted if TEMPLATE is a PATHNAME."))
|
||||
|
||||
(defmethod create-template-printer ((input-stream stream) &rest rest)
|
||||
(when rest
|
||||
(signal-template-invocation-error
|
||||
"This method doesn't accept keyword arguments"))
|
||||
(let ((*standard-input* input-stream))
|
||||
(%create-template-printer-aux nil nil)))
|
||||
|
||||
(defmethod create-template-printer ((string string) &rest rest)
|
||||
(when rest
|
||||
(signal-template-invocation-error
|
||||
"This method doesn't accept keyword arguments"))
|
||||
(with-input-from-string (*standard-input* string)
|
||||
(%create-template-printer-aux nil nil)))
|
||||
|
||||
(defmethod create-template-printer ((pathname pathname)
|
||||
&key (force *force-default*)
|
||||
(element-type #-:lispworks 'character
|
||||
#+:lispworks 'lw:simple-char)
|
||||
(if-does-not-exist :error)
|
||||
(external-format *external-format*))
|
||||
(let* ((merged-pathname (merge-pathnames pathname
|
||||
*default-template-pathname*))
|
||||
(file-write-date (or *no-cache-check*
|
||||
(file-write-date merged-pathname))))
|
||||
(destructuring-bind (hashed-printer . creation-date)
|
||||
;; see if a printer for this pathname is in the cache
|
||||
(or (gethash merged-pathname *printer-hash*)
|
||||
'(nil . nil))
|
||||
(when (and hashed-printer
|
||||
;; and if we may use it
|
||||
(not force)
|
||||
;; and if it's not too old (or maybe we don't have to
|
||||
;; check)
|
||||
(or *no-cache-check*
|
||||
(and file-write-date
|
||||
(<= file-write-date creation-date))))
|
||||
(return-from create-template-printer hashed-printer))
|
||||
(let ((new-printer
|
||||
;; push this pathname onto stack of included files (so
|
||||
;; to say) to make sure a file can't include itself
|
||||
;; recursively
|
||||
(let ((*included-files* (cons merged-pathname
|
||||
*included-files*))
|
||||
(*external-format* external-format))
|
||||
(with-open-file (*standard-input* merged-pathname
|
||||
:direction :input
|
||||
:if-does-not-exist if-does-not-exist
|
||||
:element-type element-type
|
||||
:external-format external-format)
|
||||
(%create-template-printer-aux nil nil)))))
|
||||
;; cache newly created printer (together with current time)
|
||||
(unless (eq force :do-not-cache)
|
||||
(setf (gethash merged-pathname *printer-hash*)
|
||||
(cons new-printer (get-universal-time))))
|
||||
;; optionally issue a warning
|
||||
(when *warn-on-creation*
|
||||
(warn "New template printer for ~S created" merged-pathname))
|
||||
new-printer))))
|
||||
|
||||
(defgeneric fill-and-print-template (template/printer values
|
||||
&key stream
|
||||
&allow-other-keys)
|
||||
(:documentation "Fills the template denoted by TEMPLATE/PRINTER with
|
||||
VALUES and print it to STREAM. If TEMPLATE/PRINTER is a function uses
|
||||
it as if it were a template printer, otherwise creates a printer \(or
|
||||
pull one out of the cache) with CREATE-TEMPLATE-PRINTER. Optional
|
||||
keyword arguments are given to CREATE-TEMPLATE printer and can only be
|
||||
used if TEMPLATE/PRINTER is a pathname."))
|
||||
|
||||
(defmethod fill-and-print-template ((function function) values
|
||||
&rest rest
|
||||
&key (stream *default-template-output*))
|
||||
(remf rest :stream)
|
||||
(when rest
|
||||
(signal-template-invocation-error
|
||||
"This method doesn't accept keyword arguments other than STREAM"))
|
||||
(let ((*template-output* stream))
|
||||
(funcall function values)))
|
||||
|
||||
(defmethod fill-and-print-template ((string string) values
|
||||
&rest rest
|
||||
&key (stream *default-template-output*))
|
||||
(remf rest :stream)
|
||||
(when rest
|
||||
(signal-template-invocation-error
|
||||
"This method doesn't accept keyword arguments other than STREAM"))
|
||||
(let ((*template-output* stream))
|
||||
(funcall (create-template-printer string) values)))
|
||||
|
||||
(defmethod fill-and-print-template ((input-stream stream) values
|
||||
&rest rest
|
||||
&key (stream *default-template-output*))
|
||||
(remf rest :stream)
|
||||
(when rest
|
||||
(signal-template-invocation-error
|
||||
"This method doesn't accept keyword arguments other than STREAM"))
|
||||
(let ((*template-output* stream))
|
||||
(funcall (create-template-printer input-stream) values)))
|
||||
|
||||
(defmethod fill-and-print-template ((pathname pathname) values
|
||||
&rest rest
|
||||
&key (stream *default-template-output*))
|
||||
(remf rest :stream)
|
||||
(let ((*template-output* stream))
|
||||
(funcall (apply #'create-template-printer pathname rest) values)))
|
||||
|
||||
(defun clear-template-cache ()
|
||||
"Complete clears all template printers from the cache."
|
||||
(clrhash *printer-hash*)
|
||||
(values))
|
||||
|
||||
(defun delete-from-template-cache (pathname)
|
||||
"Deletes the template printer denoted by PATHNAME from the
|
||||
cache. Returns true if such a printer existed, false otherwise."
|
||||
(remhash (merge-pathnames pathname
|
||||
*default-template-pathname*)
|
||||
*printer-hash*))
|
||||
File diff suppressed because it is too large
Load diff
|
|
@ -0,0 +1,106 @@
|
|||
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HTML-TEMPLATE-LISP; Base: 10 -*-
|
||||
;;; $Header: /usr/local/cvsrep/html-template/errors.lisp,v 1.8 2007-01-01 23:49:16 edi Exp $
|
||||
|
||||
;;; Copyright (c) 2003-2007, 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 #:html-template)
|
||||
|
||||
(defstruct syntax-error-location
|
||||
"Structure to store parser locations consisting of a stream, a line
|
||||
number, and a column number."
|
||||
line col stream)
|
||||
|
||||
(defvar *syntax-error-location* (make-syntax-error-location)
|
||||
"Used internally to remember the last position which made sense to
|
||||
the parser.")
|
||||
|
||||
(define-condition template-error (simple-error)
|
||||
()
|
||||
(:documentation "All errors signaled by HTML-TEMPLATE are of
|
||||
this type."))
|
||||
|
||||
(define-condition template-invocation-error (template-error)
|
||||
()
|
||||
(:documentation "Signaled when HTML-TEMPLATE functions are
|
||||
invoked with wrong arguments."))
|
||||
|
||||
(define-condition template-missing-value-error (template-error)
|
||||
()
|
||||
(:documentation "Signaled when a TMPL_VAR printer is provided
|
||||
with a NIL value and *CONVERT-NIL-TO-EMPTY-STRING* is false."))
|
||||
|
||||
(define-condition template-not-a-string-error (template-error)
|
||||
((value :initarg :value
|
||||
:reader template-not-a-string-error-value))
|
||||
(:documentation "Signaled when a TMPL_VAR printer is provided
|
||||
with a non-string value."))
|
||||
|
||||
(define-condition template-syntax-error (template-error)
|
||||
((line :initarg :line
|
||||
:reader template-syntax-error-line)
|
||||
(col :initarg :col
|
||||
:reader template-syntax-error-col)
|
||||
(stream :initarg :stream
|
||||
:reader template-syntax-error-stream))
|
||||
(:default-initargs
|
||||
:line (syntax-error-location-line *syntax-error-location*)
|
||||
:col (syntax-error-location-col *syntax-error-location*)
|
||||
:stream (syntax-error-location-stream *syntax-error-location*))
|
||||
(:report (lambda (condition stream)
|
||||
(format stream "~?~%[Line ~A, column ~A, stream ~A]"
|
||||
(simple-condition-format-control condition)
|
||||
(simple-condition-format-arguments condition)
|
||||
(template-syntax-error-line condition)
|
||||
(template-syntax-error-col condition)
|
||||
(template-syntax-error-stream condition))))
|
||||
(:documentation "Signaled when a syntax error occurs while
|
||||
parsing a template."))
|
||||
|
||||
(defmacro signal-template-invocation-error (format-control &rest format-arguments)
|
||||
`(error 'template-invocation-error
|
||||
:format-control ,format-control
|
||||
:format-arguments (list ,@format-arguments)))
|
||||
|
||||
(defmacro signal-template-missing-value-error (format-control &rest format-arguments)
|
||||
`(error 'template-missing-value-error
|
||||
:format-control ,format-control
|
||||
:format-arguments (list ,@format-arguments)))
|
||||
|
||||
(defmacro signal-template-syntax-error (format-control &rest format-arguments)
|
||||
`(error 'template-syntax-error
|
||||
:format-control ,format-control
|
||||
:format-arguments (list ,@format-arguments)))
|
||||
|
||||
(defmacro with-syntax-error-location ((&rest rest) &body body)
|
||||
"This is wrapped around forms in order to remember a meaningful
|
||||
position within the stream in case an error has to be signaled."
|
||||
(declare (ignore rest))
|
||||
`(let ((*syntax-error-location* (make-syntax-error-location
|
||||
:line *current-line*
|
||||
:col *current-column*
|
||||
:stream *standard-input*)))
|
||||
,@body))
|
||||
|
|
@ -0,0 +1,38 @@
|
|||
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
|
||||
;;; $Header: /usr/local/cvsrep/html-template/html-template.asd,v 1.16 2015-05-21 20:59:59 edi Exp $
|
||||
|
||||
;;; Copyright (c) 2003-2007, 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.
|
||||
|
||||
(asdf:defsystem :html-template
|
||||
:version "0.9.2"
|
||||
:serial t
|
||||
:components ((:file "packages")
|
||||
(:file "specials")
|
||||
(:file "errors")
|
||||
(:file "util")
|
||||
(:file "template")
|
||||
(:file "api")))
|
||||
|
|
@ -0,0 +1,44 @@
|
|||
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
|
||||
;;; $Header: /usr/local/cvsrep/html-template/html-template.system,v 1.5 2007-01-01 23:49:16 edi Exp $
|
||||
|
||||
;;; Copyright (c) 2003-2007, 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 *html-template-base-directory*
|
||||
(make-pathname :name nil :type nil :version nil
|
||||
:defaults (parse-namestring *load-truename*)))
|
||||
|
||||
(mk:defsystem #:html-template
|
||||
:source-pathname *html-template-base-directory*
|
||||
:source-extension "lisp"
|
||||
:components ((:file "packages")
|
||||
(:file "specials" :depends-on ("packages"))
|
||||
(:file "errors" :depends-on ("specials"))
|
||||
(:file "util" :depends-on ("errors"))
|
||||
(:file "template" :depends-on ("util"))
|
||||
(:file "api" :depends-on ("template"))))
|
||||
|
|
@ -0,0 +1,54 @@
|
|||
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
|
||||
;;; $Header: /usr/local/cvsrep/html-template/load.lisp,v 1.7 2007-01-01 23:49:16 edi Exp $
|
||||
|
||||
;;; Copyright (c) 2003-2007, 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)
|
||||
|
||||
(let ((html-template-base-directory
|
||||
(make-pathname :name nil :type nil :version nil
|
||||
:defaults (parse-namestring *load-truename*)))
|
||||
must-compile)
|
||||
(with-compilation-unit ()
|
||||
(loop for file in '("packages"
|
||||
"specials"
|
||||
"errors"
|
||||
"util"
|
||||
"template"
|
||||
"api")
|
||||
do (let ((pathname (make-pathname :name file :type "lisp" :version nil
|
||||
:defaults html-template-base-directory)))
|
||||
#-: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: CL-USER; Base: 10 -*-
|
||||
;;; $Header: /usr/local/cvsrep/html-template/packages.lisp,v 1.19 2007-01-01 23:49:16 edi Exp $
|
||||
|
||||
;;; Copyright (c) 2003-2007, 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 :html-template
|
||||
(:nicknames :template)
|
||||
(:use :cl)
|
||||
(:export :*call-template-access-function*
|
||||
:*call-values-access-function*
|
||||
:*convert-nil-to-empty-string*
|
||||
:*default-template-output*
|
||||
:*default-template-pathname*
|
||||
:*escape-char-p*
|
||||
:*force-default*
|
||||
:*format-non-strings*
|
||||
:*ignore-empty-lines*
|
||||
:*no-cache-check*
|
||||
:*sequences-are-lists*
|
||||
:*string-modifier*
|
||||
:*template-end-marker*
|
||||
:*template-start-marker*
|
||||
:*template-symbol-package*
|
||||
:*upcase-attribute-strings*
|
||||
:*value-access-function*
|
||||
:*warn-on-creation*
|
||||
:clear-template-cache
|
||||
:create-template-printer
|
||||
:delete-from-template-cache
|
||||
:escape-string
|
||||
:escape-string-all
|
||||
:escape-string-iso-8859-1
|
||||
:escape-string-minimal
|
||||
:escape-string-minimal-plus-quotes
|
||||
:fill-and-print-template
|
||||
:template-error
|
||||
:template-invocation-error
|
||||
:template-missing-value-error
|
||||
:template-not-a-string-error
|
||||
:template-not-a-string-error-value
|
||||
:template-syntax-error
|
||||
:template-syntax-error-col
|
||||
:template-syntax-error-line
|
||||
:template-syntax-error-stream))
|
||||
|
||||
(pushnew :html-template *features*)
|
||||
|
|
@ -0,0 +1,151 @@
|
|||
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HTML-TEMPLATE; Base: 10 -*-
|
||||
;;; $Header: /usr/local/cvsrep/html-template/specials.lisp,v 1.24 2007-03-09 13:09:16 edi Exp $
|
||||
|
||||
;;; Copyright (c) 2003-2007, 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 #:html-template)
|
||||
|
||||
(defvar *find-string-hash* (make-hash-table :test #'equal)
|
||||
"Hash tables used internally by READ-UNTIL to cache offset arrays.")
|
||||
|
||||
(defvar *template-start-marker* "<!--"
|
||||
"The string template tags must start with")
|
||||
(defvar *template-end-marker* "-->"
|
||||
"The string template tags must end with")
|
||||
|
||||
(defvar *printer-hash* (make-hash-table :test #'equal)
|
||||
"The cache for template printers.
|
||||
Each entry is of the form (PRINTER . WRITE-DATE).")
|
||||
|
||||
(defvar *default-template-pathname* (make-pathname)
|
||||
"Each pathname is merged with this value before it is used by
|
||||
CREATE-TEMPLATE-PRINTER.")
|
||||
|
||||
(defvar *default-template-output* *standard-output*
|
||||
"The output stream used by FILL-AND-PRINT-TEMPLATE when no STREAM
|
||||
keyword was provided.")
|
||||
|
||||
(defvar *template-output* nil
|
||||
"The output stream that's used internally.")
|
||||
|
||||
(defvar *convert-nil-to-empty-string* t
|
||||
"Controls whether NIL values should resolve to empty strings or
|
||||
raise an error.")
|
||||
|
||||
(defvar *format-non-strings* t
|
||||
"Controls whether TMPL_VAR will accept values which aren't
|
||||
strings and convert them using \(FORMAT NIL \"~A\" ...).")
|
||||
|
||||
(defvar *sequences-are-lists* t
|
||||
"Controls whether TMPL_LOOP printers expect lists or vectors.")
|
||||
|
||||
(defvar *upcase-attribute-strings* t
|
||||
"Controls whether attribute strings associated with template tags
|
||||
are upcased before they are interned.")
|
||||
|
||||
(defvar *no-cache-check* nil
|
||||
"Controls whether the FILE-WRITE-DATE check will be circumvented
|
||||
when using FILL-AND-PRINT-TEMPLATE.")
|
||||
|
||||
(defvar *template-symbol-package* (find-package '#:keyword)
|
||||
"The package symbols are interned into.")
|
||||
|
||||
(defvar *ignore-empty-lines* nil
|
||||
"Controls whether template tags on their own lines produce empty
|
||||
lines or not.")
|
||||
|
||||
(defvar *warn-on-creation* t
|
||||
"Controls whether a warning should be signaled if a new template
|
||||
printer is created from a pathname argument.")
|
||||
|
||||
(defvar *current-line* 1
|
||||
"Internal line counter of the parser.")
|
||||
(defvar *current-column* 0
|
||||
"Internal column counter of the parser.")
|
||||
|
||||
(defvar *included-files* nil
|
||||
"Internally used by CREATE-TEMPLATE-PRINTER-AUX to avoid infinite
|
||||
TMPL_INCLUDE loops.")
|
||||
|
||||
(defvar *external-format* :default
|
||||
"The external format used when opening files.")
|
||||
|
||||
(defvar *value-access-function*
|
||||
(lambda (symbol values &optional in-loop-p)
|
||||
(let ((result (getf values symbol)))
|
||||
(cond ((and in-loop-p *sequences-are-lists*)
|
||||
(loop for element in result
|
||||
when (and element (listp element))
|
||||
;; keep values from upper levels
|
||||
collect (append element values)
|
||||
else
|
||||
collect element))
|
||||
(t result))))
|
||||
"The function which associates \(attribute) symbols with their
|
||||
values.")
|
||||
|
||||
(defvar *call-template-access-function* #'car
|
||||
"Accessor function for extracting the called template from a
|
||||
TMPL_CALL form.")
|
||||
|
||||
(defvar *call-value-access-function* #'cdr
|
||||
"Accessor function for extracting the values from a TMPL_CALL
|
||||
form.")
|
||||
|
||||
(defvar *force-default* nil
|
||||
"The default value for the FORCE keyword argument to
|
||||
CREATE-TEMPLATE-PRINTER.")
|
||||
|
||||
(defvar *string-modifier* 'escape-string-iso-8859-1
|
||||
"The function which is applied to strings which replace
|
||||
TMPL_VAR tags. Use #'CL:IDENTITY if you don't want to change the
|
||||
strings.")
|
||||
|
||||
(defparameter *escape-char-p*
|
||||
#'(lambda (char)
|
||||
(or (find char "<>&'\"")
|
||||
(> (char-code char) 127)))
|
||||
"Used by ESCAPE-STRING to test whether a character should be escaped.")
|
||||
|
||||
;; 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
|
||||
|
||||
(defvar *hyperdoc-base-uri* "http://weitz.de/html-template/")
|
||||
|
||||
(let ((exported-symbols-alist
|
||||
(loop for symbol being the external-symbols of :html-template
|
||||
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,474 @@
|
|||
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HTML-TEMPLATE; Base: 10 -*-
|
||||
;;; $Header: /usr/local/cvsrep/html-template/template.lisp,v 1.24 2007-01-01 23:49:16 edi Exp $
|
||||
|
||||
;;; Copyright (c) 2003-2007, 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 #:html-template)
|
||||
|
||||
(defmacro with-use-value-restart ((symbol) error-form)
|
||||
"Provide a USE-VALUE restart for ERROR-FORM in case the value
|
||||
associated with SYMBOL isn't to our liking."
|
||||
`(restart-case
|
||||
,error-form
|
||||
(use-value (other-value)
|
||||
:report (lambda (stream)
|
||||
(format stream
|
||||
"Use another value for symbol ~S: "
|
||||
,symbol))
|
||||
:interactive (lambda ()
|
||||
(format t
|
||||
"Enter another value for symbol ~S: "
|
||||
,symbol)
|
||||
(multiple-value-list (eval (read))))
|
||||
other-value)))
|
||||
|
||||
;; indentation for LispWorks editor
|
||||
#+:lispworks
|
||||
(editor:setup-indent "with-use-value-restart" 1 2 4)
|
||||
|
||||
(defun create-simple-printer (string-list &optional (next-fn #'no-values))
|
||||
"Used internally to create template printers for strings which don't
|
||||
include template tags. NEXT-FN is the next function to be called in
|
||||
the chain of closures. STRING-LIST is a list of strings in reverse
|
||||
order to be printed first."
|
||||
(let ((string (list-to-string string-list)))
|
||||
(lambda (values)
|
||||
(write-string string *template-output*)
|
||||
(funcall next-fn values))))
|
||||
|
||||
(defun create-var-printer (string-list symbol next-fn)
|
||||
"Used internally to create template printers for TMPL_VAR. SYMBOL is
|
||||
the symbol associated with the tag. NEXT-FN is the next function to be
|
||||
called in the chain of closures. STRING-LIST is a list of strings in
|
||||
reverse order to be printed first."
|
||||
(let ((string (list-to-string string-list)))
|
||||
(lambda (values)
|
||||
(write-string string *template-output*)
|
||||
(let* ((value (funcall *value-access-function* symbol values))
|
||||
(string (typecase value
|
||||
(null
|
||||
(if *convert-nil-to-empty-string*
|
||||
""
|
||||
(with-use-value-restart (symbol)
|
||||
(signal-template-missing-value-error
|
||||
"Value for symbol ~S is NIL"
|
||||
symbol))))
|
||||
(string value)
|
||||
(otherwise
|
||||
(cond (*format-non-strings* (format nil "~A" value))
|
||||
(t (with-use-value-restart (symbol)
|
||||
(error 'template-not-a-string-error
|
||||
:value value
|
||||
:format-control "Value ~S for symbol ~S is not a string"
|
||||
:format-arguments (list value symbol)))))))))
|
||||
(write-string (funcall *string-modifier* string) *template-output*))
|
||||
(funcall next-fn values))))
|
||||
|
||||
(defun create-include-printer (string-list pathname next-fn)
|
||||
"Used internally to create template printers for TMPL_INCLUDE.
|
||||
PATHNAME is the pathname associated with the tag. NEXT-FN is the next
|
||||
function to be called in the chain of closures. STRING-LIST is a list
|
||||
of strings in reverse order to be printed first."
|
||||
(let ((string (list-to-string string-list)))
|
||||
(lambda (values)
|
||||
(write-string string *template-output*)
|
||||
(funcall (car (gethash pathname *printer-hash*)) values)
|
||||
(funcall next-fn values))))
|
||||
|
||||
(defun create-if-printer (string-list symbol if-fn else-fn next-fn unlessp)
|
||||
"Used internally to create template printers for TMPL_IF and
|
||||
TMPL_UNLESS tags. SYMBOL is the symbol associated with the tag. IF-FN
|
||||
is the printer for the IF branch, ELSE-FN is the printer for the ELSE
|
||||
branch. NEXT-FN is the next function to be called in the chain of
|
||||
closures. STRING-LIST is a list of strings in reverse order to be
|
||||
printed first. If UNLESSP is true, IF-FN and ELSE-FN are switched."
|
||||
(let ((string (list-to-string string-list)))
|
||||
(when unlessp
|
||||
(rotatef if-fn else-fn))
|
||||
(lambda (values)
|
||||
(write-string string *template-output*)
|
||||
(if (funcall *value-access-function* symbol values)
|
||||
(funcall if-fn values)
|
||||
(funcall else-fn values))
|
||||
(funcall next-fn values))))
|
||||
|
||||
(defun create-loop-printer (string-list symbol body-fn next-fn)
|
||||
"Used internally to create template printers for TMPL_LOOP
|
||||
tags. SYMBOL is the symbol associated with the tag. BODY-FN is the
|
||||
template printer for the body of the loop. NEXT-FN is the next
|
||||
function to be called in the chain of closures. STRING-LIST is a list
|
||||
of strings in reverse order to be printed first."
|
||||
(let ((string (list-to-string string-list)))
|
||||
(cond (*sequences-are-lists*
|
||||
(lambda (values)
|
||||
(write-string string *template-output*)
|
||||
(dolist (value (funcall *value-access-function*
|
||||
symbol values t))
|
||||
(funcall body-fn value))
|
||||
(funcall next-fn values)))
|
||||
(t
|
||||
(lambda (values)
|
||||
(write-string string *template-output*)
|
||||
(loop for value across (funcall *value-access-function*
|
||||
symbol values t)
|
||||
do (funcall body-fn value))
|
||||
(funcall next-fn values))))))
|
||||
|
||||
(defun create-repeat-printer (string-list symbol body-fn next-fn)
|
||||
"Used internally to create template printers for TMPL_REPEAT
|
||||
tags. SYMBOL is the symbol associated with the tag. BODY-FN is the
|
||||
template printer for the body of the loop. NEXT-FN is the next
|
||||
function to be called in the chain of closures. STRING-LIST is a list
|
||||
of strings in reverse order to be printed first."
|
||||
(let ((string (list-to-string string-list)))
|
||||
(lambda (values)
|
||||
(write-string string *template-output*)
|
||||
(let ((factor (funcall *value-access-function* symbol values)))
|
||||
(when (and (integerp factor) (plusp factor))
|
||||
(loop repeat factor
|
||||
do (funcall body-fn values))))
|
||||
(funcall next-fn values))))
|
||||
|
||||
(defun create-call-printer (string-list symbol next-fn)
|
||||
"Used internally to create template printers for TMPL_CALL tags.
|
||||
SYMBOL is the symbol associated with the tag. BODY-FN is the template
|
||||
printer for the body of the loop. NEXT-FN is the next function to be
|
||||
called in the chain of closures. STRING-LIST is a list of strings in
|
||||
reverse order to be printed first."
|
||||
(let ((string (list-to-string string-list)))
|
||||
(cond (*sequences-are-lists*
|
||||
(lambda (values)
|
||||
(write-string string *template-output*)
|
||||
(dolist (call (funcall *value-access-function*
|
||||
symbol values t))
|
||||
(fill-and-print-template
|
||||
(funcall *call-template-access-function* call)
|
||||
(funcall *call-value-access-function* call)
|
||||
:stream *template-output*))
|
||||
(funcall next-fn values)))
|
||||
(t
|
||||
(lambda (values)
|
||||
(write-string string *template-output*)
|
||||
(loop for call across (funcall *value-access-function*
|
||||
symbol values t)
|
||||
do (fill-and-print-template
|
||||
(funcall *call-template-access-function* call)
|
||||
(funcall *call-value-access-function* call)
|
||||
:stream *template-output*))
|
||||
(funcall next-fn values))))))
|
||||
|
||||
(defun create-template-printer-aux (string-stack end-token)
|
||||
"Reads from *STANDARD-INPUT* and returns a template printer from
|
||||
what it reads. When this function is entered the stream pointer must
|
||||
not be inside a template tag. STRING-STACK is a list of strings (in
|
||||
reverse order) read so far which haven't been used to build a template
|
||||
printer. END-TOKEN is either NIL or one of :LOOP, :REPEAT, :IF,
|
||||
:IF-ELSE, or :UNLESS-ELSE denoting that we expect certain tags to
|
||||
close open TMPL_LOOP, TMPL_REPEAT, TMPL_IF, or TMPL_UNLESS tags. This
|
||||
function returns a second value which is true if, after reading
|
||||
TMPL_IF or TMPL_UNLESS, a corresponding TMPL_ELSE was seen."
|
||||
(let* ((string
|
||||
;; read text up to the next template start marker
|
||||
(read-until *template-start-marker*
|
||||
;; don't skip it, return it
|
||||
:skip nil
|
||||
:eof-action (lambda (collector)
|
||||
(when end-token
|
||||
;; make sure we don't accept
|
||||
;; EOF if there are still tags
|
||||
;; waiting to be closed
|
||||
(signal-template-syntax-error
|
||||
"Unexpected EOF, ~A tag is missing"
|
||||
(case end-token
|
||||
((:loop) "<!-- /TMPL_LOOP -->")
|
||||
((:repeat) "<!-- /TMPL_REPEAT -->")
|
||||
((:if :if-else) "<!-- /TMPL_IF -->")
|
||||
((:unless :unless-else) "<!-- /TMPL_UNLESS -->"))))
|
||||
;; otherwise (EOF before another
|
||||
;; start marker was seen) just
|
||||
;; return a template printer
|
||||
;; which unconditionally prints
|
||||
;; the rest of the stream
|
||||
(return-from create-template-printer-aux
|
||||
(create-simple-printer
|
||||
(cons collector string-stack))))))
|
||||
(whitespace
|
||||
;; skip whitespace but keep it in case this turns out not
|
||||
;; to be a template tag
|
||||
(skip-whitespace :skip nil))
|
||||
(token
|
||||
;; read what could be a template token's name
|
||||
(with-syntax-error-location ()
|
||||
(read-while (lambda (c)
|
||||
(or (alpha-char-p c)
|
||||
(char= c #\_)
|
||||
(char= c #\/)))
|
||||
:skip nil
|
||||
:eof-action (lambda (collector)
|
||||
(declare (ignore collector))
|
||||
;; complain about tags which
|
||||
;; haven't been closed
|
||||
(signal-template-syntax-error
|
||||
"EOF while inside of tag starting with ~S"
|
||||
*template-start-marker*))))))
|
||||
(cond ((string-equal token "TMPL_INCLUDE")
|
||||
;; TMPL_INCLUDE tag - first read the pathname which has to
|
||||
;; follow and merge it with *DEFAULT-TEMPLATE-PATHNAME*
|
||||
(let* ((pathname (read-tag-rest :read-attribute t :intern nil))
|
||||
(merged-pathname
|
||||
(merge-pathnames pathname
|
||||
*default-template-pathname*)))
|
||||
(when (member merged-pathname *included-files*
|
||||
:test #'equal)
|
||||
;; raise an error if this file has been included
|
||||
;; before - infinite recursion ahead!
|
||||
(with-syntax-error-location ()
|
||||
(signal-template-syntax-error
|
||||
"Infinite recursion - file ~S includes itself"
|
||||
merged-pathname)))
|
||||
;; otherwise create (and cache) a template printer
|
||||
(create-template-printer merged-pathname)
|
||||
(multiple-value-bind (next-fn else-follows)
|
||||
;; first we recursively create the template printer
|
||||
;; for the rest of the stream
|
||||
(create-template-printer-aux (skip-trailing-whitespace)
|
||||
end-token)
|
||||
;; then we combine it with the strings before the tag
|
||||
;; to create a template printer for TMPL_INCLUDE
|
||||
(values
|
||||
(create-include-printer (cons (skip-leading-whitespace string)
|
||||
string-stack)
|
||||
merged-pathname
|
||||
next-fn)
|
||||
else-follows))))
|
||||
((string-equal token "TMPL_VAR")
|
||||
;; TMPL_VAR tag - first read the symbol which has to
|
||||
;; follow and intern it
|
||||
(let ((symbol (read-tag-rest :read-attribute t)))
|
||||
(multiple-value-bind (next-fn else-follows)
|
||||
;; first we recursively create the template printer
|
||||
;; for the rest of the stream
|
||||
(create-template-printer-aux nil end-token)
|
||||
(values
|
||||
;; then we combine it with the strings before the tag
|
||||
;; to create a template printer for TMPL_VAR - note
|
||||
;; that we don't skip leading and trailing whitespace
|
||||
;; here
|
||||
(create-var-printer (cons string string-stack)
|
||||
symbol
|
||||
next-fn)
|
||||
else-follows))))
|
||||
((or (string-equal token "TMPL_LOOP")
|
||||
(string-equal token "TMPL_REPEAT"))
|
||||
;; TMPL_LOOP or TMPL_REPEAT tag - first read the symbol
|
||||
;; which has to follow and intern it
|
||||
(let* ((kind (if (string-equal token "TMPL_LOOP") :loop :repeat))
|
||||
(symbol (read-tag-rest :read-attribute t))
|
||||
;; then read the stream up to the corresponding
|
||||
;; end tag and create a template printer for the
|
||||
;; loop body
|
||||
(body-fn (with-syntax-error-location ()
|
||||
(create-template-printer-aux
|
||||
(skip-trailing-whitespace)
|
||||
;; this argument denotes that we expect
|
||||
;; to see /TMPL_LOOP or /TMPL_REPEAT and
|
||||
;; want to stop there
|
||||
kind))))
|
||||
(multiple-value-bind (next-fn else-follows)
|
||||
;; now we recursively create the template printer
|
||||
;; for the rest of the stream
|
||||
(create-template-printer-aux (skip-trailing-whitespace)
|
||||
end-token)
|
||||
(values
|
||||
;; then we combine it with the strings before the tag
|
||||
;; and the body printer to create a template printer
|
||||
;; for TMPL_LOOP
|
||||
(funcall (case kind
|
||||
(:loop #'create-loop-printer)
|
||||
(:repeat #'create-repeat-printer))
|
||||
(cons (skip-leading-whitespace string)
|
||||
string-stack)
|
||||
symbol
|
||||
body-fn
|
||||
next-fn)
|
||||
else-follows))))
|
||||
((string-equal token "TMPL_CALL")
|
||||
;; TMPL_CALL tag - first read the symbol which has to
|
||||
;; follow and intern it
|
||||
(let ((symbol (read-tag-rest :read-attribute t)))
|
||||
(multiple-value-bind (next-fn else-follows)
|
||||
;; recursively create the template printer for the
|
||||
;; rest of the stream
|
||||
(create-template-printer-aux (skip-trailing-whitespace)
|
||||
end-token)
|
||||
;; create the printer that will output the strings
|
||||
;; before this tag and call the templates stored under
|
||||
;; SYMBOL
|
||||
(values (funcall #'create-call-printer
|
||||
(cons (skip-leading-whitespace string)
|
||||
string-stack)
|
||||
symbol
|
||||
next-fn)
|
||||
else-follows))))
|
||||
((string-equal token "/TMPL_LOOP")
|
||||
(unless (eq end-token :loop)
|
||||
;; check if we expected /TMPL_LOOP here, i.e. if an open
|
||||
;; TMPL_LOOP was pending
|
||||
(with-syntax-error-location ()
|
||||
(signal-template-syntax-error "Unexpected /TMPL_LOOP")))
|
||||
;; read the rest of the tag but ignore it - no attributes
|
||||
;; expected
|
||||
(read-tag-rest)
|
||||
;; just create a simple template printer for strings -
|
||||
;; this is the end of some TMPL_LOOP body
|
||||
(create-simple-printer (cons (skip-leading-whitespace string)
|
||||
string-stack)))
|
||||
((string-equal token "/TMPL_REPEAT")
|
||||
(unless (eq end-token :repeat)
|
||||
;; check if we expected /TMPL_REPEAT here, i.e. if an open
|
||||
;; TMPL_REPEAT was pending
|
||||
(with-syntax-error-location ()
|
||||
(signal-template-syntax-error "Unexpected /TMPL_REPEAT")))
|
||||
;; read the rest of the tag but ignore it - no attributes
|
||||
;; expected
|
||||
(read-tag-rest)
|
||||
;; just create a simple template printer for strings -
|
||||
;; this is the end of some TMPL_REPEAT body
|
||||
(create-simple-printer (cons (skip-leading-whitespace string)
|
||||
string-stack)))
|
||||
((or (string-equal token "TMPL_IF")
|
||||
(string-equal token "TMPL_UNLESS"))
|
||||
;; TMPL_IF or TMPL_UNLESS tag - first read the symbol
|
||||
;; which has to follow and intern it
|
||||
(let ((symbol (read-tag-rest :read-attribute t))
|
||||
(unlessp (string-equal token "TMPL_UNLESS")))
|
||||
(multiple-value-bind (if-fn else-follows)
|
||||
(with-syntax-error-location ()
|
||||
;; then read the stream up to the corresponding
|
||||
;; TMPL_ELSE, /TMPL_IF, or /TMPL_UNLESS and create
|
||||
;; a template printer for the "if" (or "unless") part
|
||||
(create-template-printer-aux
|
||||
(skip-trailing-whitespace)
|
||||
;; this argument denotes that we expect to see
|
||||
;; TMPL_ELSE _or_ one of /TMPL_IF, /TMPL_UNLESS and,
|
||||
;; in the second case, want to stop there
|
||||
(if unlessp :unless-else :if-else)))
|
||||
(let ((else-fn (if else-follows
|
||||
;; if we encountered TMPL_ELSE read
|
||||
;; the stream up to the corresponding
|
||||
;; /TMPL_IF or /TMPL_UNLESS and
|
||||
;; create a template printer for the "else" part
|
||||
(with-syntax-error-location ()
|
||||
(create-template-printer-aux
|
||||
(skip-trailing-whitespace)
|
||||
;; this argument denotes that we
|
||||
;; expect to see /TMPL_IF or /TMPL_UNLESS
|
||||
;; (but not TMPL_ELSE) and want to stop
|
||||
;; there
|
||||
(if unlessp :unless :if)))
|
||||
;; use a dummy printer for the "else"
|
||||
;; part if we didn't see TMPL_ELSE
|
||||
#'no-values)))
|
||||
(multiple-value-bind (next-fn else-follows)
|
||||
;; now we recursively create the template printer
|
||||
;; for the rest of the stream
|
||||
(create-template-printer-aux (skip-trailing-whitespace)
|
||||
end-token)
|
||||
(values
|
||||
;; then we combine it with the strings before the
|
||||
;; tag and the "if" and "else" parts to create a
|
||||
;; template printer for TMPL_IF or TMPL_UNLESS
|
||||
(create-if-printer (cons (skip-leading-whitespace string)
|
||||
string-stack)
|
||||
symbol
|
||||
if-fn
|
||||
else-fn
|
||||
next-fn
|
||||
unlessp)
|
||||
else-follows))))))
|
||||
((string-equal token "TMPL_ELSE")
|
||||
(unless (member end-token '(:if-else :unless-else))
|
||||
;; check if we expected /TMPL_ELSE here, i.e. if an open
|
||||
;; TMPL_IF or TMPL_UNLESS was pending and we haven't
|
||||
;; seen TMPL_ELSE before
|
||||
(with-syntax-error-location ()
|
||||
(signal-template-syntax-error "Unexpected TMPL_ELSE")))
|
||||
;; read the rest of the tag but ignore it - no attributes
|
||||
;; expected
|
||||
(read-tag-rest)
|
||||
;; just create a simple template printer for strings -
|
||||
;; this is the end of some "if" part
|
||||
(values
|
||||
(create-simple-printer (cons (skip-leading-whitespace string)
|
||||
string-stack))
|
||||
;; return a true second value to denote that we've seen
|
||||
;; TMPL_ELSE
|
||||
t))
|
||||
((string-equal token "/TMPL_IF")
|
||||
(unless (or (eq end-token :if) (eq end-token :if-else))
|
||||
;; check if we expected /TMPL_IF here, i.e. if an open
|
||||
;; TMPL_IF was pending
|
||||
(with-syntax-error-location ()
|
||||
(signal-template-syntax-error "Unexpected /TMPL_IF")))
|
||||
;; read the rest of the tag but ignore it - no attributes
|
||||
;; expected
|
||||
(read-tag-rest)
|
||||
;; just create a simple template printer for strings -
|
||||
;; this is the end of some "if" or "else" part
|
||||
(create-simple-printer (cons (skip-leading-whitespace string)
|
||||
string-stack)))
|
||||
((string-equal token "/TMPL_UNLESS")
|
||||
(unless (or (eq end-token :unless) (eq end-token :unless-else))
|
||||
;; check if we expected /TMPL_UNLESS here, i.e. if an open
|
||||
;; TMPL_UNLESS was pending
|
||||
(with-syntax-error-location ()
|
||||
(signal-template-syntax-error "Unexpected /TMPL_UNLESS")))
|
||||
;; read the rest of the tag but ignore it - no attributes
|
||||
;; expected
|
||||
(read-tag-rest)
|
||||
;; just create a simple template printer for strings -
|
||||
;; this is the end of some "unless" or "else" part
|
||||
(create-simple-printer (cons (skip-leading-whitespace string)
|
||||
string-stack)))
|
||||
(t
|
||||
;; we couldn't identify a valid tag, so we treat
|
||||
;; everything we've read so far as a literal string and
|
||||
;; carry on - if we're lucky our CL implementation will
|
||||
;; optimize this tail call into an iterative loop
|
||||
(create-template-printer-aux
|
||||
(cons token
|
||||
(cons whitespace
|
||||
(cons *template-start-marker*
|
||||
(cons string string-stack))))
|
||||
end-token)))))
|
||||
|
||||
(defun %create-template-printer-aux (&rest args)
|
||||
"Wrapper for CREATE-TEMPLATE-PRINTER-AUX to initialize
|
||||
*CURRENT-COLUMN* and *CURRENT-LINE*."
|
||||
(let ((*current-column* 0)
|
||||
(*current-line* 1))
|
||||
(apply #'create-template-printer-aux args)))
|
||||
|
|
@ -0,0 +1,291 @@
|
|||
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HTML-TEMPLATE-TEST; Base: 10 -*-
|
||||
;;; $Header: /usr/local/cvsrep/html-template/test.lisp,v 1.13 2007-01-01 23:49:16 edi Exp $
|
||||
|
||||
;;; Copyright (c) 2003-2007, 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)
|
||||
|
||||
#-:cormanlisp
|
||||
(defpackage #:html-template-test
|
||||
(:use #:cl #:html-template))
|
||||
|
||||
#+:cormanlisp
|
||||
(defpackage "HTML-TEMPLATE-TEST"
|
||||
(:use "CL" "HTML-TEMPLATE"))
|
||||
|
||||
(in-package #:html-template-test)
|
||||
|
||||
(format t "~&Please wait a couple of seconds.")
|
||||
(force-output)
|
||||
|
||||
(defvar tmp-dir #p"/tmp/")
|
||||
|
||||
(defmacro failedp (&body body)
|
||||
`(handler-case
|
||||
(progn ,@body nil)
|
||||
(condition () t)))
|
||||
|
||||
(defmacro warnedp (&body body)
|
||||
`(handler-case
|
||||
(progn ,@body nil)
|
||||
(warning () t)))
|
||||
|
||||
(defmacro test (result &rest args)
|
||||
(cond (result
|
||||
`(assert (string= ,result
|
||||
(with-output-to-string (*default-template-output*)
|
||||
(fill-and-print-template ,@args)))))
|
||||
(`(assert (failedp (fill-and-print-template ,@args))))))
|
||||
|
||||
(test "abc" "<!-- TMPL_VAR foo -->" '(:foo "abc"))
|
||||
(test "abc" "<!-- tmpl_var foo -->" '(:foo "abc"))
|
||||
(test "<!-- tmpl_vaar foo -->" "<!-- tmpl_vaar foo -->" '(:foo "abc"))
|
||||
(test "xabcy" "x<!-- TMPL_VAR foo -->y" '(:foo "abc"))
|
||||
(test "" "<!-- TMPL_VAR foo -->" nil)
|
||||
(test "" "<!-- TMPL_VAR foo -->" '(foo "abc"))
|
||||
(test "" "<!-- TMPL_VAR foo -->" '(:bar "abc"))
|
||||
(test "abc" "<!-- TMPL_VAR 'foo' -->" '(:foo "abc"))
|
||||
(test "abc" "<!-- TMPL_VAR \"foo\" -->" '(:foo "abc"))
|
||||
(test nil "<!-- TMPL_VAR foo-->" '(:foo "abc"))
|
||||
(test "" "<!-- TMPL_IF foo -->abc<!-- /TMPL_IF -->" nil)
|
||||
(test "" "<!-- TMPL_IF foo -->abc<!-- /TMPL_IF -->" '(:foo nil))
|
||||
(test "abc" "<!-- TMPL_IF foo -->abc<!-- /TMPL_IF -->" '(:foo t))
|
||||
(test "abc" "<!-- TMPL_IF foo -->abc<!-- /TMPL_IF -->" '(:foo t :bar 42))
|
||||
(test nil "<!-- TMPL_IF foo -->abc<!-- /TMPL_IF foo -->" nil)
|
||||
(test nil "<!-- TMPL_IF -->abc<!-- /TMPL_IF -->" nil)
|
||||
(test "def" "<!-- TMPL_IF foo -->abc<!-- TMPL_ELSE-->def<!-- /TMPL_IF -->" nil)
|
||||
(test nil "<!-- TMPL_IF foo -->abc<!-- TMPL_ELSE-->def<!-- /TMPL_UNLESS -->" nil)
|
||||
(test "def" "<!-- TMPL_IF foo -->abc<!-- TMPL_ELSE-->def<!-- /TMPL_IF -->" '(:foo nil))
|
||||
(test "abc" "<!-- TMPL_IF foo -->abc<!-- TMPL_ELSE-->def<!-- /TMPL_IF -->" '(:foo t))
|
||||
(test "abc" "<!-- TMPL_UNLESS foo -->abc<!-- TMPL_ELSE-->def<!-- /TMPL_UNLESS -->" '(:foo nil))
|
||||
(test "def" "<!-- TMPL_UNLESS foo -->abc<!-- TMPL_ELSE-->def<!-- /TMPL_UNLESS -->" '(:foo t))
|
||||
(test nil "<!-- TMPL_UNLESS foo -->abc<!-- TMPL_ELSE-->def<!-- /TMPL_IF -->" '(:foo t))
|
||||
(test "abc" "<!-- TMPL_IF foo --><!-- TMPL_VAR foo --><!-- TMPL_ELSE-->def<!-- /TMPL_IF -->" '(:foo "abc"))
|
||||
(test "def" "<!-- TMPL_IF foo --><!-- TMPL_VAR foo --><!-- TMPL_ELSE-->def<!-- /TMPL_IF -->" '(:foo nil))
|
||||
(test "abcabcabc" "<!-- TMPL_IF foo --><!-- TMPL_VAR foo -->abc<!-- TMPL_VAR foo --><!-- TMPL_ELSE-->def<!-- /TMPL_IF -->" '(:foo "abc"))
|
||||
(test "defdefdef" "<!-- TMPL_IF foo --><!-- TMPL_VAR foo -->abc<!-- TMPL_VAR foo --><!-- TMPL_ELSE--><!-- TMPL_VAR bar -->def<!-- TMPL_VAR bar --><!-- /TMPL_IF -->" '(:bar "def"))
|
||||
(test "[]" "[<!-- TMPL_LOOP foo -->[x]<!-- /TMPL_LOOP -->]" '(:foo nil))
|
||||
(test "[xxx]" "[<!-- TMPL_REPEAT foo -->x<!-- /TMPL_REPEAT -->]" '(:foo 3))
|
||||
(test "[]" "[<!-- TMPL_REPEAT foo -->x<!-- /TMPL_REPEAT -->]" '(:foo 0))
|
||||
(test "[]" "[<!-- TMPL_REPEAT foo -->x<!-- /TMPL_REPEAT -->]" '(:foo "foo"))
|
||||
(test nil "[<!-- TMPL_REPEAT foo -->x<!-- /TMPL_LOOP -->]" '(:foo 3))
|
||||
(test nil "[<!-- TMPL_LOOP foo -->x<!-- /TMPL_REPEAT -->]" '(:foo 3))
|
||||
(test "[[x][x][x]]" "[<!-- TMPL_LOOP foo -->[x]<!-- /TMPL_LOOP -->]" '(:foo (1 2 3)))
|
||||
(test "[[1][2][3]]" "[<!-- TMPL_LOOP foo -->[<!-- TMPL_VAR bar -->]<!-- /TMPL_LOOP -->]" '(:foo ((:bar "1") (:bar "2") (:bar "3"))))
|
||||
(test "[[][][]]" "[<!-- TMPL_LOOP foo -->[<!-- TMPL_VAR bar -->]<!-- /TMPL_LOOP -->]" '(:foo (() () ())))
|
||||
(test "[[1][2][3]]" "[<!-- TMPL_LOOP foo -->[<!-- TMPL_VAR bar -->]<!-- /TMPL_LOOP -->]" '(:foo ((:bar "1") (:bar "2") (:bar "3"))))
|
||||
(test "[[1][][3]]" "[<!-- TMPL_LOOP foo -->[<!-- TMPL_VAR bar -->]<!-- /TMPL_LOOP -->]" '(:foo ((:bar "1") () (:bar "3"))))
|
||||
(test "[[1][2][3]]" "[<!-- TMPL_LOOP foo -->[<!-- TMPL_IF 'bar' --><!-- TMPL_VAR bar --><!-- TMPL_ELSE-->2<!-- /TMPL_IF -->]<!-- /TMPL_LOOP -->]" '(:foo ((:bar "1") () (:bar "3"))))
|
||||
(test "[[123][456][789]]" "[<!-- TMPL_LOOP 'foo' -->[<!-- TMPL_LOOP 'bar' --><!-- TMPL_VAR 'bar' --><!-- /TMPL_LOOP -->]<!-- /TMPL_LOOP -->]" '(:foo ((:bar ((:bar "1") (:bar "2") (:bar "3")))
|
||||
(:bar ((:bar "4") (:bar "5") (:bar "6")))
|
||||
(:bar ((:bar "7") (:bar "8") (:bar "9"))))))
|
||||
(test "[[123][baz][789]]" "[<!-- TMPL_LOOP 'foo' -->[<!-- TMPL_IF baz --><!-- TMPL_LOOP 'baz' --><!-- TMPL_VAR 'bar' --><!-- /TMPL_LOOP --><!-- TMPL_ELSE -->baz<!-- /TMPL_IF -->]<!-- /TMPL_LOOP -->]" '(:foo ((:baz ((:bar "1") (:bar "2") (:bar "3")))
|
||||
()
|
||||
(:baz ((:bar "7") (:bar "8") (:bar "9"))))))
|
||||
(test nil "<!-- TMPL_ELSE -->" nil)
|
||||
(test "<!-- /TMPL_ELSE -->" "<!-- /TMPL_ELSE -->" nil)
|
||||
(test nil "<!-- /TMPL_IF -->" nil)
|
||||
(test nil "<!-- /TMPL_UNLESS -->" nil)
|
||||
(test nil "<!-- /TMPL_LOOP -->" nil)
|
||||
(test nil "<!-- TMPL_IF foo --><!-- TMPL_ELSE -->" nil)
|
||||
(test nil "<!-- TMPL_UNLESS foo --><!-- TMPL_ELSE -->" nil)
|
||||
(test nil "<!-- TMPL_LOOP foo --><!-- TMPL_ELSE -->" nil)
|
||||
(test nil "<!-- TMPL_LOOP foo --><!-- TMPL_ELSE --><!-- /TMPL_LOOP -->" nil)
|
||||
(test nil "<!-- TMPL_IF bar --><!-- TMPL_LOOP foo --><!-- TMPL_ELSE --><!-- /TMPL_LOOP -->" nil)
|
||||
(test nil "<!-- TMPL_IF foo --><!-- TMPL_IF bar -->1<!-- TMPL_ELSE -->2<!-- /TMPL_IF --><!-- TMPL_ELSE --><!-- TMPL_IF baz -->3<!-- TMPL_ELSE -->4<!-- /TMPL_IF -->" nil)
|
||||
(test "1" "<!-- TMPL_IF foo --><!-- TMPL_IF bar -->1<!-- TMPL_ELSE -->2<!-- /TMPL_IF --><!-- TMPL_ELSE --><!-- TMPL_IF baz -->3<!-- TMPL_ELSE -->4<!-- /TMPL_IF --><!-- /TMPL_IF -->" '(:foo t :bar t))
|
||||
(test "2" "<!-- TMPL_IF foo --><!-- TMPL_IF bar -->1<!-- TMPL_ELSE -->2<!-- /TMPL_IF --><!-- TMPL_ELSE --><!-- TMPL_IF baz -->3<!-- TMPL_ELSE -->4<!-- /TMPL_IF --><!-- /TMPL_IF -->" '(:foo t :bar nil))
|
||||
(test "3" "<!-- TMPL_IF foo --><!-- TMPL_IF bar -->1<!-- TMPL_ELSE -->2<!-- /TMPL_IF --><!-- TMPL_ELSE --><!-- TMPL_IF baz -->3<!-- TMPL_ELSE -->4<!-- /TMPL_IF --><!-- /TMPL_IF -->" '(:foo nil :baz t))
|
||||
(test "4" "<!-- TMPL_IF foo --><!-- TMPL_IF bar -->1<!-- TMPL_ELSE -->2<!-- /TMPL_IF --><!-- TMPL_ELSE --><!-- TMPL_IF baz -->3<!-- TMPL_ELSE -->4<!-- /TMPL_IF --><!-- /TMPL_IF -->" '(:foo nil :baz nil))
|
||||
(test "X" "<!-- TMPL_CALL foo -->" '(:foo (("X"))))
|
||||
(test "QUUX" "<!-- TMPL_VAR baz --><!-- TMPL_CALL foo -->" '(:baz "Q"
|
||||
:foo (("<!-- TMPL_VAR bar -->" :bar "U")
|
||||
("<!-- TMPL_VAR bar -->X" :bar "U"))))
|
||||
(test "" "<!-- TMPL_IF foo --><!-- TMPL_CALL bar --><!-- /TMPL_IF -->" '(:foo (("---"))))
|
||||
(test nil "<!-- TMPL_CALL foo -->" '(:foo 57))
|
||||
|
||||
(let ((temp-name (make-pathname :name (format nil "template-test-~A" (random 1000000))
|
||||
:defaults tmp-dir)))
|
||||
(with-open-file (stream temp-name :direction :output :if-exists :error)
|
||||
(write-string "<!-- TMPL_VAR foo -->" stream))
|
||||
(let ((*warn-on-creation* nil))
|
||||
(test "abc" temp-name '(:foo "abc")))
|
||||
(with-open-file (stream temp-name :direction :input)
|
||||
(test "def" stream '(:foo "def")))
|
||||
(with-open-file (stream temp-name :direction :input)
|
||||
(let ((tp (create-template-printer stream)))
|
||||
(test "ghi" tp '(:foo "ghi"))))
|
||||
(let ((tp (create-template-printer temp-name)))
|
||||
(test "jkl" tp '(:foo "jkl")))
|
||||
(let ((tp (create-template-printer "<!-- TMPL_VAR foo -->")))
|
||||
(test "mno" tp '(:foo "mno")))
|
||||
(delete-file temp-name)
|
||||
;; sleep because of FILE-WRITE-DATE
|
||||
(sleep 2)
|
||||
(with-open-file (stream temp-name :direction :output :if-exists :error)
|
||||
(write-string "<!-- TMPL_VAR bar -->" stream))
|
||||
(assert (warnedp (create-template-printer temp-name)))
|
||||
(assert (not (warnedp (create-template-printer temp-name))))
|
||||
(assert (warnedp (create-template-printer temp-name :force t)))
|
||||
(delete-from-template-cache temp-name)
|
||||
(assert (warnedp (create-template-printer temp-name)))
|
||||
(clear-template-cache)
|
||||
(assert (warnedp (create-template-printer temp-name)))
|
||||
(delete-file temp-name))
|
||||
|
||||
(let ((*template-start-marker* "<")
|
||||
(*template-end-marker* ">"))
|
||||
(test "The quick <brown> fox" "The <TMPL_VAR 'speed'> <brown> fox"
|
||||
'(:speed "quick")))
|
||||
|
||||
(let* ((random-string (format nil "template-test-~A" (random 1000000)))
|
||||
(temp-name (merge-pathnames random-string tmp-dir))
|
||||
(*default-template-pathname* tmp-dir))
|
||||
(with-open-file (stream temp-name :direction :output :if-exists :error)
|
||||
(write-string "The <!-- TMPL_VAR speed --> brown fox" stream))
|
||||
(let ((*warn-on-creation* nil))
|
||||
(test "The very fast brown fox"
|
||||
(make-pathname :name random-string)
|
||||
'(:speed "very fast")))
|
||||
(delete-file temp-name)
|
||||
;; sleep because of FILE-WRITE-DATE
|
||||
(sleep 2)
|
||||
(with-open-file (stream temp-name :direction :output :if-exists :error)
|
||||
(write-string "The <!-- TMPL_VAR speed --> brown fox" stream))
|
||||
(let ((*warn-on-creation* nil))
|
||||
(test "The very fast brown fox"
|
||||
(format nil "<!-- TMPL_INCLUDE '~A' -->" random-string)
|
||||
'(:speed "very fast")))
|
||||
(delete-file temp-name))
|
||||
|
||||
(let* ((random-string (format nil "template-test-~A" (random 1000000)))
|
||||
(temp-name (merge-pathnames random-string tmp-dir))
|
||||
(random-string-2 (format nil "template-test-2-~A" (random 1000000)))
|
||||
(temp-name-2 (merge-pathnames random-string-2 tmp-dir))
|
||||
(*default-template-pathname* tmp-dir))
|
||||
(with-open-file (stream temp-name :direction :output :if-exists :error)
|
||||
(format stream "<!-- TMPL_INCLUDE '~A' -->" random-string-2))
|
||||
(with-open-file (stream temp-name-2 :direction :output :if-exists :error)
|
||||
(format stream "<!-- TMPL_INCLUDE '~A' -->" random-string))
|
||||
(test nil (format nil "<!-- TMPL_INCLUDE '~A' -->" random-string) nil)
|
||||
(delete-file temp-name)
|
||||
(delete-file temp-name-2))
|
||||
|
||||
(assert (string= "The slow brown fox"
|
||||
(with-output-to-string (stream)
|
||||
(let ((*default-template-output* stream))
|
||||
(fill-and-print-template "The <!-- TMPL_VAR speed --> brown fox"
|
||||
'(:speed "slow"))))))
|
||||
|
||||
(let* ((tp (create-template-printer "The <!-- TMPL_VAR speed --> brown fox"))
|
||||
(*convert-nil-to-empty-string* nil))
|
||||
(with-output-to-string (*default-template-output*)
|
||||
(test nil tp '(:foo "bar"))))
|
||||
|
||||
(let ((tp (create-template-printer "The <!-- TMPL_VAR speed --> brown fox")))
|
||||
(handler-bind
|
||||
((template-missing-value-error (lambda (condition)
|
||||
(declare (ignore condition))
|
||||
(use-value "slow"))))
|
||||
(let ((*convert-nil-to-empty-string* nil))
|
||||
(test "The slow brown fox" tp '(:foo "bar")))))
|
||||
|
||||
(let ((*sequences-are-lists* nil))
|
||||
(test "[1][2][3]"
|
||||
"<!-- TMPL_LOOP vector -->[<!-- TMPL_VAR item -->]<!-- /TMPL_LOOP -->"
|
||||
'(:vector #((:item "1")
|
||||
(:item "2")
|
||||
(:item "3"))))
|
||||
(test "QUUX" "<!-- TMPL_VAR baz --><!-- TMPL_CALL foo -->"
|
||||
'(:baz "Q"
|
||||
:foo #(("<!-- TMPL_VAR bar -->" :bar "U")
|
||||
("<!-- TMPL_VAR bar -->X" :bar "U")))))
|
||||
|
||||
(let ((*upcase-attribute-strings* nil))
|
||||
(test "The slow brown fox"
|
||||
"The <!-- TMPL_VAR speed --> brown fox"
|
||||
'(:speed "quick" :|speed| "slow")))
|
||||
|
||||
(let ((*template-symbol-package* *package*))
|
||||
(test "The slow brown fox"
|
||||
"The <!-- TMPL_VAR speed --> brown fox"
|
||||
'(:speed "quick" speed "slow")))
|
||||
|
||||
(let ((tp (create-template-printer "The <!-- TMPL_VAR speed --> brown fox"))
|
||||
(*value-access-function* #'gethash)
|
||||
(hash (make-hash-table :test #'eq)))
|
||||
(setf (gethash :speed hash) "fast")
|
||||
(test "The fast brown fox" tp hash))
|
||||
|
||||
(let ((values (list :row-loop
|
||||
(loop for row in '((1 2 3 4) (2 3 4 5) (3 4 5 6))
|
||||
collect (list :col-loop
|
||||
(loop for col in row
|
||||
collect (list :item
|
||||
(format nil "~A" col)))))))
|
||||
(template "<table>
|
||||
<!-- TMPL_LOOP row-loop -->
|
||||
<tr>
|
||||
<!-- TMPL_LOOP col-loop -->
|
||||
<td><!-- TMPL_VAR item --></td>
|
||||
<!-- /TMPL_LOOP -->
|
||||
</tr>
|
||||
<!-- /TMPL_LOOP -->
|
||||
</table>")
|
||||
(result "<table>
|
||||
<tr>
|
||||
<td>1</td>
|
||||
<td>2</td>
|
||||
<td>3</td>
|
||||
<td>4</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td>2</td>
|
||||
<td>3</td>
|
||||
<td>4</td>
|
||||
<td>5</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td>3</td>
|
||||
<td>4</td>
|
||||
<td>5</td>
|
||||
<td>6</td>
|
||||
</tr>
|
||||
</table>")
|
||||
(*ignore-empty-lines* t))
|
||||
(test result template values))
|
||||
|
||||
(let ((tp (create-template-printer "A square has <!-- TMPL_VAR number --> corners"))
|
||||
(*format-non-strings* nil))
|
||||
(handler-bind
|
||||
((template-not-a-string-error (lambda (condition)
|
||||
(use-value
|
||||
(format nil "~R"
|
||||
(template-not-a-string-error-value condition))))))
|
||||
(test "A square has four corners" tp '(:number 4))))
|
||||
|
||||
(format t "~&All tests passed...")
|
||||
|
|
@ -0,0 +1,342 @@
|
|||
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HTML-TEMPLATE; Base: 10 -*-
|
||||
;;; $Header: /usr/local/cvsrep/html-template/util.lisp,v 1.21 2015-05-21 20:59:59 edi Exp $
|
||||
|
||||
;;; Copyright (c) 2003-2007, 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 #:html-template)
|
||||
|
||||
(defun no-values (&rest rest)
|
||||
"A function which does not return any values. This is always the
|
||||
last function in a chain of template printer closures."
|
||||
(declare (ignore rest))
|
||||
(values))
|
||||
|
||||
(defun list-to-string (string-list)
|
||||
"Concatenates a list of strings to one string in reverse order. The
|
||||
list is destructively modified."
|
||||
;; note that we can't use APPLY with CONCATENATE here because of
|
||||
;; CALL-ARGUMENTS-LIMIT
|
||||
(let ((total-size 0))
|
||||
(dolist (string string-list)
|
||||
(incf total-size (length string)))
|
||||
(let ((result-string (make-string total-size
|
||||
#+:lispworks #+:lispworks
|
||||
:element-type 'lw:simple-char))
|
||||
(curr-pos 0))
|
||||
(dolist (string (nreverse string-list))
|
||||
(replace result-string string :start1 curr-pos)
|
||||
(incf curr-pos (length string)))
|
||||
result-string)))
|
||||
|
||||
(defun %read-char ()
|
||||
"Like READ-CHAR but updates the line and column counters."
|
||||
(let ((char (read-char)))
|
||||
(cond ((char= char #\Newline)
|
||||
(setf *current-column* 0)
|
||||
(incf *current-line*))
|
||||
(t (incf *current-column*)))
|
||||
char))
|
||||
|
||||
(defmacro whitespacep (char)
|
||||
"Checks whether CHAR is whitespace."
|
||||
`(find ,char
|
||||
'(#\Space #\Tab #\Newline #\Linefeed #\Return #\Page)))
|
||||
|
||||
(defun read-while (predicate &key (skip t) (eof-action t))
|
||||
"Reads characters from *STANDARD-INPUT* while PREDICATE returns a
|
||||
true value for each character. Returns the string which was read
|
||||
unless SKIP is true. On reading EOF an error is signaled if
|
||||
EOF-ACTION is T, NIL is silently returned if EOF-ACTION is NIL, or the
|
||||
function EOF-ACTION is called with one argument - the string read so
|
||||
far."
|
||||
(let ((collector (or skip
|
||||
(make-array 0
|
||||
:element-type 'character
|
||||
:fill-pointer t
|
||||
:adjustable t))))
|
||||
(handler-case
|
||||
(loop for c = (peek-char)
|
||||
while (funcall predicate c)
|
||||
do (cond (skip (%read-char))
|
||||
(t (vector-push-extend (%read-char) collector)))
|
||||
finally (return collector))
|
||||
(end-of-file ()
|
||||
(cond ((eq eof-action t)
|
||||
(signal-template-syntax-error "Unexpected EOF"))
|
||||
((null eof-action)
|
||||
nil)
|
||||
(t (funcall eof-action collector)))))))
|
||||
|
||||
(defun read-delimited-string (&key (eof-action t))
|
||||
"Reads and returns a string from *STANDARD-INPUT*. The string is
|
||||
either delimited by ' or \" in which case the delimiters aren't
|
||||
returned or it is assumed to extend to the next whitespace
|
||||
character. See READ-WHILE's docstring for EOF-ACTION."
|
||||
(handler-case
|
||||
(let* ((peek-char (peek-char))
|
||||
(delimiter (find peek-char '(#\' #\"))))
|
||||
(when delimiter
|
||||
(%read-char))
|
||||
(prog1
|
||||
(read-while (if delimiter
|
||||
(lambda (c) (char/= c delimiter))
|
||||
(lambda (c) (not (whitespacep c))))
|
||||
:skip nil
|
||||
:eof-action eof-action)
|
||||
(when delimiter
|
||||
(%read-char))))
|
||||
(end-of-file ()
|
||||
(cond ((eq eof-action t)
|
||||
(signal-template-syntax-error
|
||||
"Unexpected EOF while reading (delimited) string"))
|
||||
((null eof-action)
|
||||
nil)
|
||||
(t (funcall eof-action ""))))))
|
||||
|
||||
(defun skip-whitespace (&key assert (skip t) (eof-action t))
|
||||
"Read characters from *STANDARD-INPUT* as long as they are
|
||||
whitespace. Signals an error if the first character read isn't
|
||||
whitespace and ASSERT is true. Return the string which was read unless
|
||||
SKIP is true. See READ-WHILE's docstring for EOF-ACTION."
|
||||
(handler-case
|
||||
(progn
|
||||
(when assert
|
||||
(with-syntax-error-location ()
|
||||
(unless (whitespacep (peek-char))
|
||||
(signal-template-syntax-error "Whitespace expected but read ~S" (peek-char)))))
|
||||
(read-while (lambda (c)
|
||||
(whitespacep c))
|
||||
:skip skip
|
||||
:eof-action eof-action))
|
||||
(end-of-file ()
|
||||
(cond ((eq eof-action t)
|
||||
(signal-template-syntax-error "EOF while skipping whitespace"))
|
||||
((null eof-action)
|
||||
nil)
|
||||
(t (funcall eof-action ""))))))
|
||||
|
||||
(defun skip-trailing-whitespace ()
|
||||
"Reads and skips whitespace from *STANDARD-INPUT* until a #\Newline
|
||||
characters is seen if *IGNORE-EMPTY-LINES* is true. If there is no
|
||||
#\Newline before the first non-whitespace character the string read so
|
||||
far is returned \(wrapped in a list)."
|
||||
(cond (*ignore-empty-lines*
|
||||
(let ((string (read-while (lambda (c)
|
||||
(and (whitespacep c)
|
||||
(char/= #\Newline c)))
|
||||
:skip nil
|
||||
:eof-action nil)))
|
||||
(case (peek-char nil nil nil nil)
|
||||
((#\Newline)
|
||||
nil)
|
||||
(otherwise
|
||||
(list string)))))
|
||||
(t nil)))
|
||||
|
||||
(defun read-until (string &key (skip t) (eof-action t))
|
||||
"Reads characters from *STANDARD-INPUT* up to and including STRING.
|
||||
Returns the string which was read \(excluding STRING) unless SKIP is
|
||||
true. See READ-WHILE's docstring for EOF-ACTION."
|
||||
(let* ((length (length string))
|
||||
(offsets
|
||||
;; we first check whether some substring which starts
|
||||
;; STRING can be found again later in STRING - this is
|
||||
;; necessary because we only peek one character ahead
|
||||
(cond ((gethash string *find-string-hash*))
|
||||
(t (setf (gethash string *find-string-hash*)
|
||||
;; the resulting array of offsets is
|
||||
;; cached in *FIND-STRING-HASH* so we can
|
||||
;; use it again in case READ-UNTIL is
|
||||
;; called with the same STRING argument
|
||||
(loop with offsets = (make-array length
|
||||
:initial-element nil)
|
||||
for i from 1 below length
|
||||
;; check if STRING starting from 0
|
||||
;; has something in common with
|
||||
;; STRING starting from I
|
||||
for mismatch = (mismatch string string
|
||||
:start1 i :test #'char=)
|
||||
when (> mismatch i)
|
||||
;; if this is the case remember the
|
||||
;; length of the match plus the
|
||||
;; character which must follow in
|
||||
;; OFFSETS
|
||||
do (push (cons (char string (- mismatch i))
|
||||
(1+ (- mismatch i)))
|
||||
(svref offsets mismatch))
|
||||
finally (return offsets))))))
|
||||
(collector (or skip
|
||||
(make-array 0
|
||||
:element-type 'character
|
||||
:fill-pointer t
|
||||
:adjustable t))))
|
||||
(handler-case
|
||||
(loop for i = 0 then (cond (match (1+ i))
|
||||
;; if there is an offset (see above)
|
||||
;; we don't have to start from the
|
||||
;; beginning of STRING
|
||||
((cdr (assoc c (svref offsets i))))
|
||||
(t 0))
|
||||
for c = (peek-char)
|
||||
for match = (char= c (char string i))
|
||||
while (or (not match)
|
||||
(< (1+ i) length))
|
||||
do (cond (skip (%read-char))
|
||||
(t (vector-push-extend (%read-char) collector)))
|
||||
finally (%read-char)
|
||||
(unless skip
|
||||
;; decrement the fill pointer because collector now also
|
||||
;; contains STRING itself
|
||||
(decf (fill-pointer collector) (1- length)))
|
||||
(return collector))
|
||||
(end-of-file ()
|
||||
(cond ((eq eof-action t)
|
||||
(signal-template-syntax-error "Unexpected EOF"))
|
||||
((null eof-action)
|
||||
nil)
|
||||
(t (funcall eof-action collector)))))))
|
||||
|
||||
(defun skip-leading-whitespace (string)
|
||||
"Removes whitespace from the end of STRING up to and including a
|
||||
#\Newline. If there is no #\Newline before the first non-whitespace
|
||||
character is seen nothing is removed. STRING must have a fill
|
||||
pointer."
|
||||
(when *ignore-empty-lines*
|
||||
(let ((old-fill-pointer (fill-pointer string)))
|
||||
(loop for fill-pointer = (fill-pointer string)
|
||||
for char = (and (plusp fill-pointer)
|
||||
(char string (1- fill-pointer)))
|
||||
while (and char
|
||||
(whitespacep char)
|
||||
(char/= #\Newline char))
|
||||
do (decf (fill-pointer string)))
|
||||
(cond ((let ((fill-pointer (fill-pointer string)))
|
||||
(and (plusp fill-pointer)
|
||||
(char= #\Newline (char string (1- fill-pointer)))))
|
||||
(decf (fill-pointer string)))
|
||||
(t
|
||||
(setf (fill-pointer string)
|
||||
old-fill-pointer)))))
|
||||
string)
|
||||
|
||||
(defun read-tag-rest (&key read-attribute (intern t) (eof-action t))
|
||||
"Reads the rest of a template tag from *STANDARD-INPUT* after the
|
||||
name of the tag has been read. Reads and returns the tag's attribute
|
||||
if READ-ATTRIBUTE is true. Optionally also interns the attribute
|
||||
string if INTERN is true. See READ-WHILE's docstring for EOF-ACTION."
|
||||
(with-syntax-error-location ()
|
||||
(let (rest)
|
||||
(handler-case
|
||||
(let ((attribute (and read-attribute
|
||||
(progn
|
||||
(skip-whitespace :assert t)
|
||||
(let ((string (with-syntax-error-location ()
|
||||
(read-delimited-string :eof-action
|
||||
(lambda (collector)
|
||||
(declare (ignore collector))
|
||||
(signal-template-syntax-error
|
||||
"EOF while reading tag attribute"))))))
|
||||
(if intern
|
||||
(intern
|
||||
(funcall (if *upcase-attribute-strings*
|
||||
#'string-upcase
|
||||
#'identity)
|
||||
string)
|
||||
*template-symbol-package*)
|
||||
string))))))
|
||||
(skip-whitespace)
|
||||
(setq rest (read-until *template-end-marker*
|
||||
:skip nil
|
||||
:eof-action eof-action))
|
||||
(when (plusp (length rest))
|
||||
(signal-template-syntax-error "Expected ~S but read ~S"
|
||||
*template-end-marker*
|
||||
rest))
|
||||
attribute)
|
||||
(end-of-file ()
|
||||
(cond ((eq eof-action t)
|
||||
(signal-template-syntax-error "Unexpected EOF"))
|
||||
((null eof-action)
|
||||
nil)
|
||||
(t (funcall eof-action rest))))))))
|
||||
|
||||
(defun escape-string (string &key (test *escape-char-p*))
|
||||
(declare (optimize speed))
|
||||
"Escape all characters in STRING which pass TEST. This function is
|
||||
not guaranteed to return a fresh string. Note that you can pass NIL
|
||||
for STRING which'll just be returned."
|
||||
(let ((first-pos (position-if test string)))
|
||||
(if (not first-pos)
|
||||
;; nothing to do, just return STRING
|
||||
string
|
||||
(with-output-to-string (s)
|
||||
(loop with len = (length string)
|
||||
for old-pos = 0 then (1+ pos)
|
||||
for pos = first-pos
|
||||
then (position-if test string :start old-pos)
|
||||
;; now the characters from OLD-POS to (excluding) POS
|
||||
;; don't have to be escaped while the next character has to
|
||||
for char = (and pos (char string pos))
|
||||
while pos
|
||||
do (write-sequence string s :start old-pos :end pos)
|
||||
(case char
|
||||
((#\<)
|
||||
(write-sequence "<" s))
|
||||
((#\>)
|
||||
(write-sequence ">" s))
|
||||
((#\&)
|
||||
(write-sequence "&" s))
|
||||
((#\')
|
||||
(write-sequence "'" s))
|
||||
((#\")
|
||||
(write-sequence """ s))
|
||||
(otherwise
|
||||
(format s "&#~d;" (char-code char))))
|
||||
while (< (1+ pos) len)
|
||||
finally (unless pos
|
||||
(write-sequence string s :start old-pos)))))))
|
||||
|
||||
(defun escape-string-minimal (string)
|
||||
"Escape only #\<, #\>, and #\& in STRING."
|
||||
(escape-string string :test #'(lambda (char) (find char "<>&"))))
|
||||
|
||||
(defun escape-string-minimal-plus-quotes (string)
|
||||
"Like ESCAPE-STRING-MINIMAL but also escapes quotes."
|
||||
(escape-string string :test #'(lambda (char) (find char "<>&'\""))))
|
||||
|
||||
(defun escape-string-iso-8859-1 (string)
|
||||
"Escapes all characters in STRING which aren't defined in ISO-8859-1."
|
||||
(escape-string string :test #'(lambda (char)
|
||||
(or (find char "<>&'\"")
|
||||
(> (char-code char) 255)))))
|
||||
|
||||
(defun escape-string-all (string)
|
||||
"Escapes all characters in STRING which aren't in the 7-bit ASCII
|
||||
character set."
|
||||
(escape-string string :test #'(lambda (char)
|
||||
(or (find char "<>&'\"")
|
||||
(> (char-code char) 127)))))
|
||||
1
sbcl/.quicklisp/dists/quicklisp/software/quickproject-1.4.1/.gitignore
vendored
Normal file
1
sbcl/.quicklisp/dists/quicklisp/software/quickproject-1.4.1/.gitignore
vendored
Normal file
|
|
@ -0,0 +1 @@
|
|||
*~
|
||||
|
|
@ -0,0 +1,19 @@
|
|||
Copyright (c) 2010 Zachary Beane
|
||||
|
||||
Permission is hereby granted, free of charge, to any person obtaining a copy
|
||||
of this software and associated documentation files (the "Software"), to deal
|
||||
in the Software without restriction, including without limitation the rights
|
||||
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
|
||||
copies of the Software, and to permit persons to whom the Software is
|
||||
furnished to do so, subject to the following conditions:
|
||||
|
||||
The above copyright notice and this permission notice shall be included in
|
||||
all copies or substantial portions of the Software.
|
||||
|
||||
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
||||
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
||||
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
|
||||
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
||||
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
|
||||
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
|
||||
THE SOFTWARE.
|
||||
|
|
@ -0,0 +1,8 @@
|
|||
Quickproject creates the skeleton of a Common Lisp project.
|
||||
|
||||
For full documentation, see doc/index.html.
|
||||
|
||||
Quickproject is licensed under the MIT license; see LICENSE.txt for
|
||||
details.
|
||||
|
||||
For questions or comments, please email Zach Beane <xach@xach.com>.
|
||||
|
|
@ -0,0 +1,12 @@
|
|||
# (#| TMPL_VAR name |#)
|
||||
### _(#| TMPL_VAR author |#)_
|
||||
|
||||
This is a project to do ... something.
|
||||
|
||||
## License
|
||||
|
||||
(#| TMPL_VAR license |#)
|
||||
(#| TMPL_IF copyright |#)
|
||||
|
||||
(#| TMPL_VAR copyright |#)
|
||||
(#| /TMPL_IF |#)
|
||||
|
|
@ -0,0 +1,5 @@
|
|||
;;;; (#| TMPL_VAR name |#).lisp(#| TMPL_IF copyright |#)
|
||||
;;
|
||||
;;;; (#| TMPL_VAR copyright |#)(#| /TMPL_IF |#)
|
||||
|
||||
(in-package #:(#| TMPL_VAR name |#))
|
||||
|
|
@ -0,0 +1,6 @@
|
|||
;;;; package.lisp(#| TMPL_IF copyright |#)
|
||||
;;
|
||||
;;;; (#| TMPL_VAR copyright |#)(#| /TMPL_IF |#)
|
||||
|
||||
(defpackage #:(#| TMPL_VAR name |#)
|
||||
(:use #:cl))
|
||||
|
|
@ -0,0 +1,13 @@
|
|||
;;;; (#| TMPL_VAR name |#).asd(#| TMPL_IF copyright |#)
|
||||
;;
|
||||
;;;; (#| TMPL_VAR copyright |#)(#| /TMPL_IF |#)
|
||||
|
||||
(asdf:defsystem #:(#| TMPL_VAR name |#)
|
||||
:description "Describe (#| TMPL_VAR name |#) here"
|
||||
:author "(#| TMPL_VAR author |#)"
|
||||
:license "(#| TMPL_VAR license |#)"
|
||||
:version "0.0.1"
|
||||
:serial t(#| TMPL_IF depends-on |#)
|
||||
:depends-on (#| TMPL_VAR dependencies-string |#)(#| /TMPL_IF |#)
|
||||
:components ((:file "package")
|
||||
(:file "(#| TMPL_VAR name |#)")))
|
||||
|
|
@ -0,0 +1,19 @@
|
|||
Copyright (c) 2012 Zachary Beane
|
||||
|
||||
Permission is hereby granted, free of charge, to any person obtaining a copy
|
||||
of this software and associated documentation files (the "Software"), to deal
|
||||
in the Software without restriction, including without limitation the rights
|
||||
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
|
||||
copies of the Software, and to permit persons to whom the Software is
|
||||
furnished to do so, subject to the following conditions:
|
||||
|
||||
The above copyright notice and this permission notice shall be included in
|
||||
all copies or substantial portions of the Software.
|
||||
|
||||
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
||||
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
||||
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
|
||||
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
||||
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
|
||||
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
|
||||
THE SOFTWARE.
|
||||
|
|
@ -0,0 +1,265 @@
|
|||
<html>
|
||||
<head>
|
||||
<meta http-equiv="Content-Type" content="text/html; charset=UTF-8" />
|
||||
<link rel='stylesheet' type='text/css' href='style.css'>
|
||||
<title>Quickproject - create a Common Lisp project skeleton</title>
|
||||
</head>
|
||||
<body>
|
||||
|
||||
<div id='content'>
|
||||
<h2>Quickproject - create a Common Lisp project skeleton</h2>
|
||||
|
||||
<p>Quickproject is a library for creating a Common Lisp project
|
||||
skeleton. It is available under a BSD-style license;
|
||||
see <a href='LICENSE.txt'>LICENSE.txt</a> for details.
|
||||
|
||||
The latest version is 1.4.1, released on December 26th, 2019.
|
||||
|
||||
|
||||
<p>Download
|
||||
shortcut: <a href='http://www.xach.com/lisp/quickproject.tgz'>http://www.xach.com/lisp/quickproject.tgz</a>
|
||||
|
||||
<h2>Contents</h2>
|
||||
|
||||
<ul>
|
||||
<li> <a href='#overview'>Overview</a>
|
||||
<li> <a href='#examples'>Examples</a>
|
||||
<li> <a href='#dictionary'>Dictionary</a>
|
||||
<ul>
|
||||
<li> <a href='#make-project'>make-project</a>
|
||||
<li> <a href='#*author*'>*author*</a>
|
||||
<li> <a href='#*include-copyright*'>*include-copyright*</a>
|
||||
<li> <a href='#*license*'>*license*</a>
|
||||
<li> <a href='#*template-directory*'>*template-directory*</a>
|
||||
<li> <a href='#default-template-parameters'>default-template-parameters</a>
|
||||
<li> <a href='#*template-parameter-functions*'>*template-parameter-functions*</a>
|
||||
<li> <a href='#*after-make-project-hooks*'>*after-make-project-hooks*</a>
|
||||
</ul>
|
||||
<li> <a href='#feedback'>Feedback</a>
|
||||
</ul>
|
||||
|
||||
<a name='overview'><h2>Overview</h2></a>
|
||||
|
||||
<p>Quickproject provides a quick way to make a Common Lisp
|
||||
project. After creating a project, it extends the ASDF registry so
|
||||
the project may be immediately loaded.
|
||||
|
||||
<a name='example'><h2>Examples</h2></a>
|
||||
|
||||
<pre class=code>
|
||||
* <b>(quickproject:make-project #p"~/src/myproject/" :depends-on '(drakma cxml))</b>
|
||||
"myproject"
|
||||
|
||||
* <b>(asdf:load-system "myproject")</b>
|
||||
<i>load output</i>
|
||||
</pre>
|
||||
|
||||
<pre class='code'>
|
||||
* <b>(quickproject:make-project #p"~/src/websnarf/" :name "cl-websnarf")</b>
|
||||
"cl-websnarf"
|
||||
|
||||
* <b>(directory #p"~/src/websnarf/*.*")</b>
|
||||
(#p"~/src/websnarf/README.txt"
|
||||
#p"~/src/websnarf/package.lisp"
|
||||
#p"~/src/websnarf/cl-websnarf.asd"
|
||||
#p"~/src/websnarf/cl-websnarf.lisp")
|
||||
</pre>
|
||||
|
||||
<a name='dictionary'><h2>Dictionary</h2></a>
|
||||
|
||||
<p>The following symbols are exported from the <tt>quickproject</tt>
|
||||
package.
|
||||
|
||||
<div class='item'>
|
||||
<div class='type'><a name='make-project'>[Function]</a></div>
|
||||
<div class='signature'>
|
||||
<code class='name'>make-project</code>
|
||||
<span class='args'>
|
||||
<var>pathname</var> <code class='llkw'>&key</code>
|
||||
<var>depends-on</var>
|
||||
<var>author</var>
|
||||
<var>include-copyright</var>
|
||||
<var>license</var>
|
||||
<var>name</var>
|
||||
<var>template-directory</var>
|
||||
<var>template-parameters</var>
|
||||
</span>
|
||||
<span class='result'>=> <var>project-name</var></span>
|
||||
</div>
|
||||
|
||||
<blockquote class='description'>
|
||||
<p>Create the skeleton of a Common Lisp project
|
||||
in <var>directory</var>. If given, <var>name</var> is used as the
|
||||
name of the project. Otherwise, the name is taken from the last
|
||||
component in
|
||||
the <a href="http://l1sp.org/cl/pathname-directory">pathname-directory</a>
|
||||
of the pathname. For example, the last directory component
|
||||
of <tt>#p"src/lisp/myproject/"</tt> is "myproject".
|
||||
<p>The project skeleton consists of the following files:
|
||||
|
||||
<ul>
|
||||
<li> README.txt
|
||||
<li> package.lisp — defines a package named after the project
|
||||
<li> <var>name</var>.asd — defines an ASDF system named after
|
||||
the project, with a <tt>:depends-on</tt> list as given in the
|
||||
function call
|
||||
<li> <var>name</var>.lisp
|
||||
</ul>
|
||||
|
||||
<p>If provided, <var>author</var> and <var>license</var> are used
|
||||
to initialize certain parts of the default files with extra
|
||||
information. The default values are taken
|
||||
from <a href='#*author*'><tt>*AUTHOR*</tt></a>
|
||||
and <a href='#*license*'><tt>*LICENSE*</tt></a>, respectively.
|
||||
|
||||
<p>If provided, the boolean argument to <var>include-copyright</var>
|
||||
will determine whether copyright notices will be printed in the
|
||||
header of each file.
|
||||
|
||||
<p>If provided, each file in <var>template-directory</var> is
|
||||
rewritten
|
||||
with <a href="http://weitz.de/html-template/">HTML-TEMPLATE</a>
|
||||
into the new directory. The options are as follows:
|
||||
|
||||
<ul>
|
||||
<li> The template markers are <tt>(#|</tt> and <tt>|#)</tt>
|
||||
<li> No escaping is done in template values
|
||||
<li> Template parameters are created by
|
||||
appending <var>template-parameters</var> with the lists returned by
|
||||
calling each entry
|
||||
in <a href='#*template-parameter-functions*'><tt>*TEMPLATE-PARAMETER-FUNCTIONS*</tt></a>
|
||||
</ul>
|
||||
|
||||
<p>After rewriting templates, each element
|
||||
in <a href='#*after-make-project-hooks*'><tt>*AFTER-MAKE-PROJECT-HOOKS*</tt></a>
|
||||
is called.
|
||||
|
||||
<p>After the project has been created, its pathname is added
|
||||
to <tt>ASDF:*CENTRAL-REGISTRY*</tt>, so the project is immediately
|
||||
loadable via <tt>ASDF:LOAD-SYSTEM</tt>.
|
||||
</blockquote>
|
||||
</div>
|
||||
|
||||
|
||||
<div class='item'>
|
||||
<div class='type'><a name='*author*'>[Special variable]</a></div>
|
||||
<div class='signature'>
|
||||
<code class='name'>*author*</code>
|
||||
</div>
|
||||
|
||||
<blockquote class='description'>
|
||||
<p>This string is used to initialize the <tt>:author</tt> argument
|
||||
in the project system definition. The default initial value
|
||||
is <tt>"Your Name <your.name@example.com>"</tt>.
|
||||
</blockquote>
|
||||
</div>
|
||||
|
||||
<div class='item'>
|
||||
<div class='type'><a name='*include-copyright*'>[Special variable]</a></div>
|
||||
<div class='signature'>
|
||||
<code class='name'>*include-copyright*</code>
|
||||
</div>
|
||||
|
||||
<blockquote class='description'>
|
||||
<p>This variable is used to control whether a copyright notice (with
|
||||
the author's name and the current year) should appear in the header
|
||||
of each file.</tt>.
|
||||
</blockquote>
|
||||
</div>
|
||||
|
||||
<div class='item'>
|
||||
<div class='type'><a name='*license*'>[Special variable]</a></div>
|
||||
<div class='signature'>
|
||||
<code class='name'>*license*</code>
|
||||
</div>
|
||||
|
||||
<blockquote class='description'>
|
||||
<p>This string is used to initialize the <tt>:description</tt>
|
||||
argument in the project system definition. The default initial
|
||||
value is <tt>"Specify license here"</tt>.
|
||||
</blockquote>
|
||||
</div>
|
||||
|
||||
<div class='item'>
|
||||
<div class='type'><a name='*template-directory*'>[Special variable]</a></div>
|
||||
<div class='signature'>
|
||||
<code class='name'>*template-directory*</code>
|
||||
</div>
|
||||
|
||||
<blockquote class='description'>
|
||||
<p>If non-NIL, this variable should be bound to a pathname used as
|
||||
the default value of <var>template-directory</var>
|
||||
in <a href='#make-project'><tt>MAKE-PROJECT</tt></a>.
|
||||
</blockquote>
|
||||
</div>
|
||||
|
||||
<div class='item'>
|
||||
<div class='type'><a name='default-template-parameters'>[Function]</a></div>
|
||||
<div class='signature'>
|
||||
<code class='name'>default-template-parameters</code>
|
||||
<span class='args'>
|
||||
</span>
|
||||
<span class='result'>=> <var>parameters</var></span>
|
||||
</div>
|
||||
|
||||
<blockquote class='description'>
|
||||
<p>Return a plist with values for <tt>:name</tt>, <tt>:license</tt>,
|
||||
and <tt>:author</tt> for the current project being created
|
||||
via <a href='#make-project'><tt>MAKE-PROJECT</tt></a>. This
|
||||
function is in the default value
|
||||
of <a href='#*template-parameter-functions*'><tt>*TEMPLATE-PARAMETER-FUNCTIONS*</tt></a>.
|
||||
|
||||
</blockquote>
|
||||
</div>
|
||||
|
||||
|
||||
<div class='item'>
|
||||
<div class='type'><a name='*template-parameter-functions*'>[Special variable]</a></div>
|
||||
<div class='signature'>
|
||||
<code class='name'>*template-parameter-functions*</code>
|
||||
</div>
|
||||
|
||||
<blockquote class='description'>
|
||||
<p>A list of functions that are called to produce template
|
||||
parameters when rewriting templates
|
||||
in <a href='#make-project'><tt>MAKE-PROJECT</tt></a>. Each
|
||||
function is called with no arguments and should produce a list
|
||||
of keyword/value pairs. The resulting lists are appended
|
||||
together for use as template parameters
|
||||
in <a href='http://weitz.de/html-template/#fill-and-print-template'><tt>HTML-TEMPLATE:FILL-AND-PRINT-TEMPLATE</tt></a>.
|
||||
|
||||
<p>The default value is <tt>(default-template-parameters)</tt>.
|
||||
</blockquote>
|
||||
</div>
|
||||
|
||||
|
||||
<div class='item'>
|
||||
<div class='type'><a name='*after-make-project-hooks*'>[Special variable]</a></div>
|
||||
<div class='signature'>
|
||||
<code class='name'>*after-make-project-hooks*</code>
|
||||
</div>
|
||||
|
||||
<blockquote class='description'>
|
||||
<p>A list of designators for functions to be called after a
|
||||
project has been created. Each function should accept one required
|
||||
argument, the pathname given
|
||||
to <a href='#make-project'><tt>MAKE-PROJECT</tt></a>, and two
|
||||
keyword arguments, <tt>:name</tt> and <tt>:depends-on</tt>, which
|
||||
correspond to the name of the project (whether explicitly supplied
|
||||
to <tt>MAKE-PROJECT</tt> or derived from the pathname) and the
|
||||
<tt>:depends-on</tt> argument,
|
||||
respectively. <tt>*default-pathname-defaults*</tt> is bound to the
|
||||
newly created project pathname when hooks are called.
|
||||
</blockquote>
|
||||
</div>
|
||||
|
||||
|
||||
<a name='feedback'><h2>Feedback</h2></a>
|
||||
|
||||
<p>For questions or comments about Quickproject, please email me, Zach
|
||||
Beane <<a href='mailto:xach@xach.com'>xach@xach.com</a>>.
|
||||
|
||||
</div>
|
||||
<br><br><br>
|
||||
|
||||
</body>
|
||||
|
|
@ -0,0 +1,83 @@
|
|||
|
||||
body {
|
||||
margin-left: 4em;
|
||||
font: medium/1.45em "Lucida Grande", "Trebuchet MS", "Bitstream Vera Sans", Verdana, Helvetica, sans-serif;
|
||||
|
||||
}
|
||||
|
||||
p.copyright {
|
||||
font-size: 75%;
|
||||
font-weight: bold;
|
||||
}
|
||||
|
||||
#content {
|
||||
margin-left: 4em;
|
||||
margin-right: 4em;
|
||||
max-width: 50em;
|
||||
}
|
||||
|
||||
h2, h3 {
|
||||
margin-bottom: 0em;
|
||||
margin-top: 2em;
|
||||
}
|
||||
|
||||
p.html {
|
||||
margin-left: 1em;
|
||||
font-family: monospace;
|
||||
}
|
||||
|
||||
.type {
|
||||
color: #999;
|
||||
}
|
||||
|
||||
.signature {
|
||||
color: #A01;
|
||||
margin-left: 1em;
|
||||
}
|
||||
|
||||
.signature span.result {
|
||||
color: black;
|
||||
}
|
||||
|
||||
.signature code.llkw {
|
||||
font-family: monospace;
|
||||
}
|
||||
|
||||
.signature span.result var {
|
||||
color: #A01;
|
||||
}
|
||||
|
||||
div.signature {
|
||||
margin-left: 1.5em;
|
||||
text-indent: -1.5em;
|
||||
}
|
||||
|
||||
.signature code.name {
|
||||
font-weight: bold;
|
||||
}
|
||||
|
||||
.signature code {
|
||||
font-family: sans-serif;
|
||||
}
|
||||
|
||||
blockquote.description {
|
||||
margin-left: 1em;
|
||||
}
|
||||
|
||||
a[href] {
|
||||
text-decoration: none;
|
||||
border-bottom: dotted 1px #CCC;
|
||||
color: #600;
|
||||
}
|
||||
|
||||
a:hover[href] {
|
||||
text-decoration: none;
|
||||
border-bottom: solid 1px #F00;
|
||||
color: #F00;
|
||||
}
|
||||
|
||||
pre.code {
|
||||
border: solid 1px #DDD;
|
||||
padding: 0.5em;
|
||||
background: #EEE;
|
||||
}
|
||||
|
|
@ -0,0 +1,23 @@
|
|||
;;;; package.lisp
|
||||
|
||||
(defpackage #:quickproject
|
||||
(:documentation "The Quickproject package.")
|
||||
(:use #:cl)
|
||||
(:export #:make-project
|
||||
#:*after-make-project-hooks*
|
||||
#:*author*
|
||||
#:*license*
|
||||
#:*template-directory*
|
||||
#:*include-copyright*
|
||||
#:default-template-parameters
|
||||
#:*template-parameter-functions*)
|
||||
(:shadowing-import-from #:html-template
|
||||
#:fill-and-print-template
|
||||
#:*template-start-marker*
|
||||
#:*template-end-marker*)
|
||||
(:shadowing-import-from #:cl-fad
|
||||
#:pathname-as-directory
|
||||
#:walk-directory))
|
||||
|
||||
(in-package #:quickproject)
|
||||
|
||||
|
|
@ -0,0 +1,12 @@
|
|||
;;;; quickproject.asd
|
||||
|
||||
(asdf:defsystem #:quickproject
|
||||
:description "Creates the skeleton of a new Common Lisp project"
|
||||
:version "1.4.1"
|
||||
:author "Zach Beane <xach@xach.com>"
|
||||
:license "MIT"
|
||||
:depends-on (#:cl-fad
|
||||
#:html-template)
|
||||
:serial t
|
||||
:components ((:file "package")
|
||||
(:file "quickproject")))
|
||||
|
|
@ -0,0 +1,144 @@
|
|||
;;;; quickproject.lisp
|
||||
|
||||
(in-package #:quickproject)
|
||||
|
||||
(defvar *name*)
|
||||
(setf (documentation '*name* 'variable)
|
||||
"The name of the project currently being created.")
|
||||
|
||||
(defvar *template-directory* (asdf:system-relative-pathname :quickproject "default-template")
|
||||
"A directory to use as a source of template files.")
|
||||
|
||||
(defvar *depends-on* nil
|
||||
"Dependencies specified at project creation")
|
||||
|
||||
(defvar *author*
|
||||
"Your Name <your.name@example.com>"
|
||||
"Set this variable to your contact information.")
|
||||
|
||||
(defvar *license*
|
||||
"Specify license here")
|
||||
|
||||
(defvar *include-copyright* nil ; This gives default behavior.
|
||||
"Include a copyright notice at the top of files.")
|
||||
|
||||
(defun pathname-project-name (pathname)
|
||||
"Return a project name based on PATHNAME by taking the last element
|
||||
in the pathname-directory list. E.g. returns \"awesome-project\" for
|
||||
#p\"src/awesome-project/\"."
|
||||
(first (last (pathname-directory pathname))))
|
||||
|
||||
(defmacro with-new-file ((stream file) &body body)
|
||||
"Like WITH-OPEN-FILE, but specialized for output to a file that must
|
||||
not already exist."
|
||||
`(with-open-file (,stream ,file
|
||||
:direction :output
|
||||
:if-exists :error)
|
||||
(let ((*print-case* :downcase))
|
||||
,@body)))
|
||||
|
||||
(defun current-year ()
|
||||
(nth-value 5 (decode-universal-time (get-universal-time))))
|
||||
|
||||
(defvar *after-make-project-hooks* nil
|
||||
"A list of functions to call after MAKE-PROJECT is finished making a
|
||||
project. Each function is called with the same arguments passed to
|
||||
MAKE-PROJECT, except that NAME is canonicalized if
|
||||
necessary. *DEFAULT-PATHNAME-DEFAULTS* bound to the newly created
|
||||
project directory.")
|
||||
|
||||
(defun matches-template-p (pathname template)
|
||||
(and (equal (pathname-name pathname) (pathname-name template))
|
||||
(equal (pathname-type pathname) (pathname-type template))))
|
||||
|
||||
(defun template-pathname->output-name (path)
|
||||
(if (or (matches-template-p path "system.asd")
|
||||
(matches-template-p path "application.lisp"))
|
||||
(make-pathname :name *name* :defaults path)
|
||||
path))
|
||||
|
||||
(defun rewrite-templates (template-directory target-directory parameters)
|
||||
"Treat every file in TEMPLATE-DIRECTORY as a template file; fill it
|
||||
out using PARAMETERS into a corresponding file in
|
||||
TARGET-DIRECTORY. The rewriting uses HTML-TEMPLATE. The template start
|
||||
marker is the string \"\(#|\" and the template end marker is the string
|
||||
\"|#)\". Template vars are not modified or escaped when written."
|
||||
(let ((*template-start-marker* "(#|")
|
||||
(*template-end-marker* "|#)")
|
||||
(html-template:*warn-on-creation* nil)
|
||||
(html-template:*string-modifier* 'identity))
|
||||
(setf template-directory (truename template-directory)
|
||||
target-directory (truename target-directory))
|
||||
(flet ((rewrite-template (pathname)
|
||||
(let* ((relative-namestring
|
||||
(enough-namestring pathname template-directory))
|
||||
(target-pathname (template-pathname->output-name
|
||||
(merge-pathnames relative-namestring
|
||||
target-directory))))
|
||||
(ensure-directories-exist target-pathname)
|
||||
(with-open-file (stream
|
||||
target-pathname
|
||||
:direction :output
|
||||
:if-exists :rename-and-delete)
|
||||
(fill-and-print-template pathname
|
||||
parameters
|
||||
:stream stream)))))
|
||||
(walk-directory template-directory #'rewrite-template))))
|
||||
|
||||
(defun default-template-parameters ()
|
||||
"Return a plist of :NAME, :LICENSE, and :AUTHOR parameters."
|
||||
(list :name *name*
|
||||
:license *license*
|
||||
:author *author*
|
||||
:depends-on (mapcar
|
||||
(lambda (sym)
|
||||
(list :symbol sym :uninterned (format nil "#:~(~a~)" sym)))
|
||||
*depends-on*)
|
||||
:dependencies-string (format nil "(~{#:~(~a~)~^ ~})" *depends-on*)
|
||||
:copyright (when *include-copyright*
|
||||
(format nil "Copyright (c) ~D ~A~%" (current-year) *author*))))
|
||||
|
||||
(defvar *template-parameter-functions* (list 'default-template-parameters)
|
||||
"A list of functions that return plists for use when rewriting
|
||||
template files. The results of calling each function are appended
|
||||
together to pass to FILL-AND-PRINT-TEMPLATE.")
|
||||
|
||||
(defun template-parameters (initial-parameters)
|
||||
"Return all template parameters returned by calling each element in
|
||||
*TEMPLATE-PARAMETER-FUNCTIONS*, appended together as a single plist."
|
||||
(apply 'append initial-parameters
|
||||
(mapcar 'funcall *template-parameter-functions*)))
|
||||
|
||||
(defun make-project (pathname &key
|
||||
template-parameters
|
||||
((:template-directory *template-directory*)
|
||||
*template-directory*)
|
||||
((:depends-on *depends-on*) *depends-on*)
|
||||
((:author *author*) *author*)
|
||||
((:license *license*) *license*)
|
||||
(name (pathname-project-name pathname) name-provided-p)
|
||||
((:include-copyright *include-copyright*) *include-copyright*))
|
||||
"Create a project skeleton for NAME in PATHNAME. If DEPENDS-ON is provided,
|
||||
it is used as the asdf defsystem depends-on list."
|
||||
(check-type *depends-on* list)
|
||||
(when (pathname-name pathname)
|
||||
(warn "Coercing ~S to directory"
|
||||
pathname)
|
||||
(setf pathname (pathname-as-directory pathname))
|
||||
(unless name-provided-p
|
||||
(setf name (pathname-project-name pathname))))
|
||||
(labels ((relative (file)
|
||||
(merge-pathnames file pathname))
|
||||
(nametype (type)
|
||||
(relative (make-pathname :name name :type type))))
|
||||
(ensure-directories-exist pathname)
|
||||
(let ((*default-pathname-defaults* (truename pathname))
|
||||
(*name* name))
|
||||
(rewrite-templates *template-directory* *default-pathname-defaults*
|
||||
(template-parameters template-parameters))
|
||||
(pushnew *default-pathname-defaults* asdf:*central-registry*
|
||||
:test 'equal)
|
||||
(dolist (hook *after-make-project-hooks*)
|
||||
(funcall hook pathname :depends-on *depends-on* :name name
|
||||
:allow-other-keys t)))
|
||||
name))
|
||||
Binary file not shown.
|
|
@ -99,7 +99,13 @@ let s:mac_gui = has('gui_macvim') && has('gui_running')
|
|||
let s:is_win = has('win32')
|
||||
let s:nvim = has('nvim-0.2') || (has('nvim') && exists('*jobwait') && !s:is_win)
|
||||
let s:vim8 = has('patch-8.0.0039') && exists('*job_start')
|
||||
let s:me = resolve(expand('<sfile>:p'))
|
||||
if s:is_win && &shellslash
|
||||
set noshellslash
|
||||
let s:me = resolve(expand('<sfile>:p'))
|
||||
set shellslash
|
||||
else
|
||||
let s:me = resolve(expand('<sfile>:p'))
|
||||
endif
|
||||
let s:base_spec = { 'branch': 'master', 'frozen': 0 }
|
||||
let s:TYPE = {
|
||||
\ 'string': type(''),
|
||||
|
|
@ -110,10 +116,42 @@ let s:TYPE = {
|
|||
let s:loaded = get(s:, 'loaded', {})
|
||||
let s:triggers = get(s:, 'triggers', {})
|
||||
|
||||
if s:is_win
|
||||
function! s:plug_call(fn, ...)
|
||||
let shellslash = &shellslash
|
||||
try
|
||||
set noshellslash
|
||||
return call(a:fn, a:000)
|
||||
finally
|
||||
let &shellslash = shellslash
|
||||
endtry
|
||||
endfunction
|
||||
else
|
||||
function! s:plug_call(fn, ...)
|
||||
return call(a:fn, a:000)
|
||||
endfunction
|
||||
endif
|
||||
|
||||
function! s:plug_getcwd()
|
||||
return s:plug_call('getcwd')
|
||||
endfunction
|
||||
|
||||
function! s:plug_fnamemodify(fname, mods)
|
||||
return s:plug_call('fnamemodify', a:fname, a:mods)
|
||||
endfunction
|
||||
|
||||
function! s:plug_expand(fmt)
|
||||
return s:plug_call('expand', a:fmt, 1)
|
||||
endfunction
|
||||
|
||||
function! s:plug_tempname()
|
||||
return s:plug_call('tempname')
|
||||
endfunction
|
||||
|
||||
function! plug#begin(...)
|
||||
if a:0 > 0
|
||||
let s:plug_home_org = a:1
|
||||
let home = s:path(fnamemodify(expand(a:1), ':p'))
|
||||
let home = s:path(s:plug_fnamemodify(s:plug_expand(a:1), ':p'))
|
||||
elseif exists('g:plug_home')
|
||||
let home = s:path(g:plug_home)
|
||||
elseif !empty(&rtp)
|
||||
|
|
@ -121,7 +159,7 @@ function! plug#begin(...)
|
|||
else
|
||||
return s:err('Unable to determine plug home. Try calling plug#begin() with a path argument.')
|
||||
endif
|
||||
if fnamemodify(home, ':t') ==# 'plugin' && fnamemodify(home, ':h') ==# s:first_rtp
|
||||
if s:plug_fnamemodify(home, ':t') ==# 'plugin' && s:plug_fnamemodify(home, ':h') ==# s:first_rtp
|
||||
return s:err('Invalid plug home. '.home.' is a standard Vim runtime path and is not allowed.')
|
||||
endif
|
||||
|
||||
|
|
@ -139,6 +177,16 @@ function! s:define_commands()
|
|||
if !executable('git')
|
||||
return s:err('`git` executable not found. Most commands will not be available. To suppress this message, prepend `silent!` to `call plug#begin(...)`.')
|
||||
endif
|
||||
if has('win32')
|
||||
\ && &shellslash
|
||||
\ && (&shell =~# 'cmd\.exe' || &shell =~# 'powershell\.exe')
|
||||
return s:err('vim-plug does not support shell, ' . &shell . ', when shellslash is set.')
|
||||
endif
|
||||
if !has('nvim')
|
||||
\ && (has('win32') || has('win32unix'))
|
||||
\ && !has('multi_byte')
|
||||
return s:err('Vim needs +multi_byte feature on Windows to run shell commands. Enable +iconv for best results.')
|
||||
endif
|
||||
command! -nargs=* -bar -bang -complete=customlist,s:names PlugInstall call s:install(<bang>0, [<f-args>])
|
||||
command! -nargs=* -bar -bang -complete=customlist,s:names PlugUpdate call s:update(<bang>0, [<f-args>])
|
||||
command! -nargs=0 -bar -bang PlugClean call s:clean(<bang>0)
|
||||
|
|
@ -203,7 +251,7 @@ endfunction
|
|||
|
||||
function! plug#end()
|
||||
if !exists('g:plugs')
|
||||
return s:err('Call plug#begin() first')
|
||||
return s:err('plug#end() called without calling plug#begin() first')
|
||||
endif
|
||||
|
||||
if exists('#PlugLOD')
|
||||
|
|
@ -334,11 +382,11 @@ function! s:progress_opt(base)
|
|||
\ s:git_version_requirement(1, 7, 1) ? '--progress' : ''
|
||||
endfunction
|
||||
|
||||
if s:is_win
|
||||
function! s:rtp(spec)
|
||||
function! s:rtp(spec)
|
||||
return s:path(a:spec.dir . get(a:spec, 'rtp', ''))
|
||||
endfunction
|
||||
endfunction
|
||||
|
||||
if s:is_win
|
||||
function! s:path(path)
|
||||
return s:trim(substitute(a:path, '/', '\', 'g'))
|
||||
endfunction
|
||||
|
|
@ -350,11 +398,33 @@ if s:is_win
|
|||
function! s:is_local_plug(repo)
|
||||
return a:repo =~? '^[a-z]:\|^[%~]'
|
||||
endfunction
|
||||
else
|
||||
function! s:rtp(spec)
|
||||
return s:dirpath(a:spec.dir . get(a:spec, 'rtp', ''))
|
||||
|
||||
" Copied from fzf
|
||||
function! s:wrap_cmds(cmds)
|
||||
let cmds = [
|
||||
\ '@echo off',
|
||||
\ 'setlocal enabledelayedexpansion']
|
||||
\ + (type(a:cmds) == type([]) ? a:cmds : [a:cmds])
|
||||
\ + ['endlocal']
|
||||
if has('iconv')
|
||||
if !exists('s:codepage')
|
||||
let s:codepage = libcallnr('kernel32.dll', 'GetACP', 0)
|
||||
endif
|
||||
return map(cmds, printf('iconv(v:val."\r", "%s", "cp%d")', &encoding, s:codepage))
|
||||
endif
|
||||
return map(cmds, 'v:val."\r"')
|
||||
endfunction
|
||||
|
||||
function! s:batchfile(cmd)
|
||||
let batchfile = s:plug_tempname().'.bat'
|
||||
call writefile(s:wrap_cmds(a:cmd), batchfile)
|
||||
let cmd = plug#shellescape(batchfile, {'shell': &shell, 'script': 0})
|
||||
if &shell =~# 'powershell\.exe'
|
||||
let cmd = '& ' . cmd
|
||||
endif
|
||||
return [batchfile, cmd]
|
||||
endfunction
|
||||
else
|
||||
function! s:path(path)
|
||||
return s:trim(a:path)
|
||||
endfunction
|
||||
|
|
@ -434,8 +504,8 @@ endfunction
|
|||
|
||||
function! s:dobufread(names)
|
||||
for name in a:names
|
||||
let path = s:rtp(g:plugs[name]).'/**'
|
||||
for dir in ['ftdetect', 'ftplugin']
|
||||
let path = s:rtp(g:plugs[name])
|
||||
for dir in ['ftdetect', 'ftplugin', 'after/ftdetect', 'after/ftplugin']
|
||||
if len(finddir(dir, path))
|
||||
if exists('#BufRead')
|
||||
doautocmd BufRead
|
||||
|
|
@ -554,7 +624,7 @@ function! plug#(repo, ...)
|
|||
try
|
||||
let repo = s:trim(a:repo)
|
||||
let opts = a:0 == 1 ? s:parse_options(a:1) : s:base_spec
|
||||
let name = get(opts, 'as', fnamemodify(repo, ':t:s?\.git$??'))
|
||||
let name = get(opts, 'as', s:plug_fnamemodify(repo, ':t:s?\.git$??'))
|
||||
let spec = extend(s:infer_properties(name, repo), opts)
|
||||
if !has_key(g:plugs, name)
|
||||
call add(g:plugs_order, name)
|
||||
|
|
@ -574,7 +644,7 @@ function! s:parse_options(arg)
|
|||
elseif type == s:TYPE.dict
|
||||
call extend(opts, a:arg)
|
||||
if has_key(opts, 'dir')
|
||||
let opts.dir = s:dirpath(expand(opts.dir))
|
||||
let opts.dir = s:dirpath(s:plug_expand(opts.dir))
|
||||
endif
|
||||
else
|
||||
throw 'Invalid argument type (expected: string or dictionary)'
|
||||
|
|
@ -585,7 +655,7 @@ endfunction
|
|||
function! s:infer_properties(name, repo)
|
||||
let repo = a:repo
|
||||
if s:is_local_plug(repo)
|
||||
return { 'dir': s:dirpath(expand(repo)) }
|
||||
return { 'dir': s:dirpath(s:plug_expand(repo)) }
|
||||
else
|
||||
if repo =~ ':'
|
||||
let uri = repo
|
||||
|
|
@ -738,7 +808,7 @@ function! s:finish_bindings()
|
|||
endfunction
|
||||
|
||||
function! s:prepare(...)
|
||||
if empty(getcwd())
|
||||
if empty(s:plug_getcwd())
|
||||
throw 'Invalid current working directory. Cannot proceed.'
|
||||
endif
|
||||
|
||||
|
|
@ -794,31 +864,28 @@ endfunction
|
|||
|
||||
function! s:chsh(swap)
|
||||
let prev = [&shell, &shellcmdflag, &shellredir]
|
||||
if s:is_win
|
||||
set shell=cmd.exe shellcmdflag=/c shellredir=>%s\ 2>&1
|
||||
elseif a:swap
|
||||
if !s:is_win && a:swap
|
||||
set shell=sh shellredir=>%s\ 2>&1
|
||||
endif
|
||||
return prev
|
||||
endfunction
|
||||
|
||||
function! s:bang(cmd, ...)
|
||||
let batchfile = ''
|
||||
try
|
||||
let [sh, shellcmdflag, shrd] = s:chsh(a:0)
|
||||
" FIXME: Escaping is incomplete. We could use shellescape with eval,
|
||||
" but it won't work on Windows.
|
||||
let cmd = a:0 ? s:with_cd(a:cmd, a:1) : a:cmd
|
||||
if s:is_win
|
||||
let batchfile = tempname().'.bat'
|
||||
call writefile(["@echo off\r", cmd . "\r"], batchfile)
|
||||
let cmd = batchfile
|
||||
let [batchfile, cmd] = s:batchfile(cmd)
|
||||
endif
|
||||
let g:_plug_bang = (s:is_win && has('gui_running') ? 'silent ' : '').'!'.escape(cmd, '#!%')
|
||||
execute "normal! :execute g:_plug_bang\<cr>\<cr>"
|
||||
finally
|
||||
unlet g:_plug_bang
|
||||
let [&shell, &shellcmdflag, &shellredir] = [sh, shellcmdflag, shrd]
|
||||
if s:is_win
|
||||
if s:is_win && filereadable(batchfile)
|
||||
call delete(batchfile)
|
||||
endif
|
||||
endtry
|
||||
|
|
@ -897,7 +964,7 @@ function! s:checkout(spec)
|
|||
let output = s:system('git rev-parse HEAD', a:spec.dir)
|
||||
if !v:shell_error && !s:hash_match(sha, s:lines(output)[0])
|
||||
let output = s:system(
|
||||
\ 'git fetch --depth 999999 && git checkout '.s:esc(sha).' --', a:spec.dir)
|
||||
\ 'git fetch --depth 999999 && git checkout '.plug#shellescape(sha).' --', a:spec.dir)
|
||||
endif
|
||||
return output
|
||||
endfunction
|
||||
|
|
@ -1015,7 +1082,7 @@ function! s:update_impl(pull, force, args) abort
|
|||
let s:clone_opt = get(g:, 'plug_shallow', 1) ?
|
||||
\ '--depth 1' . (s:git_version_requirement(1, 7, 10) ? ' --no-single-branch' : '') : ''
|
||||
|
||||
if has('win32unix')
|
||||
if has('win32unix') || has('wsl')
|
||||
let s:clone_opt .= ' -c core.eol=lf -c core.autocrlf=input'
|
||||
endif
|
||||
|
||||
|
|
@ -1094,7 +1161,7 @@ function! s:update_finish()
|
|||
elseif has_key(spec, 'tag')
|
||||
let tag = spec.tag
|
||||
if tag =~ '\*'
|
||||
let tags = s:lines(s:system('git tag --list '.s:shellesc(tag).' --sort -version:refname 2>&1', spec.dir))
|
||||
let tags = s:lines(s:system('git tag --list '.plug#shellescape(tag).' --sort -version:refname 2>&1', spec.dir))
|
||||
if !v:shell_error && !empty(tags)
|
||||
let tag = tags[0]
|
||||
call s:log4(name, printf('Latest tag for %s -> %s', spec.tag, tag))
|
||||
|
|
@ -1102,12 +1169,12 @@ function! s:update_finish()
|
|||
endif
|
||||
endif
|
||||
call s:log4(name, 'Checking out '.tag)
|
||||
let out = s:system('git checkout -q '.s:esc(tag).' -- 2>&1', spec.dir)
|
||||
let out = s:system('git checkout -q '.plug#shellescape(tag).' -- 2>&1', spec.dir)
|
||||
else
|
||||
let branch = s:esc(get(spec, 'branch', 'master'))
|
||||
call s:log4(name, 'Merging origin/'.branch)
|
||||
let out = s:system('git checkout -q '.branch.' -- 2>&1'
|
||||
\. (has_key(s:update.new, name) ? '' : ('&& git merge --ff-only origin/'.branch.' 2>&1')), spec.dir)
|
||||
let branch = get(spec, 'branch', 'master')
|
||||
call s:log4(name, 'Merging origin/'.s:esc(branch))
|
||||
let out = s:system('git checkout -q '.plug#shellescape(branch).' -- 2>&1'
|
||||
\. (has_key(s:update.new, name) ? '' : ('&& git merge --ff-only '.plug#shellescape('origin/'.branch).' 2>&1')), spec.dir)
|
||||
endif
|
||||
if !v:shell_error && filereadable(spec.dir.'/.gitmodules') &&
|
||||
\ (s:update.force || has_key(s:update.new, name) || s:is_updated(spec.dir))
|
||||
|
|
@ -1151,7 +1218,7 @@ function! s:job_abort()
|
|||
silent! call job_stop(j.jobid)
|
||||
endif
|
||||
if j.new
|
||||
call s:system('rm -rf ' . s:shellesc(g:plugs[name].dir))
|
||||
call s:rm_rf(g:plugs[name].dir)
|
||||
endif
|
||||
endfor
|
||||
let s:jobs = {}
|
||||
|
|
@ -1204,22 +1271,17 @@ endfunction
|
|||
|
||||
function! s:spawn(name, cmd, opts)
|
||||
let job = { 'name': a:name, 'running': 1, 'error': 0, 'lines': [''],
|
||||
\ 'batchfile': (s:is_win && (s:nvim || s:vim8)) ? tempname().'.bat' : '',
|
||||
\ 'new': get(a:opts, 'new', 0) }
|
||||
let s:jobs[a:name] = job
|
||||
let cmd = has_key(a:opts, 'dir') ? s:with_cd(a:cmd, a:opts.dir) : a:cmd
|
||||
if !empty(job.batchfile)
|
||||
call writefile(["@echo off\r", cmd . "\r"], job.batchfile)
|
||||
let cmd = job.batchfile
|
||||
endif
|
||||
let argv = add(s:is_win ? ['cmd', '/c'] : ['sh', '-c'], cmd)
|
||||
let cmd = has_key(a:opts, 'dir') ? s:with_cd(a:cmd, a:opts.dir, 0) : a:cmd
|
||||
let argv = s:is_win ? ['cmd', '/s', '/c', '"'.cmd.'"'] : ['sh', '-c', cmd]
|
||||
|
||||
if s:nvim
|
||||
call extend(job, {
|
||||
\ 'on_stdout': function('s:nvim_cb'),
|
||||
\ 'on_exit': function('s:nvim_cb'),
|
||||
\ })
|
||||
let jid = jobstart(argv, job)
|
||||
let jid = s:plug_call('jobstart', argv, job)
|
||||
if jid > 0
|
||||
let job.jobid = jid
|
||||
else
|
||||
|
|
@ -1262,9 +1324,6 @@ function! s:reap(name)
|
|||
call s:log(bullet, a:name, empty(result) ? 'OK' : result)
|
||||
call s:bar()
|
||||
|
||||
if has_key(job, 'batchfile') && !empty(job.batchfile)
|
||||
call delete(job.batchfile)
|
||||
endif
|
||||
call remove(s:jobs, a:name)
|
||||
endfunction
|
||||
|
||||
|
|
@ -1279,9 +1338,10 @@ function! s:bar()
|
|||
endfunction
|
||||
|
||||
function! s:logpos(name)
|
||||
for i in range(4, line('$'))
|
||||
let max = line('$')
|
||||
for i in range(4, max > 4 ? max : 4)
|
||||
if getline(i) =~# '^[-+x*] '.a:name.':'
|
||||
for j in range(i + 1, line('$'))
|
||||
for j in range(i + 1, max > 5 ? max : 5)
|
||||
if getline(j) !~ '^ '
|
||||
return [i, j - 1]
|
||||
endif
|
||||
|
|
@ -1354,8 +1414,8 @@ while 1 " Without TCO, Vim stack is bound to explode
|
|||
\ printf('git clone %s %s %s %s 2>&1',
|
||||
\ has_tag ? '' : s:clone_opt,
|
||||
\ prog,
|
||||
\ s:shellesc(spec.uri),
|
||||
\ s:shellesc(s:trim(spec.dir))), { 'new': 1 })
|
||||
\ plug#shellescape(spec.uri, {'script': 0}),
|
||||
\ plug#shellescape(s:trim(spec.dir), {'script': 0})), { 'new': 1 })
|
||||
endif
|
||||
|
||||
if !s:jobs[name].running
|
||||
|
|
@ -1982,19 +2042,29 @@ function! s:update_ruby()
|
|||
EOF
|
||||
endfunction
|
||||
|
||||
function! s:shellesc_cmd(arg)
|
||||
let escaped = substitute(a:arg, '[&|<>()@^]', '^&', 'g')
|
||||
let escaped = substitute(escaped, '%', '%%', 'g')
|
||||
let escaped = substitute(escaped, '"', '\\^&', 'g')
|
||||
let escaped = substitute(escaped, '\(\\\+\)\(\\^\)', '\1\1\2', 'g')
|
||||
return '^"'.substitute(escaped, '\(\\\+\)$', '\1\1', '').'^"'
|
||||
function! s:shellesc_cmd(arg, script)
|
||||
let escaped = substitute('"'.a:arg.'"', '[&|<>()@^!"]', '^&', 'g')
|
||||
return substitute(escaped, '%', (a:script ? '%' : '^') . '&', 'g')
|
||||
endfunction
|
||||
|
||||
function! s:shellesc(arg)
|
||||
if &shell =~# 'cmd.exe$'
|
||||
return s:shellesc_cmd(a:arg)
|
||||
function! s:shellesc_ps1(arg)
|
||||
return "'".substitute(escape(a:arg, '\"'), "'", "''", 'g')."'"
|
||||
endfunction
|
||||
|
||||
function! s:shellesc_sh(arg)
|
||||
return "'".substitute(a:arg, "'", "'\\\\''", 'g')."'"
|
||||
endfunction
|
||||
|
||||
function! plug#shellescape(arg, ...)
|
||||
let opts = a:0 > 0 && type(a:1) == s:TYPE.dict ? a:1 : {}
|
||||
let shell = get(opts, 'shell', s:is_win ? 'cmd.exe' : 'sh')
|
||||
let script = get(opts, 'script', 1)
|
||||
if shell =~# 'cmd\.exe'
|
||||
return s:shellesc_cmd(a:arg, script)
|
||||
elseif shell =~# 'powershell\.exe' || shell =~# 'pwsh$'
|
||||
return s:shellesc_ps1(a:arg)
|
||||
endif
|
||||
return shellescape(a:arg)
|
||||
return s:shellesc_sh(a:arg)
|
||||
endfunction
|
||||
|
||||
function! s:glob_dir(path)
|
||||
|
|
@ -2026,23 +2096,23 @@ function! s:format_message(bullet, name, message)
|
|||
endif
|
||||
endfunction
|
||||
|
||||
function! s:with_cd(cmd, dir)
|
||||
return printf('cd%s %s && %s', s:is_win ? ' /d' : '', s:shellesc(a:dir), a:cmd)
|
||||
function! s:with_cd(cmd, dir, ...)
|
||||
let script = a:0 > 0 ? a:1 : 1
|
||||
return printf('cd%s %s && %s', s:is_win ? ' /d' : '', plug#shellescape(a:dir, {'script': script}), a:cmd)
|
||||
endfunction
|
||||
|
||||
function! s:system(cmd, ...)
|
||||
let batchfile = ''
|
||||
try
|
||||
let [sh, shellcmdflag, shrd] = s:chsh(1)
|
||||
let cmd = a:0 > 0 ? s:with_cd(a:cmd, a:1) : a:cmd
|
||||
if s:is_win
|
||||
let batchfile = tempname().'.bat'
|
||||
call writefile(["@echo off\r", cmd . "\r"], batchfile)
|
||||
let cmd = batchfile
|
||||
let [batchfile, cmd] = s:batchfile(cmd)
|
||||
endif
|
||||
return system(s:is_win ? '('.cmd.')' : cmd)
|
||||
return system(cmd)
|
||||
finally
|
||||
let [&shell, &shellcmdflag, &shellredir] = [sh, shellcmdflag, shrd]
|
||||
if s:is_win
|
||||
if s:is_win && filereadable(batchfile)
|
||||
call delete(batchfile)
|
||||
endif
|
||||
endtry
|
||||
|
|
@ -2115,7 +2185,7 @@ endfunction
|
|||
|
||||
function! s:rm_rf(dir)
|
||||
if isdirectory(a:dir)
|
||||
call s:system((s:is_win ? 'rmdir /S /Q ' : 'rm -rf ') . s:shellesc(a:dir))
|
||||
call s:system((s:is_win ? 'rmdir /S /Q ' : 'rm -rf ') . plug#shellescape(a:dir))
|
||||
endif
|
||||
endfunction
|
||||
|
||||
|
|
@ -2147,7 +2217,7 @@ function! s:clean(force)
|
|||
|
||||
let allowed = {}
|
||||
for dir in dirs
|
||||
let allowed[s:dirpath(fnamemodify(dir, ':h:h'))] = 1
|
||||
let allowed[s:dirpath(s:plug_fnamemodify(dir, ':h:h'))] = 1
|
||||
let allowed[dir] = 1
|
||||
for child in s:glob_dir(dir)
|
||||
let allowed[child] = 1
|
||||
|
|
@ -2220,11 +2290,11 @@ endfunction
|
|||
function! s:upgrade()
|
||||
echo 'Downloading the latest version of vim-plug'
|
||||
redraw
|
||||
let tmp = tempname()
|
||||
let tmp = s:plug_tempname()
|
||||
let new = tmp . '/plug.vim'
|
||||
|
||||
try
|
||||
let out = s:system(printf('git clone --depth 1 %s %s', s:plug_src, tmp))
|
||||
let out = s:system(printf('git clone --depth 1 %s %s', plug#shellescape(s:plug_src), plug#shellescape(tmp)))
|
||||
if v:shell_error
|
||||
return s:err('Error upgrading vim-plug: '. out)
|
||||
endif
|
||||
|
|
@ -2365,18 +2435,17 @@ function! s:preview_commit()
|
|||
wincmd P
|
||||
endif
|
||||
setlocal previewwindow filetype=git buftype=nofile nobuflisted modifiable
|
||||
let batchfile = ''
|
||||
try
|
||||
let [sh, shellcmdflag, shrd] = s:chsh(1)
|
||||
let cmd = 'cd '.s:shellesc(g:plugs[name].dir).' && git show --no-color --pretty=medium '.sha
|
||||
let cmd = 'cd '.plug#shellescape(g:plugs[name].dir).' && git show --no-color --pretty=medium '.sha
|
||||
if s:is_win
|
||||
let batchfile = tempname().'.bat'
|
||||
call writefile(["@echo off\r", cmd . "\r"], batchfile)
|
||||
let cmd = batchfile
|
||||
let [batchfile, cmd] = s:batchfile(cmd)
|
||||
endif
|
||||
execute 'silent %!' cmd
|
||||
finally
|
||||
let [&shell, &shellcmdflag, &shellredir] = [sh, shellcmdflag, shrd]
|
||||
if s:is_win
|
||||
if s:is_win && filereadable(batchfile)
|
||||
call delete(batchfile)
|
||||
endif
|
||||
endtry
|
||||
|
|
@ -2420,9 +2489,11 @@ function! s:diff()
|
|||
call s:append_ul(2, origin ? 'Pending updates:' : 'Last update:')
|
||||
for [k, v] in plugs
|
||||
let range = origin ? '..origin/'.v.branch : 'HEAD@{1}..'
|
||||
let cmd = 'git log --graph --color=never '.join(map(['--pretty=format:%x01%h%x01%d%x01%s%x01%cr', range], 's:shellesc(v:val)'))
|
||||
let cmd = 'git log --graph --color=never '
|
||||
\ . (s:git_version_requirement(2, 10, 0) ? '--no-show-signature ' : '')
|
||||
\ . join(map(['--pretty=format:%x01%h%x01%d%x01%s%x01%cr', range], 'plug#shellescape(v:val)'))
|
||||
if has_key(v, 'rtp')
|
||||
let cmd .= ' -- '.s:shellesc(v.rtp)
|
||||
let cmd .= ' -- '.plug#shellescape(v.rtp)
|
||||
endif
|
||||
let diff = s:system_chomp(cmd, v.dir)
|
||||
if !empty(diff)
|
||||
|
|
@ -2470,7 +2541,7 @@ function! s:revert()
|
|||
return
|
||||
endif
|
||||
|
||||
call s:system('git reset --hard HEAD@{1} && git checkout '.s:esc(g:plugs[name].branch).' --', g:plugs[name].dir)
|
||||
call s:system('git reset --hard HEAD@{1} && git checkout '.plug#shellescape(g:plugs[name].branch).' --', g:plugs[name].dir)
|
||||
setlocal modifiable
|
||||
normal! "_dap
|
||||
setlocal nomodifiable
|
||||
|
|
@ -2498,7 +2569,7 @@ function! s:snapshot(force, ...) abort
|
|||
endfor
|
||||
|
||||
if a:0 > 0
|
||||
let fn = expand(a:1)
|
||||
let fn = s:plug_expand(a:1)
|
||||
if filereadable(fn) && !(a:force || s:ask(a:1.' already exists. Overwrite?'))
|
||||
return
|
||||
endif
|
||||
|
|
|
|||
2526
vim/.vim/autoload/plug.vim.old
Normal file
2526
vim/.vim/autoload/plug.vim.old
Normal file
File diff suppressed because it is too large
Load diff
|
|
@ -54,3 +54,8 @@ Tmux
|
|||
c-b {v, h} window split
|
||||
c-b w new window
|
||||
tslime: ,t
|
||||
|
||||
Help Navigation
|
||||
follow link: ctrl-]
|
||||
previous link: ctrl-t
|
||||
or ctrl-o
|
||||
|
|
|
|||
|
|
@ -25,14 +25,15 @@
|
|||
Plug 'wolf-dog/lightline-sceaduhelm.vim'
|
||||
" Plug 'unblevable/quick-scope'
|
||||
Plug 'tpope/vim-fugitive'
|
||||
Plug 'l04m33/vlime', {'rtp': 'vim/'}
|
||||
Plug 'kovisoft/paredit'
|
||||
" Plug 'l04m33/vlime', {'rtp': 'vim/'}
|
||||
" Plug 'kovisoft/paredit'
|
||||
Plug 'sainnhe/vim-color-forest-night'
|
||||
Plug 'justinmk/vim-sneak'
|
||||
Plug 'christoomey/vim-tmux-navigator'
|
||||
Plug 'ap/vim-css-color'
|
||||
Plug 'dylanaraps/wal.vim'
|
||||
Plug 'sjl/tslime.vim'
|
||||
Plug 'kovisoft/slimv'
|
||||
|
||||
" Todo:
|
||||
" GV
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue