Source

apel / product.el

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
;;; product.el --- Functions for product version information.

;; Copyright (C) 1999 Free Software Foundation, Inc.

;; 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 checker 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 a product to a family.
FAMILY is a product structure which returned by `product-define'.
PRODUCT-NAME is a string of the product's name ."
  (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 a product from a family.
FAMILY is a product string which returned by `product-define'.
PRODUCT-NAME is a string of the product's name."
  (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 checker function(s) to a product.
PRODUCT is a product structure which returned by `product-define'.
The rest arguments CHECKERS should be functions.  These functions
are regist to the product's checkers list, and will be called by
 `product-run-checkers'.
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 checker function(s) from a product.
PRODUCT is a product structure which returned by `product-define'.
The rest arguments CHECKERS should be functions.  These functions removed
from the product's checkers list."
  (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 a feature to the features list of a product.
PRODUCT is a product structure which returned by `product-define'.
FEATURE is a feature in the PRODUCT's."
  (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 a feature from the features list of a product.
PRODUCT is a product structure which returned by `product-define'.
FEATURE is a feature which registered in the products 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.
PRODUCT is a product structure which returned by `product-define'.
VERSION is target version.
If optional 3rd 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)
  "Find product by name and return a product structure.
NAME is a string of the product's name."
  (symbol-value (intern-soft name product-obarray)))

(defun product-find-by-feature (feature)
  "Get a product structure of a feature's product.
FEATURE is a symbol of the feature."
  (get feature 'product))

(defun product-find (product)
  "Find product information.
If PRODUCT is a product structure, then return PRODUCT itself.
If PRODUCT is a string, then find product by name and return a
product structure.  If PRODUCT is symbol of feature, then return
the feature's product."
  (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 a feature as a part of product.
FEATURE-DEF is a definition of the feature.
PRODUCT-DEF is a definition of the 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\".
PRODUCT is a product structure which returned by `product-define'.
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 int-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 a function to a product and the product's family with args.
PRODUCT is a product structure which returned by `product-define'.
If ALL is nil, apply function to only products which provided feature.
FUNCTION is a function.  The function called with following arguments.
The 1st argument is a product structure.  The rest arguments are ARGS."
  (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\".
PRODUCT is a product structure which returned by `product-define'."
  (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)\".
PRODUCT is a product structure which returned by `product-define'."
  (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 two versions.
Return an integer greater than, equal to, or less than 0,
according as the version V1 is greater than, equal to, or less
than the version V2.
Both V1 and V2 are a list of integer(s) respectively."
  (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)
  "Compare product version with required version.
PRODUCT is a product structure which returned by `product-define'.
REQUIRE-VERSION is a list of integer."
  (>= (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.
VERSTR is a 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.
;;;

(require 'pym)

(defconst-maybe emacs-major-version
  (progn (string-match "^[0-9]+" emacs-version)
	 (string-to-int (substring emacs-version
				   (match-beginning 0)(match-end 0))))
  "Major version number of this version of Emacs.")
(defconst-maybe emacs-minor-version
  (progn (string-match "^[0-9]+\\.\\([0-9]+\\)" emacs-version)
	 (string-to-int (substring emacs-version
				   (match-beginning 1)(match-end 1))))
  "Minor version number of this version of Emacs.")

;;(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
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.