Mercurial > emacs

comparison lisp/gnus/parse-time.el @ 31716:9968f55ad26e

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Update to emacs-21-branch of the Gnus CVS repository.
author Gerd Moellmann <gerd@gnu.org>
date Tue, 19 Sep 2000 13:37:09 +0000
parents a0e2fa7d8bb7
children a26d9b55abb6
comparison
equal deleted inserted replaced
31715:7c896543d225 31716:9968f55ad26e
1 ;;; parse-time.el --- Parsing time strings 1 ;;; parse-time.el --- Parsing time strings
2 2
3 ;; Copyright (C) 1996 by Free Software Foundation, Inc. 3 ;; Copyright (C) 1996, 2000 by Free Software Foundation, Inc.
4 4
5 ;; Author: Erik Naggum <erik@naggum.no> 5 ;; Author: Erik Naggum <erik@naggum.no>
6 ;; Keywords: util 6 ;; Keywords: util
7 7
8 ;; This file is part of GNU Emacs. 8 ;; This file is part of GNU Emacs.
34 ;; string are returned as nil. `encode-time' may be applied on these 34 ;; string are returned as nil. `encode-time' may be applied on these
35 ;; valuse to obtain an internal time value. 35 ;; valuse to obtain an internal time value.
36 36
37 ;;; Code: 37 ;;; Code:
38 38
39 (eval-when-compile (require 'cl)) ;and ah ain't kiddin' 'bout it 39 (eval-when-compile (require 'cl)) ;and ah ain't kiddin' 'bout it
40 40
41 (put 'parse-time-syntax 'char-table-extra-slots 0) 41 (defvar parse-time-syntax (make-vector 256 nil))
42 42 (defvar parse-time-digits (make-vector 256 nil))
43 (defvar parse-time-syntax (make-char-table 'parse-time-syntax))
44 (defvar parse-time-digits (make-char-table 'parse-time-syntax))
45 43
46 ;; Byte-compiler warnings 44 ;; Byte-compiler warnings
47 (defvar elt) 45 (defvar elt)
48 (defvar val) 46 (defvar val)
49 47
50 (unless (aref parse-time-digits ?0) 48 (unless (aref parse-time-digits ?0)
51 (loop for i from ?0 to ?9 49 (loop for i from ?0 to ?9
52 do (set-char-table-range parse-time-digits i (- i ?0)))) 50 do (aset parse-time-digits i (- i ?0))))
53 51
54 (unless (aref parse-time-syntax ?0) 52 (unless (aref parse-time-syntax ?0)
55 (loop for i from ?0 to ?9 53 (loop for i from ?0 to ?9
56 do (set-char-table-range parse-time-syntax i ?0)) 54 do (aset parse-time-syntax i ?0))
57 (loop for i from ?A to ?Z 55 (loop for i from ?A to ?Z
58 do (set-char-table-range parse-time-syntax i ?A)) 56 do (aset parse-time-syntax i ?A))
59 (loop for i from ?a to ?z 57 (loop for i from ?a to ?z
60 do (set-char-table-range parse-time-syntax i ?a)) 58 do (aset parse-time-syntax i ?a))
61 (set-char-table-range parse-time-syntax ?+ 1) 59 (aset parse-time-syntax ?+ 1)
62 (set-char-table-range parse-time-syntax ?- -1) 60 (aset parse-time-syntax ?- -1)
63 (set-char-table-range parse-time-syntax ?: ?d) 61 (aset parse-time-syntax ?: ?d)
64 ) 62 )
65 63
66 (defsubst digit-char-p (char) 64 (defsubst digit-char-p (char)
67 (aref parse-time-digits char)) 65 (aref parse-time-digits char))
68 66
87 (while (and (< index end) 85 (while (and (< index end)
88 (setq digit (digit-char-p (aref string index)))) 86 (setq digit (digit-char-p (aref string index))))
89 (setq integer (+ (* integer 10) digit) 87 (setq integer (+ (* integer 10) digit)
90 index (1+ index))) 88 index (1+ index)))
91 (if (/= index end) 89 (if (/= index end)
92 (signal 'parse-error `("not an integer" ,(substring string (or start 0) end))) 90 (signal 'parse-error `("not an integer"
91 ,(substring string (or start 0) end)))
93 (* sign integer)))))) 92 (* sign integer))))))
94 93
95 (defun parse-time-tokenize (string) 94 (defun parse-time-tokenize (string)
96 "Tokenize STRING into substrings." 95 "Tokenize STRING into substrings."
97 (let ((start nil) 96 (let ((start nil)
112 (push (if all-digits (parse-integer string start index) 111 (push (if all-digits (parse-integer string start index)
113 (substring string start index)) 112 (substring string start index))
114 list))) 113 list)))
115 (nreverse list))) 114 (nreverse list)))
116 115
117 (defvar parse-time-months '(("Jan" . 1) ("Feb" . 2) ("Mar" . 3) 116 (defvar parse-time-months '(("jan" . 1) ("feb" . 2) ("mar" . 3)
118 ("Apr" . 4) ("May" . 5) ("Jun" . 6) 117 ("apr" . 4) ("may" . 5) ("jun" . 6)
119 ("Jul" . 7) ("Aug" . 8) ("Sep" . 9) 118 ("jul" . 7) ("aug" . 8) ("sep" . 9)
120 ("Oct" . 10) ("Nov" . 11) ("Dec" . 12))) 119 ("oct" . 10) ("nov" . 11) ("dec" . 12)))
121 (defvar parse-time-weekdays '(("Sun" . 0) ("Mon" . 1) ("Tue" . 2) 120 (defvar parse-time-weekdays '(("sun" . 0) ("mon" . 1) ("tue" . 2)
122 ("Wed" . 3) ("Thu" . 4) ("Fri" . 5) ("Sat" . 6))) 121 ("wed" . 3) ("thu" . 4) ("fri" . 5) ("sat" . 6)))
123 (defvar parse-time-zoneinfo `(("Z" 0) ("UT" 0) ("GMT" 0) 122 (defvar parse-time-zoneinfo `(("z" 0) ("ut" 0) ("gmt" 0)
124 ("PST" ,(* -8 3600)) ("PDT" ,(* -7 3600) t) 123 ("pst" ,(* -8 3600)) ("pdt" ,(* -7 3600) t)
125 ("MST" ,(* -7 3600)) ("MDT" ,(* -6 3600) t) 124 ("mst" ,(* -7 3600)) ("mdt" ,(* -6 3600) t)
126 ("CST" ,(* -6 3600)) ("CDT" ,(* -5 3600) t) 125 ("cst" ,(* -6 3600)) ("cdt" ,(* -5 3600) t)
127 ("EST" ,(* -5 3600)) ("EDT" ,(* -4 3600) t)) 126 ("est" ,(* -5 3600)) ("edt" ,(* -4 3600) t))
128 "(zoneinfo seconds-off daylight-savings-time-p)") 127 "(zoneinfo seconds-off daylight-savings-time-p)")
129 128
130 (defvar parse-time-rules 129 (defvar parse-time-rules
131 `(((6) parse-time-weekdays) 130 `(((6) parse-time-weekdays)
132 ((3) (1 31)) 131 ((3) (1 31))
133 ((4) parse-time-months) 132 ((4) parse-time-months)
134 ((5) (1970 2038)) 133 ((5) (100 4038))
135 ((2 1 0) 134 ((2 1 0)
136 ,#'(lambda () (and (stringp elt) 135 ,#'(lambda () (and (stringp elt)
137 (= (length elt) 8) 136 (= (length elt) 8)
138 (= (aref elt 2) ?:) 137 (= (aref elt 2) ?:)
139 (= (aref elt 5) ?:))) 138 (= (aref elt 5) ?:)))
148 (or (= (aref elt 0) ?+) (= (aref elt 0) ?-)))) 147 (or (= (aref elt 0) ?+) (= (aref elt 0) ?-))))
149 ,#'(lambda () (* 60 (+ (parse-integer elt 3 5) 148 ,#'(lambda () (* 60 (+ (parse-integer elt 3 5)
150 (* 60 (parse-integer elt 1 3))) 149 (* 60 (parse-integer elt 1 3)))
151 (if (= (aref elt 0) ?-) -1 1)))) 150 (if (= (aref elt 0) ?-) -1 1))))
152 ((5 4 3) 151 ((5 4 3)
153 ,#'(lambda () (and (stringp elt) (= (length elt) 10) (= (aref elt 4) ?-) (= (aref elt 7) ?-))) 152 ,#'(lambda () (and (stringp elt)
153 (= (length elt) 10)
154 (= (aref elt 4) ?-)
155 (= (aref elt 7) ?-)))
154 [0 4] [5 7] [8 10]) 156 [0 4] [5 7] [8 10])
155 ((2 1) 157 ((2 1 0)
156 ,#'(lambda () (and (stringp elt) (= (length elt) 5) (= (aref elt 2) ?:))) 158 ,#'(lambda () (and (stringp elt) (= (length elt) 5) (= (aref elt 2) ?:)))
157 [0 2] [3 5]) 159 [0 2] [3 5] ,#'(lambda () 0))
158 ((5) (70 99) ,#'(lambda () (+ 1900 elt)))) 160 ((2 1 0)
161 ,#'(lambda () (and (stringp elt)
162 (= (length elt) 4)
163 (= (aref elt 1) ?:)))
164 [0 1] [2 4] ,#'(lambda () 0))
165 ((2 1 0)
166 ,#'(lambda () (and (stringp elt)
167 (= (length elt) 7)
168 (= (aref elt 1) ?:)))
169 [0 1] [2 4] [5 7])
170 ((5) (50 110) ,#'(lambda () (+ 1900 elt)))
171 ((5) (0 49) ,#'(lambda () (+ 2000 elt))))
159 "(slots predicate extractor...)") 172 "(slots predicate extractor...)")
160 173
161 (defun parse-time-string (string) 174 (defun parse-time-string (string)
162 "Parse the time-string STRING into (SEC MIN HOUR DAY MON YEAR DOW DST TZ). 175 "Parse the time-string STRING into (SEC MIN HOUR DAY MON YEAR DOW DST TZ).
163 The values are identical to those of `decode-time', but any values that are 176 The values are identical to those of `decode-time', but any values that are
164 unknown are returned as nil." 177 unknown are returned as nil."
165 (let ((time (list nil nil nil nil nil nil nil nil nil nil)) 178 (let ((time (list nil nil nil nil nil nil nil nil nil))
166 (temp (parse-time-tokenize string))) 179 (temp (parse-time-tokenize (downcase string))))
167 (while temp 180 (while temp
168 (let ((elt (pop temp)) 181 (let ((elt (pop temp))
169 (rules parse-time-rules) 182 (rules parse-time-rules)
170 (exit nil)) 183 (exit nil))
171 (while (and (not (null rules)) (not exit)) 184 (while (and (not (null rules)) (not exit))
172 (let* ((rule (pop rules)) 185 (let* ((rule (pop rules))
173 (slots (pop rule)) 186 (slots (pop rule))
174 (predicate (pop rule)) 187 (predicate (pop rule))
175 (val)) 188 (val))
176 (if (and (not (nth (car slots) time)) ;not already set 189 (when (and (not (nth (car slots) time)) ;not already set
177 (setq val (cond ((and (consp predicate) 190 (setq val (cond ((and (consp predicate)
178 (not (eq (car predicate) 'lambda))) 191 (not (eq (car predicate)
179 (and (numberp elt) 192 'lambda)))
180 (<= (car predicate) elt) 193 (and (numberp elt)
181 (<= elt (cadr predicate)) 194 (<= (car predicate) elt)
182 elt)) 195 (<= elt (cadr predicate))
183 ((symbolp predicate) 196 elt))
184 (cdr (assoc elt (symbol-value predicate)))) 197 ((symbolp predicate)
185 ((funcall predicate))))) 198 (cdr (assoc elt
186 (progn 199 (symbol-value predicate))))
187 (setq exit t) 200 ((funcall predicate)))))
188 (while slots 201 (setq exit t)
189 (let ((new-val (and rule 202 (while slots
190 (let ((this (pop rule))) 203 (let ((new-val (and rule
191 (if (vectorp this) 204 (let ((this (pop rule)))
192 (parse-integer elt (aref this 0) (aref this 1)) 205 (if (vectorp this)
193 (funcall this)))))) 206 (parse-integer
194 (rplaca (nthcdr (pop slots) time) (or new-val val)))))))))) 207 elt (aref this 0) (aref this 1))
208 (funcall this))))))
209 (rplaca (nthcdr (pop slots) time) (or new-val val)))))))))
195 time)) 210 time))
196 211
197 (provide 'parse-time) 212 (provide 'parse-time)
198 213
199 ;;; parse-time.el ends here 214 ;;; parse-time.el ends here