root/lang/commonlisp/xyzzy-compat/timestamp.lisp

;;; -*- Mode: Lisp -*-

;;; License: MIT license.

;;;
;;; This file was part of xyzzy.
;;;

;;; Permission is hereby granted, free of charge, to any person obtaining
;;; a copy of this software and associated documentation files (the
;;; "Software"), to deal in the Software without restriction, including
;;; without limitation the rights to use, copy, modify, merge, publish,
;;; distribute, sublicense, and/or sell copies of the Software, and to
;;; permit persons to whom the Software is furnished to do so, subject to
;;; the following conditions:
;;; 
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;; 
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

;;;
;;; format-date
;;;
;;; a: 短い形式の曜日
;;; A: 長い形式の曜日
;;; b: 短い形式の月
;;; B: 長い形式の月
;;; d: 日(00〜59)                 # (0〜59)
;;; e: 和暦の年(01〜)             # (1〜)
;;; E: 和暦の年(元, 02〜)         # (元, 2〜)
;;; g: 元号(明治,大正,昭和,平成)  # (明,大,昭,平)
;;; G: 元号(M, T, S, H)
;;; H: 時(00〜23)                 # (0〜23)
;;; I: 12時間の時(01〜12)         # (1〜12)
;;; i: Internet Time(000〜999)
;;; m: 月(01〜12)                 # (1〜12)
;;; M: 分(00〜59)                 # (0〜59)
;;; p: 午前/午後
;;; P: AM/PM                      # am/pm
;;; S: 秒(00〜59)                 # (0〜59)
;;; v: 曜日(日本語)
;;; y: 年(2桁)
;;; Y: 年(4桁)
;;; z: タイムゾーン名(JST-9)
;;; Z: タイムゾーン(+0900)        # (+09:00)

;;; Commentary:
;;;
;;; * xyzzyのlisp/timestmp.lをCommon Lispに移植したものです。
;;;   cl-ppcreに依存しています。

(in-package :xyzzy)

(defmacro defconstant* (sym value &optional doc)
  `(defconstant ,sym (if (boundp ',sym)
                         (symbol-value ',sym)
                         ,value)
     ,@(when doc (list doc))))

(defconstant* +abbreviated-weekday-names+
  #("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun"))

(defconstant* +full-weekday-names+
  #("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday"))

(defconstant* +japanese-weekday-names+ "月火水木金土日")

(defconstant* +abbreviated-month-names+
  #("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))

(defconstant* +full-month-names+
  #("January" "February" "March" "April" "May" "June"
    "July" "August" "September" "October" "November" "December"))

(defvar *timezone-name* "JST")

;; 元号と西暦の対応表(たぶん合ってる)
(defconstant* +japanese-era-list+
  '(("平成" "H" 1989 1 8)
    ("昭和" "S" 1926 12 25)
    ("大正" "T" 1912 7 30)
    ;; Common LispではGMT1900年より前は存在しない
    ;; ("明治" "M" 1868 5 9)
   ))

(defconstant* +japanese-era+
  (mapcar #'(lambda (x)
              (list (encode-universal-time
                     0 0 0 (fifth x) (fourth x) (third x) -9)
                    (third x) (first x) (second x)))
          +japanese-era-list+))

(defun get-japanese-era (universal-time year)
  (let ((x (find universal-time +japanese-era+ :test #'>= :key #'car)))
    (if x
        (cons (+ (- year (cadr x)) 1) (cddr x))
      (list (- year 1867) "明治" "M")  ; いまいち
    )))

(defun format-date (s fmt &optional (universal-time (get-universal-time)))
  (multiple-value-bind (sec min hour day mon year dow daylight tz)
      (decode-universal-time universal-time)
    (declare (ignore daylight))
    (do ((i 0 (+ i 1))
         (l (length fmt))
         (jp nil))
        ((= i l))
      (let ((c (elt fmt i)))
        (cond ((char= c #\%)
               (let ((pound nil))
                 (incf i)
                 (when (= i l)
                   (return))
                 (setq c (elt fmt i))
                 (when (char= c #\#)
                   (setq pound t)
                   (incf i)
                   (when (= i l)
                     (return))
                   (setq c (elt fmt i)))
                 (let ((fmtd (if pound "~d" "~2,'0d")))
                   (case c
                     (#\a
                      (princ (svref +abbreviated-weekday-names+ dow) s))
                     (#\A
                      (princ (svref +full-weekday-names+ dow) s))
                     (#\b
                      (princ (svref +abbreviated-month-names+ (- mon 1)) s))
                     (#\B
                      (princ (svref +full-month-names+ (- mon 1)) s))
                     (#\d
                      (format s fmtd day))
                     (#\e
                      (unless jp
                        (setq jp (get-japanese-era universal-time year)))
                      (format s fmtd (car jp)))
                     (#\E
                      (unless jp
                        (setq jp (get-japanese-era universal-time year)))
                      (if (= (car jp) 1)
                          (princ "元" s)
                        (format s fmtd (car jp))))
                     (#\g
                      (unless jp
                        (setq jp (get-japanese-era universal-time year)))
                      (princ (if pound (svref (cadr jp) 0) (cadr jp)) s))
                     (#\G
                      (unless jp
                        (setq jp (get-japanese-era universal-time year)))
                      (princ (caddr jp) s))
                     (#\H
                      (format s fmtd hour))
                     (#\I
                      (let ((h (mod hour 12)))
                        (format s fmtd (if (zerop h) 12 h))))
                     (#\i
                      (format s "~3,'0d"
                              (truncate (rem (+ universal-time 3600) 86400) 86.4)))
                     (#\m
                      (format s fmtd mon))
                     (#\M
                      (format s fmtd min))
                     (#\p
                      (princ (if (< hour 12) "午前" "午後") s))
                     (#\P
                      (if pound
                          (princ (if (< hour 12) "am" "pm") s)
                        (princ (if (< hour 12) "AM" "PM") s)))
                     (#\S
                      (format s fmtd sec))
                     (#\v
                      (princ (aref +japanese-weekday-names+ dow) s))
                     (#\y
                      (format s "~2,'0d" (mod year 100)))
                     (#\Y
                      (princ year s))
                     (#\z
                      (format s "~A~D" *timezone-name* tz))
                     (#\Z
                      (let ((x (abs tz)))
                        (format s "~:[+~;-~]~2,'0d~:[~;:~]~2,'0d"
                                (plusp tz) (truncate x) pound
                                (mod (truncate (* x 60)) 60))))
                     (t
                      (write-char c s))))))
              (t
               (write-char c s)))))))

(defun format-date-string (fmt &optional (universal-time (get-universal-time)))
  (with-output-to-string (s)
    (format-date s fmt universal-time)))

(defvar *date-formats*
  '("%a, %d %b %Y %H:%M:%S %Z"
    "%a, %d %b %Y %H:%M:%S %z"
    "%a %b %d %H:%M:%S %Y"
    "%d %b %Y %H:%M:%S %Z"
    "%d %b %Y %H:%M:%S %z"
    "%Y-%m-%dT%H:%M:%S%#Z"
    "%B %d, %Y"
    "%b %d %Y"
    "%Y-%m-%d"
    "%d %b %y"
    "%y/%m/%d"
    "%y-%m-%d"
    "%g%#e年%#m月%#d日 %v曜日"
    "%g%#e年%#m月%#d日"
    "%Y年%#m月%#d日(%v)"
    "%Y年%#m月%#d日"
    "%y年%#m月%#d日(%v)"
    "%y年%#m月%#d日"
    " %H:%M:%S"
    " %#H:%M:%S"
    " %#I:%M:%S %P"
    " %#H時%#M分%#S秒"
    " %p%#I時%#M分%#S秒"
    "@%i"
    ))

(defun add-date-format (fmt)
  (pushnew fmt *date-formats* :test #'string=))

#|(defun insert-date-string ()
  (interactive "*")
  (multiple-value-bind (result data)
      (dialog-box '(dialog 0 0 260 120
                    (:caption "日付と時刻")
                    (:font 9 "MS UI Gothic")
                    (:control
                     (:listbox list nil #x50a10001 4 5 192 114)
                     (:button IDOK "OK" #x50030001 205 5 52 14)
                     (:button IDCANCEL "キャンセル" #x50030000 205 22 52 14)))
                  (list (cons 'list (mapcar #'format-date-string *date-formats*)))
                  '((list :must-match t :enable (IDOK))))
    (when result
      (insert (cdr (assoc 'list data))))))|#

(defvar *date-format-regexp*
  (ppcre:create-scanner "([0-9][0-9]?)/([0-9][0-9]?)/([0-9][0-9]?) +([0-9][0-9]?):([0-9][0-9]?):([0-9][0-9]?)"))

(defun parse-date-string (string)
  (if (stringp string)
      (multiple-value-bind (win parts) 
          (ppcre:scan-to-strings *date-format-regexp* string)
        (when win
          (handler-case 
              (apply #'encode-universal-time
                     (nreverse (map 'list #'parse-integer parts)))
            (error () nil))))
      nil))

; usage
;(format-date-string (nth 12 *date-formats*)
;                    (get-universal-time))
;=> "平成20年8月19日 火曜日"

;(parse-date-string "1999/01/01 17:00:0")
;=> 3124166400