1
; OSLIB -- Operating System Utilities
2
; Copyright (C) 2013-2014 Centaur Technology
5
; Centaur Technology Formal Verification Group
6
; 7600-C N. Capital of Texas Highway, Suite 300, Austin, TX 78731, USA.
7
; http://www.centtech.com/
9
; License: (An MIT/X11-style license)
11
; Permission is hereby granted, free of charge, to any person obtaining a
12
; copy of this software and associated documentation files (the "Software"),
13
; to deal in the Software without restriction, including without limitation
14
; the rights to use, copy, modify, merge, publish, distribute, sublicense,
15
; and/or sell copies of the Software, and to permit persons to whom the
16
; Software is furnished to do so, subject to the following conditions:
18
; The above copyright notice and this permission notice shall be included in
19
; all copies or substantial portions of the Software.
21
; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
22
; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
23
; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
24
; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
25
; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
26
; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
27
; DEALINGS IN THE SOFTWARE.
29
; Original author: Jared Davis <jared@centtech.com>
33
(defun copy-file-fn (from to overwrite state) ;; --> (mv error/nil state)
35
(b* (((unless (live-state-p state))
36
(error "COPY-FILE can only be called on a live state.")
39
;; These should never happen due to our guard.
40
((unless (stringp from))
41
(error "COPY-FILE called on a non-stringp from?")
43
((unless (stringp to))
44
(error "COPY-FILE called on a non-stringp to?")
46
((unless (booleanp overwrite))
47
(error "COPY-FILE called on a non-boolean overwrite?")
50
((mv from-err from-kind state) (file-kind from))
51
((mv to-err to-kind state) (file-kind to))
52
((when from-err) (mv from-err state))
53
((when to-err) (mv to-err state))
55
((unless (eq from-kind :regular-file))
56
(mv (msg "~s0: can't copy ~s1: ~s2." 'copy-file from
62
((unless (or (eq to-kind nil)
63
(eq to-kind :regular-file)))
64
(mv (msg "~s0: can't copy ~s1 to ~s2: trying to overwrite ~s3."
65
'copy-file from to to-kind)
70
(cl-fad::copy-file from to :overwrite overwrite)
73
(let ((condition-str (format nil "~a" condition)))
74
(mv (msg "~s0: error copying ~s1 to ~s2: ~s3."
75
'copy-file from to condition-str)