io.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) README
(DIR) LICENSE
---
io.lisp (8280B)
---
1 ;; Copyright (c) 2002-2006, Edward Marco Baringer
2 ;; All rights reserved.
3
4 (in-package :alexandria)
5
6 (defmacro with-open-file* ((stream filespec &key direction element-type
7 if-exists if-does-not-exist external-format)
8 &body body)
9 "Just like WITH-OPEN-FILE, but NIL values in the keyword arguments mean to use
10 the default value specified for OPEN."
11 (once-only (direction element-type if-exists if-does-not-exist external-format)
12 `(with-open-stream
13 (,stream (apply #'open ,filespec
14 (append
15 (when ,direction
16 (list :direction ,direction))
17 (when ,element-type
18 (list :element-type ,element-type))
19 (when ,if-exists
20 (list :if-exists ,if-exists))
21 (when ,if-does-not-exist
22 (list :if-does-not-exist ,if-does-not-exist))
23 (when ,external-format
24 (list :external-format ,external-format)))))
25 ,@body)))
26
27 (defmacro with-input-from-file ((stream-name file-name &rest args
28 &key (direction nil direction-p)
29 &allow-other-keys)
30 &body body)
31 "Evaluate BODY with STREAM-NAME to an input stream on the file
32 FILE-NAME. ARGS is sent as is to the call to OPEN except EXTERNAL-FORMAT,
33 which is only sent to WITH-OPEN-FILE when it's not NIL."
34 (declare (ignore direction))
35 (when direction-p
36 (error "Can't specify :DIRECTION for WITH-INPUT-FROM-FILE."))
37 `(with-open-file* (,stream-name ,file-name :direction :input ,@args)
38 ,@body))
39
40 (defmacro with-output-to-file ((stream-name file-name &rest args
41 &key (direction nil direction-p)
42 &allow-other-keys)
43 &body body)
44 "Evaluate BODY with STREAM-NAME to an output stream on the file
45 FILE-NAME. ARGS is sent as is to the call to OPEN except EXTERNAL-FORMAT,
46 which is only sent to WITH-OPEN-FILE when it's not NIL."
47 (declare (ignore direction))
48 (when direction-p
49 (error "Can't specify :DIRECTION for WITH-OUTPUT-TO-FILE."))
50 `(with-open-file* (,stream-name ,file-name :direction :output ,@args)
51 ,@body))
52
53 (defun read-stream-content-into-string (stream &key (buffer-size 4096))
54 "Return the \"content\" of STREAM as a fresh string."
55 (check-type buffer-size positive-integer)
56 (let ((*print-pretty* nil))
57 (with-output-to-string (datum)
58 (let ((buffer (make-array buffer-size :element-type 'character)))
59 (loop
60 :for bytes-read = (read-sequence buffer stream)
61 :do (write-sequence buffer datum :start 0 :end bytes-read)
62 :while (= bytes-read buffer-size))))))
63
64 (defun read-file-into-string (pathname &key (buffer-size 4096) external-format)
65 "Return the contents of the file denoted by PATHNAME as a fresh string.
66
67 The EXTERNAL-FORMAT parameter will be passed directly to WITH-OPEN-FILE
68 unless it's NIL, which means the system default."
69 (with-input-from-file
70 (file-stream pathname :external-format external-format)
71 (read-stream-content-into-string file-stream :buffer-size buffer-size)))
72
73 (defun write-string-into-file (string pathname &key (if-exists :error)
74 if-does-not-exist
75 external-format)
76 "Write STRING to PATHNAME.
77
78 The EXTERNAL-FORMAT parameter will be passed directly to WITH-OPEN-FILE
79 unless it's NIL, which means the system default."
80 (with-output-to-file (file-stream pathname :if-exists if-exists
81 :if-does-not-exist if-does-not-exist
82 :external-format external-format)
83 (write-sequence string file-stream)))
84
85 (defun read-stream-content-into-byte-vector (stream &key ((%length length))
86 (initial-size 4096))
87 "Return \"content\" of STREAM as freshly allocated (unsigned-byte 8) vector."
88 (check-type length (or null non-negative-integer))
89 (check-type initial-size positive-integer)
90 (do ((buffer (make-array (or length initial-size)
91 :element-type '(unsigned-byte 8)))
92 (offset 0)
93 (offset-wanted 0))
94 ((or (/= offset-wanted offset)
95 (and length (>= offset length)))
96 (if (= offset (length buffer))
97 buffer
98 (subseq buffer 0 offset)))
99 (unless (zerop offset)
100 (let ((new-buffer (make-array (* 2 (length buffer))
101 :element-type '(unsigned-byte 8))))
102 (replace new-buffer buffer)
103 (setf buffer new-buffer)))
104 (setf offset-wanted (length buffer)
105 offset (read-sequence buffer stream :start offset))))
106
107 (defun read-file-into-byte-vector (pathname)
108 "Read PATHNAME into a freshly allocated (unsigned-byte 8) vector."
109 (with-input-from-file (stream pathname :element-type '(unsigned-byte 8))
110 (read-stream-content-into-byte-vector stream '%length (file-length stream))))
111
112 (defun write-byte-vector-into-file (bytes pathname &key (if-exists :error)
113 if-does-not-exist)
114 "Write BYTES to PATHNAME."
115 (check-type bytes (vector (unsigned-byte 8)))
116 (with-output-to-file (stream pathname :if-exists if-exists
117 :if-does-not-exist if-does-not-exist
118 :element-type '(unsigned-byte 8))
119 (write-sequence bytes stream)))
120
121 (defun copy-file (from to &key (if-to-exists :supersede)
122 (element-type '(unsigned-byte 8)) finish-output)
123 (with-input-from-file (input from :element-type element-type)
124 (with-output-to-file (output to :element-type element-type
125 :if-exists if-to-exists)
126 (copy-stream input output
127 :element-type element-type
128 :finish-output finish-output))))
129
130 (defun copy-stream (input output &key (element-type (stream-element-type input))
131 (buffer-size 4096)
132 (buffer (make-array buffer-size :element-type element-type))
133 (start 0) end
134 finish-output)
135 "Reads data from INPUT and writes it to OUTPUT. Both INPUT and OUTPUT must
136 be streams, they will be passed to READ-SEQUENCE and WRITE-SEQUENCE and must have
137 compatible element-types."
138 (check-type start non-negative-integer)
139 (check-type end (or null non-negative-integer))
140 (check-type buffer-size positive-integer)
141 (when (and end
142 (< end start))
143 (error "END is smaller than START in ~S" 'copy-stream))
144 (let ((output-position 0)
145 (input-position 0))
146 (unless (zerop start)
147 ;; FIXME add platform specific optimization to skip seekable streams
148 (loop while (< input-position start)
149 do (let ((n (read-sequence buffer input
150 :end (min (length buffer)
151 (- start input-position)))))
152 (when (zerop n)
153 (error "~@<Could not read enough bytes from the input to fulfill ~
154 the :START ~S requirement in ~S.~:@>" 'copy-stream start))
155 (incf input-position n))))
156 (assert (= input-position start))
157 (loop while (or (null end) (< input-position end))
158 do (let ((n (read-sequence buffer input
159 :end (when end
160 (min (length buffer)
161 (- end input-position))))))
162 (when (zerop n)
163 (if end
164 (error "~@<Could not read enough bytes from the input to fulfill ~
165 the :END ~S requirement in ~S.~:@>" 'copy-stream end)
166 (return)))
167 (incf input-position n)
168 (write-sequence buffer output :end n)
169 (incf output-position n)))
170 (when finish-output
171 (finish-output output))
172 output-position))