;;;; 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>=?
    uuid-clear!
    uuid-copy
    uuid-generate
    uuid-parse
    uuid-unparse )

  (import scheme chicken foreign)

  (use lolevel)
  (use uuid-lib-c-api)

;;

(define (box-puuid puuid)
  (tag-pointer puuid 'uuid) )

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

(define (new-uuid)
  (set-finalizer! (box-puuid (allocate sizeof-uuid)) free) )

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

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

;;

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

(define (uuid-null? uuid)
  (and (%uuid? uuid)
       (let-location ((result int (uuid_is_null (unbox-puuid uuid))))
         (not (zero? result)))) )

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

(define (uuid-generate #!optional (method #f))
  (let ((puuid (new-uuid)))
    (case method
      ((random)
        (uuid_generate_random puuid))
      ((time)
        (uuid_generate_time puuid))
      ((#f)
        (uuid_generate puuid))
      (else
        (error 'uuid-generate "invalid method" method)))
    puuid) )

(define (uuid-parse uuid-text)
  (unless (and uuid-text (or (string? uuid-text) (symbol? uuid-text)))
    (error 'uuid-parse "invalid text, must be a string or symbol" uuid-text))
  (when (symbol? uuid-text)
    (set! uuid-text (symbol->string uuid-text)))
  (let ((puuid (new-uuid)))
    (and (zero? (uuid_parse uuid-text puuid))
         puuid)) )

(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
             (error 'uuid-generate "invalid case" kase)))
         (substring uuid-text 0 length-uuid-string) ) ) )

) ;module uuid-lib