tools-for-build/pending-deprecations.lisp

   1 ;;;; Determine how long things been in their current deprecation
   2 ;;;; states and whether it is time to move them to the respective
   3 ;;;; successor states.
   4 ;;;;
   5 ;;;; Use like this
   6 ;;;;
   7 ;;;;   ./run-sbcl.sh --noinform --no-userinit               \
   8 ;;;;     --script tools-for-build/pending-deprecations.lisp \
   9 ;;;;     [-- -a]
  10 ;;;;
  11 ;;;; When invoked without additional commandline arguments, the output
  12 ;;;; only contains actionable things, i.e. deprecations that should be
  13 ;;;; moved to the respective successor states. The optional -a, --all
  14 ;;;; commandline option causes information to be printed for all
  15 ;;;; deprecated things, not just actionable ones.
  16 ;;;;
  17 ;;;; The output format for individual items is as follows:
  18 ;;;;
  19 ;;;;   Namespace  Name of deprecated thing   Version/time of deprecation    successor state
  20 ;;;;   v          v                          v                              v
  21 ;;;; - FUNCTION SB-THREAD::SPINLOCK-NAME     1.0.53.11/2011-11-06 EARLY  -> LATE   2012-02-04
  22 ;;;;   SYS:SRC;CODE;THREAD.LISP                                   ^                ^
  23 ;;;;   ^                                                          current state    when to move
  24 ;;;;   Source file
  25
  26
  27 ;;;; This software is part of the SBCL system. See the README file for
  28 ;;;; more information.
  29 ;;;;
  30 ;;;; This software is derived from the CMU CL system, which was
  31 ;;;; written at Carnegie Mellon University and released into the
  32 ;;;; public domain. The software is in the public domain and is
  33 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  34 ;;;; files for more information.
  35
  36 (cl:require 'sb-introspect)
  37
  38 (cl:in-package #:cl-user)
  39
  40 ;;; Git utilities
  41
  42 (defun split (separator string)
  43   (loop :for char :across string
  44      :with component = (make-string-output-stream)
  45      :if (char= char separator)
  46      :collect (prog1
  47                   (get-output-stream-string component)
  48                 (setf component (make-string-output-stream)))
  49      :into components
  50      :else :do (write-char char component)
  51      :finally (return (append
  52                        components
  53                        (list (get-output-stream-string component))))))
  54
  55 (defun version-tag (version)
  56   ;; Try to handle old and new tagging schemes.
  57   (let* ((without-fourth (if (= 3 (count #\. version))
  58                              (subseq version 0 (position #\. version
  59                                                          :from-end t))
  60                              version)))
  61     (destructuring-bind (a b c)
  62         (mapcar #'parse-integer (split #\. without-fourth))
  63       (if (or (= a 0)
  64               (and (= a 1) (= b 0) (< c 50)))
  65           (format nil "sbcl_~A_~A_~A" a b c)
  66           (format nil "sbcl-~A" without-fourth)))))
  67
  68 (defun tag-time (tag)
  69   (let* ((range     (format nil "~A^..~:*~A" tag))
  70          (directory (make-pathname
  71                      :directory (append
  72                                  (pathname-directory *load-pathname*)
  73                                  '(:up))))
  74          (process   (run-program "git" `("--no-pager" "log" "--pretty=format:%at" ,range)
  75                                  :search    t
  76                                  :directory directory
  77                                  :output    :stream
  78                                  :error     :stream)))
  79     (unless (zerop (process-exit-code process))
  80       (warn "~@<Failed to run git log for range ~S:~@:_~A.~@:>"
  81             range (read-line (process-error process))))
  82     (parse-integer (read-line (process-output process)))))
  83
  84 (defun seconds-since-release (version)
  85   (let* ((tag      (version-tag version))
  86          (tag-time (tag-time tag))
  87          (now      (nth-value 1 (sb-unix:unix-gettimeofday))))
  88     (- now tag-time)))
  89
  90 (defun seconds-since-earliest-tagged-release ()
  91   (seconds-since-release ""))
  92
  93 ;;; Time utilities
  94
  95 (defun print-universal-time (stream time &optional colonp atp)
  96   (declare (ignore colonp atp))
  97   (multiple-value-bind (second minute hour date month year)
  98       (decode-universal-time time)
  99     (declare (ignore second minute hour))
 100     (format stream "~4,'0D-~2,'0D-~2,'0D" year month date)))
 101
 102 ;;; Deprecation utilities
 103
 104 (defun next-state (state)
 105   (ecase state
 106     (:early :late)
 107     (:late  :final)
 108     (:final :remove)))
 109
 110 (defparameter *seconds-in-deprecation-state*
 111   `((:early . ,(* 90 24 3600))
 112     (:late  . ,(* 90 24 3600))
 113     (:final . ,(* 90 24 3600))))
 114
 115 (defun seconds-to-state (goal)
 116   (loop :for (state . time) :in *seconds-in-deprecation-state*
 117      :until (eq state goal)
 118      :sum time))
 119
 120 (defun process-deprecated-thing (namespace name state since
 121                                  &key force)
 122   (let* ((version      (second since))
 123          (now          (get-universal-time))
 124          (age          (ignore-errors (seconds-since-release version)))
 125          (next         (next-state state))
 126          (time-to-next (seconds-to-state next))
 127          (next-time    (when age (+ (- now age) time-to-next))))
 128     (when (or force (and next-time (>= now next-time)))
 129       (let ((source (sb-introspect:find-definition-sources-by-name
 130                      name (ecase namespace
 131                             (function :function)
 132                             (variable :variable)
 133                             (type     :type)))))
 134         (format t "- ~8A ~/sb-impl::print-symbol-with-prefix/~56T~
 135                      ~9@A/~:[??????????~:;~:*~/cl-user::print-universal-time/~] ~
 136                      ~6A ~
 137                      -> ~6A ~:[??????????~:;~:*~/cl-user::print-universal-time/~]~%~
 138                    ~2@T~{~A~^, ~}~2%"
 139                 namespace name
 140                 version (when age (- now age))
 141                 state
 142                 next (when next-time next-time)
 143                 (mapcar #'sb-introspect:definition-source-pathname source))))))
 144
 145 (defun print-deprecation-info (&key (only-actionable t))
 146   (do-all-symbols (name1)
 147     (loop :for (namespace . name) :in (list (cons 'function name1)
 148                                             (cons 'function `(setf ,name1))
 149                                             (cons 'variable name1)
 150                                             (cons 'type     name1)) :do
 151        (multiple-value-bind (state since)
 152            (sb-int:deprecated-thing-p namespace name)
 153          (when state
 154            (process-deprecated-thing namespace name state since
 155                                      :force (not only-actionable)))))))
 156
 157 (flet ((optionp (option)
 158          (find option *posix-argv* :test 'string=)))
 159   (let ((allp (or (optionp "-a") (optionp "--all"))))
 160     (print-deprecation-info :only-actionable allp)))