X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fparse-time.el;h=bbbf3d734734ce54328f5a53f9398c840f963c17;hp=a6d69696a1accd0a29e03bf1c8fa0f161710ac32;hb=0fe9cacd4c2b5cc8f12f994655f90b632be452ee;hpb=9a8731d6dea8021a10dec1b42f382609336a9aa9 diff --git a/lisp/parse-time.el b/lisp/parse-time.el index a6d69696a..bbbf3d734 100644 --- a/lisp/parse-time.el +++ b/lisp/parse-time.el @@ -1,7 +1,6 @@ ;;; parse-time.el --- parsing time strings -;; Copyright (C) 1996, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, -;; 2008, 2009, 2010 Free Software Foundation, Inc. +;; Copyright (C) 1996, 2000-2014 Free Software Foundation, Inc. ;; Author: Erik Naggum ;; Keywords: util @@ -35,62 +34,69 @@ ;;; Code: -(eval-when-compile (require 'cl)) ;and ah ain't kiddin' 'bout it - -(defvar parse-time-syntax (make-vector 256 nil)) -(defvar parse-time-digits (make-vector 256 nil)) +(eval-and-compile + (ignore-errors (require 'cl-lib))) +(eval-when-compile + (require 'cl) ;and ah ain't kiddin' 'bout it + (defalias 'parse-time-incf (if (featurep 'cl-lib) 'cl-incf 'incf))) ;; Byte-compiler warnings (defvar parse-time-elt) (defvar parse-time-val) -(unless (aref parse-time-digits ?0) - (loop for i from ?0 to ?9 - do (aset parse-time-digits i (- i ?0)))) - -(unless (aref parse-time-syntax ?0) - (loop for i from ?0 to ?9 - do (aset parse-time-syntax i ?0)) - (loop for i from ?A to ?Z - do (aset parse-time-syntax i ?A)) - (loop for i from ?a to ?z - do (aset parse-time-syntax i ?a)) - (aset parse-time-syntax ?+ 1) - (aset parse-time-syntax ?- -1) - (aset parse-time-syntax ?: ?d)) - -(defsubst digit-char-p (char) - (aref parse-time-digits char)) - -;; Note: the function definition differs from the one in Emacs -;; in order to keep the compatibility with XEmacs. -(defsubst parse-time-string-chars (char) - (and (< char (length parse-time-syntax)) - (aref parse-time-syntax char))) - -(put 'parse-error 'error-conditions '(parse-error error)) -(put 'parse-error 'error-message "Parsing error") - -(defsubst parse-integer (string &optional start end) - "[CL] Parse and return the integer in STRING, or nil if none." - (let ((integer 0) - (digit 0) - (index (or start 0)) - (end (or end (length string)))) - (when (< index end) - (let ((sign (aref string index))) - (if (or (eq sign ?+) (eq sign ?-)) - (setq sign (parse-time-string-chars sign) - index (1+ index)) - (setq sign 1)) - (while (and (< index end) - (setq digit (digit-char-p (aref string index)))) - (setq integer (+ (* integer 10) digit) - index (1+ index))) - (if (/= index end) - (signal 'parse-error `("not an integer" - ,(substring string (or start 0) end))) - (* sign integer)))))) +(eval-and-compile + (if (featurep 'xemacs) + (progn + (defvar parse-time-syntax (make-vector 256 nil)) + (loop for i from ?0 to ?9 + do (aset parse-time-syntax i ?0)) + (loop for i from ?A to ?Z + do (aset parse-time-syntax i ?A)) + (loop for i from ?a to ?z + do (aset parse-time-syntax i ?a)) + (aset parse-time-syntax ?+ 1) + (aset parse-time-syntax ?- -1) + (aset parse-time-syntax ?: ?d) + (defsubst parse-time-string-chars (char) + (and (< char (length parse-time-syntax)) + (aref parse-time-syntax char)))) + (defsubst parse-time-string-chars (char) + (save-match-data + (let (case-fold-search str) + (cond ((eq char ?+) 1) + ((eq char ?-) -1) + ((eq char ?:) ?d) + ((string-match "[[:upper:]]" (setq str (string char))) ?A) + ((string-match "[[:lower:]]" str) ?a) + ((string-match "[[:digit:]]" str) ?0))))))) + +(eval-and-compile + (if (fboundp 'cl-parse-integer) + (defalias 'parse-time-integer 'cl-parse-integer) + (defvar parse-time-digits (make-vector 256 nil)) + (loop for i from ?0 to ?9 + do (aset parse-time-digits i (- i ?0))) + (defun parse-time-integer (string &rest keys) + "[CL] Parse and return the integer in STRING, or nil if none." + (let* ((start (plist-get keys :start)) + (end (or (plist-get keys :end) (length string))) + (integer 0) + (digit 0) + (index (or start 0))) + (when (< index end) + (let ((sign (aref string index))) + (if (or (eq sign ?+) (eq sign ?-)) + (setq sign (parse-time-string-chars sign) + index (1+ index)) + (setq sign 1)) + (while (and (< index end) + (setq digit (aref parse-time-digits + (aref string index)))) + (setq integer (+ (* integer 10) digit) + index (1+ index))) + (if (/= index end) + (error "Not an integer string: `%s'" string) + (* sign integer)))))))) (defun parse-time-tokenize (string) "Tokenize STRING into substrings." @@ -101,15 +107,16 @@ (index 0) (c nil)) (while (< index end) - (while (and (< index end) ;skip invalid characters + (while (and (< index end) ;Skip invalid characters. (not (setq c (parse-time-string-chars (aref string index))))) - (incf index)) + (parse-time-incf index)) (setq start index all-digits (eq c ?0)) - (while (and (< (incf index) end) ;scan valid characters + (while (and (< (parse-time-incf index) end) ;Scan valid characters. (setq c (parse-time-string-chars (aref string index)))) (setq all-digits (and all-digits (eq c ?0)))) (if (<= index end) - (push (if all-digits (parse-integer string start index) + (push (if all-digits (parse-time-integer string + :start start :end index) (substring string start index)) list))) (nreverse list))) @@ -140,7 +147,7 @@ `(((6) parse-time-weekdays) ((3) (1 31)) ((4) parse-time-months) - ((5) (100 4038)) + ((5) (100 ,most-positive-fixnum)) ((2 1 0) ,#'(lambda () (and (stringp parse-time-elt) (= (length parse-time-elt) 8) @@ -156,8 +163,9 @@ (= 5 (length parse-time-elt)) (or (= (aref parse-time-elt 0) ?+) (= (aref parse-time-elt 0) ?-)))) - ,#'(lambda () (* 60 (+ (parse-integer parse-time-elt 3 5) - (* 60 (parse-integer parse-time-elt 1 3))) + ,#'(lambda () (* 60 (+ (parse-time-integer parse-time-elt :start 3 :end 5) + (* 60 (parse-time-integer parse-time-elt + :start 1 :end 3))) (if (= (aref parse-time-elt 0) ?-) -1 1)))) ((5 4 3) ,#'(lambda () (and (stringp parse-time-elt) @@ -202,31 +210,94 @@ unknown are returned as nil." (predicate (pop rule)) (parse-time-val)) (when (and (not (nth (car slots) time)) ;not already set - (setq parse-time-val (cond ((and (consp predicate) - (not (eq (car predicate) - 'lambda))) - (and (numberp parse-time-elt) - (<= (car predicate) parse-time-elt) - (<= parse-time-elt (cadr predicate)) - parse-time-elt)) - ((symbolp predicate) - (cdr (assoc parse-time-elt - (symbol-value predicate)))) - ((funcall predicate))))) + (setq parse-time-val + (cond ((and (consp predicate) + (not (eq (car predicate) + 'lambda))) + (and (numberp parse-time-elt) + (<= (car predicate) parse-time-elt) + (<= parse-time-elt (cadr predicate)) + parse-time-elt)) + ((symbolp predicate) + (cdr (assoc parse-time-elt + (symbol-value predicate)))) + ((funcall predicate))))) (setq exit t) (while slots - (let ((new-val (and rule - (let ((this (pop rule))) - (if (vectorp this) - (parse-integer - parse-time-elt - (aref this 0) (aref this 1)) - (funcall this)))))) - (rplaca (nthcdr (pop slots) time) - (or new-val parse-time-val))))))))) + (let ((new-val (if rule + (let ((this (pop rule))) + (if (vectorp this) + (parse-time-integer + parse-time-elt + :start (aref this 0) + :end (aref this 1)) + (funcall this))) + parse-time-val))) + (rplaca (nthcdr (pop slots) time) new-val)))))))) time)) +(defconst parse-time-iso8601-regexp + (let* ((dash "-?") + (colon ":?") + (4digit "\\([0-9][0-9][0-9][0-9]\\)") + (2digit "\\([0-9][0-9]\\)") + (date-fullyear 4digit) + (date-month 2digit) + (date-mday 2digit) + (time-hour 2digit) + (time-minute 2digit) + (time-second 2digit) + (time-secfrac "\\(\\.[0-9]+\\)?") + (time-numoffset (concat "[-+]\\(" time-hour "\\):" time-minute)) + (time-offset (concat "Z" time-numoffset)) + (partial-time (concat time-hour colon time-minute colon time-second + time-secfrac)) + (full-date (concat date-fullyear dash date-month dash date-mday)) + (full-time (concat partial-time time-offset)) + (date-time (concat full-date "T" full-time))) + (list (concat "^" full-date) + (concat "T" partial-time) + (concat "Z" time-numoffset))) + "List of regular expressions matching ISO 8601 dates. +1st regular expression matches the date. +2nd regular expression matches the time. +3rd regular expression matches the (optional) timezone specification.") + +(defun parse-iso8601-time-string (date-string) + (let* ((date-re (nth 0 parse-time-iso8601-regexp)) + (time-re (nth 1 parse-time-iso8601-regexp)) + (tz-re (nth 2 parse-time-iso8601-regexp)) + re-start + time seconds minute hour fractional-seconds + day month year day-of-week dst tz) + ;; We need to populate 'time' with + ;; (SEC MIN HOUR DAY MON YEAR DOW DST TZ) + + ;; Nobody else handles iso8601 correctly, let's do it ourselves. + (when (string-match date-re date-string re-start) + (setq year (string-to-number (match-string 1 date-string)) + month (string-to-number (match-string 2 date-string)) + day (string-to-number (match-string 3 date-string)) + re-start (match-end 0)) + (when (string-match time-re date-string re-start) + (setq hour (string-to-number (match-string 1 date-string)) + minute (string-to-number (match-string 2 date-string)) + seconds (string-to-number (match-string 3 date-string)) + fractional-seconds (string-to-number (or + (match-string 4 date-string) + "0")) + re-start (match-end 0)) + (when (string-match tz-re date-string re-start) + (setq tz (match-string 1 date-string))) + (setq time (list seconds minute hour day month year day-of-week dst tz)))) + + ;; Fall back to having Gnus do fancy things for us. + (when (not time) + (setq time (parse-time-string date-string))) + + (and time + (apply 'encode-time time)))) + (provide 'parse-time) -;; arch-tag: 07066094-45a8-4c68-b307-86195e2c1103 ;;; parse-time.el ends here