From c4ccd0e29a120f8ad151246dfde4f1e2542c2be7 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 14 Jun 2007 03:01:51 +0000 Subject: [PATCH] Removing need for .tag-list svn: r6659 --- collects/web-server/lang/labels.ss | 95 ++---------------- collects/web-server/tests/lang/labels-test.ss | 98 +------------------ 2 files changed, 14 insertions(+), 179 deletions(-) diff --git a/collects/web-server/lang/labels.ss b/collects/web-server/lang/labels.ss index c7b6c18638..ed33909c49 100644 --- a/collects/web-server/lang/labels.ss +++ b/collects/web-server/lang/labels.ss @@ -1,95 +1,18 @@ (module labels mzscheme - (require (lib "md5.ss") - (lib "list.ss") - (lib "etc.ss")) - (provide make-labeling - delete-tag-list!) + (require (lib "md5.ss")) + (provide make-labeling) ;; REQUIREMENT: The label code must be non-numeric. ;; REQUIREMENT: The first numeric character following the label code ;; indicates the start of the unique suffix identifying ;; the closure struct type. - ;; add1/string: string -> string - ;; a successor function on strings - (define (add1/string str) - (cond - [(regexp-match "$^" str) - => (lambda (x) "b")] - [(regexp-match "z(.*)" str) - => (lambda (m) (string-append "A" (cadr m)))] - [(regexp-match "Z(.*)" str) - => (lambda (m) (string-append "a" (add1/string (cadr m))))] - [else - (format "~a~a" - (integer->char (add1 (char->integer (string-ref str 0)))) - (substring str 1))])) - - (define default-file-name (build-path (this-expression-source-directory) ".tag-list")) - (define file-system-mutex (make-semaphore 1)) - - ;; read-tag-list: string -> (listof (list bytes string)) - ;; read the tag list from the file system - (define (read-tag-list filename) - (if (file-exists? filename) - (let ([v (call-with-input-file filename - read)]) - (if (eof-object? v) - empty - v)) - empty)) - - ;; save-tag-list!: (listof (list bytes string)) string -> (listof (list bytes string)) - ;; save the tag list in the file system - (define (save-tag-list! new-list filename) - (call-with-output-file filename - (lambda (o-port) - (write new-list o-port)) - 'replace)) - - ;; delete-tag-list!: [filename] -> void - ;; delete a file containing a tag-list - (define delete-tag-list! - (case-lambda - [(filename) - (when (file-exists? filename) - (delete-file filename))] - [() (delete-tag-list! default-file-name)])) - - ;; lookup-tag: bytes string -> string - ;; lookup a tag in the-tag-table - (define (lookup-tag pgm filename) - (let* ([the-tag-list (read-tag-list filename)] - [hash-code (md5 pgm)] - [new-tag - (if (null? the-tag-list) "a" - (add1/string (cadar the-tag-list)))]) - (let loop ([l the-tag-list]) - (cond - [(null? l) - (save-tag-list! - (cons (list hash-code new-tag) - the-tag-list) - filename) - new-tag] - [(bytes=? hash-code (caar l)) - (cadar l)] - [else (loop (cdr l))])))) - ;; make-labeling: bytes -> (-> symbol) ;; produce the labeling function for a particular program - (define make-labeling - (case-lambda - [(pgm) (make-labeling pgm default-file-name)] - [(pgm filename) - (dynamic-wind - (lambda () (semaphore-wait file-system-mutex)) - (lambda () - (let ([tag (lookup-tag pgm filename)] - [count 0]) - (lambda () - (begin0 - (string->symbol (format "~a~a" tag count)) - (set! count (add1 count)))))) - (lambda () (semaphore-post file-system-mutex)))])) - ) \ No newline at end of file + (define (make-labeling pgm) + (define count (box 0)) + (define tag (md5 pgm)) + (lambda () + (begin0 + (string->symbol (format "~a~a" tag (unbox count))) + (set-box! count (add1 (unbox count))))))) \ No newline at end of file diff --git a/collects/web-server/tests/lang/labels-test.ss b/collects/web-server/tests/lang/labels-test.ss index 9b3b6989fe..a3da220d09 100644 --- a/collects/web-server/tests/lang/labels-test.ss +++ b/collects/web-server/tests/lang/labels-test.ss @@ -1,97 +1,17 @@ (module labels-test mzscheme (require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) - (planet "util.ss" ("schematics" "schemeunit.plt" 2)) - (lib "etc.ss") - (lib "file.ss") (lib "labels.ss" "web-server" "lang")) (provide labels-tests) - (require/expose (lib "labels.ss" "web-server" "lang") (add1/string)) - - (define THE-TEST-FILENAME (make-temporary-file)) - (define l1 (make-labeling #"foo" THE-TEST-FILENAME)) - (define l2 (make-labeling #"foo" THE-TEST-FILENAME)) - (define l3 (make-labeling #"bar" THE-TEST-FILENAME)) - (define l4 (make-labeling #"baz" THE-TEST-FILENAME)) - - (define race-test-file (make-temporary-file)) - - (define (genbytes) - (string->bytes/utf-8 - (symbol->string (gensym)))) - - (define-struct cell (sema ival new-val)) - - (define (create-cell ival) - (make-cell (make-semaphore) ival #f)) - - ;; race?: (listof alpha) (alpha -> beta) ((listof beta) -> boolean)) -> boolean - ;; compute a list of values in parallel and determine if the result indicates a - ;; race condition. - (define (race? initial-vals make-new-val check-new-vals) - (let ([cells (map create-cell initial-vals)]) - (for-each - (lambda (cell) - (thread - (lambda () - (dynamic-wind - void - (lambda () (set-cell-new-val! cell (make-new-val (cell-ival cell)))) - (lambda () (semaphore-post (cell-sema cell))))))) - cells) - (for-each - (lambda (cell) - (semaphore-wait (cell-sema cell))) - cells) - (with-handlers ([void - (lambda (the-exn) #t)]) - (check-new-vals (map cell-new-val cells))))) - - (define (make-labeling-race? n) - (delete-tag-list! race-test-file) - (race? (build-list n (lambda (i) (genbytes))) - (lambda (some-bytes) - (make-labeling some-bytes race-test-file)) - (lambda (labelings) - (let loop ([label 0] - [labelings labelings]) - (if (null? labelings) - #f - (let ([new-label ((car labelings))]) - (or (eqv? new-label label) - (loop new-label (cdr labelings))))))))) - - (define (delete-tag-list!-race? n) - (race? (build-list n (lambda (i) #"foo")) - (lambda (some-bytes) - (delete-tag-list! race-test-file) - (make-labeling some-bytes race-test-file)) - (lambda (labelings) - (let* ([syms (map (lambda (l) (l)) labelings)] - [sym0 (car syms)]) - (not - (andmap - (lambda (sym) - (eqv? sym0 sym)) - syms)))))) + (define l1 (make-labeling #"foo")) + (define l2 (make-labeling #"foo")) + (define l3 (make-labeling #"bar")) + (define l4 (make-labeling #"baz")) (define labels-tests (test-suite "Module Labeling" - (test-case - "Test the tag incrementing scheme" - (check string=? "b" (add1/string "")) - (check string=? "A" (add1/string "z")) - (check string=? "B" (add1/string "A")) - (check string=? "b" (add1/string "a")) - (check string=? "ab" (add1/string "Z")) - (check string=? "aab" (add1/string "ZZ")) - (check string=? "Azz" (add1/string "zzz")) - (check string=? "aaaab" (add1/string "ZZZZ")) - (check string=? "baaab" (add1/string "aaaab"))) - - (test-case "The same program produces the same labeling" (check-eqv? (l1) (l2)) @@ -99,12 +19,4 @@ (test-case "Different programs produce different labelings" - (check-false (eqv? (l3) (l4)))) - - (test-case - "Check for race condition on make-labeling" - (check-false (make-labeling-race? 256))) - - (test-case - "Check for race condition on delete-tag-list!" - (check-false (delete-tag-list!-race? 256)))))) \ No newline at end of file + (check-false (eqv? (l3) (l4))))))) \ No newline at end of file