product.el

   1 ;;; product.el --- Functions for product version information.
   2
   3 ;; Copyright (C) 1999 Free Software Foundation, Inc.
   4 ;; Copyright (C) 1999 Keiichi Suzuki
   5
   6 ;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
   7 ;;      Keiichi Suzuki <keiichi@nanap.org>
   8 ;; Keywords: compatibility, User-Agent
   9
  10 ;; This file is part of APEL (A Portable Emacs Library).
  11
  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.
  16
  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.
  21
  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.
  26
  27 ;;; Commentary:
  28
  29 ;; This module defines some utility functions for product information,
  30 ;; used for User-Agent header field.
  31 ;;
  32 ;; User-Agent header field first appeared in HTTP [RFC 1945, RFC 2616]
  33 ;; and adopted to News Article Format draft [USEFOR].
  34 ;;
  35 ;; [RFC 1945] Hypertext Transfer Protocol -- HTTP/1.0.
  36 ;;  T. Berners-Lee, R. Fielding & H. Frystyk. May 1996.
  37 ;;
  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.
  41 ;;
  42 ;; [USEFOR] News Article Format, <draft-ietf-usefor-article-02.txt>.
  43 ;;  USEFOR Working Group. March 1999.
  44
  45 ;;; Code:
  46
  47 (defvar product-obarray (make-vector 13 0))
  48
  49 (defvar product-ignore-checkers nil)
  50
  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."
  56   (and family
  57        (product-add-to-family family name))
  58   (set (intern name product-obarray)
  59        (vector name family version code-name nil nil nil nil)))
  60
  61 (defun product-name (product)
  62   "Return the name of PRODUCT, a string."
  63   (aref product 0))
  64 (defun product-family (product)
  65   "Return the family name of PRODUCT, a string."
  66   (aref product 1))
  67 (defun product-version (product)
  68   "Return the version of PRODUCT, a list of numbers."
  69   (aref product 2))
  70 (defun product-code-name (product)
  71   "Return the code-name of PRODUCT, a string."
  72   (aref product 3))
  73 (defun product-checkers (product)
  74   "Return the checkers of PRODUCT, a list of functions."
  75   (aref product 4))
  76 (defun product-family-products (product)
  77   "Return the family products of PRODUCT, a list of strings."
  78   (aref product 5))
  79 (defun product-features (product)
  80   "Return the features of PRODUCT, a list of feature."
  81   (aref product 6))
  82 (defun product-version-string (product)
  83   "Return the version string of PRODUCT, a string."
  84   (aref product 7))
  85
  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))
 111
 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)))
 115     (if family-product
 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))))
 121
 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)))
 125     (if family-product
 126         (product-set-family-products
 127          family-product
 128          (delete product-name (product-family-products family-product)))
 129       (error "Family product `%s' is not defined" family))))
 130
 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))
 137             checker)
 138         (while checkers
 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))))
 144
 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)))
 149     (while checkers
 150       (setq checkers (cdr checkers)
 151             dest (delq (car checkers) dest)))
 152     (product-set-checkers product dest)))
 153
 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)))))
 160
 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))))
 166
 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
 171 all checkers."
 172   (let ((checkers (product-checkers product)))
 173     (if (or force
 174             (not (memq 'ignore checkers)))
 175         (let ((version (or version
 176                            (product-version product))))
 177           (while checkers
 178             (funcall (car checkers) version version)
 179             (setq checkers (cdr checkers)))))))
 180
 181 (defun product-find-by-name (name)
 182   "Return PRODUCT information of NAME."
 183   (symbol-value (intern-soft name product-obarray)))
 184
 185 (defun product-find-by-feature (feature)
 186   "Get product information of FEATURE."
 187   (get feature 'product))
 188
 189 (defun product-find (product)
 190   "Get product information."
 191   (cond
 192    ((and (symbolp product)
 193          (featurep product))
 194     (product-find-by-feature product))
 195    ((stringp product)
 196     (product-find-by-name product))
 197    ((vectorp product)
 198     product)
 199    (t
 200     (error "Invalid product %s" product))))
 201
 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)))
 212     (`  (progn
 213           (, product-def)
 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)
 219                                              (, product-name)))
 220                  (product-add-feature product (, feature))
 221                  (if (equal '(, product-version) (product-version product))
 222                      product
 223                    (vector (, product-name) (, product-family)
 224                            '(, product-version) (, product-code-name)
 225                            nil nil nil (, product-version-string)))))
 226           (, feature-def)))))
 227
 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)
 234           (cond
 235            ((product-version-string product)
 236             (concat "/" (product-version-string product)))
 237            ((product-version product)
 238             (concat "/"
 239                     (product-set-version-string
 240                      product
 241                      (mapconcat (function number-to-string)
 242                                 (product-version product)
 243                                 "."))))
 244            (""))
 245           (if (and verbose (product-code-name product))
 246               (concat " (" (product-code-name product) ")")
 247             "")))
 248
 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))
 256     (while family
 257       (apply 'product-for-each (car family) all function args)
 258       (setq family (cdr family)))))
 259
 260 (defun product-string (product)
 261   "Return information of PRODUCT as a string of \"NAME/VERSION\"."
 262   (let (dest)
 263     (product-for-each product nil
 264      (function
 265       (lambda (product)
 266         (let ((str (product-string-1 product nil)))
 267           (if str
 268               (setq dest (if dest
 269                              (concat dest " " str)
 270                            str)))))))
 271     dest))
 272
 273 (defun product-string-verbose (product)
 274   "Return information of PRODUCT as a string of \"NAME/VERSION (CODE-NAME)\"."
 275   (let (dest)
 276     (product-for-each product nil
 277      (function
 278       (lambda (product)
 279         (let ((str (product-string-1 product t)))
 280           (if str
 281               (setq dest (if dest
 282                              (concat dest " " str)
 283                            str)))))))
 284     dest))
 285
 286 (defun product-version-compare (v1 v2)
 287   "Compare version of product."
 288   (while (and v1 v2 (= (car v1) (car v2)))
 289     (setq v1 (cdr v1)
 290           v2 (cdr v2)))
 291   (if v1 (if v2 (- (car v1) (car v2)) 1) (if v2 -1 0)))
 292
 293 (defun product-version>= (product require-version)
 294   (>= (product-version-compare (product-version (product-find product))
 295                                require-version)
 296       0))
 297
 298 (defun product-list-products ()
 299   "List all products information."
 300   (let (dest)
 301     (mapatoms
 302      (function
 303       (lambda (sym)
 304         (setq dest (cons (symbol-value sym) dest))))
 305      product-obarray)
 306     dest))
 307
 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
 315                                            (match-beginning 1)
 316                                            (match-end 1))
 317                  code-name (and (match-beginning 4)
 318                                 (substring verstr
 319                                            (match-beginning 4)
 320                                            (match-end 4))))
 321            (while (string-match "^\\([0-9]+\\)\\.?" temp)
 322              (setq version (cons (string-to-number
 323                                   (substring temp
 324                                              (match-beginning 1)
 325                                              (match-end 1)))
 326                                  version)
 327                    temp (substring temp (match-end 0))))))
 328     (list (nreverse version) code-name version-string)))
 329
 330 ;;; @ End.
 331 ;;;
 332
 333 (provide 'product)                      ; beware of circular dependency.
 334 (require 'apel-ver)                     ; these two files depend on each other.
 335 (product-provide 'product 'apel-ver)
 336
 337 ;;; @ Define emacs versions.
 338
 339 ;;(or (product-find "emacs")
 340 ;;    (progn
 341 ;;      (product-define "emacs")
 342 ;;      (cond
 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)
 350 ;;         version-string)
 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)
 359 ;;              version-string)
 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)
 367 ;;         version-string)
 368 ;;        (product-provide 'emacs "Emacs")))
 369 ;;       )))
 370
 371 ;;; product.el ends here