elmo/elmo-date.el

   1 ;;; elmo-date.el --- Date processing module for ELMO.
   2
   3 ;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
   4
   5 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
   6 ;; Keywords: mail, net news
   7
   8 ;; This file is part of ELMO (Elisp Library for Message Orchestration).
   9
  10 ;; This program is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14 ;;
  15 ;; This program is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19 ;;
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24 ;;
  25
  26 ;;; Commentary:
  27 ;;
  28
  29 ;;; Code:
  30 ;;
  31
  32
  33 (require 'path-util)
  34 (require 'timezone)
  35 (require 'elmo-vars)
  36 (eval-when-compile (require 'cl))
  37
  38 (defmacro elmo-match-substring (pos string from)
  39   "Substring of POSth matched string of STRING."
  40   `(substring ,string
  41               (+ (match-beginning ,pos) ,from)
  42               (match-end ,pos)))
  43
  44 (defmacro elmo-match-string (pos string)
  45   "Substring POSth matched STRING."
  46   `(substring ,string (match-beginning ,pos) (match-end ,pos)))
  47
  48 (defmacro elmo-match-buffer (pos)
  49   "Substring POSth matched from the current buffer."
  50   `(buffer-substring-no-properties
  51     (match-beginning ,pos) (match-end ,pos)))
  52
  53 ;; from subr.el
  54 (defun elmo-replace-in-string (str regexp newtext &optional literal)
  55   "Replace all matches in STR for REGEXP with NEWTEXT string.
  56 And returns the new string.
  57 Optional LITERAL non-nil means do a literal replacement.
  58 Otherwise treat \\ in NEWTEXT string as special:
  59   \\& means substitute original matched text,
  60   \\N means substitute match for \(...\) number N,
  61   \\\\ means insert one \\."
  62   (let ((rtn-str "")
  63         (start 0)
  64         (special)
  65         match prev-start)
  66     (while (setq match (string-match regexp str start))
  67       (setq prev-start start
  68             start (match-end 0)
  69             rtn-str
  70             (concat
  71              rtn-str
  72              (substring str prev-start match)
  73              (cond (literal newtext)
  74                    (t (mapconcat
  75                        (function
  76                         (lambda (c)
  77                           (if special
  78                               (progn
  79                                 (setq special nil)
  80                                 (cond ((eq c ?\\) "\\")
  81                                       ((eq c ?&)
  82                                        (elmo-match-string 0 str))
  83                                       ((and (>= c ?0) (<= c ?9))
  84                                        (if (> c (+ ?0 (length
  85                                                        (match-data))))
  86                                            ;; Invalid match num
  87                                            (error "Invalid match num: %c" c)
  88                                          (setq c (- c ?0))
  89                                          (elmo-match-string c str)))
  90                                       (t (char-to-string c))))
  91                             (if (eq c ?\\) (progn (setq special t) nil)
  92                               (char-to-string c)))))
  93                        newtext ""))))))
  94     (concat rtn-str (substring str start))))
  95
  96 (defvar elmo-date-descriptions
  97   '((yesterday . [0 0 1])
  98     (lastweek  . [0 0 7])
  99     (lastmonth . [0 1 0])
 100     (lastyear  . [1 0 0])))
 101
 102 (defun elmo-date-get-description (datevec)
 103   (format "%d-%s-%d"
 104           (aref datevec 2)
 105           (car (rassq (aref datevec 1)
 106                       timezone-months-assoc))
 107           (aref datevec 0)))
 108
 109 (defun elmo-date-get-datevec (description)
 110   (cond
 111    ((not elmo-date-match)
 112     (error "Date match is not available"))
 113    ((string-match "^[ \t]*\\([0-9]+\\)?[ \t]*\\([a-zA-Z]+\\)$" description)
 114     (let ((today
 115            (save-match-data
 116              (timezone-fix-time (current-time-string) (current-time-zone)
 117                                 nil)))
 118           (number
 119            (string-to-number
 120             (if (match-beginning 1)
 121                 (elmo-match-string 1 description)
 122               "0")))
 123           (suffix (downcase (elmo-match-string 2 description)))
 124           pair)
 125       (if (setq pair (assq (intern suffix) elmo-date-descriptions))
 126           (elmo-datevec-substitute today (cdr pair))
 127         (if (string= "daysago" suffix)
 128             (elmo-date-get-offset-datevec today number)
 129           (error "%s is not supported yet" suffix)))))
 130    ((string-match "[0-9]+-[A-Za-z]+-[0-9]+" description)
 131     (timezone-fix-time
 132      (concat (elmo-replace-in-string description "-" " ") " 0:0")
 133      (current-time-zone) nil))
 134    ((string-match "\\([0-9]+\\)-\\([0-9]+\\)-\\([0-9]+\\)" description)
 135     (vector (string-to-number (match-string 1 description))
 136             (string-to-number (match-string 2 description))
 137             (string-to-number (match-string 3 description))
 138             0 0 0
 139             (current-time-zone)))))
 140
 141 (defun elmo-datevec-substitute (datevec1 datevec2)
 142   (if (/= (aref datevec2 2) 0)
 143       (elmo-date-get-offset-datevec datevec1 (aref datevec2 2))
 144     (let ((year (- (aref datevec1 0) (aref datevec2 0)))
 145           (month (- (aref datevec1 1) (aref datevec2 1)))
 146           (timezone (current-time-zone)))
 147       (while (<= month 0)
 148         (setq year (1- year)
 149               month (+ 12 month)))
 150       (timezone-fix-time
 151        (format "%d %s %d 0:00 %s"
 152                (aref datevec1 2)
 153                (car (rassq month timezone-months-assoc))
 154                year
 155                (cadr timezone)) nil nil))))
 156
 157 (defun elmo-date-get-week (year month mday)
 158   (let ((wday (symbol-value (intern (format
 159                                      "elmo-weekday-name-%s"
 160                                      elmo-lang))))
 161         y1 days p)
 162     (setq y1 (- year 1))
 163     (setq days (- (+ (* y1 365) (/ y1 400) (/ y1 4)) (/ y1 100)))
 164     (setq p 1)
 165     (while (< p month)
 166       (setq days (+ days (timezone-last-day-of-month p year)))
 167       (setq p (+ p 1)))
 168     (setq days (+ days mday))
 169     (aref wday (% days 7))))
 170
 171 (defun elmo-date-get-offset-datevec (datevec offset &optional time)
 172   (let ((year  (aref datevec 0))
 173         (month (aref datevec 1))
 174         (day   (aref datevec 2))
 175         (hour     (aref datevec 3))
 176         (minute   (aref datevec 4))
 177         (second   (aref datevec 5))
 178         (timezone (aref datevec 6))
 179         day-number p
 180         day-of-month)
 181     (setq p 1)
 182     (setq day-number (- (timezone-day-number month day year)
 183                         offset))
 184     (while (<= day-number 0)
 185       (setq year (1- year)
 186             day-number (+ (timezone-day-number 12 31 year)
 187                           day-number)))
 188     (while (> day-number (setq day-of-month
 189                                (timezone-last-day-of-month p year)))
 190       (setq day-number (- day-number day-of-month))
 191       (setq p (1+ p)))
 192     (setq month p)
 193     (setq day day-number)
 194     (timezone-fix-time
 195      (format "%d %s %d %s %s"
 196              day
 197              (car (rassq month timezone-months-assoc))
 198              year
 199              (if time
 200                  (format "%d:%d:%d" hour minute second)
 201                "0:00")
 202              (cadr timezone)) nil nil)))
 203
 204 (defmacro elmo-date-make-sortable-string (datevec)
 205   "Make a sortable string from DATEVEC."
 206   `(timezone-make-sortable-date
 207     (aref ,datevec 0)
 208     (aref ,datevec 1)
 209     (aref ,datevec 2)
 210     (timezone-make-time-string
 211      (aref ,datevec 3)
 212      (aref ,datevec 4)
 213      (aref ,datevec 5))))
 214
 215 (defsubst elmo-datevec-to-time (datevec)
 216   (encode-time (aref datevec 5) (aref datevec 4) (aref datevec 3)
 217                (aref datevec 2) (aref datevec 1) (aref datevec 0)
 218                (aref datevec 6)))
 219
 220 (defun elmo-time-parse-date-string (date)
 221   (ignore-errors
 222    (elmo-datevec-to-time (timezone-fix-time date nil nil))))
 223
 224 (defun elmo-time-make-date-string (time)
 225   (let ((system-time-locale "C"))
 226     (format-time-string "%a, %d %b %Y %T %z" time)))
 227
 228 (defun elmo-time-less-p (lhs rhs)
 229   (while (and (car lhs) (car rhs))
 230     (cond ((< (car lhs) (car rhs))
 231            (setq lhs nil))
 232           ((= (car lhs) (car rhs))
 233            (setq lhs (cdr lhs)
 234                  rhs (cdr rhs)))
 235           (t
 236            (setq rhs nil))))
 237   (not (null rhs)))
 238
 239 (defalias 'elmo-time< 'elmo-time-less-p)
 240
 241 (defun elmo-time-to-days (time)
 242   (let ((date (decode-time time)))
 243     (timezone-absolute-from-gregorian
 244      (nth 4 date) (nth 3 date) (nth 5 date))))
 245
 246 ;; from timezone-fix-time in `timezone.el'
 247 (defun elmo-time-to-datevec (time &optional timezone)
 248   (when time
 249     (let* ((date   (decode-time time))
 250            (year   (nth 5 date))
 251            (month  (nth 4 date))
 252            (day    (nth 3 date))
 253            (hour   (nth 2 date))
 254            (minute (nth 1 date))
 255            (second (nth 0 date))
 256            (local  (nth 8 date))
 257            (timezone
 258             (or timezone
 259                 (timezone-time-zone-from-absolute
 260                  (timezone-absolute-from-gregorian month day year)
 261                  (+ second (* 60 (+ minute (* 60 hour)))))))
 262            (diff   (- (timezone-zone-to-minute timezone) (/ local 60)))
 263            (minute (+ minute diff))
 264            (hour-fix (floor minute 60)))
 265       (setq hour (+ hour hour-fix))
 266       (setq minute (- minute (* 60 hour-fix)))
 267       ;; HOUR may be larger than 24 or smaller than 0.
 268       (cond ((<= 24 hour)                       ;24 -> 00
 269              (setq hour (- hour 24))
 270              (setq day  (1+ day))
 271              (when (< (timezone-last-day-of-month month year) day)
 272                (setq month (1+ month))
 273                (setq day 1)
 274                (when (< 12 month)
 275                  (setq month 1)
 276                  (setq year (1+ year)))))
 277             ((> 0 hour)
 278              (setq hour (+ hour 24))
 279              (setq day  (1- day))
 280              (when (> 1 day)
 281                (setq month (1- month))
 282                (when (> 1 month)
 283                  (setq month 12)
 284                  (setq year (1- year)))
 285                (setq day (timezone-last-day-of-month month year)))))
 286       (vector year month day hour minute second timezone))))
 287
 288 (require 'product)
 289 (product-provide (provide 'elmo-date) (require 'elmo-version))
 290
 291 ;;; elmo-date.el ends here