From: keiichi <keiichi>
Date: Mon, 20 Dec 1999 11:12:57 +0000 (+0000)
Subject: New file.
X-Git-Tag: apel-10_0~23
X-Git-Url: http://git.chise.org/gitweb/?p=elisp%2Fapel.git;a=commitdiff_plain;h=333d9638ea4331987749e50d8736d43a10b7fad5

New file.
---

diff --git a/apel-ver.el b/apel-ver.el
new file mode 100644
index 0000000..9bae87d
--- /dev/null
+++ b/apel-ver.el
@@ -0,0 +1,56 @@
+;;; apel-version.el --- Declare APEL version.
+
+;; Copyright (C) 1999 Shuhei KOBAYASHI
+
+;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
+;;         Keiichi Suzuki <keiichi@nanap.org>
+;; Keywords: compatibility
+
+;; This file is part of APEL (A Portable Emacs Library).
+
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2, or (at
+;; your option) any later version.
+
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING.  If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; Put the following lines to each file of APEL package.
+;;
+;; (require 'product)
+;; (product-provide (provide FEATURE) (require 'apel-ver))
+
+;;; Code:
+
+(require 'product)			; beware of circular dependency.
+(provide 'apel-ver)			; these two files depend on each other.
+
+(product-provide 'apel-ver
+  (product-define "APEL" nil '(9 23))	; comment.
+  ;; (product-define "APEL" nil '(9 24))	;
+  ;; (product-define "APEL" nil '(9 25))	;
+  ;; (product-define "APEL" nil '(9 26))	;
+  )
+
+(defun apel-version ()
+  "Print APEL version."
+  (interactive)
+  (let ((product-info (product-string-1 'apel-ver t)))
+    (if (interactive-p)
+	(message "%s" product-info)
+      product-info)))
+
+;;; @ End.
+;;;
+
+;;; apel-version.el ends here.
diff --git a/product.el b/product.el
new file mode 100644
index 0000000..f6ece13
--- /dev/null
+++ b/product.el
@@ -0,0 +1,371 @@
+;;; product.el --- Functions for product version information.
+
+;; Copyright (C) 1999 Shuhei KOBAYASHI
+;; Copyright (C) 1999 Keiichi Suzuki
+
+;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
+;;	Keiichi Suzuki <keiichi@nanap.org>
+;; Keywords: compatibility, User-Agent
+
+;; This file is part of APEL (A Portable Emacs Library).
+
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2, or (at
+;; your option) any later version.
+
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING.  If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; This module defines some utility functions for product information,
+;; used for User-Agent header field.
+;;
+;; User-Agent header field first appeared in HTTP [RFC 1945, RFC 2616]
+;; and adopted to News Article Format draft [USEFOR].
+;;
+;; [RFC 1945] Hypertext Transfer Protocol -- HTTP/1.0.
+;;  T. Berners-Lee, R. Fielding & H. Frystyk. May 1996.
+;;
+;; [RFC 2616] Hypertext Transfer Protocol -- HTTP/1.1.
+;;  R. Fielding, J. Gettys, J. Mogul, H. Frystyk, L. Masinter, P. Leach,
+;;  T. Berners-Lee. June 1999.
+;;
+;; [USEFOR] News Article Format, <draft-ietf-usefor-article-02.txt>.
+;;  USEFOR Working Group. March 1999.
+
+;;; Code:
+
+(defvar product-obarray (make-vector 13 0))
+
+(defvar product-ignore-checkers nil)
+
+(defun product-define (name &optional family version code-name)
+  "Define a product as a set of NAME, FAMILY, VERSION, and CODE-NAME.
+NAME is a string.  Optional 2nd argument FAMILY is a string of
+family product name.  Optional 3rd argument VERSION is a list of
+numbers.  Optional 4th argument CODE-NAME is a string."
+  (and family
+       (product-add-to-family family name))
+  (set (intern name product-obarray)
+       (vector name family version code-name nil nil nil nil)))
+
+(defun product-name (product)
+  "Return the name of PRODUCT, a string."
+  (aref product 0))
+(defun product-family (product)
+  "Return the family name of PRODUCT, a string."
+  (aref product 1))
+(defun product-version (product)
+  "Return the version of PRODUCT, a list of numbers."
+  (aref product 2))
+(defun product-code-name (product)
+  "Return the code-name of PRODUCT, a string."
+  (aref product 3))
+(defun product-checkers (product)
+  "Return the checkers of PRODUCT, a list of functions."
+  (aref product 4))
+(defun product-family-products (product)
+  "Return the family products of PRODUCT, a list of strings."
+  (aref product 5))
+(defun product-features (product)
+  "Return the features of PRODUCT, a list of feature."
+  (aref product 6))
+(defun product-version-string (product)
+  "Return the version string of PRODUCT, a string."
+  (aref product 7))
+
+(defun product-set-name (product name)
+  "Set name of PRODUCT to NAME."
+  (aset product 0 name))
+(defun product-set-family (product family)
+  "Set family name of PRODUCT to FAMILY."
+  (aset product 1 family))
+(defun product-set-version (product version)
+  "Set version of PRODUCT to VERSION."
+  (aset product 2 version))
+;; Some people want to translate code-name.
+(defun product-set-code-name (product code-name)
+  "Set code-name of PRODUCT to CODE-NAME."
+  (aset product 3 code-name))
+(defun product-set-checkers (product checkers)
+  "Set ckecker functions of PRODUCT to CHECKERS."
+  (aset product 4 checkers))
+(defun product-set-family-products (product products)
+  "Set family products of PRODUCT to PRODUCTS."
+  (aset product 5 products))
+(defun product-set-features (product features)
+  "Set features of PRODUCT to FEATURES."
+  (aset product 6 features))
+(defun product-set-version-string (product version-string)
+  "Set version string of PRODUCT to VERSION-STRING."
+  (aset product 7 version-string))
+
+(defun product-add-to-family (family product-name)
+  "Add PRODUCT-NAME to FAMILY product."
+  (let ((family-product (product-find-by-name family)))
+    (if family-product
+	(let ((dest (product-family-products family-product)))
+	  (or (member product-name dest)
+	      (product-set-family-products
+	       family-product (cons product-name dest))))
+      (error "Family product `%s' is not defined" family))))
+
+(defun product-remove-from-family (family product-name)
+  "Remove PRODUCT-NAME from FAMILY product."
+  (let ((family-product (product-find-by-name family)))
+    (if family-product
+	(product-set-family-products
+	 family-product
+	 (delete product-name (product-family-products family-product)))
+      (error "Family product `%s' is not defined" family))))
+
+(defun product-add-checkers (product &rest checkers)
+  "Add CHECKERS to checker functions list of PRODUCT.
+If a checker is `ignore' will be ignored all checkers after this."
+  (setq product (product-find product))
+  (or product-ignore-checkers
+      (let ((dest (product-checkers product))
+	    checker)
+	(while checkers
+	  (setq checker (car checkers)
+		checkers (cdr checkers))
+	  (or (memq checker dest)
+	      (setq dest (cons checker dest))))
+	(product-set-checkers product dest))))
+
+(defun product-remove-checkers (product &rest checkers)
+  "Remove CHECKERS from checker functions list of PRODUCT."
+  (setq product (product-find product))
+  (let ((dest (product-checkers product)))
+    (while checkers
+      (setq checkers (cdr checkers)
+	    dest (delq (car checkers) dest)))
+    (product-set-checkers product dest)))
+
+(defun product-add-feature (product feature)
+  "Add FEATURE to features list of PRODUCT."
+  (setq product (product-find product))
+  (let ((dest (product-features product)))
+    (or (memq feature dest)
+	(product-set-features product (cons feature dest)))))
+
+(defun product-remove-feature (product feature)
+  "Remove FEATURE from features list of PRODUCT."
+  (setq product (product-find product))
+  (product-set-features product
+			(delq feature (product-features product))))
+
+(defun product-run-checkers (product version &optional force)
+  "Run checker functions of PRODUCT.
+VERSION is target version.
+If optional 2nd argument FORCE is non-nil then do not ignore
+all checkers."
+  (let ((checkers (product-checkers product)))
+    (if (or force
+	    (not (memq 'ignore checkers)))
+	(let ((version (or version
+			   (product-version product))))
+	  (while checkers
+	    (funcall (car checkers) version version)
+	    (setq checkers (cdr checkers)))))))
+
+(defun product-find-by-name (name)
+  "Return PRODUCT information of NAME."
+  (symbol-value (intern-soft name product-obarray)))
+
+(defun product-find-by-feature (feature)
+  "Get product information of FEATURE."
+  (get feature 'product))
+
+(defun product-find (product)
+  "Get product information."
+  (cond
+   ((and (symbolp product)
+	 (featurep product))
+    (product-find-by-feature product))
+   ((stringp product)
+    (product-find-by-name product))
+   ((vectorp product)
+    product)
+   (t
+    (error "Invalid product %s" product))))
+
+(put 'product-provide 'lisp-indent-function 1)
+(defmacro product-provide (feature-def product-def)
+  "Declare FEATURE as a part of PRODUCT."
+  (let* ((feature feature-def)
+	 (product (product-find (eval product-def)))
+	 (product-name (product-name product))
+	 (product-family (product-family product))
+	 (product-version (product-version product))
+	 (product-code-name (product-code-name product))
+	 (product-version-string (product-version-string product)))
+    (`  (progn
+	  (, product-def)
+	  (put (, feature) 'product
+	       (let ((product (product-find-by-name (, product-name))))
+		 (product-run-checkers product '(, product-version))
+		 (and (, product-family)
+		      (product-add-to-family (, product-family)
+					     (, product-name)))
+		 (product-add-feature product (, feature))
+		 (if (equal '(, product-version) (product-version product))
+		     product
+		   (vector (, product-name) (, product-family)
+			   '(, product-version) (, product-code-name)
+			   nil nil nil (, product-version-string)))))
+	  (, feature-def)))))
+
+(defun product-string-1 (product &optional verbose)
+  "Return information of PRODUCT as a string of \"NAME/VERSION\".
+If optional argument VERBOSE is non-nil, then return string of
+\"NAME/VERSION (CODE-NAME)\"."
+  (setq product (product-find product))
+  (concat (product-name product)
+	  (cond
+	   ((product-version-string product)
+	    (concat "/" (product-version-string product)))
+	   ((product-version product)
+	    (concat "/"
+		    (product-set-version-string
+		     product
+		     (mapconcat (function number-to-string)
+				(product-version product)
+				"."))))
+	   (""))
+	  (if (and verbose (product-code-name product))
+	      (concat " (" (product-code-name product) ")")
+	    "")))
+
+(defun product-for-each (product all function &rest args)
+  "Apply FUNCTION to PRODUCT and PRODUCT's family with ARGS.
+If ALL is nil, apply function to only products which provide feature."
+  (setq product (product-find product))
+  (let ((family (product-family-products product)))
+    (and (or all (product-features product))
+	 (apply function product args))
+    (while family
+      (apply 'product-for-each (car family) all function args)
+      (setq family (cdr family)))))
+
+(defun product-string (product)
+  "Return information of PRODUCT as a string of \"NAME/VERSION\"."
+  (let (dest)
+    (product-for-each product nil
+     (function
+      (lambda (product)
+	(let ((str (product-string-1 product nil)))
+	  (if str
+	      (setq dest (if dest
+			     (concat dest " " str)
+			   str)))))))
+    dest))
+
+(defun product-string-verbose (product)
+  "Return information of PRODUCT as a string of \"NAME/VERSION (CODE-NAME)\"."
+  (let (dest)
+    (product-for-each product nil
+     (function
+      (lambda (product)
+	(let ((str (product-string-1 product t)))
+	  (if str
+	      (setq dest (if dest
+			     (concat dest " " str)
+			   str)))))))
+    dest))
+
+(defun product-version-compare (v1 v2)
+  "Compare version of product."
+  (while (and v1 v2 (= (car v1) (car v2)))
+    (setq v1 (cdr v1)
+	  v2 (cdr v2)))
+  (if v1 (if v2 (- (car v1) (car v2)) 1) (if v2 -1 0)))
+
+(defun product-version>= (product require-version)
+  (>= (product-version-compare (product-version (product-find product))
+			       require-version)
+      0))
+
+(defun product-list-products ()
+  "List all products information."
+  (let (dest)
+    (mapatoms
+     (function
+      (lambda (sym)
+	(setq dest (cons (symbol-value sym) dest))))
+     product-obarray)
+    dest))
+
+(defun product-parse-version-string (verstr)
+  "Parse version string \".*v1.v2... (CODE-NAME)\".
+Return list of version, code-name, and version-string."
+  (let (version version-string code-name)
+    (and (string-match "\\(\\([0-9.]+\\)[^ ]*\\)[^(]*\\((\\(.+\\))\\)?" verstr)
+	 (let ((temp (substring verstr (match-beginning 2) (match-end 2))))
+	   (setq version-string (substring verstr
+					   (match-beginning 1)
+					   (match-end 1))
+		 code-name (and (match-beginning 4)
+				(substring verstr
+					   (match-beginning 4)
+					   (match-end 4))))
+	   (while (string-match "^\\([0-9]+\\)\\.?" temp)
+	     (setq version (cons (string-to-number
+				  (substring temp
+					     (match-beginning 1)
+					     (match-end 1)))
+				 version)
+		   temp (substring temp (match-end 0))))))
+    (list (nreverse version) code-name version-string)))
+
+;;; @ End.
+;;;
+
+(provide 'product)			; beware of circular dependency.
+(require 'apel-ver)			; these two files depend on each other.
+(product-provide 'product 'apel-ver)
+
+;;; @ Define emacs versions.
+
+;;(or (product-find "emacs")
+;;    (progn
+;;      (product-define "emacs")
+;;      (cond
+;;       ((featurep 'meadow)
+;;	(let* ((info (product-parse-version-string (Meadow-version)))
+;;	       (version (nth 0 info))
+;;	       (code-name (nth 1 info))
+;;	       (version-string (nth 2 info)))
+;;	  (product-set-version-string
+;;	   (product-define "Meadow" "emacs" version code-name)
+;;	   version-string)
+;;	  (product-provide 'Meadow "Meadow"))
+;;	(and (featurep 'mule)
+;;	     (let* ((info (product-parse-version-string mule-version))
+;;		    (version (nth 0 info))
+;;		    (code-name (nth 1 info))
+;;		    (version-string (nth 2 info)))
+;;	       (product-set-version-string
+;;		(product-define "MULE" "Meadow" version code-name)
+;;		version-string)
+;;	       (product-provide 'mule "MULE")))
+;;	(let* ((info (product-parse-version-string emacs-version))
+;;	       (version (nth 0 info))
+;;	       (code-name (nth 1 info))
+;;	       (version-string (nth 2 info)))
+;;	  (product-set-version-string
+;;	   (product-define "Emacs" "Meadow" version code-name)
+;;	   version-string)
+;;	  (product-provide 'emacs "Emacs")))
+;;       )))
+
+;;; product.el ends here