From 2d39a9e1048083fb1f61d748ee37e2e2f83e7bd2 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Fri, 16 Apr 2010 13:22:17 -0400 Subject: [PATCH] Using props file rather than SVN for properties --- collects/meta/drdr/analyze.ss | 5 +-- collects/meta/drdr/metadata.ss | 56 +++++++++++++++++++++++++++------ collects/meta/drdr/render.ss | 14 +++++---- collects/meta/drdr/rendering.ss | 4 +-- collects/meta/drdr/svn.ss | 45 +------------------------- 5 files changed, 59 insertions(+), 65 deletions(-) diff --git a/collects/meta/drdr/analyze.ss b/collects/meta/drdr/analyze.ss index 25ea753910..9785346f3b 100644 --- a/collects/meta/drdr/analyze.ss +++ b/collects/meta/drdr/analyze.ss @@ -7,6 +7,7 @@ "cache.ss" "dirstruct.ss" "status.ss" + "metadata.ss" "path-utils.ss" "rendering.ss") (provide (all-from-out "rendering.ss")) @@ -263,7 +264,7 @@ (log-different? output-log (status-output-log (read-cache prev-log-pth)))) #f)) (define responsible - (or (svn-property-value/root (trunk-path log-pth) plt:responsible) + (or (path-responsible (trunk-path log-pth)) (and (regexp-match #rx"/planet/" (path->string* log-pth)) "jay") ; XXX maybe mflatt, eli, or tewk @@ -317,7 +318,7 @@ (and committer? (with-handlers ([exn:fail? (lambda (x) #f)]) (svn-rev-log-author (read-cache (revision-commit-msg (current-rev)))))) - (or (svn-property-value/root (trunk-path dir-pth) plt:responsible) + (or (path-responsible (trunk-path dir-pth)) "unknown")) empty) diff --git a/collects/meta/drdr/metadata.ss b/collects/meta/drdr/metadata.ss index f4e4a7ad83..3b3aaa1457 100644 --- a/collects/meta/drdr/metadata.ss +++ b/collects/meta/drdr/metadata.ss @@ -1,6 +1,8 @@ #lang scheme (require "path-utils.ss" - "svn.ss") + "dirstruct.ss" + "svn.ss" + scheme/system) (define (testable-file? pth) (define suffix (filename-extension pth)) @@ -8,11 +10,11 @@ (ormap (lambda (bs) (bytes=? suffix bs)) (list #"ss" #"scm" #"scrbl")))) -(define SVN-PROP:command-line "plt:drdr:command-line") -(define SVN-PROP:timeout "plt:drdr:timeout") +(define PROP:command-line "drdr:command-line") +(define PROP:timeout "drdr:timeout") (define (path-command-line a-path) - (match (svn-property-value/root a-path SVN-PROP:command-line) + (match (get-prop a-path 'drdr:command-line #f) [#f (if (testable-file? a-path) (list "mzscheme" "-qt" (path->string* a-path)) @@ -21,15 +23,49 @@ #f] [(? string? s) (map (lambda (s) - (regexp-replace (regexp-quote "$path") s (path->string* a-path))) + (regexp-replace (regexp-quote "~s") s (path->string* a-path))) (regexp-split #rx" " s))])) (define (path-timeout a-path) - (with-handlers ([exn:fail? (lambda (x) #f)]) - (string->number (svn-property-value/root a-path SVN-PROP:timeout)))) + (get-prop a-path 'drdr:timeout #f)) + +(define (path-responsible a-path) + (get-prop a-path 'responsible #:as-string? #t)) (provide/contract - [SVN-PROP:command-line string?] - [SVN-PROP:timeout string?] + [PROP:command-line string?] + [PROP:timeout string?] + [path-responsible (path-string? . -> . (or/c string? false/c))] [path-command-line (path-string? . -> . (or/c (listof string?) false/c))] - [path-timeout (path-string? . -> . (or/c exact-nonnegative-integer? false/c))]) \ No newline at end of file + [path-timeout (path-string? . -> . (or/c exact-nonnegative-integer? false/c))]) + +;;; Property lookup +(define props-cache (make-hasheq)) +(define (get-prop a-fs-path prop [def #f] #:as-string? [as-string? #f]) + (define rev (current-rev)) + (define a-path + (substring + (path->string + ((rebase-path (revision-trunk-dir rev) "/") a-fs-path)) + 1)) + (define props:get-prop + (hash-ref! props-cache rev + (lambda () + (define tmp-file (make-temporary-file "props~a.ss")) + (and + ; Checkout the props file + (system* (svn-path) + "export" + "--quiet" + "-r" (number->string rev) + (format "~a/collects/meta/props" (plt-repository)) + (path->string tmp-file)) + ; Dynamic require it + (begin0 + (dynamic-require `(file ,(path->string tmp-file)) + 'get-prop) + (delete-file tmp-file)))))) + (unless props:get-prop + (error 'get-prop "Could not load props file for ~e" (current-rev))) + (props:get-prop a-path prop def + #:as-string? as-string?)) diff --git a/collects/meta/drdr/render.ss b/collects/meta/drdr/render.ss index 23758f21ea..acc1699f80 100644 --- a/collects/meta/drdr/render.ss +++ b/collects/meta/drdr/render.ss @@ -11,7 +11,9 @@ revision-trunk-dir) "status.ss" "monitor-svn.ss" - "metadata.ss" + (only-in "metadata.ss" + PROP:command-line + PROP:timeout) "formats.ss" "path-utils.ss" "analyze.ss") @@ -416,9 +418,9 @@ @p{Only one build runs at a time and when none is running the SVN repository is polled every @,(number->string (current-monitoring-interval-seconds)) seconds.} @h1{How is the revision "tested"?} - @p{Each file's @code{@,SVN-PROP:command-line} SVN property is consulted. If it is the empty string, the file is ignored. If it is a string, then @code{$path} is replaced with the file's path, @code{mzscheme} and @code{mzc} with their path (for the current revision), and @code{mred} and @code{mred-text} with @code{mred-text}'s path (for the current revision); then the resulting command-line is executed. + @p{Each file's @code{@,PROP:command-line} property is consulted. If it is the empty string, the file is ignored. If it is a string, then a single @code{~s} is replaced with the file's path, @code{mzscheme} and @code{mzc} with their path (for the current revision), and @code{mred} and @code{mred-text} with @code{mred-text}'s path (for the current revision); then the resulting command-line is executed. (Currently no other executables are allowed, so you can't @code{rm -fr /}.) - If there is no property value, the default (@code{mzscheme -t $path}) is used if the file's suffix is @code{.ss}, @code{.scm}, or @code{.scrbl}.} + If there is no property value, the default (@code{mzscheme -t ~s}) is used if the file's suffix is @code{.ss}, @code{.scm}, or @code{.scrbl}.} @p{The command-line is always executed with a fresh empty current directory which is removed after the run. But all the files share the same home directory and X server, which are both removed after each revision's testing is complete.} @@ -426,10 +428,10 @@ @p{One per core, or @,(number->string (number-of-cpus)).} @h1{How long may a file run?} - @p{The execution timeout is @,(number->string (current-subprocess-timeout-seconds)) seconds by default, but the @code{@,SVN-PROP:timeout} property is used if @code{string->number} returns a number on it.} + @p{The execution timeout is @,(number->string (current-subprocess-timeout-seconds)) seconds by default, but the @code{@,PROP:timeout} property is used if @code{string->number} returns a number on it.} @h1{May these settings be set on a per-directory basis?} - @p{Yes; if the SVN property is set on any ancestor directory, then its value is used for its descendents when theirs is not set. + @p{Yes; if the property is set on any ancestor directory, then its value is used for its descendents when theirs is not set. } @h1{What data is gathered during these runs?} @@ -467,7 +469,7 @@ @p{So DrDr can be effective with all testing packages and untested code, it only pays attention to error output and non-zero exit codes. You can make the most of this strategy by ensuring that when your tests are run successfully they have no STDERR output and exit cleanly, but have both when they fail.} @h1{How do I fix the reporting of an error in my code?} - @p{If you know you code does not have a bug, but DrDr thinks it does, you can probably fix it by setting its SVN properties: allow it to run longer with @code{@,SVN-PROP:timeout} (but be kind and perhaps change the program to support work load selection on the command-line) or make sure it is run with the right command-line using @code{@,SVN-PROP:command-line}.} + @p{If you know you code does not have a bug, but DrDr thinks it does, you can probably fix it by setting its properties: allow it to run longer with @code{@,PROP:timeout} (but be kind and perhaps change the program to support work load selection on the command-line) or make sure it is run with the right command-line using @code{@,PROP:command-line}.} @h1{How can I do the most for DrDr?} @p{The most important thing you can do is eliminate false positives by configuring DrDr for your code and removing spurious error output.} diff --git a/collects/meta/drdr/rendering.ss b/collects/meta/drdr/rendering.ss index 791a772c72..7dae37857d 100644 --- a/collects/meta/drdr/rendering.ss +++ b/collects/meta/drdr/rendering.ss @@ -2,7 +2,6 @@ (require "list-count.ss") (define-struct rendering (start end duration timeout? unclean-exit? stderr? responsible changed?) #:prefab) -(define plt:responsible "plt:responsible") (define (rendering-responsibles r) (regexp-split #rx"," (rendering-responsible r))) @@ -16,5 +15,4 @@ [stderr? list/count] [responsible string?] [changed? list/count])] - [rendering-responsibles (rendering? . -> . (listof string?))] - [plt:responsible string?]) \ No newline at end of file + [rendering-responsibles (rendering? . -> . (listof string?))]) \ No newline at end of file diff --git a/collects/meta/drdr/svn.ss b/collects/meta/drdr/svn.ss index 70c8b7bdbb..7a286376fe 100644 --- a/collects/meta/drdr/svn.ss +++ b/collects/meta/drdr/svn.ss @@ -1,7 +1,6 @@ #lang scheme (require xml - "notify.ss" - (prefix-in ffi: (planet jaymccarthy/svn-prop))) + "notify.ss") (define svn-path (make-parameter "/opt/local/bin/svn")) @@ -35,48 +34,6 @@ (subprocess-kill the-process #t) #f))))) -;; Finding out a property going towards the root -(define (sublists l) - (if (empty? l) - empty - (list* l (sublists (rest l))))) - -(define (svn-property-value/real working-copy-path property) - #;(printf "propget ~a @ ~a~n" property working-copy-path) - (with-handlers ([exn:fail? (lambda (x) 'error)]) - (ffi:svn-property-value working-copy-path property)) - #;(match (svn/xml-parse "propget" property working-copy-path) - [(? exn:xml? x) - 'error] - [`(properties " ") - 'none] - [`(properties " " (target ((path ,_path)) " " (property ((name ,_prop)) ,value) " ") " ") - value])) - -(define property-cache (make-hash)) -(define (svn-property-value working-copy-path property) - (define key (cons working-copy-path property)) - (hash-ref! property-cache key - (lambda () - (svn-property-value/real working-copy-path property))) - #;(if (hash-has-key? property-cache key) - (or (weak-box-value (hash-ref property-cache key)) - (begin (hash-remove! property-cache key) - (svn-property-value working-copy-path property))) - (local [(define val (svn-property-value/real working-copy-path property))] - (hash-set! property-cache key (make-weak-box val)) - val))) - -(define (svn-property-value/root working-copy-path property) - (define wc-path-parts (reverse (explode-path working-copy-path))) - (define potentials (sublists wc-path-parts)) - (for/or ([potential (in-list potentials)]) - (define val (svn-property-value (path->string (apply build-path (reverse potential))) property)) - (if (string? val) val #f))) - -(provide/contract - [svn-property-value/root (path-string? string? . -> . (or/c false/c string?))]) - ;;; Finding out about SVN revisions (define-struct svn-rev () #:prefab)