;; Copyright 2006-2016, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. (use format srfi-69 srfi-1 posix typed-records stack) ;; sqlite3) (use regex) ;; regex-literals) ;;(include "regex-literals-modified.scm") ;;(import regex-literals-modified) (define getenv get-environment-variable) ;;====================================================================== ;; regex-literals hacked for logpro. please see the original code and ;; license in the regex-literals egg ;; ;; Original license: ;; ;;;; A reader extension for precompiled regular expression literals. ;; ;; Copyright (c) 2006-2007 Arto Bendiken ;; ;; Permission is hereby granted, free of charge, to any person obtaining a copy ;; of this software and associated documentation files (the "Software"), to ;; deal in the Software without restriction, including without limitation the ;; rights to use, copy, modify, merge, publish, distribute, sublicense, and/or ;; sell copies of the Software, and to permit persons to whom the Software is ;; furnished to do so, subject to the following conditions: ;; ;; The above copyright notice and this permission notice shall be included in ;; all copies or substantial portions of the Software. ;; ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;; IN THE SOFTWARE. ;; ;;====================================================================== ;;;; Internal constants (define-constant regex-literal-delimiters '((#\{ . #\}) (#\( . #\)) (#\[ . #\]) (#\< . #\>))) ;;;; Internal procedures (define (read-regex-literal/delim delim port) (define (read-option) (let ((char (peek-char port))) (cond ((eq? char #\i) (read-char port) 'caseless) ((eq? char #\x) (read-char port) 'extended) ((eq? char #\u) (read-char port) 'utf8) (else #f)))) (let loop ((buffer '())) (let ((char (read-char port))) (cond ((char=? char delim) (let* ((options (list (read-option) (read-option) (read-option))) (rx-str (list->string (reverse buffer))) (full-str (conc "/" rx-str "/" (if (memq 'caseless options) "i" "") (if (memq 'extended options) "x" "") (if (memq 'utf8 options) "u" ""))) (caseless (not (not (memq 'caseless options)))) (extended (not (not (memq 'extended options)))) (utf8 (not (not (memq 'utf8 options))))) ; (rx (regexp rx-str caseless extended utf8))) ;; `(vector ,full-str ,rx-str ,caseless ,extended ,utf8))) `(vector ,full-str (regexp ,rx-str ,caseless ,extended ,utf8) ,caseless ,extended ,utf8))) ((char=? char #\\) ; escaped character (loop (cons (read-char port) (cons char buffer)))) (else (loop (cons char buffer))))))) ;;;; Exported procedures (define (read-regex-literal #!optional (port (current-input-port))) (read-regex-literal/delim #\/ port)) (define (read-regex-literal/general #!optional (port (current-input-port))) (let* ((c (read-char port)) (c (cond ((assq c regex-literal-delimiters) => cdr) (else c)))) (read-regex-literal/delim c port))) ;;;; Initialization ;; (define-inline (init-regex-literals!) (set-sharp-read-syntax! #\/ read-regex-literal) (set-sharp-read-syntax! #\r read-regex-literal/general) ;; ) ;; (init-regex-literals!) ) ;;====================================================================== ;; END OF REGEX LITERALS ;;====================================================================== (define (readlink-f fname) (let ((readlink-exes (filter file-exists? '("/bin/readlink" "/usr/bin/readlink")))) (if (null? readlink-exes) ;; no readlink found (read-symbolic-link fname #t) ;; use the posix version (with-input-from-pipe (conc (car readlink-exes) " " (if (file-exists? fname) "-f " "-m ") fname) (lambda () (read-line)))))) ;; NOTES: ;;====================================================================== ;; Globals ;;====================================================================== (define *htmlport* #f) (define *default-html-file* #f) (define *output-file-stack* (make-stack)) (define *summport* #f) (define *curr-expect-num* 0) ;;====================================================================== ;; error count struct ;;====================================================================== (defstruct tally (skips 0) (errs 0) (warns 0) (aborts 0) (waives 0) (checks 0)) (define (increment-tally t etype) (case etype ((skip) (tally-skips-set! t (+ 1 (tally-skips t)))) ((error required value) (tally-errs-set! t (+ 1 (tally-errs t)))) ((warning required-warn) (tally-warns-set! t (+ 1 (tally-warns t)))) ((abort) (tally-aborts-set! t (+ 1 (tally-aborts t)))) ((check) (tally-checks-set! t (+ 1 (tally-checks t)))) ((waive) (tally-waives-set! t (+ 1 (tally-waives t)))))) ;;====================================================================== ;; Specs, stuff that defines how things are ;;====================================================================== ;; given the counts and a couple flags return the apropriate exit-code ;; (define (counts->exit-code tallys status code-error) (cond ;; ordering here is critical as it sets the precedence of which status "wins" ((> (tally-skips tallys) 0) 6) ((> (tally-aborts tallys) 0) 5) ((> (tally-checks tallys) 0) 3) ((> (tally-errs tallys) 0) 1) ((> (tally-warns tallys) 0) 2) ((> (tally-waives tallys) 0) 4) (code-error (begin (print "ERROR: Logpro error, probably in your command file. Look carefully at prior messages to help root cause.") 1)) (status 0) (else 0))) (define (exit-code->exit-status exit-code) (case exit-code ((1) "FAIL") ((2) "WARN") ((3) "CHECK") ((4) "WAIVE") ((5) "ABORT") ((6) "SKIP") ((0) "PASS") (else "FAIL"))) (define (exit-code->exit-sym exit-code) (case exit-code ((1) 'error) ((2) 'warning) ((5) 'abort) ((4) 'waive) ((6) 'skip) ((3) 'check) (else 'error))) ;;====================================================================== ;; Misc ;;====================================================================== (define (misc:line-match-regexs line regexs) (if (null? regexs) #f (let loop ((hed (car regexs)) (tal (cdr regexs))) (let* ((match (string-search (vector-ref hed 1) line))) (if match match ;; (car match) (if (null? tal) #f (loop (car tal)(cdr tal)))))))) ;; convert some procs to nice symbols ;; merge this with comp->string (define (misc:op->symbol op) (cond ((or (string? op) (symbol? op) (number? op)) op) ((eq? op =) '=) ((eq? op >) '>) ((eq? op <) '<) ((eq? op >=) '>=) ((eq? op <=) '<=) (else 'unk))) ;; check regexs, compile them if not already compiled and ensure they are all of the ;; form (vector "plaintext rx" compiled-rx options ...) ;; (define (check-compile-regexes patts) ;; patts is either a regex, regexvec or a list of regex or regexvec (map (lambda (rxdat) (let* ((havevec (vector? rxdat)) (vec (if havevec rxdat (vector "no regex found" rxdat #f #f #f))) (rx (if havevec (vector-ref rxdat 1) rxdat))) (handle-exceptions exn (begin (print:error "ERROR: your regex, " rx ", is not valid.") rx) (cond ((and (not havevec)(regexp? rx)) vec) ((string? rx) (vector-set! vec 1 (regexp rx (vector-ref vec 2)(vector-ref vec 3)(vector-ref vec 4)))) ;; options are probably always #f but for completeness reference them anyway ) vec))) (if (list? patts) patts (list patts)))) ;;====================================================================== ;; Settings ;;====================================================================== (define *logpro:settings* (make-hash-table)) (define (logpro:set! var val) (hash-table-set! *logpro:settings* var val)) (define (logpro:get var) (hash-table-ref/default *logpro:settings* var #f)) (define (logpro:unset! var) (if (hash-table-exists? *logpro:settings* var) (hash-table-delete! *logpro:settings* var))) ;; some default settings (for-each (lambda (datpair) (logpro:set! (car datpair)(cdr datpair))) '(("summdat" . #t))) ;; .dat is on by default ;;====================================================================== ;; Hooks ;;====================================================================== (define *logpro:hooks* (make-hash-table)) ;; if command is a string it is executed by system after substituting matches ;; m1, m2, m3, m4 in #{m5} type string targets. ;; ;; if command is a proc it is called with the list of match results ;; (define (hook:add name command #!key (one-time #f)) (hash-table-set! *logpro:hooks* name (vector command one-time))) ;; escape single quotes and surround with single quotes (define (hook:command-param-escape val) (conc "'" (string-substitute (regexp "(\'{1})") "\\\'" val) "'")) ;; (string-substitute (regexp "(\"{1})") "\\\"" val #t) #t)) (define (hook:subst-var hookstr var val) (string-substitute (regexp (conc "#\\{escaped " var "\\}")) (hook:command-param-escape val) (string-substitute (regexp (conc "#\\{" var "\\}")) (conc val) hookstr #t) #t)) ;; Variables to be substituted: ;; ;; line: the entire line matched ;; msg: the expect message (usually the 5th parameter) ;; m1, m2 .... mN the regex matches ;; (define (hook:process-line hookstr msg matches) ;; (print "HOOK:PROCESS-LINE hookstr: " hookstr "\nmsg: " msg "\nmatches: " matches) (let ((line (car matches)) (subm (cdr matches)) (res "")) (set! res (hook:subst-var hookstr "msg" msg)) (set! res (hook:subst-var res "line" line)) (if (null? subm) res (let loop ((hed (car subm)) (tal (cdr subm)) (cur 1)) (set! res (hook:subst-var res (conc "m" cur) hed)) (if (null? tal) res (loop (car tal)(cdr tal)(+ cur 1))))))) ;;====================================================================== ;; Triggers ;;====================================================================== (define *triggers* '()) (define-inline (trigger:get-name vec)(vector-ref vec 0)) (define-inline (trigger:get-patts vec)(vector-ref vec 1)) (define-inline (trigger:get-remaining-hits vec)(vector-ref vec 2)) (define-inline (trigger:set-remaining-hits! vec val)(vector-set! vec 2 val)) (define-inline (trigger:inc-total-hits vec)(vector-set! vec 3 (+ (vector-ref vec 3) 1))) (define-inline (trigger:get-total-hits vec)(vector-ref vec 3)) (define-inline (trigger:get-required-flag vec)(vector-ref vec 4)) ;; Triggers default to one hit (define (trigger name . patts) (set! *triggers* (cons (vector name patts 1 0 #t) *triggers*))) ;; Do we want lifetime control? 0 forever, or N for number of times it may be invoked ;; or a list ( skipnum numtriggers) (define (trigger-with-limit name numhits . patts) (set! *triggers* (cons (vector name patts numhits 0 #t) *triggers*))) (define (trigger:non-required name . patts) (set! *triggers* (cons (vector name patts 1 0 #f) *triggers*))) ;;====================================================================== ;; Sections ;;====================================================================== ;; (list (1 "Header" (patt1 patt2 patt3 ...)) (2 ...)) (define *sections* '()) ;; (make-hash-table)) (define-inline (section:get-name vec)(vector-ref vec 0)) (define-inline (section:get-start-trigger vec)(vector-ref vec 1)) (define-inline (section:get-end-trigger vec)(vector-ref vec 2)) (define-inline (section:get-section-file vec)(if (= 4 (vector-length vec)) (begin ;; (print "Section-file: " (vector-ref vec 3)) (vector-ref vec 3)) (begin ;; (print "No Section file for " (vector-ref vec 0) " with length " (vector-length vec)) #f))) (define (section name start-trigger end-trigger #!optional (section-file #f)) (set! *sections* (cons (vector name start-trigger end-trigger section-file) *sections*))) ;; Add the default section "LogFileBody" (trigger "LogFileBodyStart" #/.*/) (section "LogFileBody" "LogFileBodyStart" "LogFileBodyEnd") ;; For those of us who wish to save a little typing (is this mildly dangerous?) (define logfile "LogFileBody") ;;====================================================================== ;; Expects ;;====================================================================== (define *expects* (make-hash-table)) ;; expect links lookup table, each key_ entry tracks the last error pointed ;; to. Example: for expect #0, second occurance (define *expect-link-nums* (make-hash-table)) (define in 'in) (define not-in 'not-in) (define before 'before) (define after 'after) (define-inline (comp->text comp) (case comp ((=) "=") ((>) ">") ((<) "<") ((>=) ">=") ((<=) "<=") (else "unk"))) ;; for the given ops spit out the right html else return the instring (define (text->html indat) (let ((instr (if (string? indat) indat (conc indat)))) (string-substitute ">" ">" (string-substitute "<" "<" instr)))) (define-inline (expects:get-where vec)(vector-ref vec 0)) (define-inline (expects:get-section vec)(vector-ref vec 1)) (define-inline (expects:get-comparison vec)(vector-ref vec 2)) (define-inline (expects:get-comparison-as-text vec) (let ((comp (expects:get-comparison vec))) (if (string? comp) comp (comp->text comp)))) (define-inline (expects:get-value vec)(vector-ref vec 3)) (define-inline (expects:get-name vec)(vector-ref vec 4)) (define-inline (expects:get-count vec)(vector-ref vec 5)) (define-inline (expects:inc-count vec)(vector-set! vec 5 (+ (expects:get-count vec) 1))) (define-inline (expects:get-compiled-patts vec)(vector-ref vec 6)) (define-inline (expects:get-num vec)(vector-ref vec 7)) (define-inline (expects:get-expires vec)(vector-ref vec 8)) (define-inline (expects:get-type vec)(vector-ref vec 9)) ;; 'expect 'ignore (define-inline (expects:get-keyname vec)(vector-ref vec 10)) (define-inline (expects:get-tol vec)(vector-ref vec 11)) (define-inline (expects:get-measured vec)(vector-ref vec 12)) (define-inline (expects:get-val-pass-count vec) (let ((pfv (vector-ref vec 13))) (vector-ref pfv 0))) (define-inline (expects:get-val-fail-count vec) (let ((pfv (vector-ref vec 13))) (vector-ref pfv 1))) (define-inline (expects:inc-val-pass-count vec) (let ((pfv (vector-ref vec 13))) (vector-set! pfv 0 (+ 1 (vector-ref pfv 0))))) (define-inline (expects:inc-val-fail-count vec) (let ((pfv (vector-ref vec 13))) (vector-set! pfv 1 (+ 1 (vector-ref pfv 1))))) (define-inline (expects:set-measured vec val)(vector-set! vec 12 (cons val (expects:get-measured vec)))) (define-inline (expects:set-val-pass/fail vec val)(vector-set! vec 13 val)) (define-inline (expects:get-hook-ptr vec)(vector-ref vec 14)) (define-inline (expects:get-hook vec) (vector-ref (hash-table-ref/default *logpro:hooks* (expects:get-hook-ptr vec)(vector #f #f)) 0)) ;; returns #t if it is a one-time hook (define-inline (expects:get-hook-type vec) (vector-ref (hash-table-ref/default *logpro:hooks* (expects:get-hook-ptr vec)(vector #f #f)) 1)) (define-inline (expects:delete-if-one-time vec) (if (expects:get-hook-type vec) (hash-table-delete! *logpro:hooks* (expects:get-hook-ptr vec)))) (define-inline (expects:get-matchnum vec)(vector-ref vec 15)) (define-inline (expects:get-rulenum vec)(vector-ref vec 16)) (define-inline (expects:get-html-class vec)(vector-ref vec 17)) (define-inline (expects:get-failed-flag vec)(vector-ref vec 17)) (define-inline (expects:set-failed-flag! vec val)(vector-set! vec 17 val)) ;; where is 'in, 'before or 'after but only 'in is supported now. ;; (expect in "Header" > 0 "Copywrite" #/Copywrite/) ;; (expect not-in '("Header" "Footer") = 0 "ERROR" #/error/i) ;; NOTE: patts and section can be lists ;; (list rexp1 rexp2 ...) ;; '("section1" "section2" ....) (define *got-an-error* #f) (define (print:error msg . remmesg) (set! *got-an-error* #t) (apply print msg remmesg)) ;; if expires is a date convert it to seconds until or since expired ;; #t => rule is expired, no longer apply it ;; #f => rule is not expired, it still applies (define (expect:process-expires expires) (let ((ex-val (if expires (if (string-match (regexp "^\\d+\\/\\d+\\/\\d+$") expires) (local-time->seconds (string->time expires "%m/%d/%Y")) (begin (print "WARNING: Couldn't parse date: " expires ", date should be MM/DD/YY") #f)) #f))) ;; now have #f: no expire spec'd, -ve num: expired, +ve num: not expired ;; (print "expires: " expires " type: " type " ex-val: " ex-val) (if ex-val (<= ex-val (current-seconds)) ;; expire specified #f))) (define (expect where-op section comparison value name patts #!key (expires #f)(type 'error)(hook #f)(class #f)) ;; note: (hier-hash-set! value key1 key2 key3 ...) (if (not (symbol? where-op)) (print:error "ERROR: where must be a symbol")) (if (not (or (string? section) (list? section))) (print:error "ERROR: section must be a string or a list of strings")) (if (not (procedure? comparison))(print:error "ERROR: comparison must be one of > < >= <= or =")) (if (not (number? value)) (print:error "ERROR: value must be a number")) (if (not (string? name)) (print:error "ERROR: name must be a string")) (if (and expires (not (string? expires))) (print:error "ERROR: expires must be a date string MM/DD/YY, got " expires)) (set! patts (check-compile-regexes (if (list? patts) patts (list patts)))) ;; #f => rule is not expired, go ahead and apply it ;; #t => rule is expired, do NOT apply it (if (not (expect:process-expires expires)) (begin ;; (print "expect:" type " " section " " (comp->text comparison) " " value " " patts " expires=" expires " hook=" hook) (for-each (lambda (sect) (hash-table-set! *expects*;; 11 12 13 14 15 16 sect ;; 0 1 2 3 4 5 6 7 8 9 10 tol measured value=pass/fail *curr-expect-num* html-class failed-flag (cons (vector where-op sect comparison value name 0 patts *curr-expect-num* expires type (conc "key_" *curr-expect-num*) #f '() (vector 0 0) hook #f *curr-expect-num* class #f) (hash-table-ref/default *expects* section '())))) (if (list? section) section (list section)))) (print "expect:" type " " section " " (comp->text comparison) " " value " " patts " expires=" expires " hook=" hook)) (set! *curr-expect-num* (+ *curr-expect-num* 1))) (define (expect:warning where-op section comparison value name patts #!key (expires #f)(type 'warning)(hook #f)(class #f)) (expect where-op section comparison value name patts expires: expires type: type hook: hook class: class)) (define expect:warn expect:warning) ;; this one trips up so many people, just create the alias and be done with it. (define (expect:ignore where-op section comparison value name patts #!key (expires #f)(type 'ignore)(hook #f)(class #f)) (expect where-op section comparison value name patts expires: expires type: type hook: hook class: class)) (define (expect:note where-op section comparison value name patts #!key (expires #f)(type 'note)(hook #f)(class #f)) (expect where-op section comparison value name patts expires: expires type: type hook: hook class: class)) (define (expect:waive where-op section comparison value name patts #!key (expires #f)(type 'waive)(hook #f)(class #f)) (expect where-op section comparison value name patts expires: expires type: type hook: hook class: class)) (define expect:waived expect:waive) (define expect:waiver expect:waive) (define (expect:error where-op section comparison value name patts #!key (expires #f)(type 'error)(hook #f)(class #f)) (expect where-op section comparison value name patts expires: expires type: type hook: hook class: class)) (define (expect:required where-op section comparison value name patts #!key (expires #f)(type 'required)(hook #f)(class #f)) (expect where-op section comparison value name patts expires: expires type: type hook: hook class: class)) (define (expect:required-warn where-op section comparison value name patts #!key (expires #f)(type 'required-warn)(hook #f)(class #f)) (expect where-op section comparison value name patts expires: expires type: type hook: hook class: class)) (define (expect:check where-op section comparison value name patts #!key (expires #f)(type 'check)(hook #f)(class #f)) (expect where-op section comparison value name patts expires: expires type: type hook: hook class: class)) (define (expect:abort where-op section comparison value name patts #!key (expires #f)(type 'abort)(hook #f)(class #f)) (expect where-op section comparison value name patts expires: expires type: type hook: hook class: class)) (define (expect:skip where-op section comparison value name patts #!key (expires #f)(type 'skip)(hook #f)(class #f)) (expect where-op section comparison value name patts expires: expires type: type hook: hook class: class)) ;;====================================================================== ;; TODO: Compress this in with the expect routine above ;;====================================================================== (define (expect:value where-op section value tol name patt #!key (expires #f)(type 'value)(matchnum 1)(hook #f)(class #f)) ;; note: (hier-hash-set! value key1 key2 key3 ...) (if (not (symbol? where-op)) (print:error "ERROR: where must be a symbol")) (if (not (or (string? section) (list? section))) (print:error "ERROR: section must be a string or list of strings")) (if (not (number? value)) (print:error "ERROR: value must be a number")) (if (not (or (number? tol) (member tol (list < > <= >= =)))) ((print:error "ERROR: tolerance must be a number or one of < > <= >= ="))) (if (not (string? name)) (print:error "ERROR: name must be a string")) (if (and expires (not (string? expires))) (print:error "ERROR: expires must be a date string MM/DD/YY, got " expires) (set! expires #f)) (let ((patts (check-compile-regexes patt))) ;; Change methodology here. Expires becomes a flag with the following meaning ;; #f : no expires specified ;; negative number : seconds since this rule expired ;; postive number : seconds until this rule expires (if (not (expect:process-expires expires)) ;; #f means yes, apply the rule, #t means no, do not apply the rule, i.e. if expired do not apply the rule (for-each (lambda (sect) (hash-table-set! *expects* ;; comparison is not used matchnum used to pick the match from the regex sect ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 value=pass/fail (cons (vector where-op sect "<=>" value name 0 patts *curr-expect-num* expires type (conc "key_" *curr-expect-num*) tol '() (vector 0 0) hook matchnum *curr-expect-num* class) (hash-table-ref/default *expects* section '())))) (if (list? section) section (list section)))) (set! *curr-expect-num* (+ *curr-expect-num* 1)))) ;; extract out the value if possible. (define (expect:value-compare expect match) ;; (print "expect:value-compare :\n " expect "\n " match) (let* ((which-match (if (expects:get-matchnum expect) (expects:get-matchnum expect);; expects:get-compiled-patts returns a list (patt matchnum) 1)) ;; input is (patt) or (patt n) where n is the patt number to take as the value (match-str (if (> (length match) which-match)(list-ref match which-match) #f)) (match-num (if (string? match-str)(string->number match-str) #f)) (value (expects:get-value expect)) (tol (expects:get-tol expect))) (if match-num (let ((result (if (number? tol) (and (<= match-num (+ value tol)) (>= match-num (- value tol))) (tol match-num value)))) (list result match-num "ok")) (if match-str (list #f match-str "match is not a number") (list #f match "regex matched but no captured value, use parens; (...)"))))) ;; (define (expect:get-type-info expect) (case (expects:get-type expect) ((expect) (vector "Expect" "red")) ((ignore) (vector "Ignore" "green")) ((waive) (vector "Waive" "brown")) ((error) (vector "Error" "red")) ((warning) (vector "Warning" "orange")) ((required) (vector "Required" "purple")) ((required-warn)(vector "Required-warn" "orange")) ((check) (vector "Check" "pink")) ((abort) (vector "Abort" "crimson")) ((skip) (vector "Skip" "#d1db64")) ((value) (vector "Value" "blue")) ((note) (vector "Note" "darkyellow")) (else (vector "Error" "red")))) (define-inline (expect:expect-type-get-type vec)(vector-ref vec 0)) (define-inline (expect:expect-type-get-color vec)(vector-ref vec 1)) ;;====================================================================== ;; Main ;;====================================================================== (define (process-log-file cmdfname html-file waiver-file cssfile) (cond ((not (file-exists? cmdfname)) (print:error "ERROR: command file " cmdfname " not found") (exit 1)) (else (let* ((html-port (if html-file (open-output-file html-file) #f)) (summ-port (if (logpro:get "summdat") (let ((fname (conc (pathname-strip-extension (if html-file html-file "summary")) ".dat"))) (handle-exceptions exn #f ;; any problems creating output file, just move on (if fname (open-output-file fname)))) #f))) (set! *htmlport* html-port) ;; sigh, do me right some day... (set! *default-html-file* html-file) (stack-push! *output-file-stack* html-file) (set! *summport* summ-port) ;; (eval '(require-extension regex-literals)) (eval '(require-extension regex)) (handle-exceptions exn (begin (print "\nERROR: Syntax error in your command file!\n") (print " => " ((condition-property-accessor 'exn 'message) exn)) (print-call-chain) (html-print #f "\nERROR: Syntax error in your command file!\n") (html-print #f " => " ((condition-property-accessor 'exn 'message) exn)) (print-call-chain *htmlport*) (close-output-port *htmlport*) (exit 1)) ;; load the waiver file first if specified (if (and waiver-file (file-exists? waiver-file) (file-read-access? waiver-file)) (load waiver-file)) ;; Filter applied rules - defer this feature ;; (let ((allowed-rules (logpro:get "allowed-rules"))) ;; (logpro:set "allowed-rules" '(waive)) ;; doesn't do anything yet - need to filter rules in waiver file with this. ;; (load waiver-file) ;; (if allowed-rules ;; have prior settings? preserve them ;; (logpro:set "allowed-rules" allowed-rules) ;; (logpro:unset! "allowed-rules")))) ;; load the command file (load cmdfname)) ;; if we got this far we can symlink in (or create) the css file (if (string? html-file) (let ((full-css-file (conc (or (pathname-directory html-file) ".") "/logpro_style.css"))) (if (not (file-exists? full-css-file)) (if (and cssfile (file-exists? cssfile)) (create-symbolic-link cssfile full-css-file) (with-output-to-file full-css-file (lambda () (print *logpro_style.css*))))) ;; NOTE: *logpro_style.css* is defined in logpro_style.css.scm (analyze-logfile (current-output-port) (file-exists? full-css-file))) ;; cssfile is used as a flag (analyze-logfile (current-output-port) #f)) (let ((exit-code (print-results cssfile))) (if *htmlport* (close-output-port *htmlport*)) (if *summport* (close-output-port *summport*)) (exit exit-code)))))) (define (adj-active-sections trigger active-sections) (for-each (lambda (section) (let ((section-name (section:get-name section)) (start-trigger (section:get-start-trigger section)) (section-file (section:get-section-file section)) (end-trigger (section:get-end-trigger section))) (cond ((string=? start-trigger (trigger:get-name trigger)) (begin (if section-file (begin (if *htmlport* (flush-output *htmlport*)) ;;(close-output-port *htmlport*) (stack-push! *output-file-stack* section-file) ;;(print "LOGPRO: Output file stack: " (stack->list *output-file-stack*)) (html-print #f (conc "

Link to section: " section-name "

" section-file "")) (flush-output *htmlport*) ;;(print "LOGPRO: Setting output file to: " section-file) (set! *htmlport* (if section-file (open-output-file section-file #:append) #f))) (begin (if *htmlport* (flush-output *htmlport*)) ;;(close-output-port *htmlport*) (stack-push! *output-file-stack* *default-html-file*) ;;(print "LOGPRO: Setting output file to: " *default-html-file*) ;;(print "LOGPRO: Output file stack: " (stack->list *output-file-stack*)) (set! *htmlport* (if *default-html-file* (open-output-file *default-html-file* #:append) #f)) )) ;; sigh, do me right some day... (hash-table-set! active-sections section-name section) )) ((string=? end-trigger (trigger:get-name trigger)) (begin (if *htmlport* (flush-output *htmlport*)) ;;(close-output-port *htmlport*) ;;(print "LOGPRO: Closing section : " section-file) ;;(print "LOGPRO: Output file stack: " (stack->list *output-file-stack*)) (handle-exceptions exn (begin (print "LOGPRO: Caught exception on stack") (set! *htmlport* (open-output-file *default-html-file* #:append))) (begin (if section-file (begin ;;(print "LOGPRO: Considering removing " section-file " from " (stack->list *output-file-stack*)) (set! *output-file-stack* (list->stack (remove (lambda(l) (if (string= l section-file) #t #f)) (stack->list *output-file-stack*)))) ;;(print "LOGPRO: " (stack->list *output-file-stack*)) ;;(stack-pop! *output-file-stack*) )) ;;(let ((outp 0)) ;;(print "Setting output file to: " (stack-peek *output-file-stack*)) ;;(print "Output file stack: " (stack->list *output-file-stack*)) ;;(print "LOGPRO: Setting output file to: " (if (and (not (stack-empty? *output-file-stack*) ) (stack-peek *output-file-stack*)) (stack-peek *output-file-stack*) #f)) (set! *htmlport* (if (and (not (stack-empty? *output-file-stack*) ) (stack-peek *output-file-stack*)) (open-output-file (stack-peek *output-file-stack*) #:append) #f)))) (hash-table-delete! active-sections section-name)))))) *sections*)) (define (html-print destport . stuff) (if (or *htmlport* destport) (with-output-to-port (or destport *htmlport*) (lambda () (apply print stuff))))) (define (analyze-logfile oup cssfile) (let ((active-sections (make-hash-table)) (found-expects '()) (html-mode 'pre) (html-highlight-flag #f)) ;; (curr-seconds (current-seconds))) (html-print #f "") (if cssfile (begin (html-print #f "") (html-print #f "") )) (html-print #f "
LOGPRO RESULTS
") (html-print #f "Summary is here") ;; NOTE: logpro-version comes from logpro.scm file. (html-print #f "
(processed by logpro version " logpro-version ", tool details at: logpro)") (html-print #f "
")
    ;;(print *sections*)
    (if *htmlport* (flush-output *htmlport*))
    (for-each (lambda(section) 
     (if (and (fourth (vector->list section)) *default-html-file* )
      (begin
        (file-copy *default-html-file* (fourth (vector->list section)) #t)
        (let ((op-file (open-output-file (fourth (vector->list section)) #:append)))
          (html-print op-file (conc "

You are in the section log summary for " (first (vector->list section)) ". Back to Top-Level

"))
          (flush-output op-file)
        )
      )
     )
    ) *sections*) 
    (let loop ((line (read-line))
	       (line-num  0))
      (if (not (eof-object? line))
	  (begin
	    ;; first find if any triggers are hit
	    ;; (print "find any trigger hits")
	    (for-each 
	     (lambda (trigger)
	       (let ((patts (check-compile-regexes (trigger:get-patts trigger)))
		     (remhits (trigger:get-remaining-hits trigger)))
		 (if (and (> remhits 0)
			  (misc:line-match-regexs line patts))
		     (begin
		       (trigger:set-remaining-hits! trigger (- remhits 1))
		       (set! html-highlight-flag (vector "blue"
							 (trigger:get-name trigger)
							 (conc "#" (trigger:get-name trigger) "_table")
							 #f                         ;; msg
							 #f
							 'trigger                   ;; etype
							 (trigger:get-name trigger) ;; eclass
							 #f))
		       (with-output-to-port oup
			 (lambda ()
			   (print      "LOGPRO: hit trigger " (trigger:get-name trigger) " on line " line-num)))
		       (trigger:inc-total-hits trigger)
		       (adj-active-sections trigger active-sections)))))
	     *triggers*)

	    ;; now look for any expect "in" fails
	    ;; (print "looking for \"in\" fails")
	    (for-each 
	     (lambda (section)
	       (let ((expects (filter (lambda (x)(eq? 'in (expects:get-where x)))
				      (hash-table-ref/default *expects* section '()))))
		 (if expects
		     (for-each 
		      (lambda (expect)
			(let* ((patts   (expects:get-compiled-patts expect))
			       (matches (misc:line-match-regexs line patts)))
			  (if matches
			      (set! found-expects (cons (list expect section matches) found-expects)))))
		      expects))))
	     (hash-table-keys active-sections))

	    ;; now look for any expect "not-in" fails
	    ;; (print "looking for \"not-in\" fails")
	    (for-each 
	     (lambda (section)
	       (let ((expects (filter (lambda (x)(eq? 'not-in (expects:get-where x)))
				      (hash-table-ref/default *expects* section '()))))
		 (if expects
		     (for-each 
		      (lambda (expect)
			(let* ((patts   (expects:get-compiled-patts expect))
			       (matches (misc:line-match-regexs line patts)))
			  (if matches
			      (set! found-expects (cons (list expect section matches) found-expects)))))
		      expects))))
	     (filter (lambda (x)(not (member x (hash-table-keys active-sections))))
		     (map section:get-name *sections*)))

	    ;; from the expect hits choose the firstist one
	    ;; (print "choose the first matching expect")
	    (if (not (null? found-expects))
		(begin
		  ;; (print "found-expects: \n" (intersperse found-expects "\n"))
		  (let* ((dat     (car (sort found-expects (lambda (a b)
							     (let ((vala (expects:get-num (car a)))
								   (valb (expects:get-num (car b))))
							       (if (and (number? vala)(number? valb))
								   (< vala valb);; (print "car a: " (car a) " car b: " (car b))
								   (with-output-to-port oup
								     (lambda ()
								       (print "WARNING: You have triggered a bug, please report it.\n  vala: " vala " valb: " valb)
								       #f))))))))
			 (expect    (car dat)) ;;  BUGGG!!!! RENAME ME!!!!!!
			 (section   (cadr dat))
			 (match     (if (> (length dat) 2)(caddr dat) #f))
			 (type-info (expect:get-type-info expect))
			 (keyname   (expects:get-keyname   expect))
			 (errnum    (+ (hash-table-ref/default *expect-link-nums* keyname 0) 1))
			 (expect-type (expects:get-type expect))
			 (eclass    (expects:get-html-class expect))
			 (is-value  (eq? expect-type 'value))
			 (pass-fail (if is-value
					(expect:value-compare expect match)
					#f))
			 (color     (if is-value
					(if (car pass-fail) "green" "red")
					(expect:expect-type-get-color type-info)))
			 (expires   (expects:get-expires expect)))
		    (hash-table-set! *expect-link-nums* keyname errnum)
		    (if is-value
			(let ((extracted-value (cadr pass-fail)))
			  (expects:set-measured expect extracted-value)
			  (if (car pass-fail)
			      (expects:inc-val-pass-count expect)
			      (expects:inc-val-fail-count expect))))
		    (set! html-highlight-flag (vector color 
						      (conc keyname "_" errnum)
						      (conc "#" keyname "_" (+ 1 errnum))
						      #f
						      errnum
						      expect-type
						      eclass))
		    (let ((msg (list
				(expect:expect-type-get-type type-info) ": " 
				(expects:get-name expect) " "
				(if is-value
				    (let ((tol (expects:get-tol expect))
					  (val (expects:get-value expect)))
				      (conc (if (number? tol) val "") " "
					    (if (number? tol) "+/-" (conc (misc:op->symbol tol) " " val))
					    " got " (cadr pass-fail)
					    " which is " (if (car pass-fail) "PASS" "FAIL")))
				    (expects:get-comparison-as-text expect))
				" " 
				(expects:get-value expect)
				" in section " section " on line " line-num)))
		      (with-output-to-port oup
			(lambda ()
			  (apply print (cons "LOGPRO " msg))))
		      (if (and (not pass-fail)
			       (eq? expect-type 'error))
			  ;; failed error case
			  (let ((cmd    (expects:get-hook expect)))
			    (if cmd
				(let ((errhook (hook:process-line cmd line match)))
				  (with-output-to-port oup
				    (lambda ()
				      (print "ERRMSG HOOK CALLED: " errhook)))
				  (system errhook)
				  (expects:delete-if-one-time expect))))
			  (let ((cmd    (expects:get-hook expect)))
			    (if cmd
				(let ((hookcmd (hook:process-line cmd line match)))
				  (with-output-to-port oup
				    (lambda ()
				      (print "NONERR HOOK CALLED: " hookcmd)))
				  (system hookcmd)
				  (expects:delete-if-one-time expect))))))
		    (expects:inc-count expect)
		    (set! found-expects '()))))
	    (with-output-to-port oup
	      (lambda ()
		(print line)))
	    (if html-highlight-flag
		(let ((color  (vector-ref html-highlight-flag 0))
		      (label  (vector-ref html-highlight-flag 1))
		      (link   (vector-ref html-highlight-flag 2))
		      (mesg   (vector-ref html-highlight-flag 3))
		      (unkn   (vector-ref html-highlight-flag 4))
		      (etype  (vector-ref html-highlight-flag 5))
		      (eclass (vector-ref html-highlight-flag 6))) ;; the expect
                  (html-print #f ""
                              "") ;; (conc "class=\"" etype "\">")
                                                          (conc "style=\"background-color: white; color: " color ";\">"))
                              line
                              "")
                  (set! html-mode 'html))
                (begin
		  (if (not (eq? html-mode 'pre))
		      (begin
			;; (html-print #f "") ; 
")
			(set! html-mode 'pre)))
		  (html-print #f line)))
	    (if html-highlight-flag (set! html-highlight-flag #f))
	    (loop (read-line)(+ line-num 1))
	    )
		(begin
			;;(print "Hit end of file")
			(if *htmlport* (flush-output *htmlport*))
			(set! *htmlport* (if *default-html-file* (open-output-file *default-html-file*  #:append) #f))
		)
		))))

;; given an expect return the xstatus (#t or #f) and the appropriate symbol mapped to a string
;;
(define (get-xstatus-compsym expect)
  (let* ((comp     (expects:get-comparison expect))
         (value    (expects:get-value expect))
         (count    (expects:get-count expect))
         (etype    (expects:get-type expect))
         (is-value (eq? etype 'value))
         )
    (cond
     ((eq? comp =)  (values (eq? count value) "="))
     ((eq? comp >)  (values (> count value)   ">"))
     ((eq? comp <)  (values (< count value)   "<"))
     ((eq? comp >=) (values (>= count value)  "<="))
     ((eq? comp <=) (values (<= count value)  ">="))
     (is-value      (if (and (< (expects:get-val-fail-count expect) 1)
                             (> (expects:get-val-pass-count expect) 0))
                        (values #t "=")
                        (values #f "=")))
     (else (values #f "=")))))

;; print one line of html
(define (html-print-one-line destport count xstatus typeinfo etype cssfile eclass keyname outvals is-value link-file)
  (let ((color         (if (> count 0)
                           (if is-value
                               (if xstatus "green" "red")
                               (expect:expect-type-get-color typeinfo))
                           (if (member etype '(required required-warn))
                               (if xstatus (expect:expect-type-get-color typeinfo) "red")
                               "white")))
        (rule-num     (car outvals))
        (rule-type    (cadr outvals))
        (section-name (list-ref outvals 3))
        (status       (list-ref outvals 4))
        (comp         (list-ref outvals 5))
        (count-val    (list-ref outvals 6))
        (desc         (list-ref outvals 7))
        (count        (list-ref outvals 8))
        (regex-str    (list-ref outvals 11)))
    ;;        (remaining    (drop outvals 4)))
    (html-print destport ""
                (text->html rule-num) ""
                ;; rule-type
                ""
                (text->html rule-type) ""
                ;; (text->html section-name) ""
                ;; status
                ;;"" (text->html status) ""
                ;; comp
                (text->html comp)        ""
                (text->html count-val)   ""
                (text->html desc)        ""
                (text->html count)       ""
                (text->html regex-str)   ""
;;                 (string-intersperse
;;                  (map text->html remaining)
;;                  (conc ""))
                )
    (html-print destport "")))

;; factored out of print-results
;;
(define (value-print expect rulenum typeinfo is-value xstatus name compsym section count) 
  ;; If a value construct the output line using some kinda complicated logic ...
  (let ((outvals  #f)
        (lineout  #f)
        (where-op (expects:get-where expect)) ;; not used yet, "in" is only option
        (rx-str   (string-intersperse (map (lambda (x)
                                             (if (vector? x)
                                                 (vector-ref x 0)
                                                 "n/a"))
                                           (expects:get-compiled-patts expect)) ", "))
        (fmt      " ~6a ~8a ~2@a ~12a ~4@a, expected ~a ~a of ~a, got ~a, rx=~a")
	;;            type where section OK/FAIL compsym value name count
	(valfmt   " ~6a ~8a ~2@a ~12a ~4@a, expected ~a ~a ~a got ~a, ~a pass, ~a fail, rx=~a")
        (value    (expects:get-value expect))
        )
    (if is-value
        (let* ((cmd       (expects:get-hook expect))
               (tolerance (expects:get-tol expect))
               (measured  (if (null? (expects:get-measured expect)) "-" (car (expects:get-measured expect)))))
          (set! outvals (list  
                         (conc "rule-" rulenum)                                     ;; 0
                         (expect:expect-type-get-type typeinfo) 
                         where-op                                                   ;; 2
                         section 
                         (if xstatus "OK" "FAIL")                                   ;; 4
                         (if (number? tolerance) value (misc:op->symbol tolerance))
                         (if (number? tolerance) "+/-" "")                          ;; 6
                         (if (number? tolerance) (misc:op->symbol tolerance) value)
                         measured                                                   ;; 8
                         (expects:get-val-pass-count expect) 
                         (expects:get-val-fail-count expect)                        ;; 10
                         rx-str
                         ))
          (set! lineout (apply format #f valfmt outvals));; valfmt
          ;; have a hook to process for "value" items, do not call if nothing found
          (if (and cmd (number? measured))
              (let ((valuehook (hook:subst-var
                                (hook:subst-var 
                                 (hook:subst-var 
                                  (hook:subst-var cmd "measured" (conc measured))
                                  "message" name)
                                 "expected" (conc value))
                                "tolerance" (conc (misc:op->symbol tolerance)))))
                (print "VALUE HOOK CALLED: " valuehook)
                (system valuehook)))
          (if *summport*
              (with-output-to-port *summport*
                (if is-value
                    (lambda ()
                      (print "[" (conc "rule-" rulenum) "]")
                      (print "operator " where-op )
                      (print "section " section )
                      (print "desc " name)
                      (print "status " (if xstatus "OK" "FAIL"))
                      (print "expected "  value)
                      (print "measured "  measured)
                      (if (number? tolerance)
                          (begin
                            (print "type +/-")
                            (print "tolerance " tolerance))
                          (begin
                            (print "type " (misc:op->symbol tolerance))))
                      (print "pass " (expects:get-val-pass-count expect))
                      (print "fail " (expects:get-val-fail-count expect))
                      (print))
                    (lambda ()
                      (print "[" (conc "rule-" rulenum) "]")
                      (print "type "(expect:expect-type-get-type typeinfo))
                      (print "operator " where-op)
                      (print "section " section)
                      (print "status "  (if xstatus "OK" "FAIL"))
                      (print "compsym " compsym)
                      (print "value " value)
                      (print "desc " name)
                      (print "count " count)
                      (print))))))
        ;; If not a value create the output line using the format "fmt"
        (begin
          (set! outvals (list
                         (conc "rule-" rulenum)                    ;; 0
                         (expect:expect-type-get-type typeinfo)
                         where-op                                  ;; 2
                         section
                         (if xstatus "OK" "FAIL")                  ;; 4
                         compsym 
                         value                                     ;; 6
                         name
                         count                                     ;; 8
                         ""
			 ""                                        ;; 10
			 rx-str
                         ))
          (set! lineout (apply format #f fmt outvals))))
    (values outvals lineout)))

(define (print-results cssfile) ;; cssfile is used as a flag

  (let ((status        #t)
        (found-error   #f)
        (etallys       (make-tally))
		(tblfmt        (conc ""
                             (string-intersperse (map (lambda (x) "~a") '(1 2 3 4 5 6 7 8 9 10)) "")
                             ""))
        ;;             type where section OK/FAIL compsym value name count
	(fmt-trg      "Trigger: ~13a ~15@a, count=~a")
	(fmt-trg-html "Trigger: ~13a ~15@a, count=~a"))
    ;; first print any triggers that didn't get triggered - these are automatic failures
    (print      "==========================LOGPRO SUMMARY==========================")
    (html-print #f "")
    (html-print #f "==========================LOGPRO SUMMARY==========================")
    (for-each
     (lambda (trigger)
       (let ((count (trigger:get-total-hits trigger)))
	 ;; Triggers are forcibly required unless you use the "trigger:not-required"
	 (if (and (< count 1)
		  (trigger:get-required-flag trigger))
	     (set! status #f))
	 (let* ((trigger-status (if (> count 0)
				    "OK"
				    (if (trigger:get-required-flag trigger)
					"FAIL"
					"OPTIONAL"))))
	   (print      (format #f fmt-trg (trigger:get-name trigger) trigger-status count))
	   (html-print #f (format #f fmt-trg-html (trigger:get-name trigger) (trigger:get-name trigger) (trigger:get-name trigger) trigger-status count)))))
     *triggers*)
    ;; now print the expects
    ;;(print "LOGPRO: " (append (list #f) (filter identity (map section:get-section-file *sections*))))
    (for-each (lambda(output-file) 
      ;;(print "LOGPRO: " output-file) 
      (html-print output-file "

") (if output-file (html-print output-file (conc "

You are in a section log summary. Back to Top-Level

"))) (html-print output-file "") ;; style=\"width:100%\">") ;; border=\"1\" (html-print output-file "") (if output-file (flush-output output-file))) (append (list #f) (map (lambda(s) (open-output-file s #:append)) (filter identity (map section:get-section-file *sections*)) ))) (for-each (lambda (section) ;;(print "LOGPRO: " (map section:get-section-file *sections*)) (set! final-section-file #f) (for-each (lambda(section2) (let ((section-name (section:get-name section2)) (start-trigger (section:get-start-trigger section2)) (section-file (section:get-section-file section2)) (end-trigger (section:get-end-trigger section2))) ;;(print "LOGPRO: Comparing " section-name " to " section) (if (string= section-name section) (begin ;;(print "LOGPRO: MATCH!" section-file) (set! final-section-file section-file)) ;;(print "LOGPRO: No match :-( " section-name) ) )) *sections*) (print "\nExpects for " section " section: " final-section-file) (for-each (lambda(output-file) (html-print output-file "") (for-each (lambda (expect) (let* ((count (expects:get-count expect)) (name (expects:get-name expect)) (typeinfo (expect:get-type-info expect)) (etype (expects:get-type expect)) (keyname (expects:get-keyname expect)) (is-value (eq? etype 'value)) (rulenum (expects:get-rulenum expect)) (eclass (expects:get-html-class expect)) (outvals #f)) ;; xstatus is the expected vs. actual count of the item in question (let*-values (((xstatus compsym)(get-xstatus-compsym expect)) ((outvals lineout)(value-print expect rulenum typeinfo is-value xstatus name compsym section count))) ;; now send lineout to the html file (html-print-one-line output-file count xstatus typeinfo etype cssfile eclass keyname outvals is-value final-section-file) (if (> (string-length lineout) 0)(print "Expect:" lineout)) (if (not xstatus) ;; (begin (if (not found-error)(expects:set-failed-flag! expect #t)) (set! found-error #t) (set! status #f) (increment-tally etallys etype)))))) (sort (hash-table-ref *expects* section) (lambda (a b) (< (expects:get-rulenum a)(expects:get-rulenum b))))) ) (if final-section-file (list #f (open-output-file final-section-file #:append)) (list #f)) ) ) (sort (hash-table-keys *expects*) (lambda (a b)(string>=? a b)))) (html-print #f "
RuleNumRuleTypeStatusCompCount/ValDescCountRx
Expects for " section " section: " final-section-file "
") (let* ((exit-code (counts->exit-code etallys status *got-an-error*)) (exit-status (exit-code->exit-status exit-code)) (exit-sym (exit-code->exit-sym exit-code))) (html-print #f "

EXIT CODE: " exit-code " (" exit-status) (html-print #f ")

") ;; add the [final] block to the summary dat (if *summport* (with-output-to-port *summport* (lambda () (print "[final]") (print "exit-code " exit-code) (print "exit-status " exit-status) (for-each (lambda (section) (for-each (lambda (xpect) (let* ((etype (expects:get-type xpect)) (emsg (expects:get-name xpect))) ;; (print "etype: " etype " emsg: " emsg " exit-sym: " exit-sym) (if (expects:get-failed-flag xpect) ;; (equal? etype exit-sym) (print "message " (conc etype ": " emsg)) ;; (print "nonmsg " emsg) ))) (hash-table-ref *expects* section))) (hash-table-keys *expects*))))) exit-code))) (define (setup-logpro) (use regex) (use regex-literals))