Coverage report: /home/ellis/.stash/quicklisp/dists/ultralisp/software/edicl-flexi-streams-20240429143708/external-format.lisp

KindCoveredAll%
expression51297 17.2
branch334 8.8
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: FLEXI-STREAMS; Base: 10 -*-
2
 ;;; $Header: /usr/local/cvsrep/flexi-streams/external-format.lisp,v 1.24 2008/05/26 10:55:08 edi Exp $
3
 
4
 ;;; Copyright (c) 2005-2008, Dr. Edmund Weitz.  All rights reserved.
5
 
6
 ;;; Redistribution and use in source and binary forms, with or without
7
 ;;; modification, are permitted provided that the following conditions
8
 ;;; are met:
9
 
10
 ;;;   * Redistributions of source code must retain the above copyright
11
 ;;;     notice, this list of conditions and the following disclaimer.
12
 
13
 ;;;   * Redistributions in binary form must reproduce the above
14
 ;;;     copyright notice, this list of conditions and the following
15
 ;;;     disclaimer in the documentation and/or other materials
16
 ;;;     provided with the distribution.
17
 
18
 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
19
 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
20
 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
21
 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
22
 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
23
 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
24
 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
25
 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
26
 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
27
 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
28
 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
29
 
30
 (in-package :flexi-streams)
31
 
32
 (defclass external-format ()
33
   ((name :initarg :name
34
          :reader external-format-name
35
          :documentation "The name of the external format - a
36
 keyword.")
37
    (id :initarg :id
38
        :initform nil
39
        :reader external-format-id
40
        :documentation "If the external format denotes a Windows
41
 code page this ID specifies which one to use.  Otherwise the
42
 value is ignored \(and usually NIL).")
43
    (little-endian :initarg :little-endian
44
                   :initform *default-little-endian*
45
                   :reader external-format-little-endian
46
                   :documentation "Whether multi-octet values are
47
 read and written with the least significant octet first.  For
48
 8-bit encodings like :ISO-8859-1 this value is ignored.")
49
    (eol-style :initarg :eol-style
50
               :reader external-format-eol-style
51
               :documentation "The character\(s) to or from which
52
 a #\Newline will be translated - one of the keywords :CR, :LF,
53
 or :CRLF."))
54
   (:documentation "EXTERNAL-FORMAT objects are used to denote
55
 encodings for flexi streams or for the string functions defined in
56
 strings.lisp."))
57
 
58
 (defmethod make-load-form ((thing external-format) &optional environment)
59
   "Defines a way to reconstruct external formats.  Needed for OpenMCL."
60
   (make-load-form-saving-slots thing :environment environment))
61
 
62
 (defclass flexi-cr-mixin ()
63
   ()
64
   (:documentation "A mixin for external-formats where the end-of-line
65
 designator is #\Return."))
66
 
67
 (defclass flexi-crlf-mixin ()
68
   ()
69
   (:documentation "A mixin for external-formats where the end-of-line
70
 designator is the sequence #\Return #\Linefeed."))
71
 
72
 (defclass flexi-8-bit-format (external-format)
73
   ((encoding-hash :accessor external-format-encoding-hash)
74
    (decoding-table :accessor external-format-decoding-table))
75
   (:documentation "The class for all flexi streams which use an 8-bit
76
 encoding and thus need additional slots for the encoding/decoding
77
 tables."))
78
 
79
 (defclass flexi-cr-8-bit-format (flexi-cr-mixin flexi-8-bit-format)
80
   ()
81
   (:documentation "Special class for external formats which use an
82
 8-bit encoding /and/ have #\Return as the line-end character."))
83
 
84
 (defclass flexi-crlf-8-bit-format (flexi-crlf-mixin flexi-8-bit-format)
85
   ()
86
   (:documentation "Special class for external formats which use an
87
 8-bit encoding /and/ have the sequence #\Return #\Linefeed as the
88
 line-end character."))
89
 
90
 (defclass flexi-ascii-format (flexi-8-bit-format)
91
   ()
92
   (:documentation "Special class for external formats which use the
93
 US-ASCII encoding."))
94
 
95
 (defclass flexi-cr-ascii-format (flexi-cr-mixin flexi-ascii-format)
96
   ()
97
   (:documentation "Special class for external formats which use the
98
 US-ASCII encoding /and/ have #\Return as the line-end character."))
99
 
100
 (defclass flexi-crlf-ascii-format (flexi-crlf-mixin flexi-ascii-format)
101
   ()
102
   (:documentation "Special class for external formats which use the
103
 US-ASCII encoding /and/ have the sequence #\Return #\Linefeed as the
104
 line-end character."))
105
 
106
 (defclass flexi-latin-1-format (flexi-8-bit-format)
107
   ()
108
   (:documentation "Special class for external formats which use the
109
 ISO-8859-1 encoding."))
110
 
111
 (defclass flexi-cr-latin-1-format (flexi-cr-mixin flexi-latin-1-format)
112
   ()
113
   (:documentation "Special class for external formats which use the
114
 ISO-8859-1 encoding /and/ have #\Return as the line-end character."))
115
 
116
 (defclass flexi-crlf-latin-1-format (flexi-crlf-mixin flexi-latin-1-format)
117
   ()
118
   (:documentation "Special class for external formats which use the
119
 ISO-8859-1 encoding /and/ have the sequence #\Return #\Linefeed as the
120
 line-end character."))
121
 
122
 (defclass flexi-utf-32-format (external-format)
123
   ()
124
   (:documentation "Abstract class for external formats which use the
125
 UTF-32 encoding."))
126
 
127
 (defclass flexi-utf-32-le-format (flexi-utf-32-format)
128
   ()
129
   (:documentation "Special class for external formats which use the
130
 UTF-32 encoding with little-endian byte ordering."))
131
 
132
 (defclass flexi-cr-utf-32-le-format (flexi-cr-mixin flexi-utf-32-le-format)
133
   ()
134
   (:documentation "Special class for external formats which use the
135
 UTF-32 encoding with little-endian byte ordering /and/ have #\Return
136
 as the line-end character."))
137
 
138
 (defclass flexi-crlf-utf-32-le-format (flexi-crlf-mixin flexi-utf-32-le-format)
139
   ()
140
   (:documentation "Special class for external formats which use the
141
 UTF-32 encoding with little-endian byte ordering /and/ have the
142
 sequence #\Return #\Linefeed as the line-end character."))
143
 
144
 (defclass flexi-utf-32-be-format (flexi-utf-32-format)
145
   ()
146
   (:documentation "Special class for external formats which use the
147
 UTF-32 encoding with big-endian byte ordering."))
148
 
149
 (defclass flexi-cr-utf-32-be-format (flexi-cr-mixin flexi-utf-32-be-format)
150
   ()
151
   (:documentation "Special class for external formats which use the
152
 UTF-32 encoding with big-endian byte ordering /and/ have #\Return as
153
 the line-end character."))
154
 
155
 (defclass flexi-crlf-utf-32-be-format (flexi-crlf-mixin flexi-utf-32-be-format)
156
   ()
157
   (:documentation "Special class for external formats which use the
158
 the UTF-32 encoding with big-endian byte ordering /and/ have the
159
 sequence #\Return #\Linefeed as the line-end character."))
160
 
161
 (defclass flexi-utf-16-format (external-format)
162
   ()
163
   (:documentation "Abstract class for external formats which use the
164
 UTF-16 encoding."))
165
 
166
 (defclass flexi-utf-16-le-format (flexi-utf-16-format)
167
   ()
168
   (:documentation "Special class for external formats which use the
169
 UTF-16 encoding with little-endian byte ordering."))
170
 
171
 (defclass flexi-cr-utf-16-le-format (flexi-cr-mixin flexi-utf-16-le-format)
172
   ()
173
   (:documentation "Special class for external formats which use the
174
 UTF-16 encoding with little-endian byte ordering /and/ have #\Return
175
 as the line-end character."))
176
 
177
 (defclass flexi-crlf-utf-16-le-format (flexi-crlf-mixin flexi-utf-16-le-format)
178
   ()
179
   (:documentation "Special class for external formats which use the
180
 UTF-16 encoding with little-endian byte ordering /and/ have the
181
 sequence #\Return #\Linefeed as the line-end character."))
182
 
183
 (defclass flexi-utf-16-be-format (flexi-utf-16-format)
184
   ()
185
   (:documentation "Special class for external formats which use the
186
 UTF-16 encoding with big-endian byte ordering."))
187
 
188
 (defclass flexi-cr-utf-16-be-format (flexi-cr-mixin flexi-utf-16-be-format)
189
   ()
190
   (:documentation "Special class for external formats which use the
191
 UTF-16 encoding with big-endian byte ordering /and/ have #\Return as
192
 the line-end character."))
193
 
194
 (defclass flexi-crlf-utf-16-be-format (flexi-crlf-mixin flexi-utf-16-be-format)
195
   ()
196
   (:documentation "Special class for external formats which use the
197
 UTF-16 encoding with big-endian byte ordering /and/ have the sequence
198
 #\Return #\Linefeed as the line-end character."))
199
 
200
 (defclass flexi-gbk-format (external-format)
201
      ()
202
   (:documentation "Special class for external formats which use the
203
 gbk encoding."))
204
 
205
 (defclass flexi-cr-gbk-format (flexi-cr-mixin flexi-gbk-format)
206
      ()
207
   (:documentation "Special class for external formats which use the
208
 gbk encoding /and/ have #\Return as the line-end character."))
209
 
210
 (defclass flexi-crlf-gbk-format (flexi-crlf-mixin flexi-gbk-format)
211
      ()
212
   (:documentation "Special class for external formats which use the
213
 gbk encoding /and/ have the sequence #\Return #\Linefeed as the 
214
 line-end character."))
215
 (defclass flexi-utf-8-format (external-format)
216
   ()
217
   (:documentation "Special class for external formats which use the
218
 UTF-8 encoding."))
219
 
220
 (defclass flexi-cr-utf-8-format (flexi-cr-mixin flexi-utf-8-format)
221
   ()
222
   (:documentation "Special class for external formats which use the
223
 UTF-8 encoding /and/ have #\Return as the line-end character."))
224
 
225
 (defclass flexi-crlf-utf-8-format (flexi-crlf-mixin flexi-utf-8-format)
226
   ()
227
   (:documentation "Special class for external formats which use the
228
 UTF-8 encoding /and/ have the sequence #\Return #\Linefeed as the
229
 line-end character."))
230
 
231
 (defmethod initialize-instance :after ((external-format flexi-8-bit-format) &rest initargs)
232
   "Sets the fixed encoding/decoding tables for this particular
233
 external format."
234
   (declare #.*standard-optimize-settings*)
235
   (declare (ignore initargs))
236
   (with-accessors ((encoding-hash external-format-encoding-hash)
237
                    (decoding-table external-format-decoding-table)
238
                    (name external-format-name)
239
                    (id external-format-id))
240
       external-format
241
     (multiple-value-setq (encoding-hash decoding-table)
242
         (cond ((ascii-name-p name)
243
                (values +ascii-hash+ +ascii-table+))
244
               ((koi8-r-name-p name)
245
                (values +koi8-r-hash+ +koi8-r-table+))
246
               ((mac-roman-name-p name)
247
                (values +mac-roman-hash+ +mac-roman-table+))
248
               ((iso-8859-name-p name)
249
                (values (cdr (assoc name +iso-8859-hashes+ :test #'eq))                       
250
                        (cdr (assoc name +iso-8859-tables+ :test #'eq))))
251
               ((code-page-name-p name)
252
                (values (cdr (assoc id +code-page-hashes+))                       
253
                        (cdr (assoc id +code-page-tables+))))))))
254
 
255
 (defun external-format-class-name (real-name &key eol-style little-endian id)
256
   "Given the initargs for a general external format returns the name
257
 \(a symbol) of the most specific subclass matching these arguments."
258
   (declare #.*standard-optimize-settings*)
259
   (declare (ignore id))
260
   (cond ((ascii-name-p real-name)
261
          (ecase eol-style
262
            (:lf 'flexi-ascii-format)
263
            (:cr 'flexi-cr-ascii-format)
264
            (:crlf 'flexi-crlf-ascii-format)))
265
         ((eq real-name :iso-8859-1)
266
          (ecase eol-style
267
            (:lf 'flexi-latin-1-format)
268
            (:cr 'flexi-cr-latin-1-format)
269
            (:crlf 'flexi-crlf-latin-1-format)))
270
         ((or (koi8-r-name-p real-name)
271
              (mac-roman-name-p real-name)
272
              (iso-8859-name-p real-name)
273
              (code-page-name-p real-name))
274
          (ecase eol-style
275
            (:lf 'flexi-8-bit-format)
276
            (:cr 'flexi-cr-8-bit-format)
277
            (:crlf 'flexi-crlf-8-bit-format)))
278
         (t (ecase real-name
279
              (:utf-8 (ecase eol-style
280
                        (:lf 'flexi-utf-8-format)
281
                        (:cr 'flexi-cr-utf-8-format)
282
                        (:crlf 'flexi-crlf-utf-8-format)))
283
              (:utf-16 (ecase eol-style
284
                         (:lf (if little-endian
285
                                'flexi-utf-16-le-format
286
                                'flexi-utf-16-be-format))
287
                         (:cr (if little-endian
288
                                'flexi-cr-utf-16-le-format
289
                                'flexi-cr-utf-16-be-format))
290
                         (:crlf (if little-endian
291
                                  'flexi-crlf-utf-16-le-format
292
                                  'flexi-crlf-utf-16-be-format))))
293
              (:gbk (ecase eol-style
294
                      (:lf 'flexi-gbk-format)
295
                      (:cr 'flexi-cr-gbk-format)
296
                      (:crlf 'flexi-crlf-gbk-format)))
297
              (:utf-32 (ecase eol-style
298
                         (:lf (if little-endian
299
                                'flexi-utf-32-le-format
300
                                'flexi-utf-32-be-format))
301
                         (:cr (if little-endian
302
                                'flexi-cr-utf-32-le-format
303
                                'flexi-cr-utf-32-be-format))
304
                         (:crlf (if little-endian
305
                                  'flexi-crlf-utf-32-le-format
306
                                  'flexi-crlf-utf-32-be-format))))))))
307
                          
308
 (defun make-external-format% (name &key (little-endian *default-little-endian*)
309
                                    id eol-style)
310
   "Used internally by MAKE-EXTERNAL-FORMAT to default some of the
311
 keywords arguments and to determine the right subclass of
312
 EXTERNAL-FORMAT."
313
   (declare #.*standard-optimize-settings*)
314
   (let* ((real-name (normalize-external-format-name name))
315
          (initargs
316
           (cond ((or (iso-8859-name-p real-name)
317
                      (koi8-r-name-p real-name)
318
                      (ascii-name-p real-name))
319
                  (list :eol-style (or eol-style *default-eol-style*)))
320
                 ((mac-roman-name-p real-name)
321
                  ;; Default EOL style for mac-roman is :CR.
322
                  (list :eol-style (or eol-style :cr)))
323
                 ((code-page-name-p real-name)
324
                  (list :id (or (known-code-page-id-p id)
325
                                (error 'external-format-error
326
                                       :format-control "Unknown code page ID ~S"
327
                                       :format-arguments (list id)))
328
                        ;; default EOL style for Windows code pages is :CRLF
329
                        :eol-style (or eol-style :crlf)))
330
                 (t (list :eol-style (or eol-style *default-eol-style*)
331
                          :little-endian little-endian)))))
332
     (apply #'make-instance (apply #'external-format-class-name real-name initargs)
333
            :name real-name
334
            initargs)))
335
 
336
 (defun make-external-format (name &rest args
337
                                   &key (little-endian *default-little-endian*)
338
                                        id eol-style)
339
   "Creates and returns an external format object as specified.
340
 NAME is a keyword like :LATIN1 or :UTF-8, LITTLE-ENDIAN specifies
341
 the `endianess' of the external format and is ignored for 8-bit
342
 encodings, EOL-STYLE is one of the keywords :CR, :LF, or :CRLF
343
 which denote the end-of-line character \(sequence), ID is the ID
344
 of a Windows code page \(and ignored for other encodings)."
345
   (declare #.*standard-optimize-settings*)
346
   ;; the keyword arguments are only there for arglist display in the IDE
347
   (declare (ignore id little-endian))
348
   (let ((shortcut-args (cdr (assoc name +shortcut-map+ :test #'string-equal))))
349
     (cond (shortcut-args
350
            (apply #'make-external-format%
351
                   (append shortcut-args
352
                           `(:eol-style ,eol-style))))
353
           (t (apply #'make-external-format% name args)))))
354
 
355
 (defun maybe-convert-external-format (external-format)
356
   "Given an external format designator \(a keyword, a list, or an
357
 EXTERNAL-FORMAT object) returns the corresponding EXTERNAL-FORMAT
358
 object."
359
   (declare #.*standard-optimize-settings*)
360
   (typecase external-format
361
     (symbol (make-external-format external-format))
362
     (list (apply #'make-external-format external-format))
363
     (otherwise external-format)))
364
   
365
 (defun external-format-equal (ef1 ef2)
366
   "Checks whether two EXTERNAL-FORMAT objects denote the same encoding."
367
   (declare #.*standard-optimize-settings*)
368
   (let* ((name1 (external-format-name ef1))
369
          (code-page-name-p (code-page-name-p name1)))
370
     ;; they must habe the same canonical name
371
     (and (eq name1
372
              (external-format-name ef2))
373
          ;; if both are code pages the IDs must be the same
374
          (or (not code-page-name-p)
375
              (eql (external-format-id ef1)
376
                   (external-format-id ef2)))
377
          ;; for non-8-bit encodings the endianess must be the same
378
          (or code-page-name-p
379
              (ascii-name-p name1)
380
              (koi8-r-name-p name1)
381
              (mac-roman-name-p name1)
382
              (iso-8859-name-p name1)
383
              (eq name1 :utf-8)
384
              (eq (not (external-format-little-endian ef1))
385
                  (not (external-format-little-endian ef2))))
386
          ;; the EOL style must also be the same
387
          (eq (external-format-eol-style ef1)
388
              (external-format-eol-style ef2)))))
389
 
390
 (defun normalize-external-format (external-format)
391
   "Returns a list which is a `normalized' representation of the
392
 external format EXTERNAL-FORMAT.  Used internally by PRINT-OBJECT, for
393
 example.  Basically, the result is an argument list that can be fed
394
 back to MAKE-EXTERNAL-FORMAT to create an equivalent object."
395
   (declare #.*standard-optimize-settings*)
396
   (let ((name (external-format-name external-format))
397
         (eol-style (external-format-eol-style external-format)))
398
     (cond ((or (ascii-name-p name)
399
                (koi8-r-name-p name)
400
                (mac-roman-name-p name)
401
                (iso-8859-name-p name)
402
                (eq name :utf-8))
403
            (list name :eol-style eol-style))
404
           ((code-page-name-p name)
405
            (list name
406
                  :id (external-format-id external-format)
407
                  :eol-style eol-style))
408
           (t (list name
409
                    :eol-style eol-style
410
                    :little-endian (external-format-little-endian external-format))))))
411
 
412
 (defmethod print-object ((object external-format) stream)
413
   "How an EXTERNAL-FORMAT object is rendered.  Uses
414
 NORMALIZE-EXTERNAL-FORMAT."
415
   (print-unreadable-object (object stream :type t :identity t)
416
     (prin1 (normalize-external-format object) stream)))