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

(module uuid-ossp

  (;export
    ;
    uuid?
    uuid-null?
    uuid-compare
    uuid=? uuid<? uuid>? uuid<=? uuid>=?
    uuid-copy
    uuid-clear!
    make-uuid
    string->uuid uuid->string
    ;
    uuid-version
    uuid-nil?
    uuid-clone
    uuid-load! uuid-load
    uuid-import uuid-import-binary uuid-import-siv
    uuid-export uuid-export-binary uuid-export-text uuid-export-siv
    ;Deprecated
    uuid<>?)

  (import scheme chicken foreign )

  (use lolevel)

  (declare
    (always-bound
      +uuid-error-codes+
      UUID_LEN_BIN UUID_LEN_STR UUID_LEN_SIV
      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 UUID_FMT_SIV)
    (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_LEN_SIV (foreign-value "uuid_LEN_SIV" 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 UUID_FMT_SIV (foreign-value "uuid_FMT_SIV" unsigned-int))

;;

(define-foreign-type size_t "size_t") ;types like this should be collected somewhere

(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 (null-pointer? ptr)
  (##sys#check-special ptr 'null-pointer?)
  (eq? 0 (##sys#pointer->address ptr) ) )

;;

(define +uuid-error-codes+
  `((,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)
  (set-finalizer! (tag-pointer puuid 'uuid-ossp) free-uuid) )

(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 'uuid-ossp) )

(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)
    (##sys#signal-hook #:type-error loc
		       "bad argument type - not a string" str))
  (let ((str-len
          (select fmt
            ((UUID_FMT_BIN) UUID_LEN_BIN)
            ((UUID_FMT_STR) UUID_LEN_STR)
            ((UUID_FMT_SIV) UUID_LEN_SIV)
            (else
              (##sys#signal-hook #:type-error loc
				 "bad argument type - invalid format" fmt)))))
    (unless (= (string-length str) str-len)
      ;type-error here is dubious
      (##sys#signal-hook #:type-error loc
			 "bad argument type - invalid string length" str))
    (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 ((len-bias
          (select fmt
            ((UUID_FMT_BIN) 0)
            ((UUID_FMT_STR UUID_FMT_TXT UUID_FMT_SIV) 1)
            (else
              (##sys#signal-hook #:type-error loc
				 "bad argument type - 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) len-bias)))
        (let ((str (make-string str-len)))
          (move-memory! dat (make-locative str) str-len)
          (free dat)
          str ) ) ) ) )

(define (get-ns-uuid uuid ns loc)
  (when (not ns) (set! ns "nil"))
  (unless (string? ns)
    (##sys#signal-hook #:type-error loc
		       "bad argument type - not a string" ns))
  (let ((uuid (or uuid (new-uuid loc))))
    (error-check (uuid_load (unbox-puuid uuid) ns) loc)
    uuid ) )

(define (make-uuid-2 args uuid var loc)
  (unless (= 2 (length args))
    (##sys#error-hook (foreign-value "C_BAD_MINIMUM_ARGUMENT_COUNT_ERROR" int) loc
		      3 (+ 1 (length args)) #f))
  (let* ((ns (car args))
	 (ns-uuid (if (%uuid? ns) ns (get-ns-uuid #f ns loc)))
	 (name (cadr args)) )
    (unless (string? name)
      (##sys#signal-hook #:type-error loc
			  "bad argument type - not a string" name))
    (error-check (uuid_make_2 (unbox-puuid uuid) var (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) ) ) )

;;

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

;compatibility w/ uuid-lib
(define uuid-copy uuid-clone)

(define (make-uuid . args)
  (let ((uuid (new-uuid 'make-uuid)))
    (let ((variant (and (not (null? args)) (car args))))
      (case variant
	((#f)
	  ) ;the nil-uuid
	((V1 time)
	 (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 (cdr args) uuid UUID_MAKE_V3 'make-uuid))
	((V4 random)
	 (error-check (uuid_make_0 (unbox-puuid uuid) UUID_MAKE_V4) 'make-uuid))
	((V5)
	 (make-uuid-2 (cdr args) uuid UUID_MAKE_V5 'make-uuid))
	(else
	 (##sys#signal-hook #:type-error 'make-uuid
			    "bad argument type - invalid variant" variant) ) ) )
    uuid ) )

(define (uuid-clear! uuid)
  (get-ns-uuid uuid "nil" 'uuid-clear!) )

(define (uuid-load! uuid #!optional ns)
  (get-ns-uuid uuid ns 'uuid-load!) )

(define (uuid-load #!optional ns)
  (get-ns-uuid #f ns 'uuid-load) )

(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-import-siv str)
  (uuid-import-format UUID_FMT_SIV 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-export-siv uuid)
  (uuid-export-format uuid UUID_FMT_SIV 'uuid-export-siv) )

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

(define (uuid->string uuid)
  (uuid-export uuid) )

(define uuid-version uuid_version)

) ;module uuid-ossp