suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Using props file rather than SVN for properties

Browse Source
This commit is contained in:
Jay McCarthy 2010-04-16 13:22:17 -04:00
parent eb7c8daead
commit 2d39a9e104
5 changed files with 59 additions and 65 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/meta/drdr/analyze.ss
View File

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

56
collects/meta/drdr/metadata.ss
View File

@ -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))])
[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?))

14
collects/meta/drdr/render.ss
View File

@ -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.}

4
collects/meta/drdr/rendering.ss
View File

@ -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?])
[rendering-responsibles (rendering? . -> . (listof string?))])

45
collects/meta/drdr/svn.ss
View File

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