emacs_el/tiny-tools/other/date-parse.el

   1 ;;; date-parse.el --- Parse and sort dates
   2
   3 ;; This file is not part of Emacs
   4
   5 ;;{{{ Id
   6
   7 ;; Copyright (C)    1989 John Rose
   8 ;; Author:          John Rose <rose@think.com>
   9 ;; Maintainer:      none
  10 ;; Packaged-by:     Jari Aalto
  11 ;; Created:         1989-03
  12 ;; Keywords:        extensions
  13
  14 ;; This program is free software; you can redistribute it and/or modify it
  15 ;; under the terms of the GNU General Public License as published by the Free
  16 ;; Software Foundation; either version 2 of the License, or (at your option)
  17 ;; any later version.
  18 ;;
  19 ;; This program is distributed in the hope that it will be useful, but
  20 ;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  21 ;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  22 ;; for more details.
  23 ;;
  24 ;; You should have received a copy of the GNU General Public License
  25 ;; along with program; see the file COPYING. If not, write to the
  26 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  27 ;; Boston, MA 02110-1301, USA.
  28 ;;
  29 ;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
  30
  31 ;;}}}
  32 ;;{{{ Install
  33
  34 ;;; Install:
  35
  36 ;;  Put this file on your Emacs-Lisp load path, add following into your
  37 ;;  ~/.emacs startup file.
  38 ;;
  39 ;;      (require 'date-parse)
  40
  41 ;;}}}
  42 ;;{{{ Commentary
  43
  44 ;;; Commentary:
  45
  46 ;;  Preface, 1989
  47 ;;
  48 ;;      Hacks for reading dates. Something better needs to be done,
  49 ;;      obviously. In the file "dired-resort" are dired commands for
  50 ;;      reordering the buffer by modification time, which is the whole
  51 ;;      purpose of this exercise.
  52 ;;
  53 ;;}}}
  54
  55 ;;; Change Log:
  56
  57 ;;; Code:
  58
  59 (require 'cl-compat) ;; 19.30 'setnth'
  60
  61 (eval-and-compile
  62   (autoload 'sort-subr "sort"))
  63
  64 ;;; ....................................................... &variables ...
  65
  66 (defvar parse-date-indices nil
  67   "List of (START END) from last successful call to parse-date.")
  68
  69 (defconst date-patterns
  70   '(( ;; Sep 29 12:09:55 1986
  71      "[ \t]*\\([A-Za-z]+\\)[. \t]+\\([0-9]+\\)[, \t]+\
  72 \\([0-9]+\\):\\([0-9]+\\):\\([0-9]+\\)[, \t]+\
  73 \\([0-9]+\\)[ \t]*"
  74      6 1 2 nil 3 4 5)
  75     ( ;; Sep 29 12:09
  76      "[ \t]*\\([A-Za-z]+\\)[. \t]+\\([0-9]+\\)[, \t]+\
  77 \\([0-9]+\\):\\([0-9]+\\)[ \t]*"
  78      nil 1 2 nil 3 4)
  79     ( ;; Sep 29 1986
  80      "[ \t]*\\([A-Za-z]+\\)[. \t]+\\([0-9]+\\)[, \t]+\
  81 \\([0-9]+\\)[ \t]*"
  82      3 1 2)
  83     ( ;; Sep 29
  84      "[ \t]*\\([A-Za-z]+\\)[. \t]+\\([0-9]+\\)[ \t]*"
  85      nil 1 2)
  86     ( ;; 2004-10-14 17:23
  87      "^[ \t]*\\([0-9][0-9][0-9][0-9]\\)-\\([0-9][0-9]\\)-\\([0-9][0-9]\\)[ \t]+\
  88 \\([0-9][0-9]\\):\\([0-9][0-9]\\)"
  89      1 2 3 nil 4 5))
  90   "List of (regexp field field ...), each parsing a different style of date.
  91 The fields locate, in order:
  92
  93   1. the year
  94   2. month
  95   3. day
  96   4. weekday,
  97   5. hour
  98   6. minute
  99   7. second
 100   8. and timezone of the date.
 101
 102 Any or all can be null, and the list can be short. Each field is nil,
 103 an integer referring to a regexp field, or a 2-list of an integer and
 104 a string-parsing function which is applied (instead of a default) to
 105 the field string to yield the appropriate integer value.")
 106
 107 ;;; ............................................................ &code ...
 108
 109 (defun parse-date (date &optional exactp nodefault)
 110   "Parse a DATE into a 3-list of year, month, day.
 111 This list may be extended by the weekday,
 112 and then by the hour, minute, second, and timezone
 113 \(if such information is found), making a total of eight list elements.
 114 Optional arg EXACTP means the whole string must hold the date.
 115 Optional NODEFAULT means the date is not defaulted (to the current year).
 116 In any case, if parse-date succeeds, parse-date-indices is set
 117 to the 2-list holding the location of the date within the string."
 118   (if (not (stringp date))
 119       date
 120     (let ((ptr date-patterns)
 121           (string date)
 122           start end)
 123       (and (or (string= string "now")
 124                (string= string "today"))
 125            (setq string (current-time-string)
 126                  exactp nil))
 127       (setq date nil)
 128       (while ptr
 129         (let ((pat (car (car ptr)))
 130               (fields (cdr (car ptr))))
 131           (if (setq start (string-match pat string))
 132               (setq end (match-end 0)))
 133           (and start
 134                exactp
 135                (or (plusp start)
 136                    (< end (length string)))
 137                (setq start nil))
 138           (setq ptr (cdr ptr))
 139           (if start
 140               ;; First extract the strings,
 141               ;; and decide which parsers to call.
 142               ;; At this point, the pattern can still fail
 143               ;; if a parser returns nil.
 144               (let ((strs nil)
 145                     (fns nil)
 146                     (default-fns
 147                       '(parse-date-year
 148                         parse-date-month
 149                         nil ;;day
 150                         parse-date-weekday
 151                         nil nil nil ;;hhmmss
 152                         parse-date-timezone)))
 153                 (while fields
 154                   (let ((field (car fields))
 155                         (fn (car default-fns)))
 156                     (setq fields (cdr fields)
 157                           default-fns (cdr default-fns))
 158                     ;; Allow field to be either 3 or (3 string-to-int)
 159                     (if (listp field)
 160                         (setq field (car field)
 161                               fn (car (cdr field))))
 162                     (setq strs
 163                           (cons
 164                            (cond
 165                             ((null field) nil)
 166                             ((integerp field)
 167                              (substring
 168                               string
 169                               (match-beginning field)
 170                               (match-end field)))
 171                             (t field))
 172                            strs))
 173                     (setq fns (cons (or fn 'string-to-int) fns))))
 174                 ;; Now parse them:
 175                 (setq strs (nreverse strs)
 176                       fns (nreverse fns))
 177                 (setq date strs) ;; Will replace cars.
 178                 (while strs
 179                   (if (car strs)
 180                       (setcar strs
 181                               (or (funcall (car fns) (car strs))
 182                                   (setq date nil strs nil))))
 183                   (setq strs (cdr strs) fns (cdr fns)))
 184                 ;; Break the while?
 185                 (if date
 186                     (setq ptr nil))))))
 187       (or nodefault
 188           (null date)
 189           (setq date (default-date-list date)))
 190       (if date
 191           (setq parse-date-indices (list start end)))
 192       date)))
 193
 194 ;; FIXME: Yuck. We only default the year.
 195 (defun default-date-list (date)
 196   "Return DATE list."
 197   (let ((now nil))
 198     ;; If the year is missing, default it to this year or last year,
 199     ;; whichever is closer.
 200     (or (nth 0 date)
 201         (let ((year (nth 0 (or now (setq now (parse-date "now" t t)))))
 202               (diff (* 30 (- (nth 1 date) (nth 1 now)))))
 203           (if (zerop diff)
 204               (setq diff (- (nth 2 date) (nth 2 now))))
 205           (if (> diff 7)
 206               (setq year (1- year)))
 207           (setnth 0 date year)))
 208     date))
 209
 210 ;; Date field parsers:
 211
 212 (defun parse-date-month (month)
 213   "Parse MONTH."
 214   (if (not (stringp month))
 215       month
 216     (let ((sym 'parse-date-month-obarray))
 217       ;; This guy's memoized:
 218       (or (boundp sym) (set sym nil))
 219       (setq sym (intern month
 220                         (or (symbol-value sym)
 221                             (set sym (make-vector 51 0)))))
 222       (or (boundp sym)
 223           (let ((try nil)
 224                 (key (downcase month)))
 225             (or try
 226                 (plusp (setq try (string-to-int month)))
 227                 (setq try nil))
 228             (or try
 229                 (let ((ptr '("january" "february" "march" "april"
 230                              "may" "june" "july" "august"
 231                              "september" "october" "november" "december"))
 232                       (idx 1))
 233                   (while ptr
 234                     (if (eql 0 (string-match key (car ptr)))
 235                         (setq try idx ptr nil)
 236                       (setq idx (1+ idx) ptr (cdr ptr))))))
 237             (or try
 238                 (if (string= key "jly")
 239                     (setq try 7)))
 240             (and try
 241                  (or (> try 12)
 242                      (< try 1))
 243                  (setq try nil))
 244             (set sym try)))
 245       (symbol-value sym))))
 246
 247 (defun parse-date-year (year)
 248   "Parse YEAR."
 249   (if (not (stringp year))
 250       year
 251     (setq year (string-to-int year))
 252     (cond
 253      ((> year 9999) nil)
 254      ((<= year 0) nil)
 255      ((> year 100) year)
 256      (t (+ year 1900)))))
 257
 258 ;; Other functions:
 259
 260 (defun date-compare-key (date &optional integer-p)
 261   "Map DATE to strings preserving ordering.
 262 If optional INTEGER-P is true, yield an integer instead of a string.
 263 In that case, the granularity is minutes, not seconds,
 264 and years must be in this century."
 265   (or (consp date) (setq date (parse-date date)))
 266   (let ((year (- (nth 0 date) 1900))
 267         (month (- (nth 1 date) 1))
 268         (day (- (nth 2 date) 1))
 269         (hour (or (nth 4 date) 0))
 270         (minute (or (nth 5 date) 0))
 271         (second (or (nth 6 date) 0)))
 272     (if integer-p
 273         (+ (* (+ (* year 366) (* month 31) day)
 274               (* 24 60))
 275            (* hour 60)
 276            minute)
 277       ;; Else yield a string, which encodes everything:
 278       (let* ((sz (zerop second))
 279              (mz (and sz (zerop minute)))
 280              (hz (and mz (zerop hour)))
 281              (fmt
 282               (cond
 283                ((minusp year)
 284                 (setq year (+ year 1900))
 285                 (cond (hz "-%04d%c%c")
 286                       (mz "-%04d%c%c%c")
 287                       (sz "-%04d%c%c%c%02d")
 288                       (t "-%04d%c%c%c%02d%02d")))
 289                ((> year 99)
 290                 (setq year (+ year 1900))
 291                 (cond (hz "/%04d%c%c")
 292                       (mz "/%04d%c%c%c")
 293                       (sz "/%04d%c%c%c%02d")
 294                       (t "/%04d%c%c%c%02d%02d")))
 295                (hz "%02d%c%c")
 296                (mz "%02d%c%c%c")
 297                (sz "%02d%c%c%c%02d")
 298                (t "%02d%c%c%c%02d%02d"))))
 299         (setq month (+ month ?A) day (+ day ?a))
 300         (setq hour (+ hour ?A))
 301         (format fmt year month day hour minute second)))))
 302
 303 (defun date-lessp (date1 date2)
 304   "Compare DATE1 to DATE2 (which may be unparsed strings or parsed date lists).
 305 Equivalent to (string< (date-compare-key date1) (date-compare-key date2))."
 306   (or (consp date1) (setq date1 (parse-date date1)))
 307   (or (consp date2) (setq date2 (parse-date date2)))
 308   (catch 'return
 309     (let ((check (function (lambda (n1 n2)
 310                              (or n1 (setq n1 0))
 311                              (or n2 (setq n2 0))
 312                              (cond ((< n1 n2) (throw 'return t))
 313                                    ((> n1 n2) (throw 'return nil)))))))
 314       (funcall check (nth 0 date1) (nth 0 date2))
 315       (funcall check (nth 1 date1) (nth 1 date2))
 316       (funcall check (nth 2 date1) (nth 2 date2))
 317       (funcall check (nth 4 date1) (nth 4 date2))
 318       (funcall check (nth 5 date1) (nth 5 date2))
 319       (funcall check (nth 6 date1) (nth 6 date2))
 320       nil)))
 321
 322 (defun sort-date-fields (reverse beg end)
 323   "Sort lines in region by date value; argument means descending order.
 324 Called from a program, there are three required arguments:
 325 REVERSE (non-nil means reverse order), BEG and END (region to sort)."
 326   (interactive "P\nr")
 327   (save-restriction
 328     (narrow-to-region beg end)
 329     (goto-char (point-min))
 330     (sort-subr
 331      reverse 'forward-line 'end-of-line
 332      (function
 333       (lambda ()
 334         (date-compare-key
 335          (or (parse-date
 336               (buffer-substring (point) (progn (end-of-line) (point))))
 337              (throw 'key nil))))))))
 338
 339 (provide 'date-parse)
 340
 341 ;;; date-parse.el ends here