1 ;;; product.el --- Functions for product version information.
3 ;; Copyright (C) 1999 Free Software Foundation, Inc.
4 ;; Copyright (C) 1999 Keiichi Suzuki
6 ;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
7 ;; Keiichi Suzuki <keiichi@nanap.org>
8 ;; Keywords: compatibility, User-Agent
10 ;; This file is part of APEL (A Portable Emacs Library).
12 ;; This program is free software; you can redistribute it and/or
13 ;; modify it under the terms of the GNU General Public License as
14 ;; published by the Free Software Foundation; either version 2, or (at
15 ;; your option) any later version.
17 ;; This program is distributed in the hope that it will be useful, but
18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
20 ;; General Public License for more details.
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with this program; see the file COPYING. If not, write to
24 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25 ;; Boston, MA 02111-1307, USA.
29 ;; This module defines some utility functions for product information,
30 ;; used for User-Agent header field.
32 ;; User-Agent header field first appeared in HTTP [RFC 1945, RFC 2616]
33 ;; and adopted to News Article Format draft [USEFOR].
35 ;; [RFC 1945] Hypertext Transfer Protocol -- HTTP/1.0.
36 ;; T. Berners-Lee, R. Fielding & H. Frystyk. May 1996.
38 ;; [RFC 2616] Hypertext Transfer Protocol -- HTTP/1.1.
39 ;; R. Fielding, J. Gettys, J. Mogul, H. Frystyk, L. Masinter, P. Leach,
40 ;; T. Berners-Lee. June 1999.
42 ;; [USEFOR] News Article Format, <draft-ietf-usefor-article-02.txt>.
43 ;; USEFOR Working Group. March 1999.
47 (defvar product-obarray (make-vector 13 0))
49 (defvar product-ignore-checkers nil)
51 (defun product-define (name &optional family version code-name)
52 "Define a product as a set of NAME, FAMILY, VERSION, and CODE-NAME.
53 NAME is a string. Optional 2nd argument FAMILY is a string of
54 family product name. Optional 3rd argument VERSION is a list of
55 numbers. Optional 4th argument CODE-NAME is a string."
57 (product-add-to-family family name))
58 (set (intern name product-obarray)
59 (vector name family version code-name nil nil nil nil)))
61 (defun product-name (product)
62 "Return the name of PRODUCT, a string."
64 (defun product-family (product)
65 "Return the family name of PRODUCT, a string."
67 (defun product-version (product)
68 "Return the version of PRODUCT, a list of numbers."
70 (defun product-code-name (product)
71 "Return the code-name of PRODUCT, a string."
73 (defun product-checkers (product)
74 "Return the checkers of PRODUCT, a list of functions."
76 (defun product-family-products (product)
77 "Return the family products of PRODUCT, a list of strings."
79 (defun product-features (product)
80 "Return the features of PRODUCT, a list of feature."
82 (defun product-version-string (product)
83 "Return the version string of PRODUCT, a string."
86 (defun product-set-name (product name)
87 "Set name of PRODUCT to NAME."
88 (aset product 0 name))
89 (defun product-set-family (product family)
90 "Set family name of PRODUCT to FAMILY."
91 (aset product 1 family))
92 (defun product-set-version (product version)
93 "Set version of PRODUCT to VERSION."
94 (aset product 2 version))
95 ;; Some people want to translate code-name.
96 (defun product-set-code-name (product code-name)
97 "Set code-name of PRODUCT to CODE-NAME."
98 (aset product 3 code-name))
99 (defun product-set-checkers (product checkers)
100 "Set ckecker functions of PRODUCT to CHECKERS."
101 (aset product 4 checkers))
102 (defun product-set-family-products (product products)
103 "Set family products of PRODUCT to PRODUCTS."
104 (aset product 5 products))
105 (defun product-set-features (product features)
106 "Set features of PRODUCT to FEATURES."
107 (aset product 6 features))
108 (defun product-set-version-string (product version-string)
109 "Set version string of PRODUCT to VERSION-STRING."
110 (aset product 7 version-string))
112 (defun product-add-to-family (family product-name)
113 "Add PRODUCT-NAME to FAMILY product."
114 (let ((family-product (product-find-by-name family)))
116 (let ((dest (product-family-products family-product)))
117 (or (member product-name dest)
118 (product-set-family-products
119 family-product (cons product-name dest))))
120 (error "Family product `%s' is not defined" family))))
122 (defun product-remove-from-family (family product-name)
123 "Remove PRODUCT-NAME from FAMILY product."
124 (let ((family-product (product-find-by-name family)))
126 (product-set-family-products
128 (delete product-name (product-family-products family-product)))
129 (error "Family product `%s' is not defined" family))))
131 (defun product-add-checkers (product &rest checkers)
132 "Add CHECKERS to checker functions list of PRODUCT.
133 If a checker is `ignore' will be ignored all checkers after this."
134 (setq product (product-find product))
135 (or product-ignore-checkers
136 (let ((dest (product-checkers product))
139 (setq checker (car checkers)
140 checkers (cdr checkers))
141 (or (memq checker dest)
142 (setq dest (cons checker dest))))
143 (product-set-checkers product dest))))
145 (defun product-remove-checkers (product &rest checkers)
146 "Remove CHECKERS from checker functions list of PRODUCT."
147 (setq product (product-find product))
148 (let ((dest (product-checkers product)))
150 (setq checkers (cdr checkers)
151 dest (delq (car checkers) dest)))
152 (product-set-checkers product dest)))
154 (defun product-add-feature (product feature)
155 "Add FEATURE to features list of PRODUCT."
156 (setq product (product-find product))
157 (let ((dest (product-features product)))
158 (or (memq feature dest)
159 (product-set-features product (cons feature dest)))))
161 (defun product-remove-feature (product feature)
162 "Remove FEATURE from features list of PRODUCT."
163 (setq product (product-find product))
164 (product-set-features product
165 (delq feature (product-features product))))
167 (defun product-run-checkers (product version &optional force)
168 "Run checker functions of PRODUCT.
169 VERSION is target version.
170 If optional 2nd argument FORCE is non-nil then do not ignore
172 (let ((checkers (product-checkers product)))
174 (not (memq 'ignore checkers)))
175 (let ((version (or version
176 (product-version product))))
178 (funcall (car checkers) version version)
179 (setq checkers (cdr checkers)))))))
181 (defun product-find-by-name (name)
182 "Return PRODUCT information of NAME."
183 (symbol-value (intern-soft name product-obarray)))
185 (defun product-find-by-feature (feature)
186 "Get product information of FEATURE."
187 (get feature 'product))
189 (defun product-find (product)
190 "Get product information."
192 ((and (symbolp product)
194 (product-find-by-feature product))
196 (product-find-by-name product))
200 (error "Invalid product %s" product))))
202 (put 'product-provide 'lisp-indent-function 1)
203 (defmacro product-provide (feature-def product-def)
204 "Declare FEATURE as a part of PRODUCT."
205 (let* ((feature feature-def)
206 (product (product-find (eval product-def)))
207 (product-name (product-name product))
208 (product-family (product-family product))
209 (product-version (product-version product))
210 (product-code-name (product-code-name product))
211 (product-version-string (product-version-string product)))
214 (put (, feature) 'product
215 (let ((product (product-find-by-name (, product-name))))
216 (product-run-checkers product '(, product-version))
217 (and (, product-family)
218 (product-add-to-family (, product-family)
220 (product-add-feature product (, feature))
221 (if (equal '(, product-version) (product-version product))
223 (vector (, product-name) (, product-family)
224 '(, product-version) (, product-code-name)
225 nil nil nil (, product-version-string)))))
228 (defun product-string-1 (product &optional verbose)
229 "Return information of PRODUCT as a string of \"NAME/VERSION\".
230 If optional argument VERBOSE is non-nil, then return string of
231 \"NAME/VERSION (CODE-NAME)\"."
232 (setq product (product-find product))
233 (concat (product-name product)
235 ((product-version-string product)
236 (concat "/" (product-version-string product)))
237 ((product-version product)
239 (product-set-version-string
241 (mapconcat (function int-to-string)
242 (product-version product)
245 (if (and verbose (product-code-name product))
246 (concat " (" (product-code-name product) ")")
249 (defun product-for-each (product all function &rest args)
250 "Apply FUNCTION to PRODUCT and PRODUCT's family with ARGS.
251 If ALL is nil, apply function to only products which provide feature."
252 (setq product (product-find product))
253 (let ((family (product-family-products product)))
254 (and (or all (product-features product))
255 (apply function product args))
257 (apply 'product-for-each (car family) all function args)
258 (setq family (cdr family)))))
260 (defun product-string (product)
261 "Return information of PRODUCT as a string of \"NAME/VERSION\"."
263 (product-for-each product nil
266 (let ((str (product-string-1 product nil)))
269 (concat dest " " str)
273 (defun product-string-verbose (product)
274 "Return information of PRODUCT as a string of \"NAME/VERSION (CODE-NAME)\"."
276 (product-for-each product nil
279 (let ((str (product-string-1 product t)))
282 (concat dest " " str)
286 (defun product-version-compare (v1 v2)
287 "Compare version of product."
288 (while (and v1 v2 (= (car v1) (car v2)))
291 (if v1 (if v2 (- (car v1) (car v2)) 1) (if v2 -1 0)))
293 (defun product-version>= (product require-version)
294 (>= (product-version-compare (product-version (product-find product))
298 (defun product-list-products ()
299 "List all products information."
304 (setq dest (cons (symbol-value sym) dest))))
308 (defun product-parse-version-string (verstr)
309 "Parse version string \".*v1.v2... (CODE-NAME)\".
310 Return list of version, code-name, and version-string."
311 (let (version version-string code-name)
312 (and (string-match "\\(\\([0-9.]+\\)[^ ]*\\)[^(]*\\((\\(.+\\))\\)?" verstr)
313 (let ((temp (substring verstr (match-beginning 2) (match-end 2))))
314 (setq version-string (substring verstr
317 code-name (and (match-beginning 4)
321 (while (string-match "^\\([0-9]+\\)\\.?" temp)
322 (setq version (cons (string-to-number
327 temp (substring temp (match-end 0))))))
328 (list (nreverse version) code-name version-string)))
333 (provide 'product) ; beware of circular dependency.
334 (require 'apel-ver) ; these two files depend on each other.
335 (product-provide 'product 'apel-ver)
337 ;;; @ Define emacs versions.
339 ;;(or (product-find "emacs")
341 ;; (product-define "emacs")
343 ;; ((featurep 'meadow)
344 ;; (let* ((info (product-parse-version-string (Meadow-version)))
345 ;; (version (nth 0 info))
346 ;; (code-name (nth 1 info))
347 ;; (version-string (nth 2 info)))
348 ;; (product-set-version-string
349 ;; (product-define "Meadow" "emacs" version code-name)
351 ;; (product-provide 'Meadow "Meadow"))
352 ;; (and (featurep 'mule)
353 ;; (let* ((info (product-parse-version-string mule-version))
354 ;; (version (nth 0 info))
355 ;; (code-name (nth 1 info))
356 ;; (version-string (nth 2 info)))
357 ;; (product-set-version-string
358 ;; (product-define "MULE" "Meadow" version code-name)
360 ;; (product-provide 'mule "MULE")))
361 ;; (let* ((info (product-parse-version-string emacs-version))
362 ;; (version (nth 0 info))
363 ;; (code-name (nth 1 info))
364 ;; (version-string (nth 2 info)))
365 ;; (product-set-version-string
366 ;; (product-define "Emacs" "Meadow" version code-name)
368 ;; (product-provide 'emacs "Emacs")))
371 ;;; product.el ends here