;;;; uuid-ossp.scm
;;;; Kon Lovett, Jan '06

(module uuid-ossp

  (;export
    uuid-version
    make-uuid
    uuid?
    uuid-nil? uuid-null?
    uuid-compare
    uuid=? uuid<>? uuid<? uuid>? uuid<=? uuid>=?
    uuid-clone
    uuid-load
    uuid-import
    uuid-import-binary
    uuid-export
    uuid-export-binary
    uuid-export-text
    ;DEPRECATED
    uuid= uuid<> uuid< uuid> uuid<= uuid>=)

  (import scheme chicken foreign)

  (use lolevel)

  (declare
    (always-bound
      +uuid-error-codes+
      UUID_LEN_BIN UUID_LEN_STR
      UUID_RC_OK UUID_RC_ARG
      UUID_RC_MEM UUID_RC_SYS
      UUID_RC_INT UUID_RC_IMP
      UUID_MAKE_V1 UUID_MAKE_V1MC UUID_MAKE_V3 UUID_MAKE_V4 UUID_MAKE_V5
      UUID_FMT_BIN UUID_FMT_STR UUID_FMT_TXT)
    (bound-to-procedure
      uuid_create uuid_destroy uuid_clone
      uuid_load
      uuid_make_0 uuid_make_2
      uuid_isnil uuid_compare
      uuid_import uuid_export
      uuid_error uuid_version))


#>
#include "uuid-ossp-fix.h"
<#

(define UUID_LEN_BIN (foreign-value "uuid_LEN_BIN" unsigned-int))
(define UUID_LEN_STR (foreign-value "uuid_LEN_STR" unsigned-int))

(define UUID_RC_OK (foreign-value "uuid_RC_OK" unsigned-int))
(define UUID_RC_ARG (foreign-value "uuid_RC_ARG" unsigned-int))
(define UUID_RC_MEM (foreign-value "uuid_RC_MEM" unsigned-int))
(define UUID_RC_SYS (foreign-value "uuid_RC_SYS" unsigned-int))
(define UUID_RC_INT (foreign-value "uuid_RC_INT" unsigned-int))
(define UUID_RC_IMP (foreign-value "uuid_RC_IMP" unsigned-int))

(define UUID_MAKE_V1 (foreign-value "uuid_MAKE_V1" unsigned-int))
(define UUID_MAKE_V1MC (foreign-value "uuid_MAKE_V1MC" unsigned-int))
(define UUID_MAKE_V3 (foreign-value "uuid_MAKE_V3" unsigned-int))
(define UUID_MAKE_V4 (foreign-value "uuid_MAKE_V4" unsigned-int))
(define UUID_MAKE_V5 (foreign-value "uuid_MAKE_V5" unsigned-int))

(define UUID_FMT_BIN (foreign-value "uuid_FMT_BIN" unsigned-int))
(define UUID_FMT_STR (foreign-value "uuid_FMT_STR" unsigned-int))
(define UUID_FMT_TXT (foreign-value "uuid_FMT_TXT" unsigned-int))

;;

(define-foreign-type size_t unsigned-long)
(define-foreign-type uuid_rc_t unsigned-int)
(define-foreign-type uuid_fmt_t unsigned-int)
(define-foreign-type uuid_t (struct "uuid_st"))

(define uuid_create
  (foreign-lambda uuid_rc_t uuid_create (c-pointer (c-pointer uuid_t))))

(define uuid_destroy
  (foreign-lambda uuid_rc_t uuid_destroy (c-pointer uuid_t)))

(define uuid_clone
  (foreign-lambda uuid_rc_t uuid_clone (const (c-pointer uuid_t)) (c-pointer (c-pointer uuid_t))))

(define uuid_load
  (foreign-lambda uuid_rc_t uuid_load (c-pointer uuid_t) (const c-string)))

(define uuid_make_0
  (foreign-lambda uuid_rc_t uuid_make (c-pointer uuid_t) unsigned-int))

(define uuid_make_2
  (foreign-lambda uuid_rc_t uuid_make (c-pointer uuid_t) unsigned-int (c-pointer uuid_t) (const c-string)))

(define uuid_isnil
  (foreign-lambda uuid_rc_t uuid_isnil (const (c-pointer uuid_t)) (c-pointer int)))

(define uuid_compare
  (foreign-lambda uuid_rc_t uuid_compare (const (c-pointer uuid_t)) (const (c-pointer uuid_t)) (c-pointer int)))

(define uuid_import
  (foreign-lambda uuid_rc_t uuid_import (c-pointer uuid_t) uuid_fmt_t (const c-string) size_t))

(define uuid_export
  (foreign-lambda uuid_rc_t uuid_export (const (c-pointer uuid_t)) uuid_fmt_t (c-pointer c-pointer) (c-pointer size_t)))

(define uuid_error
  (foreign-lambda c-string uuid_error uuid_rc_t))

(define uuid_version
  (foreign-lambda unsigned-long uuid_version))

;;

(define +uuid-error-codes+ (list
  `(,UUID_RC_OK . "everything ok")
  `(,UUID_RC_ARG . "invalid argument")
  `(,UUID_RC_MEM . "out of memory")
  `(,UUID_RC_SYS . "system error")
  `(,UUID_RC_INT . "internal error")
  `(,UUID_RC_IMP . "not implemented") ) )

(define (uuid-error-string code)
  (or (uuid_error code)
      (let ((msg (assv code +uuid-error-codes+)))
        (if msg (cdr msg)
          "unknown result code" ) ) ) )

(define (signal-uuid-error code loc)
  (abort
    (make-composite-condition
      (make-property-condition 'exn 'location loc 'message (uuid-error-string code))
      (make-property-condition 'uuid 'code code))) )

(define-inline (uuid-status-ok? code)
  (= UUID_RC_OK code) )

(define-inline (error-check code loc)
  (unless (uuid-status-ok? code)
    (signal-uuid-error code loc) ) )

;;

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

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

(define-inline (box-puuid puuid)
  (let ((boxed-puuid (tag-pointer puuid 'ossp-uuid)))
    (set-finalizer! boxed-puuid free-uuid)
    boxed-puuid ) )

(define (new-uuid loc)
  (let-location ((puuid (c-pointer uuid_t)))
    (error-check (uuid_create (location puuid)) loc)
    (box-puuid puuid) ) )

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

(define (%uuid-compare uuid1 uuid2 loc)
  (let-location ((comp int))
    (error-check (uuid_compare (unbox-puuid uuid1) (unbox-puuid uuid2) (location comp)) loc)
    comp ) )

;;

(define (uuid-import-format fmt str loc)
  (unless (string? str)
    (error loc "can only import from a string" str))
  (let ((str-len
          (select fmt
            ((UUID_FMT_BIN) UUID_LEN_BIN)
            ((UUID_FMT_STR) UUID_LEN_STR)
            (else
              (error loc "invalid format" fmt)))))
    (unless (= (string-length str) str-len)
      (error loc "invalid length of string: wanted:" str str-len))
    (let ((uuid (new-uuid loc)))
      (error-check (uuid_import (unbox-puuid uuid) fmt str str-len) loc)
      uuid ) ) )

(define (uuid-export-format uuid fmt loc)
  (let ((str-bias
          (select fmt
            ((UUID_FMT_BIN) 0)
            ((UUID_FMT_STR) 1)
            ((UUID_FMT_TXT) 1)
            (else
              (error loc "invalid format" fmt)))))
    (let-location ((len size_t 0) (dat c-pointer #f))
      (error-check (uuid_export (unbox-puuid uuid) fmt (location dat) (location len)) loc)
      (when (or (null-pointer? dat) (zero? len))
        (signal-uuid-error UUID_RC_INT loc))
      (let ((str-len (fx- (inexact->exact len) str-bias)))
        (let ((str (make-string str-len)))
          (move-memory! dat (make-locative str) str-len)
          (free dat)
          str ) ) ) ) )

(define (get-ns-uuid ns loc)
  (cond
    ((%uuid? ns)
      ns )
    ((string? ns)
      (let ((uuid (new-uuid loc)))
        (error-check (uuid_load (unbox-puuid uuid) ns) loc)
        uuid ) )
    (else
      (error loc "invalid namespace" ns) ) ) )

(define (make-uuid-2 args uuid mode loc)
  (unless (= (length args) 3)
    (error loc "invalid or missing namespace and name" args))
  (let ((ns-uuid (get-ns-uuid (cadr args) loc)) (name (caddr args)))
    (unless (string? name)
      (error loc "invalid name" name))
    (error-check (uuid_make_2 (unbox-puuid uuid) mode (unbox-puuid ns-uuid) name) loc) ) )

;;

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

(define (uuid-nil? uuid)
  (and (%uuid? uuid)
       (let-location ((result int))
         (error-check (uuid_isnil (unbox-puuid uuid) (location result)) 'uuid-nil?)
         (not (zero? result)) ) ) )

;compatibility w/ uuid-lib
(define uuid-null? uuid-nil?)

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

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

(define (uuid<>? uuid1 uuid2)
  (not (zero? (%uuid-compare uuid1 uuid2 'uuid<>?))) )

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

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

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

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

;DEPRECATED
(define uuid= uuid=?)
(define uuid<> uuid<>?)
(define uuid< uuid<?)
(define uuid> uuid>?)
(define uuid<= uuid<=?)
(define uuid>= uuid>=?)

;;

(define (uuid-clone uuid)
  (let-location ((puuid (c-pointer uuid_t)))
    (error-check (uuid_clone (unbox-puuid uuid) (location puuid)) 'uuid-clone)
    (box-puuid puuid) ) )

(define (uuid-load ns)
  (get-ns-uuid ns 'uuid-load))

(define (make-uuid . args)
  (let ((uuid (new-uuid 'make-uuid)))
    (unless (null? args)
      (let ((mode (car args)))
        (case mode
          ((V1)
            (error-check (uuid_make_0 (unbox-puuid uuid) UUID_MAKE_V1) 'make-uuid))
          ((V1-MC)
            (error-check (uuid_make_0 (unbox-puuid uuid) UUID_MAKE_V1MC) 'make-uuid))
          ((V3)
            (make-uuid-2 args uuid UUID_MAKE_V3 'make-uuid))
          ((V4)
            (error-check (uuid_make_0 (unbox-puuid uuid) UUID_MAKE_V4) 'make-uuid))
          ((V5)
            (make-uuid-2 args uuid UUID_MAKE_V5 'make-uuid))
          (else
            (error 'make-uuid "invalid mode" mode)))))
    uuid ) )

(define (uuid-import str)
  (uuid-import-format UUID_FMT_STR str 'uuid-import) )

(define (uuid-import-binary str)
  (uuid-import-format UUID_FMT_BIN str 'uuid-import-binary) )

(define (uuid-export uuid)
  (uuid-export-format uuid UUID_FMT_STR 'uuid-export) )

(define (uuid-export-binary uuid)
  (uuid-export-format uuid UUID_FMT_BIN 'uuid-export-binary) )

(define (uuid-export-text uuid)
  (uuid-export-format uuid UUID_FMT_TXT 'uuid-export-text) )

(define uuid-version uuid_version)

) ;module uuid-ossp