;;; .EnTete "Le-Lisp (c) version 15.2" " " "Logical Pathnames"
;;; .EnPied "pathname.ll" "%" " "
;;;
;;; .SuperTitre "Fonctions sur les Noms de fichier logiques"
;;; .Auteur "Michel Dana, ENST"
;;;
;;; .Centre "*****************************************************************"
;;; .Centre " Ce fichier est en lecture seule hors du projet ALE de l'INRIA. "
;;; .Centre " Il est maintenu par ILOG SA, 2 Avenue Gallie'ni, 94250 Gentilly "
;;; .Centre " (c) Le-Lisp est une marque de'pose'e de l'INRIA "
;;; .Centre "*****************************************************************"
;;; .Centre "$Header: path.ll,v 1.12 88/12/13 18:10:40 neidl Exp $"
;;; This file contains the code which handles the virtual pathname
;;; scheme for Le-Lisp. It contains also the special handlers for the
;;; VMS and UNIX operating systems
;;; Notice for the implementors of Le-Lisp on other operating systems:
;;;
;;; if you want to extend this module for an other O.S., which name
;;; as the result of (system) is `newsys`, you have to write a driver for
;;; your OS. This driver must contain the following functions, which
;;; must be explicitely exported bye COMPLICE.
;;; #:newsys:namestring : this function takes a pathname as argument
;;; and evaluates to the external name of the pathname for the O.S.
;;; #:newsys:pathname : this function takes an external string as an
;;; argument and gives a pathname
;;; #:newsys:homedir-pathname : This function has no argument and
;;; gives the pathname which represents the "home-directory" of the
;;; current user . If there is no such facility in the current O/S,
;;; this function gives a valid directory.
;;; #:newsys:directory-namestring: This function accepts a pathname as
;;; an argument and gives the external string which represents the
;;; directory part of the pathname
;;; #:newsys:temporary-file-pathname : This function takes a string
;;; as an argument, and builds a pathname which should be a temporary
;;; file pathname, as /tmp/foo for UNIX
;;; #:newsys:file-namestring : this function takes a pathname as
;;; argument and gives the external string representing the name type
;;; et version fields of the pathname. If your OS doesn't provide ant
;;; mechanism for version support, you are supposed to emulate it in
;;; the most convenient way.
;;; #:newsys:host-namestring : takes a pathname as argument, and gives
;;; the external string representing the host on which resides the
;;; file... if your host doesn't support network access , you must
;;; return the empty string
;;; #:newsys:device-namestring : takes a pathname as argument and
;;; returns the external string which represents the physical device
;;; on which the file system resides. If this facility doesn't exist,
;;; returns the empty string
;;; #:newsys:current-directory : this function will get/set the
;;; working directory of Lisp process, and also that of the
;;; shell/process (if there is one)
;;; #:newsys:wild : this function will return the list of all pathname
;;; in the file systeme, which can be found according to the pattern
;;; which is the argument .
;;; You may also write a function #:newsys:check-pathname which will
;;; check that its argument is a valid pathname for your operating
;;; system . (i.e. No special character,etc..)
;;; this function returns () if the syntax is illegal
(unless (>= (version) 15.2)
(error 'load 'erricf 'pathname))
(setq #:sys-package:colon 'pathname)
(add-feature 'pathname)
;;; the mechanism which calls easily new operating systems
;;;
;;;
(dmd to-system (cmd . larg)
`(funcall (getfn (system) ,cmd ()) ,@larg))
;;;
;;;
; 1) definition of a pathname
(defstruct pathname
host ; name of the host of the file-system
device ; physical device
directory ; list of directories
name ; file name
type ; extension
version ; version number, or ()
)
;;;1) Let's convert a pathname in an external string
(de namestring (p)
(unless (pathnamep p) (error 'namestringname 'ERRBPA p))
(cond
(#:system:unixp (#:unix:namestring p))
((eq (system) 'vaxvms) (#:vaxvms:namestring p))
(t (to-system 'namestring p))
))
;;1.1) Unix Case.. actually no hosts or device .... poor man's
;; Operating system
(de #:unix:namestring (p)
(catenate
(#:unix:directory-namestring p)
(#:unix:file-namestring p)))
;;1.2) the same for VMS.. that's a Real Operating System
(de #:vaxvms:namestring (p)
(catenate
(#:vaxvms:host-namestring p)
(#:vaxvms:device-namestring p)
(#:vaxvms:directory-namestring p)
(#:vaxvms:file-namestring p)))
;;; The predicate for pathnames
(de pathnamep (p)
(eq (type-of p ) 'pathname)))
;;; the get function in the common-lisp flavour
(de pathname-host(p)
(unless (pathnamep p) (setq p (pathname p)))
(:host p)))
(de pathname-device (p)
(unless (pathnamep p) (setq p (pathname p)))
(:device p)))
(de pathname-directory (p)
(unless (pathnamep p) (setq p (pathname p)))
(:directory p)))
(de pathname-name (p)
(unless (pathnamep p) (setq p (pathname p)))
(:name p)))
(de pathname-type (p)
(unless (pathnamep p) (setq p (pathname p)))
(:type p)))
(de pathname-version (p)
(unless (pathnamep p) (setq p (pathname p)))
(:version p)))
;;;2) and now, let's convert an external namestring into a pathname..
;;; that is more difficult
(de pathname(f)
(cond
((equal f "")(new 'pathname))
(#:system:unixp (#:unix:pathname f))
((eq (system) 'vaxvms) (#:vaxvms:pathname f))
(t (to-system 'pathname f ))))
;2.1) UNIX case
;;; if the string begins with a /, it is an absolute pathname.
;;; ../ , you want to go upward in the hierarchy
;;; ./ or nothing, it is relative to the
;;; current directory. if it contains /,
;;; it starts with a directory part,
;;; otherwise there is only a filename
;;; . : there is only the type field
;;; ..N : there is only the version number
;;;
(de #:unix:pathname (s)
(let (( p (new 'pathname))
(s1 (string s))
(s2 ())
(l ()))
(if (eq (slen s1) 0) p ; empty path
(cond
(( eq (sref s1 0) #//) (setq s1 (substring s1 1)))
(( eq (index "../" s1) 0) (setq s1 (substring s1 3))
(:directory p (ncons ':up)))
(( eq (index "./" s1) 0) (setq s1 (substring s1 2))
(:directory p (ncons ':current)))
(( index "/" s1) (:directory p (ncons ':current))))
;; we have parsed the beginning of the string , and we do
;; actually know if we are an absolute or relative
;; specification...
;; we must now parse the directory specification
(while (setq l (index "/" s1))
(cond ( (equal (setq s2 (substring s1 0 l)) "..")(setq s2 ':up))
( (equal s2 ".") (setq s2 ':current))
( (equal s2 "*") (setq s2 ':wild)))
(:directory p (cons s2 (:directory p)))
(setq s1 (substring s1 (add1 l))))
(:directory p(nreverse (:directory p)))
;; here, there are only the name, type and version fields left
(unless (or (eq (slen s1) 0)
(eq (sref s1 0) #/.))
(setq s2
(substring s1 0
(setq l (or (index "." s1)
(slen s1)))))
(:name p (if (equal s2 "*") ':wild s2))
(setq s1(substring s1 l)))
;the type field
(unless (or
(eq (slen s1) 0)
(eq (slen (setq s1 (substring s1 1))) 0))
(setq s2
(substring s1 0
(setq l (or (index "." s1)
(slen s1)))))
(:type p
(cond ((equal s2 "*") ':wild)
((eq l 0) ())
(t s2)))
(setq s1 (substring s1 l)))
;; the version field...
;; a number or *
(unless (or (eq (slen s1)0)(eq (slen (setq s1 (substring s1 1)))0))
(setq s2 (stratom (slen s1) s1 ()))
(:version p
(cond ((fixp s2) s2)
((equal s1 "*") ':wild)
((not (fixp s2))
(when *portable-pathname*
(printerror 'pathname
"Version n'est pas un numerique"
s2))
()))))
p)))
;;;2.2 the same for VMS
;;;
;;;the syntaxe is much more complex
(de #:vaxvms:pathname (s)
(let ((p (new 'pathname))
(s1 (string s))
(l ()))
;;a- is it a decnet file ?
(when (setq l (index "::" s1 ))
(:host p (substring s1 0 l))
(setq s1 (substring s1 (add l 2))))
;;b- on which physical device ?
(when (setq l (index ":" s1 ))
(:device p (substring s1 0 l))
(setq s1 (substring s1 (add1 l))))
;;c- is there a directory part ?
(when (and (neq (slen s1) 0)(eq (sref s1 0) #/[))
(setq s1 (substring s1 1))
(while (index "]" s1)
(if (setq l (scanstring s1 ".]"))
(:directory p
(cons (substring s1 0 l) (:directory p)))
(error '#:vaxvms:pathname 'ERRSXT s))
(setq s1 (substring s1 (add1 l))))
(:directory p (nreverse (:directory p))))
;;e- is there a file name ?
(if (or (eq (slen s1)0)
(eq (sref s1 0) #/.))
(setq s1 (substring s1 1))
(:name p
(substring s1 0
(if (setq l (index "." s1 )) l (setq l (slen s1)))))
(setq s1 (substring s1 (min (add1 l) (slen s1)))))
;;e- is there a type ?
(unless (eq (slen s1) 0)
(:type p
(substring s1 0
(if (setq l (index ";" s1 )) l (setq l (slen s1)))))
(setq s1 (substring s1 (min (add1 l)(slen s1)))))
;;f- is there a version ?
(unless (eq (slen s1) 0)
(:version p
(or (fixp (stratom (slen s1) s1 ()))
())))
;;; ;; lets check its a valid syntax
;;; (if (#:vaxvms:pathname-check p)
p
;;; (error 'pathname ERRSXT p)))
))))))
;;; Now, some funny functions...
;;; let'us give a standard way to get the user home-directory.. this
;;; will be useful for the layered product, as DEC says...
(de user-homedir-pathname()
(cond
(#:system:unixp (#:unix:pathname(catenate (getenv "HOME") "/")))
((eq (system) 'vaxvms) (#:vaxvms:pathname(#:vaxvms:trlnm "sys$login:")))
(t (to-system 'homedir-pathname)))))
;;; be careful for the VMS guys. The name you get can't be
;;; concateneted with others... you'll have to wait until there is a
;;; real (#:vaxvms:trlnm) function....
;;;
;;; now, let'us build the run-time control file for a layered product
(de control-file-pathname (appli)
(let ((s (string appli))
(p (user-homedir-pathname)))
(when (gt (slen s) 12) (setq s (substring s 0 11)))
(:type p (catenate s "rc"))
p)))))
;;; here is a standard way to create temporary files...
;;; this is mainly useful for test programms, and other utilities..
;;
(de temporary-file-pathname (seed)
(cond
(#:system:unixp (pathname (catenate"/tmp/" seed)))
((eq (system) 'vaxvms)
(pathname (catenate "sys$scratch:" seed)))
(t (to-system 'temporary-file-pathname seed))))
;;; a bit more complex : a function that checks that a pathname
;;; adheres to the syntaxe of all operating systems which support
;;; le-lisp... of course, this is not a finite problem... so there is
;;; no guarantee, but just a help to write portable code...
;;; first the fields device and host are not supported by all O.S and
;;; have a very special syntax and semantic, depending on the O.S.. so
;;; no check needs to be performed for these fields..
(de #:bsd:pathname-check (p) t)
(de #:sys5:pathname-check(p)
(let ((l (mcons (:type p)(:name p)(:directory p))))
(every (lambda(x) (le (slen x) 14)) l)
)))
(de #:aegis:pathname-check(p) t)
(de #:vaxvms:pathname-check (p)
(let ((l (mcons (:type p)(:name p) (:directory p))))
(and
;;no more than 8 subdirectories
(le (length (:directory p)) 8)
;;only 32 characters each
(every (lambda(x) (if x (le (slen x) 32) t)) l )
;;many characters are illegal...
(every
(lambda(x)
(not (spanstring x
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz1234567890←-$")))
l)
;;version is a number
(if (:version p) (fixp (:version p))
t)
))))))
(de portable-pathname-p (p)
(with ((outchan t))
(unless (pathnamep p)
(error 'portable-pathnamep "N'est pas un pathname" p))
(when (or (:host p)(:device p))
(printerror 'portable-pathnamep
" Attention les champs Host ou Device ne sont pas vides"
(list (:host p) (:device p))))
(unless (#:vaxvms:pathname-check p)
(printerror 'portable-pathnamep
"Pas une specification VMS" p))
(unless (#:bsd:pathname-check p)
(printerror 'portable-pathnamep
"Pas une specification BSD" p))
(unless (#:sys5:pathname-check p)
(print 'portable-pathnamep
"Pas une specification SYS5" p))
(unless (#:aegis:pathname-check p)
(print 'portable-pathnamep
"Pas une specification AEGIS" p))
))
;;; a method to print pathames in a fair way
;;;default printing is
;;; #p:the-string-in-the-os-syntaxe, or the typed vector syntax...
(de :prin (p)
(if #:system:print-for-read
(progn
(let (( #:system:print-for-read ()))
(prin ":#[ "))
(mapvector
(lambda(x)
(prin x)
(princn #/ ))
p)
(princn #/] ))
(prin "#p""" (namestring p) """"))
p)
(defsharp p ()
(ncons (pathname(read))))
(defsharp u ()
(ncons (#:unix:pathname (read))))
;;; default values for parsing and merging as defined bye
;;; CLtL
(defvar *default-pathname-defaults* #p"")
(defvar *portable-pathname* ())
(de make-pathname liste-of-elements
(let ((p (new 'pathname)))
(:host p
(or (car liste-of-elements)
(:host *default-pathname-defaults*)))
(:device p
(or (cadr liste-of-elements)
(:device *default-pathname-defaults*)))
(:directory p
(or (caddr liste-of-elements)
(:directory *default-pathname-defaults*)))
(:name p
(or (cadddr liste-of-elements)
(:name *default-pathname-defaults*)))
(:type p
(or (car (cddddr liste-of-elements))
(:type *default-pathname-defaults*)))
(:version p
(or (fixp (cadr (cddddr liste-of-elements)))
(:version *default-pathname-defaults*)))
p)))
(de file-namestring (p)
(if (pathnamep p)
(cond
(#:system:unixp (#:unix:file-namestring p))
((eq (system) 'vaxvms) (#:vaxvms:file-namestring p))
(t( to-system 'file-namestring p)))
(error 'file-namestring ERRBPA p)))
(de directory-namestring (p)
(if (pathnamep p)
(cond
(#:system:unixp (#:unix:directory-namestring p))
((eq (system) 'vaxvms) (#:vaxvms:directory-namestring p))
(t (to-system 'directory-namestring p)))
(error 'directory-namestring ERRBPA p)))
(de host-namestring (p)
(if (pathnamep p)
(cond
(#:system:unixp (#:unix:host-namestring p))
((eq (system) 'vaxvms) (#:vaxvms:host-namestring p))
(t(to-system 'host-namestring p)))
(error 'host-namestring ERRBPA p)))
(de device-namestring (p)
(if (pathnamep p)
(cond
(#:system:unixp (#:unix:device-namestring p))
((eq (system) 'vaxvms) (#:vaxvms:device-namestring p))
(t (to-system 'device-namestring p)))
(error 'device-namestring ERRBPA p)))
(de #:unix:host-namestring (p)
"")
(de #:unix:device-namestring (p) "")
(de #:unix:directory-namestring (p)
(ifn (:directory p) ""
(let ((q "/")(y (if (stringp (car (:directory p))) "/" "")))
(mapc (lambda(x) (setq y
(catenate y
(cond ((stringp x) x)
((eq x ':up) "..")
((eq x ':wild) "*")
((eq x ':current) "."))
q)))
(:directory p))
y)))
(de #:unix:file-namestring (p)
(catenate
(cond ((stringp (:name p)))
((not (:name p)) "")
((eq (:name p) ':wild) "*"))
(when (:type p) ".")
(cond ((stringp (:type p))(:type p))
((not (:type p))"")
((eq (:type p) ':wild) "*"))
(when (:version p) ".")
(cond ((fixp (:version p))(string (:version p)))
((eq (:version p) ':wild) "*")
(t ""))))
(de #:vaxvms:host-namestring (p)
(if (:host p)
(catenate (:host p) "::")
""))
(de #:vaxvms:device-namestring(p)
(if (:device p)
(catenate (:device p) ":")
""))
(de #:vaxvms:directory-namestring (p)
(let ((y "["))
(if (:directory p)
(progn
(mapc (lambda(x)
(setq y
(cond ((stringp x)
(if (or (eq (sref y (sub1 (slen y))) #/[)
(eq (sref y (sub1 (slen y))) #/.))
(catenate y x)
(catenate y "." x)))
((eq x ':wild)
(if (or (eq (sref y (sub1 (slen y))) #/[)
(eq (sref y (sub1 (slen y))) #/.))
(catenate y "*")
(catenate y ".*")))
((eq x ':current) (catenate y "."))
((eq x ':up) (catenate y "-")))))
(:directory p))
(if (eq (sref y (sub1 (slen y))) #/.)
(sset y (sub1 (slen y)) #/])
(setq y (catenate y "]")))
(if (equal y "[]") "" y))
())))
(de #:vaxvms:file-namestring (p)
(catenate
(cond
((stringp (:name p)) (:name p))
((eq (:name p) ':wild) "*")
((not (:name p)) "")
(t (error 'file-namestring 'ERRSXT (:name p))))
(if (:type p) "." "")
(cond
((stringp (:type p)) (:type p))
((eq (:type p) ':wild) "*")
((not (:type p)) "")
(t (error 'file-namestring 'ERRSXT (:type p))))
(if (:version p) ";" "")
(string (:version p))))
(de merge-pathnames ( p default)
(let ((p1 (new 'pathname)))
(:host p1
(or (:host p)
(:host default)))
(:device p1
(or (:device p)
(:device default)))
(:directory p1
(or (:directory p)
(:directory default)))
(:name p1
(or (:name p)
(:name default)))
(:type p1
(or (:type p)
(:type default)))
(:version p1
(or (:version p)
(:version default)))
p1))
(de enough-namestring (p . defaults)
(cond
((not defaults ) (setq defaults *default-pathname-defaults*))
((not (pathnamep (setq defaults (car defaults))))
(setq defaults (pathname defaults))))
(let ((p1 (new 'pathname)))
(unless (equal (:host defaults)
(:host p))
(:host p1 (:host p)))
(unless (equal (:device defaults)
(:device p))
(:device p1 (:device p)))
(unless (equal (:directory defaults)
(:directory p))
(:directory p1 (:directory p)))
(unless (equal (:name defaults)
(:name p))
(:name p1 (:name p)))
(unless (equal (:type defaults)
(:type p))
(:type p1 (:type p)))
(unless (equal (:version defaults)
(:version p))
(:version p1 (:version p)))
(namestring p1)))))
;;; this part of the code handles the true pathname facility of CLtL..
;;; The hidden mechanism may be different , depending on the operating
;;; system . UNIX has environnment variables which may be put as the
;;; beginning of a word.. VMS has logfical name translations.. etc...
( de true-pathname (p)
;; P is a pathname
(if (pathnamep p)
(cond
(#:system:unixp (#:unix:true-pathname p))
((eq (system) 'vaxvms) (#:vaxvms:true-pathname p))
(t (to-system 'true-pathname p)))
(error 'true-pathname ERRBPA p)))
(de #:unix:true-pathname (p)
;; the convention assumed here is that environnement variables
;; have been inserted somewhere in the pathname... as the first
;; element of the directory list (which will start with :current,)
;; or instead of the name of the file... we recognize it because
;; it starts with a "$" sign... so we use (getenv) to see if by
;; chance......
(let ((new-p (new 'pathname))
(new-s ()))
(if
(and (eq (car (:directory p)) ':current)
(stringp (cadr (:directory p)))
(eq (sref (cadr (:directory p)) 0) #/$)
(setq new-s (getenv (substring (cadr (:directory p))
1)))
(setq new-s (string new-s)))
(:directory new-p
(cons
(ifn (eq (sref new-s 0)#//)
new-s
(substring new-s 1))
(caddr (:directory p))))
(:directory new-p (:directory p)))
(if (and (stringp (:name p))
(eq (sref (:name p) 0 ) #/$)
(setq new-s (string (getenv (substring (:name p) 1)))))
(:name new-p new-s)
(:name new-p (:name p)))
(:type new-p (:type p))
(:version new-p (:version p))
(#:unix:pathname (#:unix:namestring new-p))))
;;; the kernel for VMS... but it doesn't work yet since it requires
;;; the help of an internal operating system routine
(de #:vaxvms:true-pathname (s)
;; On VAX/VMS the normal way is to use logical names...
;; so what we do is to build the external string, and call the
;; system service.. then we build the new pathname
(pathname (#:vaxvms:trlnm (#:vaxvms:namestring p))))
;;;a pseudo
(de #:vaxvms:trlnm(s) s) ;the compiler won't complain
;;; now, much greater...
;;; a get/set working directory, the portable way
(de current-directory p
;; P is a pathname, a string, or ()
(cond
(#:system:unixp (#:unix:current-directory (car p)))
((eq (system) 'vaxvms) (#:vaxvms:current-directory(car p)))
(t (to-system 'current-directory (car p)))))
;; the unix-way
(de #:unix:current-directory p
(cond ((not (car p))
(let ((the←string (makestring 100 #/ ))
(ret-length ()))
(setq ret-length (←llgetwd the←string 100))
(substring the←string 0 ret-length)))
((pathnamep (car p))
(let ((the←directory
(or (stringp p)
(directory-namestring (car p)))))
(←llglobb the←directory the←directory 0)))
(t (error 'current-directory ERRBPA (car p)))))
#+#:system:unixp
(progn
(defextern ←llgetwd(string fix) fix )
(defextern ←llglobb (string string fix) fix)
)
;;; And Now, ladies and gentlemen.... The wild carding process
;;; very special ....
;;; the following code uses a pathname or an external string as
;;; argument and returns all wildcarding possibilities... it is the
;;; user's responsability to do what it needs with it...
(de expand-pathname (p)
;;p is a pathname or a string which follows the full convention of
;;the host system
(cond
(#:system:unixp (#:unix:wild p))
((eq (system) 'vaxvms) (#:vaxvms:wild p))
(t (to-system 'wild (car p)))))
(defvar #:unix:wildbuffer (makestring 1024 #/ ))
(de #:unix:wild (p)
(let ((the←string #:unix:wildbuffer)
(the←pattern (or (stringp p) (namestring p)))
(the←result ()) ; list of the returned pathnames
(the←slen ())
(i ())
(j ())) ; working indexes
(setq the←slen (slen the←string))
(setq i (←llglobb the←pattern the←string the←slen))
;; strange return-codes from lelisp.c
(when (< i 0)
(setq i (←llglobb the←pattern the←string the←slen))
(if (< i 0)
(error 'errios '#:unix:wild i)))
;; buffer limits exceeded
(when (lt (differ the←slen i) 6)
(←llglobb "" "" -1)
(error 'errstl '#:unix:wild the←pattern))
;;in i, we have now the effective size of the buffer
;;the←string : the returned buffer
(setq the←string (substring the←string 0 i))
(chrset (sub1 (slen the←string)) the←string #/ )
(while (neq i 0)
(setq j (chrpos 32 the←string))
(newl the←result
(#:unix:pathname (substring the←string 0 j)))
(setq i (slen (setq the←string (substring the←string (add1 j))))))
(nreverse the←result)))
;;stubs for VMS.. the compiler won't complain
(de #:vaxvms:current-directory p ()"")
(de #:vaxvms:wild (p) ())
;;; this function coerces an external string, and when required,
;;; checks the syntaxe of the pathname
(de coerce-namestring (file-name)
(if (pathnamep file-name)
(progn
(when *portable-pathname* (portable-pathname-p file-name))
(namestring file-name))
file-name))