1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
|
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name: impl.lisp
;;;; Purpose: Implementation Dependent routines for kmrcl
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Sep 2003
;;;;
;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
;;;; KMRCL users are granted the rights to distribute and use this software
;;;; as governed by the terms of the Lisp Lesser GNU Public License
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
(in-package #:kmrcl)
(defun canonicalize-directory-name (filename)
(flet ((un-unspecific (value)
(if (eq value :unspecific) nil value)))
(let* ((path (pathname filename))
(name (un-unspecific (pathname-name path)))
(type (un-unspecific (pathname-type path)))
(new-dir
(cond ((and name type) (list (concatenate 'string name "." type)))
(name (list name))
(type (list type))
(t nil))))
(if new-dir
(make-pathname
:directory (append (un-unspecific (pathname-directory path))
new-dir)
:name nil :type nil :version nil :defaults path)
path))))
(defun probe-directory (filename &key (error-if-does-not-exist nil))
(let* ((path (canonicalize-directory-name filename))
(probe
#+allegro (excl:probe-directory path)
#+clisp (values
(ignore-errors
(#+lisp=cl ext:probe-directory
#-lisp=cl lisp:probe-directory
path)))
#+(or cmu scl) (when (eq :directory
(unix:unix-file-kind (namestring path)))
path)
#+lispworks (when (lw:file-directory-p path)
path)
#+sbcl
(let ((file-kind-fun
(or (find-symbol "NATIVE-FILE-KIND" :sb-impl)
(find-symbol "UNIX-FILE-KIND" :sb-unix))))
(when (eq :directory (funcall file-kind-fun (namestring path)))
path))
#-(or allegro clisp cmu lispworks sbcl scl)
(probe-file path)))
(if probe
probe
(when error-if-does-not-exist
(error "Directory ~A does not exist." filename)))))
(defun cwd (&optional dir)
"Change directory and set default pathname"
(cond
((not (null dir))
(when (and (typep dir 'logical-pathname)
(translate-logical-pathname dir))
(setq dir (translate-logical-pathname dir)))
(when (stringp dir)
(setq dir (parse-namestring dir)))
#+allegro (excl:chdir dir)
#+clisp (#+lisp=cl ext:cd #-lisp=cl lisp:cd dir)
#+(or cmu scl) (setf (ext:default-directory) dir)
#+cormanlisp (ccl:set-current-directory dir)
#+(and mcl (not openmcl)) (ccl:set-mac-default-directory dir)
#+openmcl (ccl:cwd dir)
#+gcl (si:chdir dir)
#+lispworks (hcl:change-directory dir)
(setq cl:*default-pathname-defaults* dir))
(t
(let ((dir
#+allegro (excl:current-directory)
#+clisp (#+lisp=cl ext:default-directory #-lisp=cl lisp:default-directory)
#+(or cmu scl) (ext:default-directory)
#+sbcl (sb-unix:posix-getcwd/)
#+cormanlisp (ccl:get-current-directory)
#+lispworks (hcl:get-working-directory)
#+mcl (ccl:mac-default-directory)
#-(or allegro clisp cmu scl cormanlisp mcl sbcl lispworks) (truename ".")))
(when (stringp dir)
(setq dir (parse-namestring dir)))
dir))))
(defun quit (&optional (code 0))
"Function to exit the Lisp implementation. Copied from CLOCC's QUIT function."
#+allegro (excl:exit code :quiet t)
#+clisp (#+lisp=cl ext:quit #-lisp=cl lisp:quit code)
#+(or cmu scl) (ext:quit code)
#+cormanlisp (win32:exitprocess code)
#+gcl (lisp:bye code)
#+lispworks (lw:quit :status code)
#+lucid (lcl:quit code)
#+sbcl (sb-ext:quit :unix-status (typecase code (number code) (null 0) (t 1)))
#+mcl (ccl:quit code)
#-(or allegro clisp cmu scl cormanlisp gcl lispworks lucid sbcl mcl)
(error 'not-implemented :proc (list 'quit code)))
(defun command-line-arguments ()
#+allegro (system:command-line-arguments)
#+sbcl sb-ext:*posix-argv*
)
(defun copy-file (from to &key link overwrite preserve-symbolic-links
(preserve-time t) remove-destination force verbose)
#+allegro (sys:copy-file from to :link link :overwrite overwrite
:preserve-symbolic-links preserve-symbolic-links
:preserve-time preserve-time
:remove-destination remove-destination
:force force :verbose verbose)
#-allegro
(declare (ignore verbose preserve-symbolic-links overwrite))
(cond
((and (typep from 'stream) (typep to 'stream))
(copy-binary-stream from to))
((not (probe-file from))
(error "File ~A does not exist." from))
((eq link :hard)
(run-shell-command "ln -f ~A ~A" (namestring from) (namestring to)))
(link
(multiple-value-bind (stdout stderr status)
(command-output "ln -f ~A ~A" (namestring from) (namestring to))
(declare (ignore stdout stderr))
;; try symbolic if command failed
(unless (zerop status)
(run-shell-command "ln -sf ~A ~A" (namestring from) (namestring to)))))
(t
(when (and (or force remove-destination) (probe-file to))
(delete-file to))
(let* ((options (if preserve-time
"-p"
""))
(cmd (format nil "cp ~A ~A ~A" options (namestring from) (namestring to))))
(run-shell-command cmd)))))
|