Skip to content
Snippets Groups Projects
Forked from asdf / asdf
3800 commits behind the upstream repository.
make-helper.lisp 11.11 KiB
(in-package #:common-lisp-user)
  
#+(or)
(build-web-page "/repository/git/asdf/test/results/" "/tmp/x.html" :if-exists :supersede)

;;; metatilities-base 
;;; because sometimes copy and paste is just too easy

(eval-when (:compile-toplevel :load-toplevel :execute) 
  (defmacro generate-time-part-function (part-name position)
    (let ((function-name (intern (concatenate 'string 
					      (symbol-name 'time) "-" (symbol-name part-name)))))
      `(eval-when (:compile-toplevel :load-toplevel :execute) 
         (export ',function-name)
         (defun ,function-name
                (&optional (universal-time (get-universal-time))
                           (time-zone nil))
           ,(format nil "Returns the ~(~A~) part of the given time." part-name)
           (nth-value ,position (apply #'decode-universal-time universal-time time-zone))))))

  (generate-time-part-function second 0)
  (generate-time-part-function minute 1)
  (generate-time-part-function hour 2)
  (generate-time-part-function date 3)
  (generate-time-part-function month 4)
  (generate-time-part-function year 5)
  (generate-time-part-function day-of-week 6)
  (generate-time-part-function daylight-savings-time-p 7))

;;; format-date

(defparameter +days-per-month+
  '(31 28 31 30 31 30 31 31 30 31 30 31))


(defun days-in-month (month &optional leap-year?)
  "Returns the number of days in the specified month. The month should be
between 1 and 12."
  (+ (nth (1- month) +days-per-month+) (if (and (= month 2) leap-year?) 1 0)))

(defun leap-year-p (year)
  "Returns t if the specified year is a leap year. I.e. if the year
is divisible by four but not by 100 or if it is divisible by 400."
  (or (and (= (mod year 4) 0)               ; logand is faster but less perspicuous
           (not (= (mod year 100) 0)))
      (= (mod year 400) 0)))

(defun day-of-year (date)
  "Returns the day of the year [1 to 366] of the specified date [which must be \(CL\) universal time format.]" 
  (let ((leap-year? (leap-year-p (time-year date))))
    (+ (loop for month from 1 to (1- (time-month date)) sum
             (days-in-month month leap-year?))
       (time-date date))))

(defconstant +longer-format-index+ 0)
(defconstant +shorter-format-index+ 1)

(defparameter +month-output-list+
  '(("January" "February" "March" "April" "May" "June" "July" "August" "September"
     "October" "November" "December")
    ("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")))

(defparameter +dow-output-list
  '(("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday")
    ("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun")))

(defun day->string (day-of-the-week &optional (format :long))
  "Returns the name of `day-of-the-week`. The parameter should be a number between 0 and 6 where 0 represents Sunday and 6 repressents Saturday. The optional format argument can be either :long or :short. In the latter case, the return string will be of length three; in the former it will be the complete name of the appropriate day."
  (check-type day-of-the-week (mod 7))
  (check-type format (member :long :short))
  (nth day-of-the-week 
       (case format
	 (:long (nth +longer-format-index+ +dow-output-list))
	 (:short (nth +shorter-format-index+ +dow-output-list)))))

(defun month->string (month &optional (format :long))
  "Returns the name \(in English\) of the month. Format can be :long or :short."
  (check-type month (integer 1 12))
  (check-type format (member :long :short))
  (nth (1- month) 
       (case format
	 (:long (nth +longer-format-index+ +month-output-list+))
	 (:short (nth +shorter-format-index+ +month-output-list+)))))

(defun format-date (format date &optional stream time-zone)
  "Formats universal dates using the same format specifiers as NSDateFormatter. The format is:

%% - A '%' character
%a - Abbreviated weekday name
%A - Full weekday name
%b - Abbreviated month name
%B - Full month name
%c - Shorthand for \"%X %x\", the locale format for date and time
%d - Day of the month as a decimal number [01-31]
%e - Same as %d but does not print the leading 0 for days 1 through 9 
     [unlike strftime[], does not print a leading space]
%F - Milliseconds as a decimal number [000-999]
%H - Hour based on a 24-hour clock as a decimal number [00-23]
%I - Hour based on a 12-hour clock as a decimal number [01-12]
%j - Day of the year as a decimal number [001-366]
%m - Month as a decimal number [01-12]
%M - Minute as a decimal number [00-59]
%p - AM/PM designation for the locale
%S - Second as a decimal number [00-59]
%w - Weekday as a decimal number [0-6], where Sunday is 0
%x - Date using the date representation for the locale, including 
     the time zone [produces different results from strftime[]]
%X - Time using the time representation for the locale [produces 
     different results from strftime[]]
%y - Year without century [00-99]
%Y - Year with century [such as 1990]
%Z - Time zone name [such as Pacific Daylight Time; 
     produces different results from strftime[]]
%z - Time zone offset in hours and minutes from GMT [HHMM]

None of %c, %F, %p, %x, %X, %Z, %z are implemented."
  (declare (ignore time-zone))
  (let ((format-length (length format)))
    (format 
     stream "~{~A~}"
     (loop for index = 0 then (1+ index) 
	while (< index format-length) collect 
	  (let ((char (aref format index)))
	    (cond 
	      ((char= #\% char)
	       (setf char (aref format (incf index)))
	       (cond 
		 ;; %% - A '%' character
		 ((char= char #\%) #\%)
                            
		 ;; %a - Abbreviated weekday name
		 ((char= char #\a) (day->string (time-day-of-week date) :short))
                            
		 ;; %A - Full weekday name
		 ((char= char #\A) (day->string (time-day-of-week date) :long))
                            
		 ;; %b - Abbreviated month name
		 ((char= char #\b) (month->string (time-month date) :short))
                            
		 ;; %B - Full month name
		 ((char= char #\B) (month->string (time-month date) :long))
                            
		 ;; %d - Day of the month as a decimal number [01-31]
		 ((char= char #\d) (format nil "~2,'0D" (time-date date)))
                            
		 ;; %e - Same as %d but does not print the leading 0 for days 1 through 9 
		 ;;      Unlike strftime, does not print a leading space
		 ((char= char #\e) (format nil "~D" (time-date date)))
                            
		 ;; %H - Hour based on a 24-hour clock as a decimal number [00-23]
		 ((char= char #\H) (format nil "~2,'0D" (time-hour date)))
                            
		 ;; %I - Hour based on a 12-hour clock as a decimal number [01-12]
		 ((char= char #\I) (format nil "~2,'0D" (1+ (mod (time-hour date) 12))))
                            
		 ;; %j - Day of the year as a decimal number [001-366]
		 ((char= char #\j) (format nil "~3,'0D" (day-of-year date)))
                            
		 ;; %m - Month as a decimal number [01-12]
		 ((char= char #\m) (format nil "~2,'0D" (time-month date)))
                            
		 ;; %M - Minute as a decimal number [00-59]
		 ((char= char #\M) (format nil "~2,'0D" (time-minute date)))
                            
		 ;; %S - Second as a decimal number [00-59]
		 ((char= char #\S) (format nil "~2,'0D" (time-second date)))
                            
		 ;; %w - Weekday as a decimal number [0-6], where Sunday is 0
		 ((char= char #\w) (format nil "~D" (time-day-of-week date)))
                            
		 ;; %y - Year without century [00-99]
		 ((char= char #\y) 
		  (let ((year-string (format nil "~,2A" (time-year date))))
		    (subseq year-string (- (length year-string) 2))))
                            
		 ;; %Y - Year with century [such as 1990]
		 ((char= char #\Y) (format nil "~D" (time-year date)))
                                                        
		 (t
		  (error "Ouch - unknown formatter '%~c" char))))
	      (t char)))))))

;;; metatilites-base


(defun extract-summary (pathname stream)
  (with-open-file (in pathname :direction :input
		      :if-does-not-exist :error)
    (let ((start nil))
      (loop for line = (read-line in nil :eof)
	 until (eq line :eof) do
	 (when (and (> (length line) 5) (string-equal "-#---" (subseq line 0 5)))
	   (setf start t))
	 (when start
	   (format stream "~&~a~%" line))))))

(defun html-header (stream title style-sheet)
  (format stream "~&<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\"
        \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">")
  (format stream "~&<html>~&<head>")
  (when title
    (format stream "~&<title>~a</title>" title))
  (when style-sheet 
    (unless (search ".css" style-sheet)
      (setf style-sheet (concatenate 'string style-sheet ".css")))
    (format stream "~&<link type='text/css' href='~a' rel='stylesheet' />"
	    style-sheet))
  (format stream "~&</head>~&<body>"))

(defun html-footer (stream)
  (format stream "<div id=\"footer\">")
  (format stream "~&generated on ~a"
	  (format-date "%B %d, %Y" (get-universal-time)))
  (format stream "</div>")
  (format stream "~&</body></html>"))


(defun build-web-page (input-directory output-file &key (if-exists :error)
		       (title "ASDF test report") (style-sheet "styles.css"))
  (with-open-file (stream output-file
			  :direction :output
			  :if-exists if-exists
			  :if-does-not-exist :create)
    (html-header stream title style-sheet)
    (format stream "~&~%<h1>ASDF Test results</h1>~%")

    (dolist (pathname (directory 
		       (merge-pathnames (make-pathname :name :wild :type "text")
					input-directory)))
      (print pathname)
      (format stream "~&~%<h2>~a</h2>~%" (pathname-name pathname))
      (format stream "~&<pre>~%")
      (extract-summary pathname stream)
      (format stream "~&</pre>~%"))
    (html-footer stream)
    ))

(defun extract-license (input-pathname output-pathname)
  (with-open-file (in input-pathname :direction :input
		      :if-does-not-exist :error)
    (with-open-file (out output-pathname
			 :direction :output
			 :if-does-not-exist :create
			 :if-exists :error)
      (let* ((state nil)
	     (flag ";;; -- LICENSE")
	     (flag-length (length flag)))
	(loop for line = (read-line in nil :eof)
	   until (eq line :eof) do
	     (when (and (> (length line) flag-length) 
			(string-equal flag (subseq line 0 flag-length)))
	       (if (eq state :running) 
		   (return)
		   (setf state :starting)))
	     (when (eq state :running)
	       (format out "~&~a~%" (subseq line (min (length line) 4))))
	     (when (eq state :starting)
	       (setf state :running)))))))

(defun rewrite-license ()
  (let* ((*default-pathname-defaults* 
	  (make-pathname :name nil :type nil :defaults *load-truename*))
	 (output (merge-pathnames (make-pathname :name "LICENSE"))))
    (when (probe-file output)
      (delete-file output))
    (extract-license 
     (merge-pathnames (make-pathname :name "asdf" :type "lisp"))
     output)))

(defun write-test-web-pages ()
  (let* ((*default-pathname-defaults* 
	  (make-pathname :name nil :type nil :defaults *load-truename*))
	 (source (merge-pathnames
		  (make-pathname
		   :directory '(:relative "results"))))
	 (output (merge-pathnames (make-pathname 
				   :directory '(:relative "website" "output")
				   :name "test-results"
				   :type "html"))))
    (print (list source output))
    (build-web-page source output :if-exists :supersede)))