gistfile1.el

;;;
;;; 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)
;;; 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)

(eval-when-compile
  (require 'cl))

(defconst +abbreviated-weekday-names+
  ["Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat"])
(defconst +full-weekday-names+
  ["Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"])
(defconst +japanese-weekday-names+ "日月火水木金土")
(defconst +abbreviated-month-names+
  ["Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"])
(defconst +full-month-names+
  ["January" "February" "March" "April" "May" "June"
    "July" "August" "September" "October" "November" "December"])

(defconst +japanese-era-list+
  '(("平成" "H" 1989 1 8)
    ("昭和" "S" 1926 12 25)
    ("大正" "T" 1912 7 30)
    ;; ("明治" "M" 1868 5 9)
   ))
(defconst +japanese-era+
  (mapcar #'(lambda (x)
              (list (encode-time
                     0 0 0 (fifth x) (fourth x) (third x) (* 9 60 60))
                    (third x) (first x) (second x)))
          +japanese-era-list+))

(defun time-compare (time1 time2 pred)
  (cond ((funcall pred (car time1) (car time2))
         t)
        ((funcall pred (car time2) (car time1))
         nil)
        ((funcall pred (cadr time1) (cadr time2))
         t)
        (t
         nil)))

(defun time>= (time1 time2)
  (not (time-compare time1 time2 #'<)))

(defun get-japanese-era (time year)
  (let ((x (dolist (l +japanese-era+)
           (when (time>= time (car l))
             (return l)))))
    (if x 
        (cons (+ (- year (cadr x)) 1) (cddr x))
      (list (- year 1867) "明治" "M"))))

(defun char= (char1 char2)
  (let ((case-fold-search nil))
    (char-equal char1 char2)))

(defun format-date-string (fmt &optional time)
  (unless time
    (setq time (current-time)))
  (let* ((decoded (decode-time time))
         (sec  (nth 0 decoded))
         (min  (nth 1 decoded))
         (hour (nth 2 decoded))
         (day  (nth 3 decoded))
         (mon  (nth 4 decoded))
         (year (nth 5 decoded))
         (dow  (nth 6 decoded))
         (daylight (nth 7 decoded))
         (tz   (nth 8 decoded)))
    (with-output-to-string
      (do ((i 0 (1+ i))
           (l (length fmt))
           (jp nil))
          ((= i l))
        (let ((c (elt fmt i)))
          (cond ((char= c ?%)
                 (let ((pound nil))
                   (setq i (1+ i))
                   (when (= i l) (return))
                   (setq c (elt fmt i))
                   (when (char= c ?#)
                     (setq pound t)
                     (setq i (1+ i))
                     (when (= i l) (return))
                     (setq c (elt fmt i)))
                   (let ((fmtd (if pound "%d" "%02d")))
                     (case c
                       (?a 
                        (princ (aref +abbreviated-weekday-names+ dow)))
                       (?A
                        (princ (aref +full-weekday-names+ dow)))
                       (?b
                        (princ (aref +abbreviated-month-names+ (- mon 1))))
                       (?B
                        (princ (aref +full-month-names+ (- mon 1))))
                       (?d
                        (princ (format fmtd day)))
                       (?e
                        (unless jp
                          (setq jp (get-japanese-era time year)))
                        (princ (format fmtd (car jp))))
                       (?E
                        (unless jp
                          (setq jp (get-japanese-era time year)))
                        (if (= (car jp) 1)
                            (princ "元")
                          (princ (format fmtd (car jp)))))
                       (?g
                        (unless jp
                           (setq jp (get-japanese-era time year)))
                        (princ (if pound (aref (cadr jp) 0) (cadr jp))))
                       (?G
                        (unless jp
                          (setq jp (get-japanese-era time year)))
                        (princ (caddr jp)))
                       (?H
                        (princ (format fmtd hour)))
                       (?I
                        (let ((h (mod hour 12)))
                          (princ (format fmtd (if (zerop h) 12 h)))))
                       (?m
                        (princ (format fmtd mon)))
                       (?M
                        (princ (format fmtd min)))
                       (?p
                        (princ (if (< hour 12) "午前" "午後")))
                       (?P
                        (if pound
                            (princ (if (< hour 12) "am" "pm"))
                          (princ (if (< hour 12) "AM" "PM"))))
                       (?S
                        (princ (format fmtd sec)))
                       (?v
                        (princ (aref +japanese-weekday-names+ dow)))
                       (?y
                        (princ (format "%02d" (mod year 100))))
                       (?Y
                        (princ year))
                       (?z
                        (princ (format "%s%d" (cadr (current-time-zone time)) (- (/ tz 60 60)))))
                       (?Z
                        (let* ((x (abs tz)))
                          (princ (concat (if (>= tz 0) "+" "-")
                                         (format "%02d" (/ x 60 60))
                                         (if pound ":" "")
                                         (format "%02d" (mod (/ x 60) 60))))))
                       (t
                        (write-char c))))))
                (t
                 (write-char c))))))))
;;
;;
;; (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秒"
;;     ))
;; (mapcar #'format-date-string *date-formats*)