623 lines
22 KiB
Scheme
623 lines
22 KiB
Scheme
|
#!/usr/bin/env -S guix repl --
|
||
|
|
!#
|
||
|
|
;; Copyright (C) 2024 Denis 'GNUtoo' Carikli <GNUtoo@cyberdimension.org>
|
||
|
|
;;
|
||
|
|
;; This program is free software: you can redistribute it and/or modify
|
||
|
|
;; it under the terms of the GNU General Public License as published by
|
||
|
|
;; the Free Software Foundation, either version 3 of the License, or
|
||
|
|
;; (at your option) any later version.
|
||
|
|
;;
|
||
|
|
;; This program is distributed in the hope that it will be useful,
|
||
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
|
|
;; GNU General Public License for more details.
|
||
|
|
;;
|
||
|
|
;; You should have received a copy of the GNU General Public License
|
||
|
|
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
||
|
|
|
||
|
|
(use-modules (ice-9 rdelim))
|
||
|
|
(use-modules (ice-9 regex))
|
||
|
|
(use-modules (srfi srfi-1))
|
||
|
|
(use-modules (srfi srfi-9))
|
||
|
|
(use-modules (srfi srfi-19))
|
||
|
|
|
||
|
|
(define (startswith str value)
|
||
|
|
(if (> (string-length str) (string-length value))
|
||
|
|
(string=? (substring str 0 (string-length value)) value) #f))
|
||
|
|
|
||
|
|
(define (read-file path func)
|
||
|
|
(define results #f)
|
||
|
|
(let ((port (open-input-file path)))
|
||
|
|
(set! results (func path port))
|
||
|
|
(close-port port)
|
||
|
|
results))
|
||
|
|
|
||
|
|
(define (print-patch-name path)
|
||
|
|
(define dashes
|
||
|
|
(string-append
|
||
|
|
(string-join (make-list (string-length path) "-") "")
|
||
|
|
"\n"))
|
||
|
|
(display dashes)
|
||
|
|
(display (string-append path "\n"))
|
||
|
|
(display dashes))
|
||
|
|
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;; ;;
|
||
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;; ;;
|
||
|
|
;; ;; Patch parsing logic ;; ;;
|
||
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;; ;;
|
||
|
|
;; ;;
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
|
||
|
|
(define-record-type <rule>
|
||
|
|
(make-rule name default line-match line end)
|
||
|
|
rule?
|
||
|
|
(name rule-name) ;; Name of the rule
|
||
|
|
(default rule-default) ;; Runs once at the beginning, inconditionally
|
||
|
|
(line-match rule-line-match) ;; Runs each line, returns true/false
|
||
|
|
(line rule-line) ;; Runs if rule-line-match is true
|
||
|
|
(end rule-end)) ;; Runs once at the end, inconditionally
|
||
|
|
|
||
|
|
(define parse-rules
|
||
|
|
(list
|
||
|
|
|
||
|
|
;; Here's an example of a parse rule below. Since it runs each time it is
|
||
|
|
;; also tested. TODO: A a proper unit testing environment needs to
|
||
|
|
;; be added and then this could be moved to only run inside that
|
||
|
|
;; separate testing environment.
|
||
|
|
(make-rule
|
||
|
|
"Example empty rule"
|
||
|
|
(lambda (results) results)
|
||
|
|
(lambda (line _ results) #t)
|
||
|
|
(lambda (line _ results) results)
|
||
|
|
(lambda (path _ results) results))
|
||
|
|
|
||
|
|
(make-rule
|
||
|
|
"Count lines"
|
||
|
|
(lambda (results) (acons 'line 0 results))
|
||
|
|
(lambda (line _ results) #t)
|
||
|
|
(lambda (line _ results)
|
||
|
|
(acons 'line (+ 1 (assq-ref results 'line)) results))
|
||
|
|
(lambda (path _ results) results))
|
||
|
|
|
||
|
|
(make-rule
|
||
|
|
"Find diff start"
|
||
|
|
(lambda (results) results)
|
||
|
|
(lambda (line _ results)
|
||
|
|
(startswith line "diff --git "))
|
||
|
|
(lambda (line _ results)
|
||
|
|
(acons 'diff-start
|
||
|
|
(assq-ref results
|
||
|
|
'line) results))
|
||
|
|
(lambda (path _ results)
|
||
|
|
results))
|
||
|
|
|
||
|
|
(make-rule
|
||
|
|
"Retrieve Signed-off-by"
|
||
|
|
(lambda (results) (acons 'signed-off-by '() results))
|
||
|
|
(lambda (line _ results) (startswith line "Signed-off-by: "))
|
||
|
|
(lambda (line _ results)
|
||
|
|
(let ((signed-off-by
|
||
|
|
(string-join (cdr (string-split line #\ )) " ")))
|
||
|
|
(acons 'signed-off-by
|
||
|
|
(append (assq-ref results 'signed-off-by) (list signed-off-by))
|
||
|
|
results)))
|
||
|
|
(lambda (path _ results) results))
|
||
|
|
|
||
|
|
;; TODO: Raise an exception if there is no lines with From:, and
|
||
|
|
;; when handling it, complain that the file is not a valid git
|
||
|
|
;; patch.
|
||
|
|
(make-rule
|
||
|
|
"Find commit author"
|
||
|
|
(lambda (results) results)
|
||
|
|
(lambda (line _ results) (startswith line "From: "))
|
||
|
|
(lambda (line _ results)
|
||
|
|
(let ((commit-author (string-join (cdr (string-split line #\ )) " ")))
|
||
|
|
(acons
|
||
|
|
'commit-author
|
||
|
|
commit-author
|
||
|
|
results)))
|
||
|
|
(lambda (path _ results) results))
|
||
|
|
|
||
|
|
(make-rule
|
||
|
|
"Find commit hash"
|
||
|
|
(lambda (results) results)
|
||
|
|
(lambda (line _ results)
|
||
|
|
;; Example:
|
||
|
|
;; From 0df4fe5fadfb7f51c1c34dad10ca9e6e04c3fa18 Mon Sep 17 00:00:00 2001
|
||
|
|
(and (not (startswith line "From: "))
|
||
|
|
(startswith line "From ")))
|
||
|
|
(lambda (line _ results)
|
||
|
|
(let ((commit-hash (list-ref (string-split line #\ ) 1)))
|
||
|
|
(acons 'commit-hash commit-hash results)))
|
||
|
|
(lambda (path _ results) results))
|
||
|
|
|
||
|
|
;; TODO: Raise an exception if there is no lines with Date:, and
|
||
|
|
;; when handling it, complain that the file is not a valid git
|
||
|
|
;; patch.
|
||
|
|
(make-rule
|
||
|
|
"Find commit date"
|
||
|
|
(lambda (results) results)
|
||
|
|
(lambda (line _ results) (startswith line "Date: "))
|
||
|
|
(lambda (line _ results)
|
||
|
|
(acons 'commit-date
|
||
|
|
(string->date
|
||
|
|
(string-join (cdr (string-split line #\ )) " ")
|
||
|
|
"~a, ~d ~b ~Y ~H:~M:~S ~z")
|
||
|
|
results))
|
||
|
|
(lambda (path _ results) results))
|
||
|
|
|
||
|
|
;; TODO:
|
||
|
|
;; - In general we might want to have the commit summary instead of
|
||
|
|
;; the subject, but for now we will use the mail subject instead
|
||
|
|
;; as we don't use the summary yet and properly parsing the
|
||
|
|
;; subject would require to reimplement the cleanup_subject
|
||
|
|
;; function from mailinfo.c in git source code.
|
||
|
|
;; - Raise an exception if there is no lines with From:, and when
|
||
|
|
;; handling it, complain that the file is not a valid git patch.
|
||
|
|
(make-rule
|
||
|
|
"Find patch subject"
|
||
|
|
(lambda (results) results)
|
||
|
|
(lambda (line _ results) (startswith line "Subject: "))
|
||
|
|
(lambda (line _ results)
|
||
|
|
(let ((commit-subject (string-join (cdr (string-split line #\ )) " ")))
|
||
|
|
(acons
|
||
|
|
'commit-subject-line
|
||
|
|
(assq-ref results 'line)
|
||
|
|
(acons
|
||
|
|
'commit-subject
|
||
|
|
commit-subject
|
||
|
|
results))))
|
||
|
|
(lambda (path _ results) results))
|
||
|
|
|
||
|
|
(make-rule
|
||
|
|
"Find commit subject and message separator"
|
||
|
|
(lambda (results) results)
|
||
|
|
(lambda (line _ results)
|
||
|
|
;; TODO: Raise an exception if the line after the commit subject
|
||
|
|
;; line is not empty, and when handling it, complain that the
|
||
|
|
;; file is not a valid git patch.
|
||
|
|
(and
|
||
|
|
(not (assq-ref results 'commit-message-end-line))
|
||
|
|
(assq-ref results 'commit-subject)
|
||
|
|
(string=? line "")
|
||
|
|
(eq? (+ 1 (assq-ref results 'commit-subject-line))
|
||
|
|
(assq-ref results 'line))))
|
||
|
|
(lambda (line _ results)
|
||
|
|
(acons
|
||
|
|
'commit-subject-message-separator-line
|
||
|
|
(assq-ref results 'line)
|
||
|
|
results))
|
||
|
|
(lambda (path _ results) results))
|
||
|
|
|
||
|
|
;; TODO: Raise an exception if there is more than two lines with
|
||
|
|
;; ---, and when handling it, complain that the file is not a valid
|
||
|
|
;; git patch.
|
||
|
|
(make-rule
|
||
|
|
"Find changelog end"
|
||
|
|
(lambda (results) results)
|
||
|
|
(lambda (line _ results)
|
||
|
|
(and
|
||
|
|
(assq-ref results 'commit-message-end-line)
|
||
|
|
(string=? line "---")))
|
||
|
|
(lambda (line _ results)
|
||
|
|
(acons 'changelog-end-line (assq-ref results 'line) results))
|
||
|
|
(lambda (path _ results) results))
|
||
|
|
|
||
|
|
;; TODO: Raise an exception if there is no line with ---, and when
|
||
|
|
;; handling it, complain that the file is not a valid git patch.
|
||
|
|
(make-rule
|
||
|
|
"Find commit message end"
|
||
|
|
(lambda (results) results)
|
||
|
|
(lambda (line _ results)
|
||
|
|
;; This matches the first "---" but there could be more as shown
|
||
|
|
;; in the example below:
|
||
|
|
;; ---
|
||
|
|
;; ChangeLog: [...]
|
||
|
|
;; ---
|
||
|
|
;; So until found we are in the commit message, but after it is found
|
||
|
|
;; we could also be in the ChangeLog.
|
||
|
|
(and (string=? line "---")
|
||
|
|
(not (assq-ref results 'commit-message-end-line))))
|
||
|
|
(lambda (line _ results)
|
||
|
|
(acons 'commit-message-end-line (assq-ref results 'line) results))
|
||
|
|
(lambda (path _ results) results))
|
||
|
|
|
||
|
|
(make-rule
|
||
|
|
"Find the end of the commit"
|
||
|
|
(lambda (results) results)
|
||
|
|
(lambda (line _ results) #f)
|
||
|
|
(lambda (line _ results) results)
|
||
|
|
(lambda (path _ results)
|
||
|
|
(acons 'commit-end-line
|
||
|
|
(if (assq-ref results 'changelog-end-line)
|
||
|
|
(assq-ref results 'changelog-end-line)
|
||
|
|
(assq-ref results 'commit-message-end-line))
|
||
|
|
results)))
|
||
|
|
|
||
|
|
(make-rule
|
||
|
|
"Find commit message"
|
||
|
|
(lambda (results) results)
|
||
|
|
(lambda (line _ results)
|
||
|
|
(and
|
||
|
|
(not (assq-ref results 'commit-message-end-line))
|
||
|
|
(assq-ref results 'commit-subject-message-separator-line)
|
||
|
|
(> (assq-ref results 'line)
|
||
|
|
(assq-ref results 'commit-subject-message-separator-line))))
|
||
|
|
(lambda (line _ results)
|
||
|
|
(let ((commit-message
|
||
|
|
(if (not (assq-ref results 'commit-message))
|
||
|
|
(list)
|
||
|
|
(append (assq-ref results 'commit-message) (list line)))))
|
||
|
|
(acons
|
||
|
|
'commit-message
|
||
|
|
commit-message
|
||
|
|
results)))
|
||
|
|
(lambda (path _ results) results))
|
||
|
|
|
||
|
|
(make-rule
|
||
|
|
"Find added files"
|
||
|
|
(lambda (results)
|
||
|
|
(acons 'added-files
|
||
|
|
'() results))
|
||
|
|
(lambda (line _ results)
|
||
|
|
(and (startswith line " create mode ")))
|
||
|
|
(lambda (line _ results)
|
||
|
|
(define line-parts
|
||
|
|
(string-split line #\space))
|
||
|
|
(define added-file
|
||
|
|
'())
|
||
|
|
(if (> (length line-parts) 3)
|
||
|
|
(set! added-file
|
||
|
|
(list (list-ref line-parts 4))))
|
||
|
|
(acons 'added-files
|
||
|
|
(append (assq-ref results 'added-files) added-file)
|
||
|
|
results))
|
||
|
|
(lambda (path _ results)
|
||
|
|
results))
|
||
|
|
|
||
|
|
(make-rule
|
||
|
|
"Find deleted files"
|
||
|
|
(lambda (results)
|
||
|
|
(acons 'deleted-files
|
||
|
|
'() results))
|
||
|
|
(lambda (line _ results)
|
||
|
|
(and (startswith line " delete mode ")))
|
||
|
|
(lambda (line _ results)
|
||
|
|
(define line-parts
|
||
|
|
(string-split line #\space))
|
||
|
|
(define deleted-file
|
||
|
|
'())
|
||
|
|
(if (> (length line-parts) 3)
|
||
|
|
(set! deleted-file
|
||
|
|
(list (list-ref line-parts 4))))
|
||
|
|
(acons 'deleted-files
|
||
|
|
(append (assq-ref results 'deleted-files) deleted-file)
|
||
|
|
results))
|
||
|
|
(lambda (path _ results)
|
||
|
|
results))
|
||
|
|
|
||
|
|
(make-rule
|
||
|
|
"Find modified files and track current file diff"
|
||
|
|
(lambda (results)
|
||
|
|
(acons 'current-diff-file #f
|
||
|
|
(acons 'modified-files '() results)))
|
||
|
|
(lambda (line _ results)
|
||
|
|
(startswith line "diff --git a/"))
|
||
|
|
(lambda (line _ results)
|
||
|
|
(define line-parts
|
||
|
|
(string-split line #\space))
|
||
|
|
(define current-diff-file
|
||
|
|
#f)
|
||
|
|
(define modified-file
|
||
|
|
'())
|
||
|
|
(if (> (length line-parts) 3)
|
||
|
|
;; Example: b/www/x60t_unbrick/0009.JPG
|
||
|
|
(let* ((part3 (list-ref line-parts 3))
|
||
|
|
;; remove the b/
|
||
|
|
(path (substring part3 2
|
||
|
|
(string-length part3))))
|
||
|
|
(set! current-diff-file path)
|
||
|
|
(if (not (or (any (lambda (added-file-path)
|
||
|
|
(string=? added-file-path path))
|
||
|
|
(assq-ref results 'added-files))
|
||
|
|
(any (lambda (deleted-file-path)
|
||
|
|
(string=? deleted-file-path
|
||
|
|
path))
|
||
|
|
(assq-ref results 'deleted-files))))
|
||
|
|
(set! modified-file
|
||
|
|
(list path)))))
|
||
|
|
(acons 'modified-files
|
||
|
|
(append (assq-ref results 'modified-files) modified-file)
|
||
|
|
(acons 'current-diff-file current-diff-file
|
||
|
|
results)))
|
||
|
|
(lambda (path _ results)
|
||
|
|
results))
|
||
|
|
|
||
|
|
(make-rule
|
||
|
|
"Track diff"
|
||
|
|
(lambda (results) results)
|
||
|
|
(lambda (line _ results) #t)
|
||
|
|
(lambda (line _ results)
|
||
|
|
(define diff-start
|
||
|
|
0)
|
||
|
|
(define diff-end
|
||
|
|
0)
|
||
|
|
(if (and (assq-ref results
|
||
|
|
'current-diff-file)
|
||
|
|
(startswith line "@@"))
|
||
|
|
(set! diff-start
|
||
|
|
(assq-ref results
|
||
|
|
'line)))
|
||
|
|
(if (startswith line "diff --git a/")
|
||
|
|
(set! diff-end
|
||
|
|
(assq-ref results
|
||
|
|
'line)))
|
||
|
|
(if (and (not (eq? diff-start 0))
|
||
|
|
(not (eq? diff-end 0)))
|
||
|
|
(acons 'diff-end diff-end
|
||
|
|
(acons 'diff-start diff-start results))
|
||
|
|
(if (not (eq? diff-start 0))
|
||
|
|
(acons 'diff-start diff-start results)
|
||
|
|
(acons 'diff-end diff-end results))))
|
||
|
|
(lambda (path _ results) results))
|
||
|
|
|
||
|
|
(make-rule
|
||
|
|
"Check for copyrights inside the patch"
|
||
|
|
(lambda (results)
|
||
|
|
(acons 'diff-path-added-proper-copyright
|
||
|
|
'() results))
|
||
|
|
(lambda (line _ results)
|
||
|
|
(and (startswith line "+")
|
||
|
|
(assq-ref results
|
||
|
|
'current-diff-file)
|
||
|
|
(> (assq-ref results
|
||
|
|
'diff-start) 0)))
|
||
|
|
(lambda (line _ results)
|
||
|
|
(let ((diff-start (assq-ref results
|
||
|
|
'diff-start))
|
||
|
|
(diff-end (assq-ref results
|
||
|
|
'diff-end))
|
||
|
|
(current-diff-file (assq-ref results
|
||
|
|
'current-diff-file))
|
||
|
|
(commit-author (assq-ref results
|
||
|
|
'commit-author))
|
||
|
|
(commit-year (date-year (assq-ref results
|
||
|
|
'commit-date))))
|
||
|
|
;; Example: Copyright (C) 2024 Some Name <mail@domain.org>
|
||
|
|
(if
|
||
|
|
(string-match
|
||
|
|
(string-append
|
||
|
|
"Copyright[ ]\\(C\\)[ ]" ;"Copyright (C) "
|
||
|
|
".*" ;We can have multiple years
|
||
|
|
(number->string commit-year 10) ;Year
|
||
|
|
".*" ;We can have multiple years
|
||
|
|
" " ;We have at least 1 space before the author line
|
||
|
|
commit-author) line)
|
||
|
|
(acons 'diff-path-added-proper-copyright
|
||
|
|
(append (assq-ref results
|
||
|
|
'diff-path-added-proper-copyright)
|
||
|
|
(list current-diff-file)) results)
|
||
|
|
results)))
|
||
|
|
(lambda (path _ results) results))
|
||
|
|
|
||
|
|
;; We can also use rules for debugging the code, here are two
|
||
|
|
;; examples below.
|
||
|
|
|
||
|
|
;; (make-rule
|
||
|
|
;; "Debug: print lines."
|
||
|
|
;; (lambda (results) results)
|
||
|
|
;; (lambda (line _ results) #t)
|
||
|
|
;; (lambda (line _ results)
|
||
|
|
;; (display "Count lines: line #")
|
||
|
|
;; (display (+ 1 (assq-ref results 'line)))
|
||
|
|
;; (display (string-append ": " line "\n"))
|
||
|
|
;; results)
|
||
|
|
;; (lambda (path _ results) results))
|
||
|
|
|
||
|
|
;; (make-rule
|
||
|
|
;; "Debug: print results."
|
||
|
|
;; (lambda (results) results)
|
||
|
|
;; (lambda (line _ results) #f)
|
||
|
|
;; (lambda (line _ results) results)
|
||
|
|
;; (lambda (path _ results)
|
||
|
|
;; (pk results)
|
||
|
|
;; results))
|
||
|
|
))
|
||
|
|
|
||
|
|
(define (set-defaults rules results)
|
||
|
|
(for-each
|
||
|
|
(lambda (rule)
|
||
|
|
(set! results ((rule-default rule) results)))
|
||
|
|
rules)
|
||
|
|
results)
|
||
|
|
|
||
|
|
(define (run-line-match-rules port rules parse-results results)
|
||
|
|
(define line (read-line port))
|
||
|
|
(if (eof-object? line)
|
||
|
|
results
|
||
|
|
((lambda _
|
||
|
|
(for-each
|
||
|
|
(lambda (rule)
|
||
|
|
(if ((rule-line-match rule) line parse-results results)
|
||
|
|
(set! results ((rule-line rule) line parse-results results))))
|
||
|
|
rules)
|
||
|
|
(run-line-match-rules port rules parse-results results)))))
|
||
|
|
|
||
|
|
(define (run-end-rules path rules other-results results)
|
||
|
|
(for-each
|
||
|
|
(lambda (rule)
|
||
|
|
(set! results ((rule-end rule) path other-results results)))
|
||
|
|
rules)
|
||
|
|
results)
|
||
|
|
|
||
|
|
(define (run-parse-rules rules path)
|
||
|
|
(read-file
|
||
|
|
path
|
||
|
|
(lambda (path port)
|
||
|
|
(let* ((defaults (set-defaults rules '()))
|
||
|
|
(results (run-line-match-rules port rules #f defaults)))
|
||
|
|
(run-end-rules path rules #f results)))))
|
||
|
|
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;; ;;
|
||
|
|
;; ;;;;;;;;;;;; ;;
|
||
|
|
;; ;; Checks ;; ;;
|
||
|
|
;; ;;;;;;;;;;;; ;;
|
||
|
|
;; ;;
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
|
||
|
|
(define (run-check-rules parse-results rules path)
|
||
|
|
(read-file
|
||
|
|
path
|
||
|
|
(lambda (path port)
|
||
|
|
(let* ((defaults (set-defaults rules '()))
|
||
|
|
(check-results
|
||
|
|
(run-line-match-rules port rules parse-results defaults)))
|
||
|
|
(run-end-rules path rules parse-results check-results)))))
|
||
|
|
|
||
|
|
(define check-rules
|
||
|
|
(list
|
||
|
|
|
||
|
|
;; Here's an example of a check rule below. Since it runs each time it is
|
||
|
|
;; also tested. TODO: A a proper unit testing environment needs to
|
||
|
|
;; be added and then this could be moved to only run inside that
|
||
|
|
;; separate testing environment.
|
||
|
|
(make-rule
|
||
|
|
"Example empty rule"
|
||
|
|
(lambda (check-results) check-results)
|
||
|
|
(lambda (line parse-results check-results) #t)
|
||
|
|
(lambda (line parse-results check-results) check-results)
|
||
|
|
(lambda (path parse-results check-results) check-results))
|
||
|
|
|
||
|
|
(make-rule
|
||
|
|
"Count lines"
|
||
|
|
(lambda (check-results) (acons 'line 0 check-results))
|
||
|
|
(lambda (line parse-results check-results) #t)
|
||
|
|
(lambda (line parse-results check-results)
|
||
|
|
(acons 'line (+ 1 (assq-ref check-results 'line)) check-results))
|
||
|
|
(lambda (path parse-results check-results) check-results))
|
||
|
|
|
||
|
|
;; Workarround for the bug #66268
|
||
|
|
;; [1]https://debbugs.gnu.org/cgi/bugreport.cgi?bug=66268
|
||
|
|
(make-rule
|
||
|
|
"Enforce commit size < 4KB"
|
||
|
|
(lambda (check-results)
|
||
|
|
(acons 'commit-size 0 check-results))
|
||
|
|
(lambda (line parse-results check-results)
|
||
|
|
(< (assq-ref check-results 'line)
|
||
|
|
(assq-ref parse-results 'commit-end-line)))
|
||
|
|
(lambda (line parse-results check-results)
|
||
|
|
(acons 'commit-size
|
||
|
|
(+
|
||
|
|
1 ;; for the \n
|
||
|
|
(string-length line)
|
||
|
|
(assq-ref check-results 'commit-size))
|
||
|
|
check-results))
|
||
|
|
(lambda (path parse-results check-results)
|
||
|
|
;; We're not sure of the exact size limit so let's use 2500
|
||
|
|
;; instead of 4096, since we're not counting signatures etc
|
||
|
|
(let ((limit 2500)
|
||
|
|
(commit-size (assq-ref check-results 'commit-size)))
|
||
|
|
(if (>= commit-size limit)
|
||
|
|
((lambda _
|
||
|
|
(display
|
||
|
|
(string-append
|
||
|
|
"ERROR: Commit size is " (number->string commit-size) " B"
|
||
|
|
" which is over the " (number->string limit) " B limit\n\n"))
|
||
|
|
(acons
|
||
|
|
'errors
|
||
|
|
(+ 1 (assq-ref check-results 'errors)) check-results)))
|
||
|
|
check-results))))
|
||
|
|
|
||
|
|
(make-rule
|
||
|
|
"Check for Signed-off-by"
|
||
|
|
(lambda (check-results) check-results)
|
||
|
|
(lambda (line parse-results check-results) #t)
|
||
|
|
(lambda (line parse-results check-results) check-results)
|
||
|
|
(lambda (path parse-results check-results)
|
||
|
|
(let ((author (assq-ref parse-results 'commit-author)))
|
||
|
|
(if (not (any (lambda (elm)
|
||
|
|
(string=? author elm))
|
||
|
|
(assq-ref parse-results 'signed-off-by)))
|
||
|
|
((lambda _
|
||
|
|
(display
|
||
|
|
(string-append "ERROR: Missing Signed-off-by: " author "\n\n"))
|
||
|
|
(acons
|
||
|
|
'errors
|
||
|
|
(+ 1 (assq-ref check-results 'errors)) check-results)))
|
||
|
|
check-results))))
|
||
|
|
|
||
|
|
(make-rule
|
||
|
|
"Track total errors and warnings"
|
||
|
|
(lambda (check-results) (acons 'warnings 0 (acons 'errors 0 check-results)))
|
||
|
|
(lambda (line parse-results check-results) #t)
|
||
|
|
(lambda (line parse-results check-results) check-results)
|
||
|
|
(lambda (path parse-results check-results)
|
||
|
|
(let* ((nr-lines (number->string (assq-ref parse-results 'line) 10))
|
||
|
|
(errors (assq-ref check-results 'errors))
|
||
|
|
(warnings (assq-ref check-results 'warnings))
|
||
|
|
(error-text
|
||
|
|
(string-append (number->string errors 10)
|
||
|
|
(if (> errors 1) " errors, " " error, ")))
|
||
|
|
(warning-text
|
||
|
|
(string-append (number->string warnings 10)
|
||
|
|
(if (> warnings 1) " warnings, " " warning, "))))
|
||
|
|
(display
|
||
|
|
(string-append
|
||
|
|
"total: " error-text warning-text nr-lines " lines checked\n\n"))
|
||
|
|
(if (or (> errors 0) (> warnings 0))
|
||
|
|
((lambda _
|
||
|
|
(display
|
||
|
|
(string-append path " has style problems, please review.\n"))
|
||
|
|
(display
|
||
|
|
(string-append
|
||
|
|
"NOTE: If any of the errors are false positives, "
|
||
|
|
"please report them to the GNU Boot maintainers.\n"))))
|
||
|
|
(display
|
||
|
|
(string-append
|
||
|
|
path
|
||
|
|
" has no obvious style problems "
|
||
|
|
"and is ready for submission.\n"))))
|
||
|
|
check-results))))
|
||
|
|
|
||
|
|
(define (test-patch path)
|
||
|
|
(let* ((parse-results (run-parse-rules parse-rules path))
|
||
|
|
(check-results (run-check-rules parse-results check-rules path)))
|
||
|
|
parse-results))
|
||
|
|
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;; ;;
|
||
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;
|
||
|
|
;; ;; Command line parsing handlig ;; ;;
|
||
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;
|
||
|
|
;; ;;
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
|
||
|
|
;; error if not in git tree and in topdir.
|
||
|
|
(define (in-tree-topdir?)
|
||
|
|
(string=?
|
||
|
|
(canonicalize-path (getcwd))
|
||
|
|
(dirname (dirname (current-filename)))))
|
||
|
|
|
||
|
|
(define (usage progname exit-code)
|
||
|
|
(display (string-append
|
||
|
|
"Usage: "
|
||
|
|
progname
|
||
|
|
" [path/to/file.patch [path/to/file.patch ...]]\n"))
|
||
|
|
(exit exit-code))
|
||
|
|
|
||
|
|
(if (eq? (length (program-arguments)) 1)
|
||
|
|
(usage "checkpatch.pl" 64) ;; 64 is EX_USAGE in sysexits.h
|
||
|
|
(if (not (in-tree-topdir?))
|
||
|
|
((lambda _
|
||
|
|
(display
|
||
|
|
(string-append
|
||
|
|
"Error: please run checkpatch.scm in the git top directory.\n"))
|
||
|
|
(exit 69))) ;; 69 is EX_UNAVAILABLE in sysexits.h
|
||
|
|
(map (lambda (path)
|
||
|
|
(if (> (length (program-arguments)) 2)
|
||
|
|
(print-patch-name path))
|
||
|
|
(test-patch path))
|
||
|
|
(cdr (program-arguments)))))
|