1;;; product.el --- Functions for product version information -*- lexical-binding: t -*- 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., 51 Franklin Street, Fifth Floor, 24;; Boston, MA 02110-1301, 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. 52NAME is a string. Optional 2nd argument FAMILY is a string of 53family product name. Optional 3rd argument VERSION is a list of 54numbers. 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 checker 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. 113FAMILY is a product structure which returned by `product-define'. 114PRODUCT-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. 125FAMILY is a product string which returned by `product-define'. 126PRODUCT-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. 136PRODUCT is a product structure which returned by `product-define'. 137The rest arguments CHECKERS should be functions. These functions 138are registered to the product's checkers list, and will be called by 139 `product-run-checkers'. 140If 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. 154PRODUCT is a product structure which returned by `product-define'. 155The rest arguments CHECKERS should be functions. These functions removed 156from 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. 166PRODUCT is a product structure which returned by `product-define'. 167FEATURE 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. 175PRODUCT is a product structure which returned by `product-define'. 176FEATURE 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. 183PRODUCT is a product structure which returned by `product-define'. 184VERSION is target version. 185If optional 3rd argument FORCE is non-nil then do not ignore 186all 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. 198NAME 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. 203FEATURE is a symbol of the feature." 204 (get feature 'product)) 205 206(defun product-find (product) 207 "Find product information. 208If PRODUCT is a product structure, then return PRODUCT itself. 209If PRODUCT is a string, then find product by name and return a 210product structure. If PRODUCT is symbol of feature, then return 211the 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. 226FEATURE-DEF is a definition of the feature. 227PRODUCT-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. 253PRODUCT is a product structure which returned by `product-define'. 254If optional argument UPDATE is non-nil, then regenerate 255`product-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\". 266PRODUCT is a product structure which returned by `product-define'. 267If 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. 279PRODUCT is a product structure which returned by `product-define'. 280If ALL is nil, apply function to only products which provided feature. 281FUNCTION is a function. The function called with following arguments. 282The 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\". 293PRODUCT is a product structure which returned by `product-define'." 294 (let (dest) 295 (product-for-each product nil 296 (lambda (product) 297 (let ((str (product-string-1 product nil))) 298 (if str 299 (setq dest (if dest 300 (concat dest " " str) 301 str)))))) 302 dest)) 303 304(defun product-string-verbose (product) 305 "Return information of product as a string of \"NAME/VERSION (CODE-NAME)\". 306PRODUCT is a product structure which returned by `product-define'." 307 (let (dest) 308 (product-for-each product nil 309 (lambda (product) 310 (let ((str (product-string-1 product t))) 311 (if str 312 (setq dest (if dest 313 (concat dest " " str) 314 str)))))) 315 dest)) 316 317(defun product-version-compare (v1 v2) 318 "Compare two versions. 319Return an integer greater than, equal to, or less than 0, 320according as the version V1 is greater than, equal to, or less 321than the version V2. 322Both V1 and V2 are a list of integer(s) respectively." 323 (while (and v1 v2 (= (car v1) (car v2))) 324 (setq v1 (cdr v1) 325 v2 (cdr v2))) 326 (if v1 (if v2 (- (car v1) (car v2)) 1) (if v2 -1 0))) 327 328(defun product-version>= (product require-version) 329 "Compare product version with required version. 330PRODUCT is a product structure which returned by `product-define'. 331REQUIRE-VERSION is a list of integer." 332 (>= (product-version-compare (product-version (product-find product)) 333 require-version) 334 0)) 335 336(defun product-list-products () 337 "List all products information." 338 (let (dest) 339 (mapatoms 340 (lambda (sym) 341 (setq dest (cons (symbol-value sym) dest))) 342 product-obarray) 343 dest)) 344 345(defun product-parse-version-string (verstr) 346 "Parse version string \".*v1.v2... (CODE-NAME)\". 347Return list of version, code-name, and version-string. 348VERSTR is a string." 349 (let (version version-string code-name) 350 (and (string-match "\\(\\([0-9.]+\\)[^ ]*\\)[^(]*\\((\\(.+\\))\\)?" verstr) 351 (let ((temp (substring verstr (match-beginning 2) (match-end 2)))) 352 (setq version-string (substring verstr 353 (match-beginning 1) 354 (match-end 1)) 355 code-name (and (match-beginning 4) 356 (substring verstr 357 (match-beginning 4) 358 (match-end 4)))) 359 (while (string-match "^\\([0-9]+\\)\\.?" temp) 360 (setq version (cons (string-to-number 361 (substring temp 362 (match-beginning 1) 363 (match-end 1))) 364 version) 365 temp (substring temp (match-end 0)))))) 366 (list (nreverse version) code-name version-string))) 367 368 369;;; @ End. 370;;; 371 372(provide 'product) ; beware of circular dependency. 373(require 'apel-ver) ; these two files depend on each other. 374(product-provide 'product 'apel-ver) 375 376;;; product.el ends here 377