poe/product.el

   1 ;;; product.el --- Functions for product version information.
   2
   3 ;; Copyright (C) 1999 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-string-1 (product &optional verbose)
 252   "Return information of product as a string of \"NAME/VERSION\".
 253 PRODUCT is a product structure which returned by `product-define'.
 254 If optional argument VERBOSE is non-nil, then return string of
 255 \"NAME/VERSION (CODE-NAME)\"."
 256   (setq product (product-find product))
 257   (concat (product-name product)
 258           (cond
 259            ((product-version-string product)
 260             (concat "/" (product-version-string product)))
 261            ((product-version product)
 262             (concat "/"
 263                     (product-set-version-string
 264                      product
 265                      (mapconcat (function int-to-string)
 266                                 (product-version product)
 267                                 "."))))
 268            (""))
 269           (if (and verbose (product-code-name product))
 270               (concat " (" (product-code-name product) ")")
 271             "")))
 272
 273 (defun product-for-each (product all function &rest args)
 274   "Apply a function to a product and the product's family with args.
 275 PRODUCT is a product structure which returned by `product-define'.
 276 If ALL is nil, apply function to only products which provided feature.
 277 FUNCTION is a function.  The function called with following arguments.
 278 The 1st argument is a product structure.  The rest arguments are ARGS."
 279   (setq product (product-find product))
 280   (let ((family (product-family-products product)))
 281     (and (or all (product-features product))
 282          (apply function product args))
 283     (while family
 284       (apply 'product-for-each (car family) all function args)
 285       (setq family (cdr family)))))
 286
 287 (defun product-string (product)
 288   "Return information of product as a string of \"NAME/VERSION\".
 289 PRODUCT is a product structure which returned by `product-define'."
 290   (let (dest)
 291     (product-for-each product nil
 292      (function
 293       (lambda (product)
 294         (let ((str (product-string-1 product nil)))
 295           (if str
 296               (setq dest (if dest
 297                              (concat dest " " str)
 298                            str)))))))
 299     dest))
 300
 301 (defun product-string-verbose (product)
 302   "Return information of product as a string of \"NAME/VERSION (CODE-NAME)\".
 303 PRODUCT is a product structure which returned by `product-define'."
 304   (let (dest)
 305     (product-for-each product nil
 306      (function
 307       (lambda (product)
 308         (let ((str (product-string-1 product t)))
 309           (if str
 310               (setq dest (if dest
 311                              (concat dest " " str)
 312                            str)))))))
 313     dest))
 314
 315 (defun product-version-compare (v1 v2)
 316   "Compare two versions.
 317 Return an integer greater than, equal to, or less than 0,
 318 according as the version V1 is greater than, equal to, or less
 319 than the version V2.
 320 Both V1 and V2 are a list of integer(s) respectively."
 321   (while (and v1 v2 (= (car v1) (car v2)))
 322     (setq v1 (cdr v1)
 323           v2 (cdr v2)))
 324   (if v1 (if v2 (- (car v1) (car v2)) 1) (if v2 -1 0)))
 325
 326 (defun product-version>= (product require-version)
 327   "Compare product version with required version.
 328 PRODUCT is a product structure which returned by `product-define'.
 329 REQUIRE-VERSION is a list of integer."
 330   (>= (product-version-compare (product-version (product-find product))
 331                                require-version)
 332       0))
 333
 334 (defun product-list-products ()
 335   "List all products information."
 336   (let (dest)
 337     (mapatoms
 338      (function
 339       (lambda (sym)
 340         (setq dest (cons (symbol-value sym) dest))))
 341      product-obarray)
 342     dest))
 343
 344 (defun product-parse-version-string (verstr)
 345   "Parse version string \".*v1.v2... (CODE-NAME)\".
 346 Return list of version, code-name, and version-string.
 347 VERSTR is a string."
 348   (let (version version-string code-name)
 349     (and (string-match "\\(\\([0-9.]+\\)[^ ]*\\)[^(]*\\((\\(.+\\))\\)?" verstr)
 350          (let ((temp (substring verstr (match-beginning 2) (match-end 2))))
 351            (setq version-string (substring verstr
 352                                            (match-beginning 1)
 353                                            (match-end 1))
 354                  code-name (and (match-beginning 4)
 355                                 (substring verstr
 356                                            (match-beginning 4)
 357                                            (match-end 4))))
 358            (while (string-match "^\\([0-9]+\\)\\.?" temp)
 359              (setq version (cons (string-to-number
 360                                   (substring temp
 361                                              (match-beginning 1)
 362                                              (match-end 1)))
 363                                  version)
 364                    temp (substring temp (match-end 0))))))
 365     (list (nreverse version) code-name version-string)))
 366
 367
 368 ;;; @ End.
 369 ;;;
 370
 371 (provide 'product)                      ; beware of circular dependency.
 372 (require 'apel-ver)                     ; these two files depend on each other.
 373 (product-provide 'product 'apel-ver)
 374 \f
 375
 376 ;;; @ Define emacs versions.
 377 ;;;
 378
 379 (require 'pym)
 380
 381 (defconst-maybe emacs-major-version
 382   (progn (string-match "^[0-9]+" emacs-version)
 383          (string-to-int (substring emacs-version
 384                                    (match-beginning 0)(match-end 0))))
 385   "Major version number of this version of Emacs.")
 386 (defconst-maybe emacs-minor-version
 387   (progn (string-match "^[0-9]+\\.\\([0-9]+\\)" emacs-version)
 388          (string-to-int (substring emacs-version
 389                                    (match-beginning 1)(match-end 1))))
 390   "Minor version number of this version of Emacs.")
 391
 392 ;;(or (product-find "emacs")
 393 ;;    (progn
 394 ;;      (product-define "emacs")
 395 ;;      (cond
 396 ;;       ((featurep 'meadow)
 397 ;;      (let* ((info (product-parse-version-string (Meadow-version)))
 398 ;;             (version (nth 0 info))
 399 ;;             (code-name (nth 1 info))
 400 ;;             (version-string (nth 2 info)))
 401 ;;        (product-set-version-string
 402 ;;         (product-define "Meadow" "emacs" version code-name)
 403 ;;         version-string)
 404 ;;        (product-provide 'Meadow "Meadow"))
 405 ;;      (and (featurep 'mule)
 406 ;;           (let* ((info (product-parse-version-string mule-version))
 407 ;;                  (version (nth 0 info))
 408 ;;                  (code-name (nth 1 info))
 409 ;;                  (version-string (nth 2 info)))
 410 ;;             (product-set-version-string
 411 ;;              (product-define "MULE" "Meadow" version code-name)
 412 ;;              version-string)
 413 ;;             (product-provide 'mule "MULE")))
 414 ;;      (let* ((info (product-parse-version-string emacs-version))
 415 ;;             (version (nth 0 info))
 416 ;;             (code-name (nth 1 info))
 417 ;;             (version-string (nth 2 info)))
 418 ;;        (product-set-version-string
 419 ;;         (product-define "Emacs" "Meadow" version code-name)
 420 ;;         version-string)
 421 ;;        (product-provide 'emacs "Emacs")))
 422 ;;       )))
 423
 424 ;;; product.el ends here