X-Git-Url: https://code.consxy.com/gitweb/gitweb.cgi?p=wolf;a=blobdiff_plain;f=src%2Fmain%2Fwolf.lisp;fp=src%2Fmain%2Fwolf.lisp;h=776a535ae57c1f51106b048f22f048f4d1aeb55f;hp=d6f60e3db3f43462aaf3f66e5c2d26eac99f02fd;hb=d8636e889212a943adefc3837476bfb2efd23a7b;hpb=6ea66bbdff1cc0356c121d453857ecb9d3c1e351

diff --git a/src/main/wolf.lisp b/src/main/wolf.lisp
index d6f60e3..776a535 100644
--- a/src/main/wolf.lisp
+++ b/src/main/wolf.lisp
@@ -18,7 +18,8 @@
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
  (defparameter *possible-states*
-  '(:begin ; start of file
+  '(:copyright-required
+    :begin ; start of file
     :normal ; normal processing
     :beginning-of-line
     :beginning-of-line-with-separator ; empty space in there
@@ -36,27 +37,28 @@
  (setf *state* state)
  nil)
 
+(defun make-evaluator (eval-state match func)
+ (let
+  ((scanner (when (stringp match) (cl-ppcre:create-scanner match))))
+  (list
+   (lambda (state text)
+    (and
+     (or (eql :all eval-state) (eql eval-state state))
+     (or
+      (and (symbolp text) (eql text match))
+      (and
+       scanner
+       (stringp text)
+       (multiple-value-bind (start end) (cl-ppcre:scan scanner text)
+        (and start end (= 0 start)))))))
+   (lambda (text) (nth-value 1 (cl-ppcre:scan scanner text)))
+   func)))
+
 (defmacro defevaluator (state match func)
  (when (not (find state *possible-states*)) (error "~A is an invalid state" state))
  (let
   ((scanner (gensym)))
-  `(let
-    ((,scanner (when (stringp ,match) (cl-ppcre:create-scanner ,match))))
-    (pushnew
-     (list
-      (lambda (state text)
-       (and
-        (or (eql :all ,state) (eql ,state state))
-        (or
-         (and (symbolp text) (eql text ,match))
-         (and
-          ,scanner
-          (stringp text)
-          (multiple-value-bind (start end) (cl-ppcre:scan ,scanner text)
-           (and start end (= 0 start)))))))
-      (lambda (text) (second (multiple-value-list (cl-ppcre:scan ,scanner text))))
-      ,func)
-     *evaluators*))))
+  `(pushnew (make-evaluator ,state ,match ,func) *evaluators*)))
 
 (defun evaluate (text)
  (if (string= "" text)
@@ -77,7 +79,10 @@
      (error (make-condition 'check-failure :msg problem :line-no *line-no* :col-no *col-no*)))
     (let
      ((length-of-match (funcall (cadr evaluator) text)))
-     (incf *col-no* length-of-match)
+     (if
+      (eql *col-no* :reset)
+      (setf *col-no* 0)
+      (incf *col-no* length-of-match))
      (when (< 120 *col-no*)
       (error (make-condition 'check-failure :msg "Line longer than 120 characters" :line-no *line-no* :col-no 0)))
      (evaluate (subseq text length-of-match)))))))
@@ -86,8 +91,35 @@
  (with-open-file (str filename :element-type element-type)
   (let ((seq (make-sequence sequence-type (file-length str)))) (read-sequence seq str) seq)))
 
-(defun check-file (file)
- "CHECK-FILE FILE => RESULT
+(defun check-file (file &key copyright-notice)
+ (cond
+  (copyright-notice (set-state :copyright-required))
+  ((string= "package" (pathname-name file)) (set-state :normal))
+  (t (set-state :begin)))
+ (setf *line-no* 0)
+ (setf *col-no* 0)
+ (setf *form-stack* nil)
+ (setf *form-ended-on-same-line* nil)
+ (when copyright-notice
+  (setf *evaluators*
+   (append *evaluators*
+    (list
+     (make-evaluator :copyright-required (format nil "~A\\n" copyright-notice)
+      (lambda ()
+       (incf *line-no*)
+       (setf *col-no* :reset)
+       (if (string= "package" (pathname-name file))
+        (set-state :normal)
+        (set-state :begin))))))))
+ (handler-case
+  (progn
+   (evaluate (slurp-file file))
+   (list :success file))
+  (check-failure (cf)
+   (list :failure file (check-failure-msg cf) (check-failure-line-no cf) (check-failure-col-no cf)))))
+
+(setf (documentation 'check-file 'function)
+ "CHECK-FILE FILE &key COPYRIGHT-NOTICE => RESULT
 
   RESULT: SUCCESS-RESULT | FAILURE-RESULT
   SUCCESS-RESULT: (:success FILENAME)
@@ -96,6 +128,7 @@
 ARGUMENTS AND VALUES:
 
   FILE: a pathname
+  COPYRIGHT-NOTICE: A regex string
   FILENAME: the file this check was run on
   MSG: a string containing the failure message
   LINE-NO: an integer, the line number on which the failure appeared
@@ -106,33 +139,24 @@ DESCRIPTION:
   CHECK-FILE runs all the checks against a file and returns
   as soon as the first style error is found.
 
+  If COPYRIGHT-NOTICE is included, then the first line must match the
+  regular expression passed.
+
 EXAMPLES:
 
   (check-file #P\"path/to/file.lisp\") => (:success \"path/to/file.lisp\")
-  (check-file #P\"path/to/error.lisp\") => (:failure \"path/to/error.lisp\" \"File cannot end with empty line\" 20 0)"
+  (check-file #P\"path/to/error.lisp\") => (:failure \"path/to/error.lisp\" \"File cannot end with empty line\" 20 0)
+  (check-file #P\"path/to/error.lisp\" :copyright-notice \"; Copyright .* AGPL\") => (:failure ...)")
 
- (if (string= "package" (pathname-name file))
-  (set-state :normal)
-  (set-state :begin))
- (setf *line-no* 0)
- (setf *col-no* 0)
- (setf *form-stack* nil)
- (setf *form-ended-on-same-line* nil)
- (handler-case
-  (progn
-   (evaluate (slurp-file file))
-   (list :success file))
-  (check-failure (cf)
-   (list :failure file (check-failure-msg cf) (check-failure-line-no cf) (check-failure-col-no cf)))))
-
-(defun check-directory (dir)
- "CHECK-DIRECTORY DIR => RESULTS
+(defun check-directory (dir &key copyright-notice)
+ "CHECK-DIRECTORY DIR &key COPYRIGHT-NOTICE => RESULTS
 
   RESULTS: RESULT*
 
 ARGUMENTS AND VALUES:
 
   DIR: A directory to recurse into and check files
+  COPYRIGHT-NOTICE: A regex string
   RESULT: A result as returned by check-file
 
 DESCRIPTION:
@@ -140,10 +164,15 @@ DESCRIPTION:
   CHECK-DIRECTORY grabs all .lisp files in the tree under DIR, and loads
   checks them all.
 
+  If COPYRIGHT-NOTICE is included, then the first line must match the
+  regular expression passed.
+
   The results are then put together into a list which can be programatically
   evaluated.  As opposed to pretty-print-check-directory, this function doesn't
   clutter up your standard out."
- (mapcar #'check-file (directory (format nil "~A/**/*.lisp" dir))))
+ (mapcar
+  (lambda (file) (check-file file :copyright-notice copyright-notice))
+  (directory (format nil "~A/**/*.lisp" dir))))
 
 (defun any-failures (checks)
  (find :failure checks :key #'car))
@@ -158,12 +187,13 @@ DESCRIPTION:
   (with-open-file (str (second failure)) (loop :repeat (fourth failure) :do (read-line str)) (read-line str))
   (+ (fifth failure) 2)))
 
-(defun pretty-print-check-directory (dir)
- "PRETTY-PRINT-CHECK-DIRECTORY DIR => SUCCESS
+(defun pretty-print-check-directory (dir &key copyright-notice)
+ "PRETTY-PRINT-CHECK-DIRECTORY DIR &key COPYRIGHT-NOTICE => SUCCESS
 
 ARGUMENTS AND VALUES:
 
   DIR: A directory to recurse into and check files
+  COPYRIGHT-NOTICE: A regex string
   SUCCESS: T if there were no failures
 
 DESCRIPTION:
@@ -171,6 +201,9 @@ DESCRIPTION:
   PRETTY-PRINT-CHECK-DIRECTORY checks DIR for any errors, dumping them to output
   and returning a single flag.
 
+  If COPYRIGHT-NOTICE is included, then the first line must match the
+  regular expression passed.
+
   Unlike check-directory, PRETTY-PRINT-CHECK-DIRECTORY is built for continuous
   integration, dumping errors to standard out and returning a singular result.
 
@@ -178,7 +211,7 @@ EXAMPLES:
 
   (pretty-print-check-directory \"src\") => nil"
  (let
-  ((checks (check-directory dir)))
+  ((checks (check-directory dir :copyright-notice copyright-notice)))
   (format t "In ~A: Checked ~A files with ~A failures~%~%"
    dir (length checks) (length (remove :success checks :key #'car)))
   (format t "~{~A~%~}" (mapcar #'print-failure (remove :success checks :key #'car)))
@@ -212,6 +245,7 @@ EXAMPLES:
 (defevaluator :all "\\t" (constantly "Must not use tabs"))
 
 (defevaluator :begin "\\(in-package[^\\)]*\\)" (lambda () (set-state :normal)))
+(defevaluator :copyright-required "\\(in-package[^\\)]*\\)" (constantly "Must begin with specified copyright notice"))
 
 (defevaluator :beginning-of-line-with-separator :eof
  (lambda ()
@@ -220,6 +254,8 @@ EXAMPLES:
 
 (defevaluator :beginning-of-line-with-separator "\\n" (constantly "Must not have two empty lines in a row"))
 
+(defevaluator :copyright-required ".*" (constantly "Must begin with specified copyright notice"))
+
 (defevaluator :begin ".*" (constantly "Must begin with in-package form"))
 
 (defevaluator :all "\\( *in-package " (constantly "Only one in-package per file"))
@@ -227,13 +263,13 @@ EXAMPLES:
 (defevaluator :normal "\\n"
  (lambda ()
   (incf *line-no*)
-  (setf *col-no* -1)
+  (setf *col-no* :reset)
   (set-state :beginning-of-line)))
 
 (defevaluator :comment-with-separator "\\n"
  (lambda ()
   (incf *line-no*)
-  (setf *col-no* -1)
+  (setf *col-no* :reset)
   (set-state :beginning-of-line-with-comment-and-separator)
   nil))
 
@@ -247,7 +283,7 @@ EXAMPLES:
  (lambda ()
   (progn
    (incf *line-no*)
-   (setf *col-no* -1)
+   (setf *col-no* :reset)
    (set-state :beginning-of-line-with-separator))))
 
 (defevaluator :beginning-of-line-with-comment-and-separator " *"
@@ -260,7 +296,7 @@ EXAMPLES:
    "No whitespace only lines"
    (progn
     (incf *line-no*)
-    (setf *col-no* -1)
+    (setf *col-no* :reset)
     (set-state :beginning-of-line-with-separator)))))
 
 (defevaluator :beginning-of-symbols "\\)" (constantly "No hanging close parens"))
@@ -298,7 +334,7 @@ EXAMPLES:
 (defevaluator :in-string "\\n"
  (lambda ()
   (incf *line-no*)
-  (setf *col-no* -1)
+  (setf *col-no* :reset)
   nil))
 
 (defevaluator :in-string "." (constantly nil))