Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Added parts of CL-FAD to resolve portability issues with DIRECTORY.

  • Loading branch information...
commit d7aae00d344f30db79b361714c27d300353bfc68 1 parent d0807c5
@blitz blitz authored
Showing with 120 additions and 7 deletions.
  1. +7 −7 Makefile.in
  2. +112 −0 pathnames.lisp
  3. +1 −0  stumpwm.asd
View
14 Makefile.in
@@ -19,13 +19,13 @@ infodir=@infodir@
# This is copied from the .asd file. It'd be nice to have the list in
# one place, but oh well.
-FILES=package.lisp primitives.lisp wrappers.lisp keysyms.lisp \
-keytrans.lisp kmap.lisp input.lisp core.lisp command.lisp menu.lisp \
-screen.lisp head.lisp group.lisp window.lisp floating-group.lisp \
-tile-window.lisp window-placement.lisp message-window.lisp \
-selection.lisp user.lisp iresize.lisp bindings.lisp events.lisp \
-help.lisp fdump.lisp mode-line.lisp time.lisp color.lisp module.lisp \
-stumpwm.lisp version.lisp
+FILES=package.lisp primitives.lisp wrappers.lisp pathnames.lisp \
+keysyms.lisp keytrans.lisp kmap.lisp input.lisp core.lisp command.lisp \
+menu.lisp screen.lisp head.lisp group.lisp window.lisp \
+floating-group.lisp tile-window.lisp window-placement.lisp \
+message-window.lisp selection.lisp user.lisp iresize.lisp \
+bindings.lisp events.lisp help.lisp fdump.lisp mode-line.lisp \
+time.lisp color.lisp module.lisp stumpwm.lisp version.lisp
all: stumpwm stumpwm.info
View
112 pathnames.lisp
@@ -0,0 +1,112 @@
+;;; -*- Mode: Lisp -*-
+
+;;; This code is taken from CL-FAD. Original copyright notice follows:
+
+;;; $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-2009, 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 :stumpwm)
+
+(export '(list-directory))
+
+(defun component-present-p (value)
+ "Helper function for DIRECTORY-PATHNAME-P which checks whether VALUE
+is neither NIL nor the keyword :UNSPECIFIC."
+ (and value (not (eql value :unspecific))))
+
+(defun directory-pathname-p (pathspec)
+ "Returns NIL if PATHSPEC \(a pathname designator) does not designate
+a directory, PATHSPEC otherwise. It is irrelevant whether file or
+directory designated by PATHSPEC does actually exist."
+ (and
+ (not (component-present-p (pathname-name pathspec)))
+ (not (component-present-p (pathname-type pathspec)))
+ pathspec))
+
+(defun pathname-as-directory (pathspec)
+ "Converts the non-wild pathname designator PATHSPEC to directory
+form."
+ (let ((pathname (pathname pathspec)))
+ (when (wild-pathname-p pathname)
+ (error "Can't reliably convert wild pathnames."))
+ (cond ((not (directory-pathname-p pathspec))
+ (make-pathname :directory (append (or (pathname-directory pathname)
+ (list :relative))
+ (list (file-namestring pathname)))
+ :name nil
+ :type nil
+ :defaults pathname))
+ (t pathname))))
+
+(defun directory-wildcard (dirname)
+ "Returns a wild pathname designator that designates all files within
+the directory named by the non-wild pathname designator DIRNAME."
+ (when (wild-pathname-p dirname)
+ (error "Can only make wildcard directories from non-wildcard directories."))
+ (make-pathname :name #-:cormanlisp :wild #+:cormanlisp "*"
+ :type #-(or :clisp :cormanlisp) :wild
+ #+:clisp nil
+ #+:cormanlisp "*"
+ :defaults (pathname-as-directory dirname)))
+#+:clisp
+(defun clisp-subdirectories-wildcard (wildcard)
+ "Creates a wild pathname specifically for CLISP such that
+sub-directories are returned by DIRECTORY."
+ (make-pathname :directory (append (pathname-directory wildcard)
+ (list :wild))
+ :name nil
+ :type nil
+ :defaults wildcard))
+
+(defun list-directory (dirname)
+ "Returns a fresh list of pathnames corresponding to the truenames of
+all files within the directory named by the non-wild pathname
+designator DIRNAME. The pathnames of sub-directories are returned in
+directory form - see PATHNAME-AS-DIRECTORY."
+ (when (wild-pathname-p dirname)
+ (error "Can only list concrete directory names."))
+ #+:ecl
+ (let ((dir (pathname-as-directory dirname)))
+ (concatenate 'list
+ (directory (merge-pathnames (pathname "*/") dir))
+ (directory (merge-pathnames (pathname "*.*") dir))))
+ #-:ecl
+ (let ((wildcard (directory-wildcard dirname)))
+ #+:abcl (system::list-directory dirname)
+ #+(or :sbcl :cmu :scl :lispworks) (directory wildcard)
+ #+(or :openmcl :digitool) (directory wildcard :directories t)
+ #+:allegro (directory wildcard :directories-are-files nil)
+ #+:clisp (nconc (directory wildcard :if-does-not-exist :keep)
+ (directory (clisp-subdirectories-wildcard wildcard)))
+ #+:cormanlisp (nconc (directory wildcard)
+ (cl::directory-subdirs dirname)))
+ #-(or :sbcl :cmu :scl :lispworks :openmcl :allegro :clisp :cormanlisp :ecl :abcl :digitool)
+ (error "LIST-DIRECTORY not implemented"))
+
+;;; EOF
View
1  stumpwm.asd
@@ -24,6 +24,7 @@
(:file "primitives")
(:file "workarounds")
(:file "wrappers")
+ (:file "pathnames")
(:file "keysyms")
(:file "keytrans")
(:file "kmap")
Please sign in to comment.
Something went wrong with that request. Please try again.