diff options
Diffstat (limited to 'ebus-racket/3rdparty/bzlib/base/uuid.ss')
| -rw-r--r-- | ebus-racket/3rdparty/bzlib/base/uuid.ss | 202 |
1 files changed, 202 insertions, 0 deletions
diff --git a/ebus-racket/3rdparty/bzlib/base/uuid.ss b/ebus-racket/3rdparty/bzlib/base/uuid.ss new file mode 100644 index 0000000..d4cf293 --- /dev/null +++ b/ebus-racket/3rdparty/bzlib/base/uuid.ss @@ -0,0 +1,202 @@ +#lang scheme/base
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; BASE.plt - common routines that are shared by all other bzlib modules
+;;
+;; in a way, base.plt is the most fundamental module of the whole bzlib stack
+;; and as such it also is the lowest level code. We are not likely to
+;; fix the code any time soon, and hence any of the functions here are
+;; explicitly likely to be obsoleted or moved elsewhere.
+;;
+;; Proceed with caution.
+;;
+;;
+;; Bonzai Lab, LLC. All rights reserved.
+;;
+;; Licensed under LGPL.
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; uuid.ss - provide uuid object (currently wrapping over zitterbewegung/uuid-v4)
+;; yc 9/11/2009 - first version
+(require (prefix-in z: "../../zitterbewegung/uuid/uuid-v4.ss")
+ "base.ss"
+ scheme/list
+ scheme/string
+ scheme/contract
+ ;; (planet vyzo/crypto/util)
+ )
+
+(define (bytes->integer bytes)
+ (define (helper rest num)
+ (if (null? rest) num
+ (helper (cdr rest) (+ (* num 255) (car rest)))))
+ (helper (bytes->list bytes) 0))
+
+(define (bytes->hex bytes)
+ (define (helper rest acc)
+ (if (null? rest) (list->string (map hex-byte->char (reverse acc)))
+ (helper (cdr rest)
+ (let-values (((quotient remainder)
+ (quotient/remainder (car rest) 16)))
+ (list* remainder quotient acc)))))
+ (helper (bytes->list bytes) '()))
+
+;; *uuid structure - representing UUID, and holds bytes format...
+(define-struct *uuid (bytes)
+ #:property prop:custom-write
+ (lambda (u out write?)
+ (display (format "#<uuid:~a>" (uuid->string u)) out))
+ #:property prop:equal+hash
+ (list (lambda (u1 u2 sub?)
+ (bytes=? (*uuid-bytes u1) (*uuid-bytes u2)))
+ (lambda (u recur)
+ (bytes->integer (*uuid-bytes u)))
+ (lambda (u recur)
+ (bytes->integer (*uuid-bytes u)))))
+
+(define (uuid-time-low u)
+ (integer-bytes->integer (subbytes (*uuid-bytes u) 0 4) #f #t))
+
+(define (uuid-time-mid u)
+ (integer-bytes->integer (subbytes (*uuid-bytes u) 4 6) #f #t))
+
+(define (uuid-time-high u)
+ (integer-bytes->integer (subbytes (*uuid-bytes u) 6 8) #f #t))
+
+(define (uuid-clock-high u)
+ (integer-bytes->integer (bytes-append (list->bytes (list 0))
+ (subbytes (*uuid-bytes u) 8 9)) #f #t))
+
+(define (uuid-clock-low u)
+ (integer-bytes->integer (bytes-append (list->bytes (list 0))
+ (subbytes (*uuid-bytes u) 9 10)) #f #t))
+
+(define (uuid-node u)
+ (integer-bytes->integer (bytes-append (list->bytes (list 0 0))
+ (subbytes (*uuid-bytes u) 10 16)) #f #t))
+
+(define (uuid->string u (dash? #t))
+ (define (sub start end)
+ (subbytes (*uuid-bytes u) start end))
+ (if (not dash?)
+ (bytes->hex (*uuid-bytes u))
+ (string-join (map (lambda (b)
+ (bytes->hex b))
+ (list (sub 0 4) (sub 4 6) (sub 6 8) (sub 8 10) (sub 10 16)))
+ "-")))
+
+
+(define (uuid-string? u)
+ (and (string? u)
+ (regexp-match #px"^(?i:([0-9a-f]{,8})-?([0-9a-f]{,4})-?([0-9a-f]{,4})-?([0-9a-f]{,4})-?([0-9a-f]{,12}))$" u)))
+
+(define (uuid-symbol? u)
+ (and (symbol? u)
+ (uuid-string? (symbol->string u))))
+
+(define (uuid-bytes? u)
+ (and (bytes? u)
+ (= (bytes-length u) 16)))
+
+;; an uuid should be one of the following:
+;; struct of *uuid
+;; 16-bytes byte string.
+;; a string of 32 or 36 hex chars.
+(define (uuid? u)
+ (or (*uuid? u)
+ (uuid-bytes? u)
+ (uuid-string? u)))
+
+(define (make-uuid (u (symbol->string (z:make-uuid))))
+ (cond ((*uuid? u)
+ (make-*uuid (*uuid-bytes u)))
+ ((uuid-bytes? u)
+ (make-*uuid u))
+ (else
+ (uuid-string->uuid u))))
+
+(define (hex-byte->char h)
+ (case h
+ ((0) #\0)
+ ((1) #\1)
+ ((2) #\2)
+ ((3) #\3)
+ ((4) #\4)
+ ((5) #\5)
+ ((6) #\6)
+ ((7) #\7)
+ ((8) #\8)
+ ((9) #\9)
+ ((10) #\a)
+ ((11) #\b)
+ ((12) #\c)
+ ((13) #\d)
+ ((14) #\e)
+ ((15) #\f)
+ (else (error 'hex-byte->char "Not an hex byte: ~a" h))))
+
+(define (hex-char->integer c)
+ (case c
+ ((#\1) 1)
+ ((#\2) 2)
+ ((#\3) 3)
+ ((#\4) 4)
+ ((#\5) 5)
+ ((#\6) 6)
+ ((#\7) 7)
+ ((#\8) 8)
+ ((#\9) 9)
+ ((#\0) 0)
+ ((#\a #\A) 10)
+ ((#\b #\B) 11)
+ ((#\c #\C) 12)
+ ((#\d #\D) 13)
+ ((#\e #\E) 14)
+ ((#\f #\F) 15)
+ (else (error 'hex-char->integer "char ~a out of range" c))))
+
+(define (hex-char? c)
+ (member c '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\a #\A #\b #\B #\c #\C #\d #\D #\e #\E #\f #\F)))
+
+(define (hex-chars->byte chars)
+ (define (helper rest num)
+ (if (null? rest)
+ num
+ (helper (cdr rest) (+ (* 16 num) (hex-char->integer (car rest))))))
+ (helper chars 0))
+
+(define (hex-string->bytes h)
+ (define (helper rest acc)
+ (cond ((null? rest) (reverse acc))
+ ((null? (cdr rest)) ;; wrong
+ (error 'hex-string->bytes "Uneven # of hexdecimal strings: ~a" h))
+ (else
+ (helper (cddr rest)
+ (cons (hex-chars->byte (list (car rest) (cadr rest)))
+ acc)))))
+ (helper (string->list h) '()))
+
+(define (uuid-string->uuid uuid)
+ (make-*uuid (list->bytes (flatten (map hex-string->bytes (cdr (uuid-string? uuid)))))))
+
+;; how quickly can all the generation take?
+;; it seems that
+(provide/contract
+ (make-uuid (->* ()
+ (uuid?)
+ *uuid?))
+ (uuid->string (->* (*uuid?)
+ (boolean?)
+ string?))
+ (rename *uuid-bytes uuid->bytes (-> *uuid? bytes?))
+ (uuid-string? (-> any/c any))
+ (uuid-bytes? (-> any/c any))
+ (uuid-time-low (-> *uuid? number?))
+ (uuid-time-mid (-> *uuid? number?))
+ (uuid-time-high (-> *uuid? number?))
+ (uuid-clock-low (-> *uuid? number?))
+ (uuid-clock-high (-> *uuid? number?))
+ (uuid-node (-> *uuid? number?))
+ (uuid? (-> any/c any))
+ (bytes->hex (-> bytes? string?))
+ (bytes->integer (-> bytes? number?))
+ )
+
|