package-excl.lisp 18.1 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
(defparameter *external-format-translations*
  '((:octets . :latin1)
    (:latin1-base . :latin1)
11
    (:utf-8 . :utf-8)
12
13
14
15
16
17
    (nil . :latin1)))

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


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

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

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

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

29

Zach Beane's avatar
Zach Beane committed
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
(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
45

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

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

Zach Beane's avatar
Zach Beane committed
56
(defun excl:match-re (pattern string &key (return :string) case-fold)
57
  (multiple-value-bind (start end regs-starts regs-ends)
Zach Beane's avatar
Zach Beane committed
58
      (scan (create-scanner pattern :case-insensitive-mode case-fold) string )
59
60
61
62
63
64
65
66
67
    (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
68
69
70
                                  regs-ends))))
        ((nil)
         t)))))
Zach Beane's avatar
Zach Beane committed
71

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

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

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

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

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

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

;;; Streams

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

92
93
94
95
96
97
98
99
100
(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) ())
101
(define-condition excl::socket-chunking-end-of-file (error) ())
102
103
104
105

(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)
106
107
(defmethod excl:stream-error-identifier (condition)
  (socket-error-identifier condition))
108

109
110
(defmethod excl:stream-error-code (condition)
  (socket-error-code condition))
111

112
113
;;; Misc

114
115
(defstruct excl::ssl-context)

116
117
118
119
120
121
122
(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))

123
124
125
126
127
128
129
130
131
(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
132

133
134
135
(defun excl::tilde-expand-unix-namestring (namestring)
  (merge-pathnames namestring))

Zach Beane's avatar
Zach Beane committed
136
137
138
139
140
141
(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
142
143
144
(defun excl::merge-to-physical (pathname)
  (merge-pathnames (translate-logical-pathname pathname)))

Zach Beane's avatar
Zach Beane committed
145
146
147
148
149
150
151
(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
152
153
154
155
156
157
(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
158
(defun excl:stream-input-fn (stream)
Zach Beane's avatar
Zach Beane committed
159
  "Return the underlying Unix input FD of STREAM."
160
  (stream-unix-fd stream))
Zach Beane's avatar
Zach Beane committed
161

162
163
164
(defun excl::filesys-size (fd)
  (fstat-size fd))

165
166
167
(defvar *unix-epoch-universal-time*
  (encode-universal-time 0 0 0 1 1 1970 0))

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

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

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

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

182
183
(defun excl:find-external-format (name &key errorp)
  (declare (ignore errorp))
184
  (translate-external-format name))
185
186
187
188
189
190

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

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

Zach Beane's avatar
Zach Beane committed
192
(defun excl:fixnump (integer)
193
194
195
196
  (typep integer 'fixnum))

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

198
199
(defun excl:split-on-character (string character)
  (split-sequence character string))
Zach Beane's avatar
Zach Beane committed
200
201
202
203
204
205

(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))
206
  (length (string-to-octets string :external-format (translate-external-format external-format))))
Zach Beane's avatar
Zach Beane committed
207

208
(defun excl:string-to-mb (string &key external-format mb-vector null-terminate)
Zach Beane's avatar
Zach Beane committed
209
210
  (when null-terminate
    (error "Cannot null-terminate"))
211
212
213
214
215
216
  (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
217

218
219
220
(defun excl:string-to-octets (string &key external-format null-terminate)
  (when null-terminate
    (error "No null terminating!"))
221
222
223
224
  (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
225
226
                                   (end (length string)))
  (octets-to-string string
227
                    :external-format (translate-external-format external-format)
Zach Beane's avatar
Zach Beane committed
228
229
230
                    :start start
                    :end end))

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

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

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

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

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

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

269
270
271
272
273
274
275
276
277
278
279
280
281
282
(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)))
283
284
285
286
287
288
289
290

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

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

291
292
(defmacro excl:with-locked-structure ((struct &key block non-smp) &body body)
  (declare (ignore block non-smp))
293
294
295
  `(call-with-locked-structure ,struct (lambda () ,@body)))

(defmacro excl:incf-atomic (place &optional (delta 1))
296
  ;; XXX FIXME
297
298
299
  `(incf ,place ,delta))

(defmacro excl:decf-atomic (place &optional (delta 1))
300
  ;; XXX FIXME
301
  `(decf ,place (- ,delta)))
302
303
304
305
306
307

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

(defun excl::make-basic-lock (&key name)
  (make-basic-lock :name name))
308
309
310
311
312

(define-condition excl:socket-error (error)
  ((identifier
    :initarg :identifier
    :reader excl:stream-error-identifier)))
313
314
315
316
317
318
319
320


;;; 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
321
322
323
(defgeneric excl:install-single-channel-character-strategy (stream format &optional default)
  (:method (stream format &optional default)
    (declare (ignore stream format default))))
324
325
326

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

Zach Beane's avatar
Zach Beane committed
327
328
329
330
(defclass zacl-simple-stream (fundamental-binary-output-stream
                              fundamental-binary-input-stream)
  ())

331
332
333
334
;; Needed for SBCL
(defmethod stream-element-type ((stream zacl-simple-stream))
  '(unsigned-byte 8))

Zach Beane's avatar
Zach Beane committed
335
336
337
338
339
340
341
342
343
344
(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)
345
  ((excl::buffer
346
347
    :initform (make-array 1024 :element-type '(unsigned-byte 8))
    :reader buffer)
348
349
350
   (excl::output-handle
    :initarg :output-handle)
   (excl::input-handle
351
352
    :initarg :input-handle
    :reader excl::stream-input-handle)
353
354
   (excl::buffer-ptr)
   (excl::control-out)
355
   (excl::co-state)
Zach Beane's avatar
Zach Beane committed
356
   (excl::oc-state)
357
358
   (external-format
    :initarg :external-format
359
    :initform :latin1
360
361
362
363
364
365
366
367
    :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
368
369
370
371
372
(defmethod close ((stream excl:single-channel-simple-stream) &key abort)
  (excl:device-close stream abort))



Zach Beane's avatar
Zach Beane committed
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
(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
391
(defmethod stream-write-string ((stream excl:single-channel-simple-stream) string &optional start end)
392
393
  (unless start (setf start 0))
  (unless end (setf end (length string)))
394
395
  (let ((buffer (string-to-octets string :start start :end end
                                  :external-format (zacl-cl:stream-external-format stream))))
Zach Beane's avatar
Zach Beane committed
396
    (excl:device-write stream buffer 0 (length buffer) nil)))
397

398
(defmethod stream-write-sequence ((stream excl:single-channel-simple-stream) sequence start end &key &allow-other-keys)
399
400
  (excl:device-write stream sequence start end nil)
  sequence)
401
402

#+ccl
Zach Beane's avatar
Zach Beane committed
403
404
405
(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)))
406
  (excl:device-write stream sequence start end nil))
Zach Beane's avatar
Zach Beane committed
407

408
409
410
411
#+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)))
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
  (if (stringp sequence)
      (let ((result (excl:device-read stream nil 0 nil nil))
            (buffer (buffer stream )))
        (when (minusp result)
          (return-from ccl:stream-read-vector 0))
        (when (<= (- end start) result)
          (error "Can't handle buffering yet"))
        (let ((string (octets-to-string buffer
                                        :end result
                                        :external-format (zacl-cl:stream-external-format stream))))
          (replace sequence string :start1 start :end1 end)
          (min end (+ start (length string)))))
      (let ((result (excl:device-read stream sequence start end nil)))
        (if (minusp result)
            0
            result))))
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448

(defmethod stream-read-sequence ((stream excl:single-channel-simple-stream) sequence start end
                                 &key &allow-other-keys)
  (unless start (setf start 0))
  (unless end (setf end (length sequence)))
  (if (stringp sequence)
      (let ((result (excl:device-read stream nil 0 nil nil))
            (buffer (buffer stream )))
        (when (minusp result)
          (return-from stream-read-sequence 0))
        (when (<= (- end start) result)
          (error "Can't handle buffering yet"))
        (let ((string (octets-to-string buffer
                                        :end result
                                        :external-format (zacl-cl:stream-external-format stream))))
          (replace sequence string :start1 start :end1 end)
          (min end (+ start (length string)))))
      (let ((result (excl:device-read stream sequence start end nil)))
        (if (minusp result)
            0
            result))))
449

Zach Beane's avatar
Zach Beane committed
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
(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))

465
466
467
468
469
470
471
(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.
472
473
474
475
476
477
478
  (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))
479

480
481
482
483
(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
484
485
486
487
488
489
490
491
492
493
(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 ))
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527


;;; 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)))))
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545

;;; 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)))
546
547
548

;;; BASE64

549
(defun excl:base64-string-to-string (string)
550
  (cl-base64:base64-string-to-string string))
551
552

(defun excl:string-to-base64-string (str)
553
554
  (cl-base64:string-to-base64-string str :columns 52))

555
556
557
558
559
560
561
562

;;; Microtime

(defconstant excl::base-for-internal-real-time -455615030)

(defun excl::acl-internal-real-time ()
  (values (-  (get-universal-time) 4165516800)
	  (/ (local-time:nsec-of (local-time:now)) 1000)))