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

Last change on this file since 19530 was 19530, checked in by Kon Lovett, 10 years ago

Rel

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