;;;; 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)

;;

#>
#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-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) )

;;

(define (uuid? uuid)
  (%uuid? uuid) )

(define (uuid-null? uuid)
  (and (%uuid? uuid)
       (uuid_is_null (unbox-puuid uuid))) )

(define (uuid-compare uuid1 uuid2)
  (and (%uuid? uuid1)
       (%uuid? uuid2)
       (let ((cmp (%uuid-compare uuid1 uuid2)))
	 (cond
	  ((negative? cmp)  -1)
	  ((zero? cmp)      0)
	  (else             1) ) ) ) )

(define (uuid=? uuid1 uuid2)
  (and (%uuid? uuid1)
       (%uuid? uuid2)
       (zero? (%uuid-compare uuid1 uuid2))) )

(define (uuid<>? uuid1 uuid2)
  (not (uuid=? uuid1 uuid2)) )

(define (uuid<? uuid1 uuid2)
  (and (%uuid? uuid1)
       (%uuid? uuid2)
       (negative? (%uuid-compare uuid1 uuid2))) )

(define (uuid>? uuid1 uuid2)
  (and (%uuid? uuid1)
       (%uuid? uuid2)
       (positive? (%uuid-compare uuid1 uuid2))) )

(define (uuid<=? uuid1 uuid2)
  (and (%uuid? uuid1)
       (%uuid? uuid2)
       (let ((comp (%uuid-compare uuid1 uuid2)))
         (or (zero? comp) (negative? comp)))) )

(define (uuid>=? uuid1 uuid2)
  (and (%uuid? uuid1)
       (%uuid? uuid2)
       (let ((comp (%uuid-compare uuid1 uuid2)))
         (or (zero? comp) (positive? comp)))) )

(define (uuid-clear! uuid)
  (and (%uuid? uuid)
       (uuid_clear (unbox-puuid uuid))
       uuid) )

(define (uuid-copy uuid-old)
  (and (%uuid? uuid-old)
       (let ((uuid (new-uuid)))
         (uuid_copy (unbox-puuid uuid) (unbox-puuid uuid-old))
         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 ) )

(define (make-uuid . args)
  (if (null? args) (uuid-clear! (new-uuid))
      (apply uuid-generate args) ) )

(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))
  (when (symbol? uuid-text) (set! uuid-text (symbol->string uuid-text)))
  (let ((uuid (new-uuid)))
    (and (zero? (uuid_parse uuid-text (unbox-puuid uuid)))
         uuid) ) )

(define (uuid-unparse uuid #!optional (kase #f))
  (and (%uuid? 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) ) ) )

(define (string->uuid str)
  (uuid-parse str) )

(define (uuid->string uuid)
  (uuid-unparse uuid 'lower) )

) ;module uuid-lib