Skip to content


Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

234 lines (213 sloc) 6.513 kb
;;; -*- Mode: Lisp; Package: EDITOR -*-
;;; This file is part of xyzzy.
;;; format-date
;;; a: 短い形式の曜日
;;; A: 長い形式の曜日
;;; b: 短い形式の月
;;; B: 長い形式の月
;;; d: 日(00~31) # (0~31)
;;; 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)
(provide "timestmp")
(in-package "editor")
(export '(format-date format-date-string *date-formats* add-date-format
insert-date-string parse-date-string))
(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)))
(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)
(unless universal-time
(setq universal-time (get-universal-time)))
(multiple-value-bind (sec min hour day mon year dow daylight tz)
(decode-universal-time universal-time)
(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)
(setq c (elt fmt i))
(when (char= c #\#)
(setq pound t)
(incf i)
(when (= i l)
(setq c (elt fmt i)))
(let ((fmtd (if pound "~d" "~2,'0d")))
(case c
(princ (svref *abbreviated-weekday-names* dow) s))
(princ (svref *full-weekday-names* dow) s))
(princ (svref *abbreviated-month-names* (- mon 1)) s))
(princ (svref *full-month-names* (- mon 1)) s))
(format s fmtd day))
(unless jp
(setq jp (get-japanese-era universal-time year)))
(format s fmtd (car jp)))
(unless jp
(setq jp (get-japanese-era universal-time year)))
(if (= (car jp) 1)
(princ "" s)
(format s fmtd (car jp))))
(unless jp
(setq jp (get-japanese-era universal-time year)))
(princ (if pound (svref (cadr jp) 0) (cadr jp)) s))
(unless jp
(setq jp (get-japanese-era universal-time year)))
(princ (caddr jp) s))
(format s fmtd hour))
(let ((h (mod hour 12)))
(format s fmtd (if (zerop h) 12 h))))
(format s "~3,'0d"
(truncate (rem (+ universal-time 3600) 86400) 86.4)))
(format s fmtd mon))
(format s fmtd min))
(princ (if (< hour 12) "午前" "午後") s))
(if pound
(princ (if (< hour 12) "am" "pm") s)
(princ (if (< hour 12) "AM" "PM") s)))
(format s fmtd sec))
(princ (svref *japanese-weekday-names* dow) s))
(format s "~2,'0d" (mod year 100)))
(princ year s))
(format s "~A~D" *timezone-name* tz))
(let ((x (abs tz)))
(format s "~:[+~;-~]~2,'0d~:[~;:~]~2,'0d"
(plusp tz) (truncate x) pound
(mod (truncate (* x 60)) 60))))
(write-char c s))))))
(write-char c s)))))))
(defun format-date-string (fmt &optional 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"
"%B %d, %Y"
"%b %d %Y"
"%d %b %y"
"%g%#e年%#m月%#d日 %v曜日"
" %H:%M:%S"
" %#H:%M:%S"
" %#I:%M:%S %P"
" %#H時%#M分%#S秒"
" %p%#I時%#M分%#S秒"
(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")
(: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*
"\\([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)
(when (and (stringp string)
(ed:string-match *date-format-regexp* string))
(handler-case (apply #'encode-universal-time
(do ((x 1 (1+ x))
(r nil))
((> x 6) r)
(push (parse-integer (substring string
(ed:match-beginning x)
(ed:match-end x)))
(error () nil))))
Jump to Line
Something went wrong with that request. Please try again.