1 | ;;; product.el --- Functions for product version information. |
---|
2 | |
---|
3 | ;; Copyright (C) 1999,2000 Free Software Foundation, Inc. |
---|
4 | |
---|
5 | ;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp> |
---|
6 | ;; Keiichi Suzuki <keiichi@nanap.org> |
---|
7 | ;; Keywords: compatibility, User-Agent |
---|
8 | |
---|
9 | ;; This file is part of APEL (A Portable Emacs Library). |
---|
10 | |
---|
11 | ;; This program is free software; you can redistribute it and/or |
---|
12 | ;; modify it under the terms of the GNU General Public License as |
---|
13 | ;; published by the Free Software Foundation; either version 2, or (at |
---|
14 | ;; your option) any later version. |
---|
15 | |
---|
16 | ;; This program is distributed in the hope that it will be useful, but |
---|
17 | ;; WITHOUT ANY WARRANTY; without even the implied warranty of |
---|
18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
---|
19 | ;; General Public License for more details. |
---|
20 | |
---|
21 | ;; You should have received a copy of the GNU General Public License |
---|
22 | ;; along with this program; see the file COPYING. If not, write to |
---|
23 | ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, |
---|
24 | ;; Boston, MA 02111-1307, USA. |
---|
25 | |
---|
26 | ;;; Commentary: |
---|
27 | |
---|
28 | ;; This module defines some utility functions for product information, |
---|
29 | ;; used for User-Agent header field. |
---|
30 | ;; |
---|
31 | ;; User-Agent header field first appeared in HTTP [RFC 1945, RFC 2616] |
---|
32 | ;; and adopted to News Article Format draft [USEFOR]. |
---|
33 | ;; |
---|
34 | ;; [RFC 1945] Hypertext Transfer Protocol -- HTTP/1.0. |
---|
35 | ;; T. Berners-Lee, R. Fielding & H. Frystyk. May 1996. |
---|
36 | ;; |
---|
37 | ;; [RFC 2616] Hypertext Transfer Protocol -- HTTP/1.1. |
---|
38 | ;; R. Fielding, J. Gettys, J. Mogul, H. Frystyk, L. Masinter, P. Leach, |
---|
39 | ;; T. Berners-Lee. June 1999. |
---|
40 | ;; |
---|
41 | ;; [USEFOR] News Article Format, <draft-ietf-usefor-article-02.txt>. |
---|
42 | ;; USEFOR Working Group. March 1999. |
---|
43 | |
---|
44 | ;;; Code: |
---|
45 | |
---|
46 | (defvar product-obarray (make-vector 13 0)) |
---|
47 | |
---|
48 | (defvar product-ignore-checkers nil) |
---|
49 | |
---|
50 | (defun product-define (name &optional family version code-name) |
---|
51 | "Define a product as a set of NAME, FAMILY, VERSION, and CODE-NAME. |
---|
52 | NAME is a string. Optional 2nd argument FAMILY is a string of |
---|
53 | family product name. Optional 3rd argument VERSION is a list of |
---|
54 | numbers. Optional 4th argument CODE-NAME is a string." |
---|
55 | (and family |
---|
56 | (product-add-to-family family name)) |
---|
57 | (set (intern name product-obarray) |
---|
58 | (vector name family version code-name nil nil nil nil))) |
---|
59 | |
---|
60 | (defun product-name (product) |
---|
61 | "Return the name of PRODUCT, a string." |
---|
62 | (aref product 0)) |
---|
63 | (defun product-family (product) |
---|
64 | "Return the family name of PRODUCT, a string." |
---|
65 | (aref product 1)) |
---|
66 | (defun product-version (product) |
---|
67 | "Return the version of PRODUCT, a list of numbers." |
---|
68 | (aref product 2)) |
---|
69 | (defun product-code-name (product) |
---|
70 | "Return the code-name of PRODUCT, a string." |
---|
71 | (aref product 3)) |
---|
72 | (defun product-checkers (product) |
---|
73 | "Return the checkers of PRODUCT, a list of functions." |
---|
74 | (aref product 4)) |
---|
75 | (defun product-family-products (product) |
---|
76 | "Return the family products of PRODUCT, a list of strings." |
---|
77 | (aref product 5)) |
---|
78 | (defun product-features (product) |
---|
79 | "Return the features of PRODUCT, a list of feature." |
---|
80 | (aref product 6)) |
---|
81 | (defun product-version-string (product) |
---|
82 | "Return the version string of PRODUCT, a string." |
---|
83 | (aref product 7)) |
---|
84 | |
---|
85 | (defun product-set-name (product name) |
---|
86 | "Set name of PRODUCT to NAME." |
---|
87 | (aset product 0 name)) |
---|
88 | (defun product-set-family (product family) |
---|
89 | "Set family name of PRODUCT to FAMILY." |
---|
90 | (aset product 1 family)) |
---|
91 | (defun product-set-version (product version) |
---|
92 | "Set version of PRODUCT to VERSION." |
---|
93 | (aset product 2 version)) |
---|
94 | ;; Some people want to translate code-name. |
---|
95 | (defun product-set-code-name (product code-name) |
---|
96 | "Set code-name of PRODUCT to CODE-NAME." |
---|
97 | (aset product 3 code-name)) |
---|
98 | (defun product-set-checkers (product checkers) |
---|
99 | "Set ckecker functions of PRODUCT to CHECKERS." |
---|
100 | (aset product 4 checkers)) |
---|
101 | (defun product-set-family-products (product products) |
---|
102 | "Set family products of PRODUCT to PRODUCTS." |
---|
103 | (aset product 5 products)) |
---|
104 | (defun product-set-features (product features) |
---|
105 | "Set features of PRODUCT to FEATURES." |
---|
106 | (aset product 6 features)) |
---|
107 | (defun product-set-version-string (product version-string) |
---|
108 | "Set version string of PRODUCT to VERSION-STRING." |
---|
109 | (aset product 7 version-string)) |
---|
110 | |
---|
111 | (defun product-add-to-family (family product-name) |
---|
112 | "Add a product to a family. |
---|
113 | FAMILY is a product structure which returned by `product-define'. |
---|
114 | PRODUCT-NAME is a string of the product's name ." |
---|
115 | (let ((family-product (product-find-by-name family))) |
---|
116 | (if family-product |
---|
117 | (let ((dest (product-family-products family-product))) |
---|
118 | (or (member product-name dest) |
---|
119 | (product-set-family-products |
---|
120 | family-product (cons product-name dest)))) |
---|
121 | (error "Family product `%s' is not defined" family)))) |
---|
122 | |
---|
123 | (defun product-remove-from-family (family product-name) |
---|
124 | "Remove a product from a family. |
---|
125 | FAMILY is a product string which returned by `product-define'. |
---|
126 | PRODUCT-NAME is a string of the product's name." |
---|
127 | (let ((family-product (product-find-by-name family))) |
---|
128 | (if family-product |
---|
129 | (product-set-family-products |
---|
130 | family-product |
---|
131 | (delete product-name (product-family-products family-product))) |
---|
132 | (error "Family product `%s' is not defined" family)))) |
---|
133 | |
---|
134 | (defun product-add-checkers (product &rest checkers) |
---|
135 | "Add checker function(s) to a product. |
---|
136 | PRODUCT is a product structure which returned by `product-define'. |
---|
137 | The rest arguments CHECKERS should be functions. These functions |
---|
138 | are regist to the product's checkers list, and will be called by |
---|
139 | `product-run-checkers'. |
---|
140 | If a checker is `ignore' will be ignored all checkers after this." |
---|
141 | (setq product (product-find product)) |
---|
142 | (or product-ignore-checkers |
---|
143 | (let ((dest (product-checkers product)) |
---|
144 | checker) |
---|
145 | (while checkers |
---|
146 | (setq checker (car checkers) |
---|
147 | checkers (cdr checkers)) |
---|
148 | (or (memq checker dest) |
---|
149 | (setq dest (cons checker dest)))) |
---|
150 | (product-set-checkers product dest)))) |
---|
151 | |
---|
152 | (defun product-remove-checkers (product &rest checkers) |
---|
153 | "Remove checker function(s) from a product. |
---|
154 | PRODUCT is a product structure which returned by `product-define'. |
---|
155 | The rest arguments CHECKERS should be functions. These functions removed |
---|
156 | from the product's checkers list." |
---|
157 | (setq product (product-find product)) |
---|
158 | (let ((dest (product-checkers product))) |
---|
159 | (while checkers |
---|
160 | (setq checkers (cdr checkers) |
---|
161 | dest (delq (car checkers) dest))) |
---|
162 | (product-set-checkers product dest))) |
---|
163 | |
---|
164 | (defun product-add-feature (product feature) |
---|
165 | "Add a feature to the features list of a product. |
---|
166 | PRODUCT is a product structure which returned by `product-define'. |
---|
167 | FEATURE is a feature in the PRODUCT's." |
---|
168 | (setq product (product-find product)) |
---|
169 | (let ((dest (product-features product))) |
---|
170 | (or (memq feature dest) |
---|
171 | (product-set-features product (cons feature dest))))) |
---|
172 | |
---|
173 | (defun product-remove-feature (product feature) |
---|
174 | "Remove a feature from the features list of a product. |
---|
175 | PRODUCT is a product structure which returned by `product-define'. |
---|
176 | FEATURE is a feature which registered in the products list of PRODUCT." |
---|
177 | (setq product (product-find product)) |
---|
178 | (product-set-features product |
---|
179 | (delq feature (product-features product)))) |
---|
180 | |
---|
181 | (defun product-run-checkers (product version &optional force) |
---|
182 | "Run checker functions of product. |
---|
183 | PRODUCT is a product structure which returned by `product-define'. |
---|
184 | VERSION is target version. |
---|
185 | If optional 3rd argument FORCE is non-nil then do not ignore |
---|
186 | all checkers." |
---|
187 | (let ((checkers (product-checkers product))) |
---|
188 | (if (or force |
---|
189 | (not (memq 'ignore checkers))) |
---|
190 | (let ((version (or version |
---|
191 | (product-version product)))) |
---|
192 | (while checkers |
---|
193 | (funcall (car checkers) version version) |
---|
194 | (setq checkers (cdr checkers))))))) |
---|
195 | |
---|
196 | (defun product-find-by-name (name) |
---|
197 | "Find product by name and return a product structure. |
---|
198 | NAME is a string of the product's name." |
---|
199 | (symbol-value (intern-soft name product-obarray))) |
---|
200 | |
---|
201 | (defun product-find-by-feature (feature) |
---|
202 | "Get a product structure of a feature's product. |
---|
203 | FEATURE is a symbol of the feature." |
---|
204 | (get feature 'product)) |
---|
205 | |
---|
206 | (defun product-find (product) |
---|
207 | "Find product information. |
---|
208 | If PROCUCT is a product structure, then return PRODUCT itself. |
---|
209 | If PRODUCT is a string, then find product by name and return a |
---|
210 | product structure. If PRODUCT is symbol of feature, then return |
---|
211 | the feature's product." |
---|
212 | (cond |
---|
213 | ((and (symbolp product) |
---|
214 | (featurep product)) |
---|
215 | (product-find-by-feature product)) |
---|
216 | ((stringp product) |
---|
217 | (product-find-by-name product)) |
---|
218 | ((vectorp product) |
---|
219 | product) |
---|
220 | (t |
---|
221 | (error "Invalid product %s" product)))) |
---|
222 | |
---|
223 | (put 'product-provide 'lisp-indent-function 1) |
---|
224 | (defmacro product-provide (feature-def product-def) |
---|
225 | "Declare a feature as a part of product. |
---|
226 | FEATURE-DEF is a definition of the feature. |
---|
227 | PRODUCT-DEF is a definition of the product." |
---|
228 | (let* ((feature feature-def) |
---|
229 | (product (product-find (eval product-def))) |
---|
230 | (product-name (product-name product)) |
---|
231 | (product-family (product-family product)) |
---|
232 | (product-version (product-version product)) |
---|
233 | (product-code-name (product-code-name product)) |
---|
234 | (product-version-string (product-version-string product))) |
---|
235 | (` (progn |
---|
236 | (, product-def) |
---|
237 | (put (, feature) 'product |
---|
238 | (let ((product (product-find-by-name (, product-name)))) |
---|
239 | (product-run-checkers product '(, product-version)) |
---|
240 | (and (, product-family) |
---|
241 | (product-add-to-family (, product-family) |
---|
242 | (, product-name))) |
---|
243 | (product-add-feature product (, feature)) |
---|
244 | (if (equal '(, product-version) (product-version product)) |
---|
245 | product |
---|
246 | (vector (, product-name) (, product-family) |
---|
247 | '(, product-version) (, product-code-name) |
---|
248 | nil nil nil (, product-version-string))))) |
---|
249 | (, feature-def))))) |
---|
250 | |
---|
251 | (defun product-version-as-string (product) |
---|
252 | "Return version number of product as a string. |
---|
253 | PRODUCT is a product structure which returned by `product-define'. |
---|
254 | If optional argument UPDATE is non-nil, then regenerate |
---|
255 | `produce-version-string' from `product-version'." |
---|
256 | (setq product (product-find product)) |
---|
257 | (or (product-version-string product) |
---|
258 | (and (product-version product) |
---|
259 | (product-set-version-string product |
---|
260 | (mapconcat (function int-to-string) |
---|
261 | (product-version product) |
---|
262 | "."))))) |
---|
263 | |
---|
264 | (defun product-string-1 (product &optional verbose) |
---|
265 | "Return information of product as a string of \"NAME/VERSION\". |
---|
266 | PRODUCT is a product structure which returned by `product-define'. |
---|
267 | If optional argument VERBOSE is non-nil, then return string of |
---|
268 | \"NAME/VERSION (CODE-NAME)\"." |
---|
269 | (setq product (product-find product)) |
---|
270 | (concat (product-name product) |
---|
271 | (let ((version-string (product-version-as-string product))) |
---|
272 | (and version-string |
---|
273 | (concat "/" version-string))) |
---|
274 | (and verbose (product-code-name product) |
---|
275 | (concat " (" (product-code-name product) ")")))) |
---|
276 | |
---|
277 | (defun product-for-each (product all function &rest args) |
---|
278 | "Apply a function to a product and the product's family with args. |
---|
279 | PRODUCT is a product structure which returned by `product-define'. |
---|
280 | If ALL is nil, apply function to only products which provided feature. |
---|
281 | FUNCTION is a function. The function called with following arguments. |
---|
282 | The 1st argument is a product structure. The rest arguments are ARGS." |
---|
283 | (setq product (product-find product)) |
---|
284 | (let ((family (product-family-products product))) |
---|
285 | (and (or all (product-features product)) |
---|
286 | (apply function product args)) |
---|
287 | (while family |
---|
288 | (apply 'product-for-each (car family) all function args) |
---|
289 | (setq family (cdr family))))) |
---|
290 | |
---|
291 | (defun product-string (product) |
---|
292 | "Return information of product as a string of \"NAME/VERSION\". |
---|
293 | PRODUCT is a product structure which returned by `product-define'." |
---|
294 | (let (dest) |
---|
295 | (product-for-each product nil |
---|
296 | (function |
---|
297 | (lambda (product) |
---|
298 | (let ((str (product-string-1 product nil))) |
---|
299 | (if str |
---|
300 | (setq dest (if dest |
---|
301 | (concat dest " " str) |
---|
302 | str))))))) |
---|
303 | dest)) |
---|
304 | |
---|
305 | (defun product-string-verbose (product) |
---|
306 | "Return information of product as a string of \"NAME/VERSION (CODE-NAME)\". |
---|
307 | PRODUCT is a product structure which returned by `product-define'." |
---|
308 | (let (dest) |
---|
309 | (product-for-each product nil |
---|
310 | (function |
---|
311 | (lambda (product) |
---|
312 | (let ((str (product-string-1 product t))) |
---|
313 | (if str |
---|
314 | (setq dest (if dest |
---|
315 | (concat dest " " str) |
---|
316 | str))))))) |
---|
317 | dest)) |
---|
318 | |
---|
319 | (defun product-version-compare (v1 v2) |
---|
320 | "Compare two versions. |
---|
321 | Return an integer greater than, equal to, or less than 0, |
---|
322 | according as the version V1 is greater than, equal to, or less |
---|
323 | than the version V2. |
---|
324 | Both V1 and V2 are a list of integer(s) respectively." |
---|
325 | (while (and v1 v2 (= (car v1) (car v2))) |
---|
326 | (setq v1 (cdr v1) |
---|
327 | v2 (cdr v2))) |
---|
328 | (if v1 (if v2 (- (car v1) (car v2)) 1) (if v2 -1 0))) |
---|
329 | |
---|
330 | (defun product-version>= (product require-version) |
---|
331 | "Compare product version with required version. |
---|
332 | PRODUCT is a product structure which returned by `product-define'. |
---|
333 | REQUIRE-VERSION is a list of integer." |
---|
334 | (>= (product-version-compare (product-version (product-find product)) |
---|
335 | require-version) |
---|
336 | 0)) |
---|
337 | |
---|
338 | (defun product-list-products () |
---|
339 | "List all products information." |
---|
340 | (let (dest) |
---|
341 | (mapatoms |
---|
342 | (function |
---|
343 | (lambda (sym) |
---|
344 | (setq dest (cons (symbol-value sym) dest)))) |
---|
345 | product-obarray) |
---|
346 | dest)) |
---|
347 | |
---|
348 | (defun product-parse-version-string (verstr) |
---|
349 | "Parse version string \".*v1.v2... (CODE-NAME)\". |
---|
350 | Return list of version, code-name, and version-string. |
---|
351 | VERSTR is a string." |
---|
352 | (let (version version-string code-name) |
---|
353 | (and (string-match "\\(\\([0-9.]+\\)[^ ]*\\)[^(]*\\((\\(.+\\))\\)?" verstr) |
---|
354 | (let ((temp (substring verstr (match-beginning 2) (match-end 2)))) |
---|
355 | (setq version-string (substring verstr |
---|
356 | (match-beginning 1) |
---|
357 | (match-end 1)) |
---|
358 | code-name (and (match-beginning 4) |
---|
359 | (substring verstr |
---|
360 | (match-beginning 4) |
---|
361 | (match-end 4)))) |
---|
362 | (while (string-match "^\\([0-9]+\\)\\.?" temp) |
---|
363 | (setq version (cons (string-to-number |
---|
364 | (substring temp |
---|
365 | (match-beginning 1) |
---|
366 | (match-end 1))) |
---|
367 | version) |
---|
368 | temp (substring temp (match-end 0)))))) |
---|
369 | (list (nreverse version) code-name version-string))) |
---|
370 | |
---|
371 | |
---|
372 | ;;; @ End. |
---|
373 | ;;; |
---|
374 | |
---|
375 | (provide 'product) ; beware of circular dependency. |
---|
376 | (require 'apel-ver) ; these two files depend on each other. |
---|
377 | (product-provide 'product 'apel-ver) |
---|
378 | |
---|
379 | |
---|
380 | ;;; @ Define emacs versions. |
---|
381 | ;;; |
---|
382 | |
---|
383 | (require 'pym) |
---|
384 | |
---|
385 | (defconst-maybe emacs-major-version |
---|
386 | (progn (string-match "^[0-9]+" emacs-version) |
---|
387 | (string-to-int (substring emacs-version |
---|
388 | (match-beginning 0)(match-end 0)))) |
---|
389 | "Major version number of this version of Emacs.") |
---|
390 | (defconst-maybe emacs-minor-version |
---|
391 | (progn (string-match "^[0-9]+\\.\\([0-9]+\\)" emacs-version) |
---|
392 | (string-to-int (substring emacs-version |
---|
393 | (match-beginning 1)(match-end 1)))) |
---|
394 | "Minor version number of this version of Emacs.") |
---|
395 | |
---|
396 | ;;(or (product-find "emacs") |
---|
397 | ;; (progn |
---|
398 | ;; (product-define "emacs") |
---|
399 | ;; (cond |
---|
400 | ;; ((featurep 'meadow) |
---|
401 | ;; (let* ((info (product-parse-version-string (Meadow-version))) |
---|
402 | ;; (version (nth 0 info)) |
---|
403 | ;; (code-name (nth 1 info)) |
---|
404 | ;; (version-string (nth 2 info))) |
---|
405 | ;; (product-set-version-string |
---|
406 | ;; (product-define "Meadow" "emacs" version code-name) |
---|
407 | ;; version-string) |
---|
408 | ;; (product-provide 'Meadow "Meadow")) |
---|
409 | ;; (and (featurep 'mule) |
---|
410 | ;; (let* ((info (product-parse-version-string mule-version)) |
---|
411 | ;; (version (nth 0 info)) |
---|
412 | ;; (code-name (nth 1 info)) |
---|
413 | ;; (version-string (nth 2 info))) |
---|
414 | ;; (product-set-version-string |
---|
415 | ;; (product-define "MULE" "Meadow" version code-name) |
---|
416 | ;; version-string) |
---|
417 | ;; (product-provide 'mule "MULE"))) |
---|
418 | ;; (let* ((info (product-parse-version-string emacs-version)) |
---|
419 | ;; (version (nth 0 info)) |
---|
420 | ;; (code-name (nth 1 info)) |
---|
421 | ;; (version-string (nth 2 info))) |
---|
422 | ;; (product-set-version-string |
---|
423 | ;; (product-define "Emacs" "Meadow" version code-name) |
---|
424 | ;; version-string) |
---|
425 | ;; (product-provide 'emacs "Emacs"))) |
---|
426 | ;; ))) |
---|
427 | |
---|
428 | ;;; product.el ends here |
---|