make-helper.lisp 11.8 KB
Newer Older
1 2
(load (make-pathname :name "prelude" :type "lisp" :defaults *load-pathname*)
  :verbose nil :print nil)
3

4
(in-package :asdf)
Gary King's avatar
Gary King committed
5

6
(defvar *make-helper-home* *load-truename*)
7

8
;;; metatilities-base
Gary King's avatar
Gary King committed
9 10
;;; because sometimes copy and paste is just too easy

11
(eval-when (:compile-toplevel :load-toplevel :execute)
Gary King's avatar
Gary King committed
12
  (defmacro generate-time-part-function (part-name position)
13 14
    (let ((function-name (intern (strcat (symbol-name 'time) "-" (symbol-name part-name)))))
      `(eval-when (:compile-toplevel :load-toplevel :execute)
Gary King's avatar
Gary King committed
15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35
         (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))

Gary King's avatar
Gary King committed
36 37 38 39 40 41 42 43 44 45 46 47 48 49

(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)
50
  "Returns the day of the year [1 to 366] of the specified date [which must be \(CL\) universal time format.]"
Gary King's avatar
Gary King committed
51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71
  (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))
72
  (nth day-of-the-week
Gary King's avatar
Gary King committed
73
       (case format
74 75
         (:long (nth +longer-format-index+ +dow-output-list))
         (:short (nth +shorter-format-index+ +dow-output-list)))))
Gary King's avatar
Gary King committed
76 77 78 79 80

(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))
81
  (nth (1- month)
Gary King's avatar
Gary King committed
82
       (case format
83 84
         (:long (nth +longer-format-index+ +month-output-list+))
         (:short (nth +shorter-format-index+ +month-output-list+)))))
Gary King's avatar
Gary King committed
85

Gary King's avatar
Gary King committed
86 87 88 89 90 91 92 93 94 95
(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]
96
%e - Same as %d but does not print the leading 0 for days 1 through 9
Gary King's avatar
Gary King committed
97 98 99 100 101 102 103 104 105 106
     [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
107
%x - Date using the date representation for the locale, including
Gary King's avatar
Gary King committed
108
     the time zone [produces different results from strftime[]]
109
%X - Time using the time representation for the locale [produces
Gary King's avatar
Gary King committed
110 111 112
     different results from strftime[]]
%y - Year without century [00-99]
%Y - Year with century [such as 1990]
113
%Z - Time zone name [such as Pacific Daylight Time;
Gary King's avatar
Gary King committed
114 115 116 117 118 119
     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)))
120
    (format
Gary King's avatar
Gary King committed
121
     stream "~{~A~}"
122 123
     (loop for index = 0 then (1+ index)
        while (< index format-length) collect
124
          (let ((char (aref format index)))
125
            (cond
126 127
              ((char= #\% char)
               (setf char (aref format (incf index)))
128
               (cond
129 130
                 ;; %% - A '%' character
                 ((char= char #\%) #\%)
131

132 133
                 ;; %a - Abbreviated weekday name
                 ((char= char #\a) (day->string (time-day-of-week date) :short))
134

135 136
                 ;; %A - Full weekday name
                 ((char= char #\A) (day->string (time-day-of-week date) :long))
137

138 139
                 ;; %b - Abbreviated month name
                 ((char= char #\b) (month->string (time-month date) :short))
140

141 142
                 ;; %B - Full month name
                 ((char= char #\B) (month->string (time-month date) :long))
143

144 145
                 ;; %d - Day of the month as a decimal number [01-31]
                 ((char= char #\d) (format nil "~2,'0D" (time-date date)))
146 147

                 ;; %e - Same as %d but does not print the leading 0 for days 1 through 9
148 149
                 ;;      Unlike strftime, does not print a leading space
                 ((char= char #\e) (format nil "~D" (time-date date)))
150

151 152
                 ;; %H - Hour based on a 24-hour clock as a decimal number [00-23]
                 ((char= char #\H) (format nil "~2,'0D" (time-hour date)))
153

154 155
                 ;; %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))))
156

157 158
                 ;; %j - Day of the year as a decimal number [001-366]
                 ((char= char #\j) (format nil "~3,'0D" (day-of-year date)))
159

160 161
                 ;; %m - Month as a decimal number [01-12]
                 ((char= char #\m) (format nil "~2,'0D" (time-month date)))
162

163 164
                 ;; %M - Minute as a decimal number [00-59]
                 ((char= char #\M) (format nil "~2,'0D" (time-minute date)))
165

166 167
                 ;; %S - Second as a decimal number [00-59]
                 ((char= char #\S) (format nil "~2,'0D" (time-second date)))
168

169 170
                 ;; %w - Weekday as a decimal number [0-6], where Sunday is 0
                 ((char= char #\w) (format nil "~D" (time-day-of-week date)))
171

172
                 ;; %y - Year without century [00-99]
173
                 ((char= char #\y)
174 175
                  (let ((year-string (format nil "~,2A" (time-year date))))
                    (subseq year-string (- (length year-string) 2))))
176

177 178
                 ;; %Y - Year with century [such as 1990]
                 ((char= char #\Y) (format nil "~D" (time-year date)))
179

180 181 182
                 (t
                  (error "Ouch - unknown formatter '%~c" char))))
              (t char)))))))
Gary King's avatar
Gary King committed
183 184 185

;;; metatilites-base

186 187 188

(defun extract-summary (pathname stream)
  (with-open-file (in pathname :direction :input
189
                      :if-does-not-exist :error)
190 191
    (let ((start nil))
      (loop for line = (read-line in nil :eof)
192 193 194 195 196
         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))))))
197 198 199 200 201 202 203

(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))
204
  (when style-sheet
205 206 207
    (unless (search ".css" style-sheet)
      (setf style-sheet (concatenate 'string style-sheet ".css")))
    (format stream "~&<link type='text/css' href='~a' rel='stylesheet' />"
208
            style-sheet))
209 210 211 212 213
  (format stream "~&</head>~&<body>"))

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


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

228
    (dolist (pathname (directory
229 230
                       (merge-pathnames (make-pathname :name :wild :type "text")
                                        input-directory)))
231 232 233 234 235 236 237 238 239 240
      (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
241
                      :if-does-not-exist :error)
242
    (with-open-file (out output-pathname
243 244 245
                         :direction :output
                         :if-does-not-exist :create
                         :if-exists :error)
246
      (let* ((state nil)
247 248 249 250
             (flag ";;; -- LICENSE")
             (flag-length (length flag)))
        (loop for line = (read-line in nil :eof)
           until (eq line :eof) do
251
             (when (and (> (length line) flag-length)
252
                        (string-equal flag (subseq line 0 flag-length)))
253
               (if (eq state :running)
254 255 256 257 258 259
                   (return)
                   (setf state :starting)))
             (when (eq state :running)
               (format out "~&~a~%" (subseq line (min (length line) 4))))
             (when (eq state :starting)
               (setf state :running)))))))
260 261

(defun rewrite-license ()
262
  (let* ((*default-pathname-defaults*
263 264 265
          (make-pathname :name nil :type nil :defaults *make-helper-home*))
         (output (merge-pathnames (make-pathname :name "LICENSE"
          :directory '(:relative :up)))))
266 267
    (when (probe-file output)
      (delete-file output))
268 269
    (extract-license
     (merge-pathnames (make-pathname :name "header" :type "lisp"
270
      :directory '(:relative :up)))
271 272
     output)))

273
(defun write-test-web-pages ()
274
  (let* ((*default-pathname-defaults*
275 276 277 278
          (make-pathname :name nil :type nil :defaults *make-helper-home*))
         (source (merge-pathnames
                  (make-pathname
                   :directory '(:relative :up "test" "results"))))
279
         (output (merge-pathnames (make-pathname
280 281 282
                                   :directory '(:relative :up "website" "output")
                                   :name "test-results"
                                   :type "html"))))
283 284 285
    (print (list source output))
    (build-web-page source output :if-exists :supersede)))