source: project/release/4/uuid-ossp/trunk/uuid-ossp.scm @ 21918

Last change on this file since 21918 was 21918, checked in by Kon Lovett, 9 years ago

Expanded the "common API" w/ uuid-lib. Rmvd uuid=, etc. (were dep in 1.3), Added "single integer value' external form support; could break on some systems with older OSSP library. Added uuid-load! Better error kinds. More comments.

Still needs the uuid-ossp-fix cut-out BS to deal with the system header conflict.

File size: 10.2 KB
Line 
1;;;; uuid-ossp.scm
2;;;; Kon Lovett, Jan '06
3
4(module uuid-ossp
5
6  (;export
7    ;
8    uuid?
9    uuid-null?
10    uuid-compare
11    uuid=? uuid<? uuid>? uuid<=? uuid>=?
12    uuid-copy
13    uuid-clear!
14    make-uuid
15    string->uuid uuid->string
16    ;
17    uuid-version
18    uuid-nil?
19    uuid-clone
20    uuid-load! uuid-load
21    uuid-import uuid-import-binary uuid-import-siv
22    uuid-export uuid-export-binary uuid-export-text uuid-export-siv
23    ;Deprecated
24    uuid<>?)
25
26  (import scheme chicken foreign)
27
28  (use lolevel)
29
30  (declare
31    (always-bound
32      +uuid-error-codes+
33      UUID_LEN_BIN UUID_LEN_STR UUID_LEN_SIV
34      UUID_RC_OK UUID_RC_ARG
35      UUID_RC_MEM UUID_RC_SYS
36      UUID_RC_INT UUID_RC_IMP
37      UUID_MAKE_V1 UUID_MAKE_V1MC UUID_MAKE_V3 UUID_MAKE_V4 UUID_MAKE_V5
38      UUID_FMT_BIN UUID_FMT_STR UUID_FMT_TXT UUID_FMT_SIV)
39    (bound-to-procedure
40      uuid_create uuid_destroy uuid_clone
41      uuid_load
42      uuid_make_0 uuid_make_2
43      uuid_isnil uuid_compare
44      uuid_import uuid_export
45      uuid_error uuid_version))
46
47#>
48#include "uuid-ossp-fix.h"
49<#
50
51(define UUID_LEN_BIN (foreign-value "uuid_LEN_BIN" unsigned-int))
52(define UUID_LEN_STR (foreign-value "uuid_LEN_STR" unsigned-int))
53(define UUID_LEN_SIV (foreign-value "uuid_LEN_SIV" unsigned-int))
54
55(define UUID_RC_OK (foreign-value "uuid_RC_OK" unsigned-int))
56(define UUID_RC_ARG (foreign-value "uuid_RC_ARG" unsigned-int))
57(define UUID_RC_MEM (foreign-value "uuid_RC_MEM" unsigned-int))
58(define UUID_RC_SYS (foreign-value "uuid_RC_SYS" unsigned-int))
59(define UUID_RC_INT (foreign-value "uuid_RC_INT" unsigned-int))
60(define UUID_RC_IMP (foreign-value "uuid_RC_IMP" unsigned-int))
61
62(define UUID_MAKE_V1 (foreign-value "uuid_MAKE_V1" unsigned-int))
63(define UUID_MAKE_V1MC (foreign-value "uuid_MAKE_V1MC" unsigned-int))
64(define UUID_MAKE_V3 (foreign-value "uuid_MAKE_V3" unsigned-int))
65(define UUID_MAKE_V4 (foreign-value "uuid_MAKE_V4" unsigned-int))
66(define UUID_MAKE_V5 (foreign-value "uuid_MAKE_V5" unsigned-int))
67
68(define UUID_FMT_BIN (foreign-value "uuid_FMT_BIN" unsigned-int))
69(define UUID_FMT_STR (foreign-value "uuid_FMT_STR" unsigned-int))
70(define UUID_FMT_TXT (foreign-value "uuid_FMT_TXT" unsigned-int))
71(define UUID_FMT_SIV (foreign-value "uuid_FMT_SIV" unsigned-int))
72
73;;
74
75(define-foreign-type size_t "size_t") ;types like this should be collected somewhere
76
77(define-foreign-type uuid_rc_t unsigned-int)
78(define-foreign-type uuid_fmt_t unsigned-int)
79(define-foreign-type uuid_t (struct "uuid_st"))
80
81(define uuid_create
82  (foreign-lambda uuid_rc_t uuid_create (c-pointer (c-pointer uuid_t))))
83
84(define uuid_destroy
85  (foreign-lambda uuid_rc_t uuid_destroy (c-pointer uuid_t)))
86
87(define uuid_clone
88  (foreign-lambda uuid_rc_t uuid_clone (const (c-pointer uuid_t)) (c-pointer (c-pointer uuid_t))))
89
90(define uuid_load
91  (foreign-lambda uuid_rc_t uuid_load (c-pointer uuid_t) (const c-string)))
92
93(define uuid_make_0
94  (foreign-lambda uuid_rc_t uuid_make (c-pointer uuid_t) unsigned-int))
95
96(define uuid_make_2
97  (foreign-lambda uuid_rc_t uuid_make (c-pointer uuid_t) unsigned-int (c-pointer uuid_t) (const c-string)))
98
99(define uuid_isnil
100  (foreign-lambda uuid_rc_t uuid_isnil (const (c-pointer uuid_t)) (c-pointer int)))
101
102(define uuid_compare
103  (foreign-lambda uuid_rc_t uuid_compare (const (c-pointer uuid_t)) (const (c-pointer uuid_t)) (c-pointer int)))
104
105(define uuid_import
106  (foreign-lambda uuid_rc_t uuid_import (c-pointer uuid_t) uuid_fmt_t (const c-string) size_t))
107
108(define uuid_export
109  (foreign-lambda uuid_rc_t uuid_export (const (c-pointer uuid_t)) uuid_fmt_t (c-pointer c-pointer) (c-pointer size_t)))
110
111(define uuid_error
112  (foreign-lambda c-string uuid_error uuid_rc_t))
113
114(define uuid_version
115  (foreign-lambda unsigned-long uuid_version))
116
117;;
118
119(define +uuid-error-codes+
120  `((,UUID_RC_OK . "everything ok")
121    (,UUID_RC_ARG . "invalid argument")
122    (,UUID_RC_MEM . "out of memory")
123    (,UUID_RC_SYS . "system error")
124    (,UUID_RC_INT . "internal error")
125    (,UUID_RC_IMP . "not implemented")))
126
127(define (uuid-error-string code)
128  (or (uuid_error code)
129      (let ((msg (assv code +uuid-error-codes+)))
130        (if msg (cdr msg)
131            "unknown result code" ) ) ) )
132
133(define (signal-uuid-error code loc)
134  (abort
135   (make-composite-condition
136    (make-property-condition 'exn 'location loc 'message (uuid-error-string code))
137    (make-property-condition 'uuid 'code code))) )
138
139(define-inline (uuid-status-ok? code)
140  (= UUID_RC_OK code) )
141
142(define-inline (error-check code loc)
143  (unless (uuid-status-ok? code)
144    (signal-uuid-error code loc) ) )
145
146;;
147
148(define-inline (unbox-puuid boxed-puuid)
149  boxed-puuid )
150
151(define (free-uuid uuid)
152  (uuid_destroy (unbox-puuid uuid)) )
153
154(define-inline (box-puuid puuid)
155  (set-finalizer! (tag-pointer puuid 'uuid-ossp) free-uuid) )
156
157(define (new-uuid loc)
158  (let-location ((puuid (c-pointer uuid_t)))
159    (error-check (uuid_create (location puuid)) loc)
160    (box-puuid puuid) ) )
161
162(define-inline (%uuid? obj)
163  (tagged-pointer? obj 'uuid-ossp) )
164
165(define (%uuid-compare uuid1 uuid2 loc)
166  (let-location ((comp int))
167    (error-check (uuid_compare (unbox-puuid uuid1) (unbox-puuid uuid2) (location comp)) loc)
168    comp ) )
169
170;;
171
172(define (uuid-import-format fmt str loc)
173  (unless (string? str)
174    (##sys#signal-hook #:type-error loc
175                       "bad argument type - not a string" str))
176  (let ((str-len
177          (select fmt
178            ((UUID_FMT_BIN) UUID_LEN_BIN)
179            ((UUID_FMT_STR) UUID_LEN_STR)
180            ((UUID_FMT_SIV) UUID_LEN_SIV)
181            (else
182              (##sys#signal-hook #:type-error loc
183                                 "bad argument type - invalid format" fmt)))))
184    (unless (= (string-length str) str-len)
185      ;type-error here is dubious
186      (##sys#signal-hook #:type-error loc
187                         "bad argument type - invalid string length" str))
188    (let ((uuid (new-uuid loc)))
189      (error-check (uuid_import (unbox-puuid uuid) fmt str str-len) loc)
190      uuid ) ) )
191
192(define (uuid-export-format uuid fmt loc)
193  (let ((len-bias
194          (select fmt
195            ((UUID_FMT_BIN) 0)
196            ((UUID_FMT_STR UUID_FMT_TXT UUID_FMT_SIV) 1)
197            (else
198              (##sys#signal-hook #:type-error loc
199                                 "bad argument type - invalid format" fmt)))))
200    (let-location ((len size_t 0)
201                   (dat c-pointer #f) )
202      (error-check (uuid_export (unbox-puuid uuid) fmt (location dat) (location len)) loc)
203      (when (or (null-pointer? dat) (zero? len))
204        (signal-uuid-error UUID_RC_INT loc))
205      (let ((str-len (fx- (inexact->exact len) len-bias)))
206        (let ((str (make-string str-len)))
207          (move-memory! dat (make-locative str) str-len)
208          (free dat)
209          str ) ) ) ) )
210
211(define (get-ns-uuid uuid ns loc)
212  (when (not ns) (set! ns "nil"))
213  (unless (string? ns)
214    (##sys#signal-hook #:type-error loc
215                       "bad argument type - not a string" ns))
216  (let ((uuid (or uuid (new-uuid loc))))
217    (error-check (uuid_load (unbox-puuid uuid) ns) loc)
218    uuid ) )
219
220(define (make-uuid-2 args uuid var loc)
221  (unless (= 2 (length args))
222    (##sys#error-hook (foreign-value "C_BAD_MINIMUM_ARGUMENT_COUNT_ERROR" int) loc
223                      3 (+ 1 (length args)) #f))
224  (let* ((ns (car args))
225         (ns-uuid (if (%uuid? ns) ns (get-ns-uuid #f ns loc)))
226         (name (cadr args)) )
227    (unless (string? name)
228      (##sys#signal-hook #:type-error loc
229                          "bad argument type - not a string" name))
230    (error-check (uuid_make_2 (unbox-puuid uuid) var (unbox-puuid ns-uuid) name) loc) ) )
231
232;;
233
234(define (uuid? obj)
235  (%uuid? obj) )
236
237(define (uuid-nil? uuid)
238  (and (%uuid? uuid)
239       (let-location ((result int))
240         (error-check (uuid_isnil (unbox-puuid uuid) (location result)) 'uuid-nil?)
241         (not (zero? result)) ) ) )
242
243;compatibility w/ uuid-lib
244(define uuid-null? uuid-nil?)
245
246(define (uuid-compare uuid1 uuid2)
247  (let ((cmp (%uuid-compare uuid1 uuid2 'uuid-compare)))
248    (cond
249      ((negative? cmp) -1)
250      ((zero? cmp)     0)
251      (else            1) ) ) )
252
253(define (uuid=? uuid1 uuid2)
254  (zero? (%uuid-compare uuid1 uuid2 'uuid=?)) )
255
256(define (uuid<>? uuid1 uuid2)
257  (not (zero? (%uuid-compare uuid1 uuid2 'uuid<>?))) )
258
259(define (uuid<? uuid1 uuid2)
260  (negative? (%uuid-compare uuid1 uuid2 'uuid<?)) )
261
262(define (uuid>? uuid1 uuid2)
263  (positive? (%uuid-compare uuid1 uuid2 'uuid>?)) )
264
265(define (uuid<=? uuid1 uuid2)
266  (let ((cmp (%uuid-compare uuid1 uuid2 'uuid<=?)))
267    (or (zero? cmp) (negative? cmp)) ) )
268
269(define (uuid>=? uuid1 uuid2)
270  (let ((cmp (%uuid-compare uuid1 uuid2 'uuid>=?)))
271    (or (zero? cmp) (positive? cmp) ) ) )
272
273;;
274
275(define (uuid-clone uuid)
276  (let-location ((puuid (c-pointer uuid_t)))
277    (error-check (uuid_clone (unbox-puuid uuid) (location puuid)) 'uuid-clone)
278    (box-puuid puuid) ) )
279
280;compatibility w/ uuid-lib
281(define uuid-copy uuid-clone)
282
283(define (make-uuid . args)
284  (let ((uuid (new-uuid 'make-uuid)))
285    (let ((variant (and (not (null? args)) (car args))))
286      (case variant
287        ((#f)
288          ) ;the nil-uuid
289        ((V1 time)
290         (error-check (uuid_make_0 (unbox-puuid uuid) UUID_MAKE_V1) 'make-uuid))
291        ((V1-MC)
292         (error-check (uuid_make_0 (unbox-puuid uuid) UUID_MAKE_V1MC) 'make-uuid))
293        ((V3)
294         (make-uuid-2 (cdr args) uuid UUID_MAKE_V3 'make-uuid))
295        ((V4 random)
296         (error-check (uuid_make_0 (unbox-puuid uuid) UUID_MAKE_V4) 'make-uuid))
297        ((V5)
298         (make-uuid-2 (cdr args) uuid UUID_MAKE_V5 'make-uuid))
299        (else
300         (##sys#signal-hook #:type-error 'make-uuid
301                            "bad argument type - invalid variant" variant) ) ) )
302    uuid ) )
303
304(define (uuid-clear! uuid)
305  (get-ns-uuid uuid "nil" 'uuid-clear!) )
306
307(define (uuid-load! uuid #!optional ns)
308  (get-ns-uuid uuid ns 'uuid-load!) )
309
310(define (uuid-load #!optional ns)
311  (get-ns-uuid #f ns 'uuid-load) )
312
313(define (uuid-import str)
314  (uuid-import-format UUID_FMT_STR str 'uuid-import) )
315
316(define (uuid-import-binary str)
317  (uuid-import-format UUID_FMT_BIN str 'uuid-import-binary) )
318
319(define (uuid-import-siv str)
320  (uuid-import-format UUID_FMT_SIV str 'uuid-import-binary) )
321
322(define (uuid-export uuid)
323  (uuid-export-format uuid UUID_FMT_STR 'uuid-export) )
324
325(define (uuid-export-binary uuid)
326  (uuid-export-format uuid UUID_FMT_BIN 'uuid-export-binary) )
327
328(define (uuid-export-text uuid)
329  (uuid-export-format uuid UUID_FMT_TXT 'uuid-export-text) )
330
331(define (uuid-export-siv uuid)
332  (uuid-export-format uuid UUID_FMT_SIV 'uuid-export-siv) )
333
334(define (string->uuid str)
335  (uuid-import str) )
336
337(define (uuid->string uuid)
338  (uuid-export uuid) )
339
340(define uuid-version uuid_version)
341
342) ;module uuid-ossp
Note: See TracBrowser for help on using the repository browser.