Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

113 lines (97 sloc) 5.064 kb
;;; -*- 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
Jump to Line
Something went wrong with that request. Please try again.