package-excl.lisp 16.2 KB
Newer Older
Zach Beane's avatar
Zach Beane committed
1
2
3
4
5
6
7
;;;; package-excl.lisp
;;;
;;; This file is a grab-bag of miscellaneous functions from EXCL.
;;;

(in-package #:zacl)

8
9
10
11
12
13
14
15
16
(defparameter *external-format-translations*
  '((:octets . :latin1)
    (:latin1-base . :latin1)
    (nil . :latin1)))

(defun translate-external-format (external-format)
  (let ((entry (assoc external-format *external-format-translations*)))
    (if entry
        (cdr entry)
17
        :utf-8)))
18
19


20
21
(defvar excl:*initial-terminal-io* *terminal-io*)

22
23
(defvar excl:*cl-default-special-bindings* nil)

24
25
(defvar excl:*required-top-level-bindings* nil)

Zach Beane's avatar
Zach Beane committed
26
27
(defvar excl:*current-case-mode* :case-insensitive-upper)

28

Zach Beane's avatar
Zach Beane committed
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
(defmacro excl:named-function (name lambda-form)
  "Return the function produced by LAMBDA-FORM wrapped in a named
function object. Useful for debugging, as the function object is no
longer anonymous, but has a meaningful name name."
  (destructuring-bind (lambda-name lambda-list &body body)
      lambda-form
    (unless (eq lambda-name 'cl:lambda)
      (error "Unexpected named-function form"))
    `(flet ((,name ,lambda-list ,@body))
       #',name)))


(defun excl:featurep (feature)
  (find feature *features*))

Zach Beane's avatar
Zach Beane committed
44

45
46
47
(defmacro excl::fast (&body body)
  `(progn ,@body))

Zach Beane's avatar
Zach Beane committed
48
49
50
51
52
53
54
(defun excl:gc (&optional full)
  (declare (ignorable full))
  #+ccl
  (ccl:gc)
  #+sbcl
  (sb-ext:gc :full full))

Zach Beane's avatar
Zach Beane committed
55
(defun excl:match-re (pattern string &key (return :string) case-fold)
56
  (multiple-value-bind (start end regs-starts regs-ends)
Zach Beane's avatar
Zach Beane committed
57
      (scan (create-scanner pattern :case-insensitive-mode case-fold) string )
58
59
60
61
62
63
64
65
66
    (when (and start end)
      (ecase return
        (:index
         (values-list (list* (cons start end) (map 'list 'cons regs-starts regs-ends))))
        (:string
         (values-list (list* (subseq string start end)
                             (map 'list (lambda (start end)
                                          (subseq string start end))
                                  regs-starts
Zach Beane's avatar
Zach Beane committed
67
68
69
                                  regs-ends))))
        ((nil)
         t)))))
Zach Beane's avatar
Zach Beane committed
70

71
72
(defun excl:match-regexp (pattern string &key (return :string))
  (excl:match-re pattern string :return return))
Zach Beane's avatar
Zach Beane committed
73

Zach Beane's avatar
Zach Beane committed
74
75
76
(defun excl:compile-regexp (pattern)
  (create-scanner pattern))

Zach Beane's avatar
Zach Beane committed
77
78
79
80

(defmacro excl:with-output-to-buffer ((stream) &body body)
  `(with-output-to-sequence (,stream)
     ,@body))
Zach Beane's avatar
Zach Beane committed
81

82
83
84
(defun excl:get-output-stream-buffer (stream)
  (get-output-stream-sequence stream))

Zach Beane's avatar
Zach Beane committed
85
86
87
88
89

;;; Streams

(defmacro excl:sm (slot-name object)
  `(slot-value ,object ',slot-name))
90

91
92
93
94
95
96
97
98
99
(defmacro excl:def-stream-class (name (&rest parents) &body slot-defs)
  `(defclass ,name (,@parents)
     ,@slot-defs))

(defmacro excl:with-stream-class ((class var) &body body)
  (declare (ignore class var))
  `(progn ,@body))

(define-condition excl:stream-closed-error (error) ())
100
(define-condition excl::socket-chunking-end-of-file (error) ())
101
102
103
104

(def-fake-slot excl::stream-property-list stream :default-value nil)
(def-fake-slot excl:stream-error-identifier stream :default-value nil)
(def-fake-slot excl:stream-error-code stream :default-value 0)
105

106
107
108
109
110
111
112
113
#+ccl
(defmethod excl:stream-error-identifier ((condition ccl:socket-error))
  (ccl:socket-error-identifier condition))

#+ccl
(defmethod excl:stream-error-code ((condition ccl:socket-error))
  (ccl:socket-error-code condition))

114
115
;;; Misc

116
117
(defstruct excl::ssl-context)

118
119
120
121
122
123
124
(defmacro excl::.atomically (&body body)
  `(progn ,@body))

(defmacro excl:atomic-conditional-setf (place new-value old-value)
  (declare (ignore old-value))
  `(setf ,place ,new-value))

125
126
127
128
129
130
131
132
133
(defmacro excl:errorset (form &optional announce catch-breaks)
  "Return NIL if FORM signals an error, T and values as multiple
values otherwise."
  (declare (ignore announce catch-breaks))
  (let ((result (gensym "RESULT")))
    `(let ((,result (multiple-value-list (ignore-errors ,form))))
       (if (not (first ,result))
           nil
           (values-list (list* t ,result))))))
Zach Beane's avatar
Zach Beane committed
134

135
136
137
(defun excl::tilde-expand-unix-namestring (namestring)
  (merge-pathnames namestring))

Zach Beane's avatar
Zach Beane committed
138
139
140
141
142
143
(defun excl:run-shell-command (program
                               &key input output error-output separate-streams
                                 wait environment show-window)
  (declare (ignore program input output error-output separate-streams wait environment show-window))
  (error "Not implemented -- RUN-SHELL-COMMAND"))

Zach Beane's avatar
Zach Beane committed
144
145
146
(defun excl::merge-to-physical (pathname)
  (merge-pathnames (translate-logical-pathname pathname)))

Zach Beane's avatar
Zach Beane committed
147
148
149
150
151
152
153
(defun excl:rename-file-raw (file new-name)
  (let ((new-name (merge-pathnames new-name
                                   (make-pathname :name :unspecific
                                                  :type :unspecific
                                                  :defaults *default-pathname-defaults*))))
    (rename-file file new-name)))

Zach Beane's avatar
Zach Beane committed
154
155
156
157
158
159
(defun excl:delimited-string-to-list (string delimiter)
  (unless (characterp delimiter)
    ;; aserve only uses a character
    (error "Unsupported delimiter -- ~A" delimiter))
  (split-sequence delimiter string))

Zach Beane's avatar
Zach Beane committed
160
(defun excl:stream-input-fn (stream)
Zach Beane's avatar
Zach Beane committed
161
  "Return the underlying Unix input FD of STREAM."
162
  (stream-unix-fd stream))
Zach Beane's avatar
Zach Beane committed
163

164
165
166
(defun excl::filesys-size (fd)
  (fstat-size fd))

167
168
169
(defvar *unix-epoch-universal-time*
  (encode-universal-time 0 0 0 1 1 1970 0))

170
(defun excl::filesys-write-date (fd)
171
  (+ *unix-epoch-universal-time* (fstat-mtime fd)))
172
173
174
175

(defun excl::filesys-type (native-namestring)
  (file-kind native-namestring))

176
(defun excl.osi:stat (file)
177
178
179
  (if (probe-file file)
      (list :mtime (stat-mtime file))
      (error "~A does not exist" file)))
180
181
182
183

(defun excl.osi:stat-mtime (stat)
  (getf stat :mtime))

184
185
(defun excl:find-external-format (name &key errorp)
  (declare (ignore errorp))
186
187
188
189
190
191
192
193
  (declare (ignore name))
  :latin-1)

(defun excl:crlf-base-ef (external-format)
  external-format)

(defun excl:ef-name (external-format)
  external-format)
194

Zach Beane's avatar
Zach Beane committed
195
(defun excl:fixnump (integer)
196
197
198
199
  (typep integer 'fixnum))

(defun excl:split-into-words (string)
  (split "\\s+" string))
Zach Beane's avatar
Zach Beane committed
200

201
202
(defun excl:split-on-character (string character)
  (split-sequence character string))
Zach Beane's avatar
Zach Beane committed
203
204
205
206
207
208

(defmacro excl::with-dynamic-extent-usb8-array ((var len) &body body)
  `(let ((,var (make-array ,len :element-type '(unsigned-byte 8))))
     ,@body))

(defun excl:native-string-sizeof (string &key (external-format :latin1))
209
  (length (string-to-octets string :external-format (translate-external-format external-format))))
Zach Beane's avatar
Zach Beane committed
210

211
(defun excl:string-to-mb (string &key external-format mb-vector null-terminate)
Zach Beane's avatar
Zach Beane committed
212
213
  (when null-terminate
    (error "Cannot null-terminate"))
214
215
216
217
218
219
  (let ((result
         (string-to-octets string
                           :external-format (translate-external-format external-format))))
    (if mb-vector
        (replace mb-vector result)
        result)))
Zach Beane's avatar
Zach Beane committed
220

221
222
223
(defun excl:string-to-octets (string &key external-format null-terminate)
  (when null-terminate
    (error "No null terminating!"))
224
225
226
227
  (string-to-octets string
                    :external-format (translate-external-format external-format)))

(defun excl:mb-to-string (string &key external-format (start 0)
Zach Beane's avatar
Zach Beane committed
228
229
                                   (end (length string)))
  (octets-to-string string
230
                    :external-format (translate-external-format external-format)
Zach Beane's avatar
Zach Beane committed
231
232
233
                    :start start
                    :end end))

234
(defun excl:octets-to-string (octets &key external-format
235
                                       string string-start string-end truncate
236
                                       (start 0) (end (length octets)))
237
238
  (when (or string string-start string-end truncate)
    (error "Unsupported options given to excl:octets-to-string"))
239
  (octets-to-string octets
240
241
                    :start start
                    :end end
242
243
                    :external-format (translate-external-format external-format)))

Zach Beane's avatar
Zach Beane committed
244
(defun excl:schedule-finalization (object fun)
Zach Beane's avatar
Zach Beane committed
245
246
247
  ;; Doesn't work; semantics differ.
  ;; (finalize object fun))
  (declare (ignore object fun)))
Zach Beane's avatar
Zach Beane committed
248
249
250

(defun excl::unix-signal (signal-number action)
  (declare (ignore signal-number action)))
Zach Beane's avatar
Zach Beane committed
251
252

(defmacro excl:without-package-locks (&body body)
253
  #-sbcl
Zach Beane's avatar
Zach Beane committed
254
255
256
  `(progn ,@body)
  #+sbcl
  `(without-package-locks ,@body))
257

Zach Beane's avatar
Zach Beane committed
258
(defmacro excl:without-interrupts (&body body)
259
260
261
  #+(or ccl sbcl)
  `(without-interrupts ,@body)
  #-(or ccl sbcl)
Zach Beane's avatar
Zach Beane committed
262
263
  `(progn ,@body))

264
265
266
(defmacro excl:defvar-nonbindable (name value &optional doc)
  #+sbcl
  `(defglobal ,name ,value ,@(if doc (list doc)))
267
268
269
  #+ccl
  `(defstaticvar ,name ,value ,@(if doc (list doc)) )
  #-(or ccl sbcl)
270
271
  `(defvar ,name ,value ,@(if doc  (list doc))))

272
273
274
275
276
277
278
279
280
281
282
283
284
285
(defclass excl:lockable-object ()
  ((lock
    :initarg :lock
    :reader lock
    :initform (make-lock))))

(defun call-with-locked-object (object fun)
  (let ((lock (lock object)))
    (with-lock-held (lock)
      (funcall fun))))

(defmacro excl:with-locked-object ((object &key type block non-smp) &body body)
  (declare (ignore type block non-smp))
  `(call-with-locked-object ,object (lambda () ,@body)))
286
287
288
289
290
291
292
293

(defstruct excl:synchronizing-structure
  (lock (make-lock)))

(defun call-with-locked-structure (struct fun)
  (with-lock-held ((synchronizing-structure-lock struct))
    (funcall fun)))

294
295
(defmacro excl:with-locked-structure ((struct &key block non-smp) &body body)
  (declare (ignore block non-smp))
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
  `(call-with-locked-structure ,struct (lambda () ,@body)))

(defmacro excl:incf-atomic (place &optional (delta 1))
  #+ccl
  ;; Doesn't work on structure slots on CCL!
  ;;`(atomic-incf-decf ,place ,delta)
  `(incf ,place ,delta)
  ;; XXX
  #-ccl
  `(incf ,place ,delta))

(defmacro excl:decf-atomic (place &optional (delta 1))
  #+ccl
  ;; Doesn't work on structure slots on CCL!
  ;;`(atomic-incf-decf ,place (- ,delta))
  `(decf ,place (- ,delta))
  ;; XXX
  #-ccl
  `(decf ,place (- ,delta)))
315
316
317
318
319
320

(defstruct (basic-lock (:include excl:synchronizing-structure))
  name)

(defun excl::make-basic-lock (&key name)
  (make-basic-lock :name name))
321
322
323
324
325

(define-condition excl:socket-error (error)
  ((identifier
    :initarg :identifier
    :reader excl:stream-error-identifier)))
326
327
328
329
330
331
332
333


;;; Streams

(defgeneric excl:device-open (stream slot-names initargs))
(defgeneric excl:device-close (stream abort))
(defgeneric excl:device-read (stream buffer start end blocking))
(defgeneric excl:device-write (stream buffer start end blocking))
Zach Beane's avatar
Zach Beane committed
334
335
336
(defgeneric excl:install-single-channel-character-strategy (stream format &optional default)
  (:method (stream format &optional default)
    (declare (ignore stream format default))))
337
338
339

(defvar excl::*std-control-out-table* nil)

Zach Beane's avatar
Zach Beane committed
340
341
342
343
344
345
346
347
348
349
350
351
352
353
(defclass zacl-simple-stream (fundamental-binary-output-stream
                              fundamental-binary-input-stream)
  ())

(defmethod stream-write-char ((stream zacl-simple-stream) char)
  (let ((buffer (string-to-octets (string char))))
    (excl:device-write stream buffer 0 (length buffer) nil)))

(defmethod stream-write-byte ((stream zacl-simple-stream) byte)
  (let ((buffer (make-array 1 :element-type '(unsigned-byte 8)
                            :initial-element byte)))
    (excl:device-write stream buffer 0 1 nil)))

(defclass excl:single-channel-simple-stream (zacl-simple-stream)
354
355
  ((excl::buffer
    :initform (make-array 1024 :element-type '(unsigned-byte 8)))
356
357
358
   (excl::output-handle
    :initarg :output-handle)
   (excl::input-handle
359
360
    :initarg :input-handle
    :reader excl::stream-input-handle)
361
362
   (excl::buffer-ptr)
   (excl::control-out)
363
   (excl::co-state)
Zach Beane's avatar
Zach Beane committed
364
   (excl::oc-state)
365
366
367
368
369
370
371
372
373
374
375
   (external-format
    :initarg :external-format
    :initform :default
    :accessor zacl-cl:stream-external-format)))

(defmethod shared-initialize :after ((stream
                                      excl:single-channel-simple-stream)
                                     slot-names
                                     &rest initargs &key &allow-other-keys)
  (excl:device-open stream slot-names initargs))

Zach Beane's avatar
Zach Beane committed
376
377
378
379
380
(defmethod close ((stream excl:single-channel-simple-stream) &key abort)
  (excl:device-close stream abort))



Zach Beane's avatar
Zach Beane committed
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
(defgeneric underlying-output-stream (stream)
  (:method ((stream excl:single-channel-simple-stream))
    (underlying-output-stream (slot-value stream 'excl::output-handle)))
  (:method ((stream stream-usocket))
    (socket-stream stream))
  (:method ((stream usocket))
    (socket-stream stream))
  (:method ((stream stream))
    stream))

(defgeneric underlying-input-stream (stream)
  (:method ((stream excl:single-channel-simple-stream))
    (underlying-input-stream (slot-value stream 'excl::input-handle)))
  (:method ((stream usocket))
    (socket-stream stream))
  (:method ((stream stream))
    stream))

Zach Beane's avatar
Zach Beane committed
399
(defmethod stream-write-string ((stream excl:single-channel-simple-stream) string &optional start end)
400
401
  (unless start (setf start 0))
  (unless end (setf end (length string)))
Zach Beane's avatar
Zach Beane committed
402
403
  (let ((buffer (string-to-octets string :start start :end end)))
    (excl:device-write stream buffer 0 (length buffer) nil)))
404

405
406
407
408
(defmethod stream-write-sequence ((stream excl:single-channel-simple-stream) sequence start end &key &allow-other-keys)
  (excl:device-write stream sequence start end nil))

#+ccl
Zach Beane's avatar
Zach Beane committed
409
410
411
(defmethod ccl:stream-write-vector ((stream excl:single-channel-simple-stream) sequence start end)
  (unless start (setf start 0))
  (unless end (setf end (length sequence)))
412
  (excl:device-write stream sequence start end nil))
Zach Beane's avatar
Zach Beane committed
413

414
415
416
417
418
419
420
421
422
#+ccl
(defmethod ccl:stream-read-vector ((stream excl:single-channel-simple-stream) sequence start end)
  (unless start (setf start 0))
  (unless end (setf end (length sequence)))
  (let ((result (excl:device-read stream sequence start end nil)))
    (if (minusp result)
        0
        result)))

Zach Beane's avatar
Zach Beane committed
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
(defmethod stream-force-output ((stream excl:single-channel-simple-stream))
  (force-output (underlying-output-stream stream)))

(defmethod stream-force-output ((stream usocket))
  (force-output (underlying-output-stream stream)))

(defmethod stream-read-char ((stream usocket))
  (stream-read-char (socket-stream stream)))

(defmethod stream-read-byte ((stream usocket))
  (stream-read-byte (socket-stream stream)))

(defmethod cl:close ((stream usocket) &key abort)
  (close (socket-stream stream) :abort abort))

438
439
440
441
442
443
444
(defmacro excl:add-stream-instance-flags (stream &rest flags)
  (declare (ignore stream flags))
  nil)

(defun excl:write-vector (vector stream &key (start 0) (end (length vector)))
  ;; The real write-vector has more complicated blocking
  ;; behavior. Save that for later.
445
446
447
448
449
450
451
  (let ((result end))
    (when (stringp vector)
      (setf vector (string-to-octets vector :start start :end end))
      (setf start 0)
      (setf end (length vector)))
    (write-sequence vector stream :start start :end end)
    result))
452

453
454
455
456
(defun excl:read-vector (vector stream &key (start 0) end endian-swap)
  (declare (ignore endian-swap))
  (read-sequence vector stream :start start :end end))

Zach Beane's avatar
Zach Beane committed
457
458
459
460
461
462
463
464
465
466
(defmethod excl::socket-bytes-written (socket &optional set)
  (declare (ignore socket))
  (or set
      42))

(defmacro excl:pop-atomic (place)
  `(pop ,place))

(defmacro excl:push-atomic (value place)
  `(push ,value ,place ))
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500


;;; MD5

(defun excl:md5-init ()
  (make-md5-state))

(defun excl:md5-update (state data &key (start 0) end external-format)
  (when (stringp data)
    (setf data (string-to-octets data
                                 :external-format (or external-format :latin-1)
                                 :start start
                                 :end (or end (length data))))
    (setf start 0)
    (setf end (length data)))
  (update-md5-state state data :start start :end end)
  (values))

(defun excl:md5-final (state &key (return :integer))
  (let ((result (finalize-md5-state state)))
    (ecase return
      (:usb8
       result)
      (:hex
       (with-output-to-string (s)
         (map nil (lambda (octet)
                    (format s "~2,'0X" octet))
              result)))
      (:integer
       (let ((i 0))
         (map nil (lambda (octet)
                    (setf i (logior (ash i 8) octet)))
              result)
         i)))))
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518

;;; FASL

(defun excl:fasl-write (object stream &optional fasl-circle compile-verbose)
  (declare (ignore compile-verbose))
  (let ((*check-for-circs* fasl-circle))
    ;; This conversion is used because calls to EXCL:FASL-WRITE assume
    ;; a bivalent stream while passing a character stream. May not
    ;; matter, because it's not in a hot spot - just called at proxy
    ;; shutdown.
    (let ((octets
           (with-output-to-sequence (s)
             (store object stream))))
      (write-string (octets-to-string octets :external-format :latin-1) stream))))

(defun excl:fasl-read (file)
  (with-open-file (stream file :element-type '(unsigned-byte 8))
    (restore stream)))