version.lisp - clic - Clic is an command line interactive client for gopher wri… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
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 s… | |
7 #:next-version | |
8 #:deprecated-function-condition #:deprecated-function-name ;; depreca… | |
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 vers… | |
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 … | |
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 N… | |
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 … | |
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 numb… | |
39 'parse-version version-string) | |
40 (return)) | |
41 (let* ((version-list | |
42 (mapcar #'parse-integer (split-string version-string :sep… | |
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… | |
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… | |
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 s… | |
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-functi… | |
71 (define-condition deprecated-function-warning (deprecated-function-con… | |
72 (define-condition deprecated-function-error (deprecated-function-condi… | |
73 (define-condition deprecated-function-should-be-deleted (deprecated-fu… | |
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 ":na… | |
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~^… | |
99 "~A: Using deprecated function ~S -- please updat… | |
100 ~@[~%The docstring for this function says:~%~A~%~]") | |
101 type name (when (symbolp name) (documentation name 'f… | |
102 | |
103 (defun notify-deprecated-function (status name) | |
104 (ecase status | |
105 ((nil) nil) | |
106 ((:style-warning) (style-warn 'deprecated-function-style-warning :… | |
107 ((:warning) (warn 'deprecated-function-warning :name name)) | |
108 ((:error) (cerror "USE FUNCTION ANYWAY" 'deprecated-function-error… | |
109 | |
110 (defun version-deprecation (version &key (style-warning nil) | |
111 (warning (next-version style-war… | |
112 (error (next-version warning)) | |
113 (delete (next-version error))) | |
114 "Given a VERSION string, and the starting versions for notifying the… | |
115 various levels of deprecation, return the current level of deprecation a… | |
116 that is the highest level that has a declared version older than the spe… | |
117 Each start version for a level of deprecation can be specified by a keyw… | |
118 if left unspecified, will be the NEXT-VERSION of the immediate lower lev… | |
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-warn… | |
124 | |
125 (defmacro with-deprecation ((level) &body definitions) | |
126 "Given a deprecation LEVEL (a form to be EVAL'ed at macro-expansion … | |
127 DEFUN and DEFMETHOD forms in DEFINITIONS to notify the programmer of the… | |
128 when it is compiled or called. | |
129 | |
130 Increasing levels (as result from evaluating LEVEL) are: NIL (not deprec… | |
131 :STYLE-WARNING (a style warning is issued when used), :WARNING (a full w… | |
132 :ERROR (a continuable error instead), and :DELETE (it's an error if the … | |
133 at that level). | |
134 | |
135 Forms other than DEFUN and DEFMETHOD are not instrumented, and you can p… | |
136 from instrumentation by enclosing it in a PROGN." | |
137 (let ((level (eval level))) | |
138 (check-type level (member nil :style-warning :warning :error :dele… | |
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 de… | |
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 n… | |
149 (multiple-value-bind (remaining-forms declaration… | |
150 (parse-body body :documentation t :whole whol… | |
151 `(progn | |
152 (defparameter ,notifiedp nil) | |
153 ;; tell some implementations to use the comp… | |
154 (declaim (inline ,name)) | |
155 (define-compiler-macro ,name (&whole form &r… | |
156 (declare (ignore args)) | |
157 (notify-deprecated-function ,level ',name) | |
158 form) | |
159 (,@head ,@(when doc-string (list doc-string)… | |
160 (unless ,notifiedp | |
161 (setf ,notifiedp t) | |
162 (notify-deprecated-function ,level… | |
163 ,@remaining-forms)))) | |
164 `(progn | |
165 (eval-when (:compile-toplevel :load-toplevel :ex… | |
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 fo… | |
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)))))))) |