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

;;;

(declare
 (usual-integrations)
 (fixnum)
 (inline)
 (no-procedure-checks)
 (no-bound-checks) )


(module uuid-lib (
    uuid?
    uuid-null?
    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)
;;

; Use of 'define-inline' results in larger binary.

(define-syntax box-puuid
  (syntax-rules ()
    [(_ PUUID)
      (tag-pointer PUUID 'uuid)] ) )

(define-syntax unbox-puuid
  (syntax-rules ()
    [(_ BOXED-PUUID)
      BOXED-PUUID] ) )

(define-syntax new-uuid
  (syntax-rules ()
    [(_)
      (set-finalizer! (box-puuid (allocate uuidlibC$sizeof-uuid)) free)] ) )

(define-syntax uuid-compare
  (syntax-rules ()
    [(_ UUID1 UUID2)
      (uuidlibC$uuid_compare (unbox-puuid UUID1) (unbox-puuid UUID2))] ) )

(define-syntax %uuid?
  (syntax-rules ()
    [(_ OBJ)
      (tagged-pointer? OBJ 'uuid)] ) )

;;

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

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

(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)
       (uuidlibC$uuid_clear (unbox-puuid uuid))
       uuid) )

(define (uuid-copy uuid)
  (and (%uuid? uuid)
       (let ([puuid (new-uuid)])
         (uuidlibC$uuid_copy puuid (unbox-puuid uuid))
         puuid)) )

(define (uuid-generate #!optional (method #f))
  (let ([puuid (new-uuid)])
    (case method
      [(random)
        (uuidlibC$uuid_generate_random puuid)]
      [(time)
        (uuidlibC$uuid_generate_time puuid)]
      [(#f)
        (uuidlibC$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? (uuidlibC$uuid_parse uuid-text puuid))
         puuid)) )

(define (uuid-unparse uuid #!optional (kase #f))
  (and (%uuid? uuid)
       (let* ([uuid-text (make-string (add1 uuidlibC$length-uuid-string))]
              [puuid-text (make-locative uuid-text)])
         (case kase
           [(upper)
             (uuidlibC$uuid_unparse_upper (unbox-puuid uuid) puuid-text)]
           [(lower)
             (uuidlibC$uuid_unparse_lower (unbox-puuid uuid) puuid-text)]
           [(#f)
             (uuidlibC$uuid_unparse (unbox-puuid uuid) puuid-text)]
           [else
             (error 'uuid-generate "invalid case" kase)])
         (substring uuid-text 0 uuidlibC$length-uuid-string) ) ) )

) ;uuid-lib