Subject: 29.0.50; Suggestion: refactor time.el into a more general 'clock' framework

From: Arthur Miller <[email-masked]>
Date: Thu, 02 Dec 2021 00:08:37 +0100

Last few days I have being playing with a clock just to test the transparency,
and what I have noticed is that I don't see some framework to work with clock
time. For tests I have used timer + 60s to get per minut update, but that is of
course skew time.

Emacs has a better "clock" framework in form of 'display-time-mode', but it is
explicitly coupled to mode-line updates. So any application that would like to
per-use it, will also trigger mode-line re-display, regardless if user have
'display-time-mode' on or not.

My idea to per-use it is to simply run 'update-hooks' on clock beat, so any
application can register a hook that will be called on a "clock beat". While it
is maybe not so super-synchronized with system clock, it still gives impression
of clocks in Emacs be synchronized.

Changes look bigger than they are, but I have made some let-bound variables
global, so I can use them as precalculated variables instead of calculating them
in the application code. I am not sure if it is correct. but it's just a test.

Allaround naming is bad, but I tried to be completely backward compatible, so I
had to preserve the old hook/var/mode names.

Example usage is in attached emvac-vision-clock.el, with attached screenshot of
it running.

I haven't thought of how/when to kill timer and internal minor mode properly; I
guess when hooks variable could be tested for nil, but I haven't done it yet.

--- ./time.el	2021-11-28 16:21:48.518437586 +0100
+++ /home/arthur/repos/time.el	2021-12-01 23:00:43.761860792 +0100
@@ -110,6 +110,10 @@
   "List of functions to be called when the time is updated on the mode line."
   :type 'hook)
 
+(defcustom display-time-update-hooks nil
+  "List of functions to be called when the time is updated."
+  :type 'hook)
+
 (defvar display-time-server-down-time nil
    "Time when mail file's file system was recorded to be down.
 If that file system seems to be up, the value is nil.")
@@ -171,17 +175,34 @@
   :type '(choice (const :tag "Default" nil)
 		 string))
 
+(defvar display-time-now nil)
+(defvar display-time-time nil)
+(defvar display-time-load nil)
+(defvar display-time-mail nil)
+(defvar display-time-24-hours nil)
+(defvar display-time-hour nil)
+(defvar display-time-12-hours nil)
+(defvar display-time-am-pm nil)
+(defvar display-time-minutes nil)
+(defvar display-time-seconds nil)
+(defvar display-time-time-zone nil)
+(defvar display-time-day nil)
+(defvar display-time-year nil)
+(defvar display-time-monthname nil)
+(defvar display-time-month nil)
+(defvar display-time-dayname nil)
+
 (defcustom display-time-string-forms
   '((if (and (not display-time-format) display-time-day-and-date)
-	(format-time-string "%a %b %e " now)
+	(format-time-string "%a %b %e " display-time-now)
       "")
     (propertize
      (format-time-string (or display-time-format
 			     (if display-time-24hr-format "%H:%M" "%-I:%M%p"))
-			 now)
-     'help-echo (format-time-string "%a %b %e, %Y" now))
-    load
-    (if mail
+			 display-time-now)
+     'help-echo (format-time-string "%a %b %e, %Y" display-time-now))
+    display-time-load
+    (if display-time-mail
 	;; Build the string every time to act on customization.
 	;; :set-after doesn't help for `customize-option'.  I think it
 	;; should.
@@ -225,7 +246,8 @@
 
 would give mode line times like `94/12/30 21:07:48 (UTC)'."
   :type '(repeat sexp))
-
+
+;;; Implementation
 (defun display-time-event-handler ()
   (display-time-update)
   (let* ((current (current-time))
@@ -266,25 +288,6 @@
 	size
       nil)))
 
-(with-no-warnings
-  ;; Warnings are suppressed to avoid "global/dynamic var `X' lacks a prefix".
-  (defvar now)
-  (defvar time)
-  (defvar load)
-  (defvar mail)
-  (defvar 24-hours)
-  (defvar hour)
-  (defvar 12-hours)
-  (defvar am-pm)
-  (defvar minutes)
-  (defvar seconds)
-  (defvar time-zone)
-  (defvar day)
-  (defvar year)
-  (defvar monthname)
-  (defvar month)
-  (defvar dayname))
-
 (defun display-time-update--load ()
   (if (null display-time-load-average)
       ""
@@ -339,40 +342,42 @@
                                     end-time start-time))
                        (float-time end-time))))))))))
 
+(defun display-time-update--mode-line ()
+  (run-hooks 'display-time-hook)
+  (force-mode-line-update 'all))
+
 (defun display-time-update ()
+  "Run all registered hooks that wish to be updated on a clock beat."
   "Update the `display-time' info for the mode line.
 However, don't redisplay right now.
 
 This is used for things like Rmail \\`g' that want to force an
 update which can wait for the next redisplay."
-  (let* ((now (current-time))
-         (time (current-time-string now))
-         (load (display-time-update--load))
-         (mail (display-time-update--mail))
-         (24-hours (substring time 11 13))
-         (hour (string-to-number 24-hours))
-         (12-hours (int-to-string (1+ (% (+ hour 11) 12))))
-         (am-pm (if (>= hour 12) "pm" "am"))
-         (minutes (substring time 14 16))
-         (seconds (substring time 17 19))
-         (time-zone (car (cdr (current-time-zone now))))
-         (day (substring time 8 10))
-         (year (format-time-string "%Y" now))
-         (monthname (substring time 4 7))
-         (month
-          (cdr
-           (assoc
-            monthname
-            '(("Jan" . "1") ("Feb" . "2") ("Mar" . "3") ("Apr" . "4")
-              ("May" . "5") ("Jun" . "6") ("Jul" . "7") ("Aug" . "8")
-              ("Sep" . "9") ("Oct" . "10") ("Nov" . "11") ("Dec" . "12")))))
-         (dayname (substring time 0 3)))
-    (setq display-time-string
-          (mapconcat 'eval display-time-string-forms ""))
-    ;; This is inside the let binding, but we are not going to document
-    ;; what variables are available.
-    (run-hooks 'display-time-hook))
-  (force-mode-line-update 'all))
+  (setq
+   display-time-now (current-time)
+   display-time-time (current-time-string display-time-now)
+   display-time-load (display-time-update--load)
+   display-time-mail (display-time-update--mail)
+   display-time-24-hours (substring display-time-time 11 13)
+   display-time-hour (string-to-number display-time-24-hours)
+   display-time-12-hours (int-to-string (1+ (% (+ display-time-hour 11) 12)))
+   display-time-am-pm (if (>= display-time-hour 12) "pm" "am")
+   display-time-minutes (substring display-time-time 14 16)
+   display-time-seconds (substring display-time-time 17 19)
+   display-time-time-zone (car (cdr (current-time-zone display-time-now)))
+   display-time-day (substring display-time-time 8 10)
+   display-time-year (format-time-string "%Y" display-time-now)
+   display-time-monthname (substring display-time-time 4 7)
+   display-time-month
+   (cdr
+    (assoc
+     display-time-monthname
+     '(("Jan" . "1") ("Feb" . "2") ("Mar" . "3") ("Apr" . "4")
+       ("May" . "5") ("Jun" . "6") ("Jul" . "7") ("Aug" . "8")
+       ("Sep" . "9") ("Oct" . "10") ("Nov" . "11") ("Dec" . "12"))))
+   display-time-dayname (substring display-time-time 0 3)
+   display-time-string  (mapconcat 'eval display-time-string-forms ""))
+  (run-hooks 'display-time-update-hooks))
 
 (defun display-time-file-nonempty-p (file)
   (let ((remote-file-name-inhibit-cache (- display-time-interval 5)))
@@ -381,37 +386,53 @@
 	       (file-attributes (file-chase-links file)))))))
 
 ;;;###autoload
-(define-minor-mode display-time-mode
-  "Toggle display of time, load level, and mail flag in mode lines.
+(define-minor-mode update-time-mode
+  "Internal mode used to setup timerand hooks for periodic clock updates.
 
-When Display Time mode is enabled, it updates every minute (you
-can control the number of seconds between updates by customizing
-`display-time-interval').  If `display-time-day-and-date' is
-non-nil, the current day and date are displayed as well.  This
-runs the normal hook `display-time-hook' after each update."
+To customize update interval choose display-time variables as defined by
+DISPLAY-TIME-UPDATE mode."
   :global t :group 'display-time
   (and display-time-timer (cancel-timer display-time-timer))
   (setq display-time-timer nil)
-  (setq display-time-string "")
-  (or global-mode-string (setq global-mode-string '("")))
   (setq display-time-load-average display-time-default-load-average)
   (if display-time-mode
       (progn
-	(or (memq 'display-time-string global-mode-string)
-	    (setq global-mode-string
-		  (append global-mode-string '(display-time-string))))
 	;; Set up the time timer.
 	(setq display-time-timer
 	      (run-at-time t display-time-interval
-			   'display-time-event-handler))
-	;; Make the time appear right away.
-	(display-time-update)
-	;; When you get new mail, clear "Mail" from the mode line.
-	(add-hook 'rmail-after-get-new-mail-hook
-		  'display-time-event-handler))
-    (remove-hook 'rmail-after-get-new-mail-hook
-		 'display-time-event-handler)))
+			   'display-time-event-handler)))))
+
+;;;###autoload
+(define-minor-mode display-time-mode
+  "Toggle display of time, load level, and mail flag in mode lines.
 
+When Display Time mode is enabled, it updates every minute (you
+can control the number of seconds between updates by customizing
+`display-time-interval').  If `display-time-day-and-date' is
+non-nil, the current day and date are displayed as well.  This
+runs the normal hook `display-time-hook' after each update."
+  :global t :group 'display-time
+  (cond
+   (display-time-mode
+    (update-time-mode 1)
+    (or global-mode-string (setq global-mode-string '("")))
+    (or (memq 'display-time-string global-mode-string)
+	(setq global-mode-string
+	      (append global-mode-string '(display-time-string))))
+    ;; When you get new mail, clear "Mail" from the mode line.
+    (add-hook 'rmail-after-get-new-mail-hook
+	      'display-time-event-handler)
+    (add-hook 'display-time-update-hooks
+              'display-time-update--mode-line)
+    ;; Make the time appear right away.
+    (display-time-update--mode-line))
+   (t
+    (setq global-mode-string
+          (remove 'display-time-string global-mode-string))
+    (remove-hook 'rmail-after-get-new-mail-hook
+		 'display-time-event-handler)
+    (add-hook 'display-time-update-hooks
+              'display-time-update--mode-line))))
 
 ;;; Obsolete names

In GNU Emacs 29.0.50 (build 1, x86_64-pc-linux-gnu, GTK+ Version 3.24.30, cairo version 1.17.4)
 of 2021-11-28 built on pascal
Repository revision: f5498a608fe85b66a4068a5ccf88c9b3d3b88f98
Repository branch: private
Windowing system distributor 'The X.Org Foundation', version 11.0.12101001
System Description: Arch Linux

Configured using:
 'configure --with-native-compilation 'CFLAGS=-O2 -mtune=native -march=native''

Configured features:
ACL CAIRO DBUS FREETYPE GIF GLIB GMP GNUTLS GPM GSETTINGS HARFBUZZ JPEG JSON
LCMS2 LIBOTF LIBSYSTEMD LIBXML2 M17N_FLT MODULES NATIVE_COMP NOTIFY INOTIFY
PDUMPER PNG RSVG SECCOMP SOUND THREADS TIFF TOOLKIT_SCROLL_BARS WEBP X11 XDBE
XIM XPM GTK3 ZLIB

Important settings:
  value of $LANG: sv_SE.UTF-8
  locale-coding-system: utf-8-unix

Major mode: Text

Minor modes in effect:
  beacon-mode: t
  emms-mode-line-mode: t
  emms-playing-time-display-mode: t
  emms-playing-time-mode: t
  company-mode: t
  electric-pair-mode: t
  global-auto-revert-mode: t
  global-hl-line-mode: t
  global-subword-mode: t
  subword-mode: t
  auto-image-file-mode: t
  auto-insert-mode: t
  display-time-mode: t
  delete-selection-mode: t
  save-place-mode: t
  winner-mode: t
  which-key-mode: t
  wrap-region-global-mode: t
  wrap-region-mode: t
  helm-mode: t
  helm-adaptive-mode: t
  shell-dirtrack-mode: t
  helm-autoresize-mode: t
  helm--remap-mouse-mode: t
  async-bytecomp-package-mode: t
  tooltip-mode: t
  global-eldoc-mode: t
  show-paren-mode: t
  electric-indent-mode: t
  mouse-wheel-mode: t
  tool-bar-mode: t
  menu-bar-mode: t
  file-name-shadow-mode: t
  global-font-lock-mode: t
  font-lock-mode: t
  blink-cursor-mode: t
  auto-composition-mode: t
  auto-encryption-mode: t
  auto-compression-mode: t
  column-number-mode: t
  line-number-mode: t
  auto-fill-function: do-auto-fill
  transient-mark-mode: t
  abbrev-mode: t

Load-path shadows:
/home/arthur/repos/emacs/lisp/transient hides /home/arthur/.emacs.d/elpa/transient-20210723.1601/transient
/home/arthur/.emacs.d/elpa/lispy-20210914.1209/elpa hides /home/arthur/.emacs.d/elpa/ivy-20210930.1450/elpa
/home/arthur/repos/emacs/lisp/emacs-lisp/helper hides /home/arthur/.emacs.d/elpa/helper-0.5/helper
/home/arthur/.emacs.d/lisp/helm-git-branch hides /home/arthur/.emacs.d/elpa/helm-git-branch-0.1/helm-git-branch
/home/arthur/.emacs.d/elpa/elisp-refs-20211009.1531/elisp-refs hides /home/arthur/.emacs.d/elpa/elisp-refs-1.4/elisp-refs
/home/arthur/.emacs.d/elpa/elisp-refs-20211009.1531/elisp-refs-autoloads hides /home/arthur/.emacs.d/elpa/elisp-refs-1.4/elisp-refs-autoloads
/home/arthur/.emacs.d/elpa/elisp-refs-20211009.1531/elisp-refs-pkg hides /home/arthur/.emacs.d/elpa/elisp-refs-1.4/elisp-refs-pkg
/home/arthur/.emacs.d/lisp/company-cmake hides /home/arthur/.emacs.d/elpa/company-20211002.1732/company-cmake

Features:
(shadow mail-extr helm-external helm-net ffap emacsbug sendmail gnus-topic
cursor-sensor nndraft nnmh nnfolder utf-7 gnutls network-stream gnus-agent
gnus-srvr gnus-score score-mode nnvirtual gnus-msg gnus-art mm-uu mml2015
mm-view mml-smime smime dig nntp gnus-cache gnus-sum shr kinsoku svg dom
gnus-group gnus-undo gnus-start gnus-dbus gnus-cloud nnimap nnmail mail-source
utf7 netrc nnoo gnus-spec gnus-int gnus-range message yank-media rfc822 mml
mml-sec epa epg rfc6068 epg-config mm-decode mm-bodies mm-encode mailabbrev
gmm-utils mailheader gnus-win tramp-archive tramp-gvfs tramp-cache zeroconf dbus
helm-command beacon emms-librefm-stream xml emms-librefm-scrobbler emms-i18n
emms-history emms-score emms-stream-info emms-metaplaylist-mode emms-bookmarks
emms-cue emms-mode-line-icon emms-browser sort emms-playlist-sort
emms-last-played emms-player-xine emms-player-mpd emms-lyrics emms-url
emms-streams emms-show-all emms-tag-editor emms-tag-tracktag emms-mark
emms-cache emms-info-native bindat emms-info-exiftool emms-info-tinytag
emms-info-metaflac emms-info-opusinfo emms-info-ogginfo emms-info-mp3info
emms-player-vlc emms-player-mplayer emms-player-mpv emms-mode-line-cycle
emms-mode-line emms-playing-time emms-player-simple emms-info emms-later-do
emms-playlist-limit emms-volume emms-volume-sndioctl emms-volume-mixerctl
emms-volume-pulse emms-volume-amixer emms-playlist-mode emms-source-playlist
emms-source-file locate emms-setup emms emms-compat c++-setup sv-kalender lunar
solar cal-dst holidays hol-loaddefs extras recentf tree-widget server overseer
pkg-info url-http url-auth url-gw nsm rmc puny epl f s outshine
outshine-org-cmds outorg org-protocol org-pdftools pdf-occur pdf-isearch
let-alist pdf-annot tablist tablist-filter semantic/wisent/comp semantic/wisent
semantic/wisent/wisent semantic/util-modes semantic/util semantic semantic/tag
semantic/lex semantic/fw mode-local cedet facemenu pdf-misc imenu pdf-tools
cus-edit cus-start cus-load pdf-view bookmark pp jka-compr pdf-cache pdf-info tq
pdf-util pdf-macs image-mode dired-extras dired-copy-paste dired-subtree
dired-hacks-utils openwith dired-x wdired dired-async dired-aux dired
dired-loaddefs exif org-noter org-element avl-tree org-refile org ob ob-tangle
ob-ref ob-lob ob-table ob-exp org-macro org-footnote org-src ob-comint
org-pcomplete org-list org-faces org-entities org-version ob-emacs-lisp ob-core
ob-eval org-table oc-basic bibtex ol org-keys oc org-compat org-macs
org-loaddefs cal-menu calendar cal-loaddefs noutline outline yasnippet-snippets
yasnippet derived disp-table page-break-lines company-yasnippet company-ispell
ispell company-clang company-elisp company-etags etags fileloop generator xref
project company-semantic company-template company-keywords company-files
company-capf company pcase comp comp-cstr warnings rx cl-extra elec-pair
autorevert hl-line cap-words superword subword image-file image-converter
autoinsert time delsel saveplace winner which-key advice solarized-dark-theme
solarized solarized-faces color wrap-region dash nnir gnus nnheader gnus-util
rmail rmail-loaddefs mail-utils wid-edit helm-mode helm-adaptive helm-projectile
projectile lisp-mnt mail-parse rfc2231 rfc2047 rfc2045 mm-util ietf-drums
mail-prsvr grep compile text-property-search ibuf-ext ibuffer ibuffer-loaddefs
thingatpt helm-eshell helm-elisp helm-files filenotify tramp tramp-loaddefs
trampver tramp-integration files-x tramp-compat shell pcomplete comint
ansi-color parse-time iso8601 time-date ls-lisp helm-buffers helm-occur
helm-tags helm-locate helm-eval edebug backtrace find-func helm-info ring
helm-types helm-config diminish helm-pages helm-grep helm-regexp help-mode
helm-utils helm-help format-spec helm easy-mmode async-bytecomp
helm-global-bindings edmacro kmacro helm-source helm-multi-match helm-lib async
elisp-extras popup helm-easymenu cl info package browse-url url url-proxy
url-privacy url-expand url-methods url-history url-cookie url-domsuf url-util
mailcap url-handlers url-parse auth-source cl-seq eieio eieio-core cl-macs
eieio-loaddefs password-cache json map url-vars seq gv subr-x byte-opt bytecomp
byte-compile cconv cl-loaddefs cl-lib iso-transl tooltip eldoc paren electric
uniquify ediff-hook vc-hooks lisp-float-type elisp-mode mwheel term/x-win x-win
term/common-win x-dnd tool-bar dnd fontset image regexp-opt fringe
tabulated-list replace newcomment text-mode lisp-mode prog-mode register page
tab-bar menu-bar rfn-eshadow isearch easymenu timer select scroll-bar mouse
jit-lock font-lock syntax font-core term/tty-colors frame minibuffer cl-generic
cham georgian utf-8-lang misc-lang vietnamese tibetan thai tai-viet lao korean
japanese eucjp-ms cp51932 hebrew greek romanian slovak czech european ethiopic
indian cyrillic chinese composite emoji-zwj charscript charprop case-table
epa-hook jka-cmpr-hook help simple abbrev obarray cl-preloaded nadvice button
loaddefs faces cus-face macroexp files window text-properties overlay sha1 md5
base64 format env code-pages mule custom widget keymap hashtable-print-readable
backquote threads dbusbind inotify lcms2 dynamic-setting system-font-setting
font-render-setting cairo move-toolbar gtk x-toolkit x multi-tty
make-network-process native-compile emacs)

Memory information:
((conses 16 646147 600209)
 (symbols 48 42638 423)
 (strings 32 149107 107480)
 (string-bytes 1 5524678)
 (vectors 16 73654)
 (vector-slots 8 1303521 923992)
 (floats 8 1181 2025)
 (intervals 56 2601 1886)
 (buffers 992 26))