version.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) README
(DIR) LICENSE
---
version.lisp (9383B)
---
1 (uiop/package:define-package :uiop/version
2 (:recycle :uiop/version :uiop/utility :asdf)
3 (:use :uiop/common-lisp :uiop/package :uiop/utility)
4 (:export
5 #:*uiop-version*
6 #:parse-version #:unparse-version #:version< #:version<= ;; version support, moved from uiop/utility
7 #:next-version
8 #:deprecated-function-condition #:deprecated-function-name ;; deprecation control
9 #:deprecated-function-style-warning #:deprecated-function-warning
10 #:deprecated-function-error #:deprecated-function-should-be-deleted
11 #:version-deprecation #:with-deprecation))
12 (in-package :uiop/version)
13
14 (with-upgradability ()
15 (defparameter *uiop-version* "3.3.4")
16
17 (defun unparse-version (version-list)
18 "From a parsed version (a list of natural numbers), compute the version string"
19 (format nil "~{~D~^.~}" version-list))
20
21 (defun parse-version (version-string &optional on-error)
22 "Parse a VERSION-STRING as a series of natural numbers separated by dots.
23 Return a (non-null) list of integers if the string is valid;
24 otherwise return NIL.
25
26 When invalid, ON-ERROR is called as per CALL-FUNCTION before to return NIL,
27 with format arguments explaining why the version is invalid.
28 ON-ERROR is also called if the version is not canonical
29 in that it doesn't print back to itself, but the list is returned anyway."
30 (block nil
31 (unless (stringp version-string)
32 (call-function on-error "~S: ~S is not a string" 'parse-version version-string)
33 (return))
34 (unless (loop :for prev = nil :then c :for c :across version-string
35 :always (or (digit-char-p c)
36 (and (eql c #\.) prev (not (eql prev #\.))))
37 :finally (return (and c (digit-char-p c))))
38 (call-function on-error "~S: ~S doesn't follow asdf version numbering convention"
39 'parse-version version-string)
40 (return))
41 (let* ((version-list
42 (mapcar #'parse-integer (split-string version-string :separator ".")))
43 (normalized-version (unparse-version version-list)))
44 (unless (equal version-string normalized-version)
45 (call-function on-error "~S: ~S contains leading zeros" 'parse-version version-string))
46 version-list)))
47
48 (defun next-version (version)
49 "When VERSION is not nil, it is a string, then parse it as a version, compute the next version
50 and return it as a string."
51 (when version
52 (let ((version-list (parse-version version)))
53 (incf (car (last version-list)))
54 (unparse-version version-list))))
55
56 (defun version< (version1 version2)
57 "Given two version strings, return T if the second is strictly newer"
58 (let ((v1 (parse-version version1 nil))
59 (v2 (parse-version version2 nil)))
60 (lexicographic< '< v1 v2)))
61
62 (defun version<= (version1 version2)
63 "Given two version strings, return T if the second is newer or the same"
64 (not (version< version2 version1))))
65
66
67 (with-upgradability ()
68 (define-condition deprecated-function-condition (condition)
69 ((name :initarg :name :reader deprecated-function-name)))
70 (define-condition deprecated-function-style-warning (deprecated-function-condition style-warning) ())
71 (define-condition deprecated-function-warning (deprecated-function-condition warning) ())
72 (define-condition deprecated-function-error (deprecated-function-condition error) ())
73 (define-condition deprecated-function-should-be-deleted (deprecated-function-condition error) ())
74
75 (defun deprecated-function-condition-kind (type)
76 (ecase type
77 ((deprecated-function-style-warning) :style-warning)
78 ((deprecated-function-warning) :warning)
79 ((deprecated-function-error) :error)
80 ((deprecated-function-should-be-deleted) :delete)))
81
82 (defmethod print-object ((c deprecated-function-condition) stream)
83 (let ((name (deprecated-function-name c)))
84 (cond
85 (*print-readably*
86 (let ((fmt "#.(make-condition '~S :name ~S)")
87 (args (list (type-of c) name)))
88 (if *read-eval*
89 (apply 'format stream fmt args)
90 (error "Can't print ~?" fmt args))))
91 (*print-escape*
92 (print-unreadable-object (c stream :type t) (format stream ":name ~S" name)))
93 (t
94 (let ((*package* (find-package :cl))
95 (type (type-of c)))
96 (format stream
97 (if (eq type 'deprecated-function-should-be-deleted)
98 "~A: Still defining deprecated function~:P ~{~S~^ ~} that promised to delete"
99 "~A: Using deprecated function ~S -- please update your code to use a newer API.~
100 ~@[~%The docstring for this function says:~%~A~%~]")
101 type name (when (symbolp name) (documentation name 'function))))))))
102
103 (defun notify-deprecated-function (status name)
104 (ecase status
105 ((nil) nil)
106 ((:style-warning) (style-warn 'deprecated-function-style-warning :name name))
107 ((:warning) (warn 'deprecated-function-warning :name name))
108 ((:error) (cerror "USE FUNCTION ANYWAY" 'deprecated-function-error :name name))))
109
110 (defun version-deprecation (version &key (style-warning nil)
111 (warning (next-version style-warning))
112 (error (next-version warning))
113 (delete (next-version error)))
114 "Given a VERSION string, and the starting versions for notifying the programmer of
115 various levels of deprecation, return the current level of deprecation as per WITH-DEPRECATION
116 that is the highest level that has a declared version older than the specified version.
117 Each start version for a level of deprecation can be specified by a keyword argument, or
118 if left unspecified, will be the NEXT-VERSION of the immediate lower level of deprecation."
119 (cond
120 ((and delete (version<= delete version)) :delete)
121 ((and error (version<= error version)) :error)
122 ((and warning (version<= warning version)) :warning)
123 ((and style-warning (version<= style-warning version)) :style-warning)))
124
125 (defmacro with-deprecation ((level) &body definitions)
126 "Given a deprecation LEVEL (a form to be EVAL'ed at macro-expansion time), instrument the
127 DEFUN and DEFMETHOD forms in DEFINITIONS to notify the programmer of the deprecation of the function
128 when it is compiled or called.
129
130 Increasing levels (as result from evaluating LEVEL) are: NIL (not deprecated yet),
131 :STYLE-WARNING (a style warning is issued when used), :WARNING (a full warning is issued when used),
132 :ERROR (a continuable error instead), and :DELETE (it's an error if the code is still there while
133 at that level).
134
135 Forms other than DEFUN and DEFMETHOD are not instrumented, and you can protect a DEFUN or DEFMETHOD
136 from instrumentation by enclosing it in a PROGN."
137 (let ((level (eval level)))
138 (check-type level (member nil :style-warning :warning :error :delete))
139 (when (eq level :delete)
140 (error 'deprecated-function-should-be-deleted :name
141 (mapcar 'second
142 (remove-if-not #'(lambda (x) (member x '(defun defmethod)))
143 definitions :key 'first))))
144 (labels ((instrument (name head body whole)
145 (if level
146 (let ((notifiedp
147 (intern (format nil "*~A-~A-~A-~A*"
148 :deprecated-function level name :notified-p))))
149 (multiple-value-bind (remaining-forms declarations doc-string)
150 (parse-body body :documentation t :whole whole)
151 `(progn
152 (defparameter ,notifiedp nil)
153 ;; tell some implementations to use the compiler-macro
154 (declaim (inline ,name))
155 (define-compiler-macro ,name (&whole form &rest args)
156 (declare (ignore args))
157 (notify-deprecated-function ,level ',name)
158 form)
159 (,@head ,@(when doc-string (list doc-string)) ,@declarations
160 (unless ,notifiedp
161 (setf ,notifiedp t)
162 (notify-deprecated-function ,level ',name))
163 ,@remaining-forms))))
164 `(progn
165 (eval-when (:compile-toplevel :load-toplevel :execute)
166 (setf (compiler-macro-function ',name) nil))
167 (declaim (notinline ,name))
168 (,@head ,@body)))))
169 `(progn
170 ,@(loop :for form :in definitions :collect
171 (cond
172 ((and (consp form) (eq (car form) 'defun))
173 (instrument (second form) (subseq form 0 3) (subseq form 3) form))
174 ((and (consp form) (eq (car form) 'defmethod))
175 (let ((body-start (if (listp (third form)) 3 4)))
176 (instrument (second form)
177 (subseq form 0 body-start)
178 (subseq form body-start)
179 form)))
180 (t
181 form))))))))