;;;; uuid-lib.scm
;;;; Kon Lovett, May '06
;;;; BSD

;;; Wrapper for Theodore Y. Ts'o OSF DCE 1.1 UUID Suite
;;; http://lib.sourceforge.net/
;;; Part of MacOS X & Linux (every modern unix?)

(module uuid-lib

(;export
  ;
  uuid?
  uuid-null?
  uuid-compare
  uuid=? uuid<? uuid>? uuid<=? uuid>=?
  uuid-copy
  uuid-clear!
  make-uuid
  string->uuid uuid->string
  ;
  uuid-generate
  uuid-parse
  uuid-unparse
  ;Deprecated
  uuid<>?)

(import scheme chicken foreign)

(use lolevel)

;;

(define (fxzero? x)
  (fx= 0 x) )

(define (fxnegative? x)
  (fx< x 0) )

(define (fxpositive? x)
  (fx> x 0) )

;;

#>
#include <uuid/uuid.h>
<#

(define sizeof-uuid (foreign-value "sizeof(uuid_t)" int))

(define length-uuid-string 36)

(define uuid_is_null
  (foreign-lambda bool uuid_is_null c-pointer))

(define uuid_compare
  (foreign-lambda int uuid_compare c-pointer c-pointer))

(define uuid_clear
  (foreign-lambda void uuid_clear c-pointer))

(define uuid_copy
  (foreign-lambda void uuid_copy c-pointer c-pointer))

(define uuid_generate
  (foreign-lambda void uuid_generate c-pointer))

(define uuid_generate_random
  (foreign-lambda void uuid_generate_random c-pointer))

(define uuid_generate_time
  (foreign-lambda void uuid_generate_time c-pointer))

(define uuid_parse
  (foreign-lambda int uuid_parse c-string c-pointer))

(define uuid_unparse
  (foreign-lambda void uuid_unparse c-pointer c-pointer))

(define uuid_unparse_upper
  (foreign-lambda void uuid_unparse_upper c-pointer c-pointer))

(define uuid_unparse_lower
  (foreign-lambda void uuid_unparse_lower c-pointer c-pointer))

;;

(define-type boxed-uuid pointer)

(define-inline (unbox-puuid boxed-puuid)
  boxed-puuid )

(define (free-uuid uuid)
  (free (unbox-puuid uuid)) )

(define-inline (box-puuid puuid)
  (set-finalizer! (tag-pointer puuid 'uuid-lib) free-uuid) )

(define-inline (new-uuid)
  (box-puuid (allocate sizeof-uuid)) )

(define-inline (%uuid-compare uuid1 uuid2)
  (uuid_compare (unbox-puuid uuid1) (unbox-puuid uuid2)) )

(define-inline (%uuid? obj)
  (tagged-pointer? obj 'uuid-lib) )

;;

(: uuid? (* -> boolean : boxed-uuid))
;
(define (uuid? obj)
  (%uuid? obj) )

(: check-uuid (symbol * --> boxed-uuid))
;
(define (check-uuid loc obj)
  (unless (%uuid? obj)
    (##sys#signal-hook
      #:type-error 'uuid-compare'
      "bad argument type - not a uuid" obj))
  obj )

(: uuid-null? (* --> boolean))
;
(define (uuid-null? obj)
  (and
    (%uuid? obj)
    (uuid_is_null (unbox-puuid obj))) )

(: uuid-compare (boxed-uuid boxed-uuid --> fixnum))
;
(define (uuid-compare uuid1 uuid2)
  (let (
    (cmp
      (%uuid-compare
        (check-uuid 'uuid-compare uuid1)
        (check-uuid 'uuid-compare uuid2))) )
    (cond
      ((fxnegative? cmp)  -1)
      ((fxzero? cmp)      0)
      (else               1) ) ) )

(: uuid=? (boxed-uuid boxed-uuid --> boolean))
;
(define (uuid=? uuid1 uuid2)
  (fxzero? (%uuid-compare uuid1 uuid2)) )

(: uuid<>? (boxed-uuid boxed-uuid --> boolean))
;
(define (uuid<>? uuid1 uuid2)
  (not (uuid=? uuid1 uuid2)) )

(: uuid<? (boxed-uuid boxed-uuid --> boolean))
;
(define (uuid<? uuid1 uuid2)
  (fxnegative? (%uuid-compare uuid1 uuid2)) )

(: uuid>? (boxed-uuid boxed-uuid --> boolean))
;
(define (uuid>? uuid1 uuid2)
  (fxpositive? (%uuid-compare uuid1 uuid2)) )

(: uuid<=? (boxed-uuid boxed-uuid --> boolean))
;
(define (uuid<=? uuid1 uuid2)
  (let (
    (comp (%uuid-compare uuid1 uuid2)) )
    (or (fxzero? comp) (fxnegative? comp))) )

(: uuid>=? (boxed-uuid boxed-uuid --> boolean))
;
(define (uuid>=? uuid1 uuid2)
  (let (
    (comp (%uuid-compare uuid1 uuid2)) )
    (or (fxzero? comp) (fxpositive? comp))) )

(: uuid-clear! (boxed-uuid -> boxed-uuid))
;
(define (uuid-clear! uuid)
  (check-uuid 'uuid-clear! uuid)
  (and
    (uuid_clear (unbox-puuid uuid))
    uuid) )

(: uuid-copy (boxed-uuid --> boxed-uuid))
;
(define (uuid-copy old-uuid)
  (check-uuid 'uuid-copy old-uuid)
  (let (
    (uuid (new-uuid)) )
    (uuid_copy (unbox-puuid uuid) (unbox-puuid old-uuid))
    uuid) )

(: uuid-generate (#!optional (or boolean symbol) --> boxed-uuid))
;
(define (uuid-generate #!optional (variant #f))
  (let (
    (uuid (new-uuid)) )
    (case variant
      ((#f)
        (uuid_generate (unbox-puuid uuid)))
      ((V4 random)
        (uuid_generate_random (unbox-puuid uuid)))
      ((V1 time)
        (uuid_generate_time (unbox-puuid uuid)))
      (else
        (##sys#signal-hook #:type-error 'uuid-generate
			    "bad argument type - invalid variant" variant)))
    uuid ) )

(: make-uuid (#!optional (or boolean symbol) --> boxed-uuid))
;
(define (make-uuid . args)
  (if (null? args)
    (uuid-clear! (new-uuid))
    (apply uuid-generate args) ) )

(: uuid-parse ((or string symbol) --> boxed-uuid))
;
(define (uuid-parse uuid-text)
  (unless (or (string? uuid-text) (symbol? uuid-text))
    (##sys#signal-hook #:type-error 'uuid-parse
      "bad argument type - not a string or symbol" uuid-text))
  (let* (
    (uuid-text
      (if (symbol? uuid-text) (symbol->string uuid-text) uuid-text))
    (uuid
      (new-uuid)) )
    (and
      (zero? (uuid_parse uuid-text (unbox-puuid uuid)))
      uuid) ) )

(: uuid-unparse (boxed-uuid #!optional (or boolean symbol) --> string))
;
(define (uuid-unparse uuid #!optional (kase #f))
  (check-uuid 'uuid-unparse uuid)
  (let* (
    (uuid-text (make-string (add1 length-uuid-string)))
    (puuid-text (make-locative uuid-text)) )
    (case kase
      ((upper)
        (uuid_unparse_upper (unbox-puuid uuid) puuid-text))
      ((lower)
        (uuid_unparse_lower (unbox-puuid uuid) puuid-text))
      ((#f)
        (uuid_unparse (unbox-puuid uuid) puuid-text))
      (else
        (##sys#signal-hook #:type-error 'uuid-generate
          "bad argument type - invalid case" kase)) )
    (substring uuid-text 0 length-uuid-string) ) )

(: string->uuid (string --> boxed-uuid))
;
(define (string->uuid str)
  (uuid-parse str) )

(: uuid->string (boxed-uuid --> string))
;
(define (uuid->string uuid)
  (uuid-unparse uuid 'lower) )

) ;module uuid-lib