cage
/
tinmop
mirror of https://codeberg.org/cage/tinmop/
1
0
Fork 0
Code Issues

- added a slot in 'command-window' to allow the user to insert secret 

input.

 the same character is echoed instead of the actual input.
This commit is contained in:
cage 2020-08-15 14:58:54 +02:00
parent 5169deaedd
commit dd1e4f6066
7 changed files with 70 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
etc/default-theme.conf
View File

@ -37,6 +37,10 @@ main-window.foreground = white
crypted.mark.value = " 🔏👌"
# the string to be drawn instead of actual character when input password
password-echo-character = "•"
# the character used to draw the vote's horizontal histogram
# note: keeps it one character wide

49
src/command-window.lisp
View File

@ -22,6 +22,13 @@
:initarg :command-line
:accessor command-line
:documentation "A list of keys so far inserted by the user")
(echo-character
:initform nil
:initarg :echo-character
:accessor echo-character
:documentation "If non nil print a number of copies (equals to
length of slot 'command-line' of this string instead of the
command-line itself")
(error-message
:initform nil
:initarg :error-message
@ -159,23 +166,31 @@ be either `:keybinding' or `:string'. the former for key command the latter for
(point-position point-position)
(point-bg point-bg)
(point-fg point-fg)
(prompt prompt)) win
(let* ((length-cmd-line (length command-line))
(no-prompt-point-pos (no-prompt-point-pos win))
(cursor-value (if (and (> length-cmd-line 0)
(< no-prompt-point-pos
length-cmd-line))
(elt command-line no-prompt-point-pos)
#\Space)))
(print-text win prompt 0 0)
(when command-line
(print-text win command-line (length prompt) 0))
(print-text win
cursor-value
point-position
0
:fgcolor point-fg
:bgcolor point-bg))))
(prompt prompt)
(echo-character echo-character)) win
(flet ((print-echo-character ()
(let ((echoed (with-output-to-string (stream)
(loop repeat (length command-line) do
(princ echo-character stream)))))
(print-text win echoed (length prompt) 0))))
(let* ((length-cmd-line (length command-line))
(no-prompt-point-pos (no-prompt-point-pos win))
(cursor-value (if (and (> length-cmd-line 0)
(< no-prompt-point-pos
length-cmd-line))
(elt command-line no-prompt-point-pos)
#\Space)))
(print-text win prompt 0 0)
(when command-line
(if echo-character
(print-echo-character)
(print-text win command-line (length prompt) 0)))
(print-text win
cursor-value
point-position
0
:fgcolor point-fg
:bgcolor point-bg)))))
(defmethod draw ((object command-window))
(with-accessors ((command-line command-line)

2
src/package.lisp
View File

@ -993,6 +993,7 @@
:config-notification-life
:config-server-name
:config-username
:config-password-echo-character
:config-win-focus-mark
:thread-message-symbol
:thread-message-read-colors
@ -1784,6 +1785,7 @@
:print-error
:command-window
:command-line
:echo-character
:event-to-answer
:prompt
:add-error-message

17
src/program-events.lisp
View File

@ -172,6 +172,10 @@
:initform nil
:initarg :initial-value
:accessor initial-value)
(echo-character
:initform nil
:initarg :echo-character
:accessor echo-character)
(complete-fn
:initform nil
:initarg :complete-fn
@ -189,9 +193,10 @@
(setf (priority object) (truncate (/ +standard-event-priority+ 2)))))
(defmethod process-event ((object ask-user-input-string-event))
(with-accessors ((prompt prompt)
(initial-value initial-value)
(complete-fn complete-fn)) object
(with-accessors ((prompt prompt)
(initial-value initial-value)
(complete-fn complete-fn)
(echo-character echo-character)) object
(setf (command-window:event-to-answer specials:*command-window*)
object)
(setf (point-tracker:prompt specials:*command-window*)
@ -203,7 +208,9 @@
(setf (command-window:command-line specials:*command-window*)
initial-value)
(point-tracker:move-point-to-end specials:*command-window* initial-value)
(windows:draw specials:*command-window*)))
(setf (command-window:echo-character specials:*command-window*)
echo-character)
(windows:draw specials:*command-window*)))
(defclass user-input-string-event (ask-user-input-string-event)
()
@ -220,6 +227,8 @@
(defmethod process-event ((object user-input-string-event))
(with-accessors ((lock lock)
(condition-variable condition-variable)) object
(setf (command-window:echo-character specials:*command-window*)
nil)
(with-lock (lock)
(bt:condition-notify condition-variable))))

4
src/software-configuration.lisp
View File

@ -399,6 +399,7 @@
input
read
unread
password-echo-character
color-re
ignore-user-re
purge-history-days-offset
@ -657,6 +658,9 @@
(gen-simple-access (username)
+key-username+)
(gen-simple-access (password-echo-character)
+key-password-echo-character+)
(defun config-win-focus-mark ()
(values (access:accesses *software-configuration*
+key-window+

2
src/tui-utils.lisp
View File

@ -155,7 +155,7 @@ as argument `complex-string'."
(croatoan:concat-complex-string a b :color-attributes-contagion color-attributes-contagion))
(defmethod cat-complex-string ((a complex-string) (b complex-string)
&key (color-attributes-contagion t))
&key (color-attributes-contagion nil))
"Return a complex string that is the results of concatenating of `a'
and `b': two `complex-string'. If `color-attributes-contagion' is
non nil `b' will inherit all the attributes and color of a."

24
src/ui-goodies.lisp
View File

@ -145,17 +145,21 @@
(defun ask-string-input (on-input-complete-fn
&key
(priority nil)
(initial-value nil)
(prompt +default-command-prompt+)
(complete-fn #'complete:directory-complete))
(hide-input nil)
(priority nil)
(initial-value nil)
(prompt +default-command-prompt+)
(complete-fn #'complete:directory-complete))
(flet ((thread-fn ()
(let ((event (make-instance 'ask-user-input-string-event
:forced-priority priority
:initial-value initial-value
:complete-fn complete-fn
:prompt prompt
:payload (box:dbox nil))))
(let* ((password-echo (and hide-input
(swconf:config-password-echo-character)))
(event (make-instance 'ask-user-input-string-event
:echo-character password-echo
:forced-priority priority
:initial-value initial-value
:complete-fn complete-fn
:prompt prompt
:payload (box:dbox nil))))
(with-accessors ((lock lock)
(condition-variable condition-variable)) event
(push-event event)