;; tinmop: a multiprotocol client ;; Copyright © cage ;; This program is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see . (in-package :sending-message) (define-constant +header-send-window-height+ 6 :test #'=) (defclass message-ready-to-send () ((language :initform nil :initarg :language :accessor language) (subject :initform nil :initarg :subject :accessor subject) (attachments :initform () :initarg :attachments :accessor attachments) (reply-to :initform () :initarg :reply-to :accessor reply-to :documentation "The id of table 'status' you are replying to.") (mentions :initform "" :initarg :mentions :accessor mentions) (visibility :initform +status-public-visibility+ :initarg :visibility :accessor visibility :documentation "One of swconf:*allowed-status-visibility*.") (body :initform nil :initarg :body :accessor body))) (defmethod print-object ((object message-ready-to-send) stream) (print-unreadable-object (object stream :type t) (with-accessors ((subject subject) (attachments attachments) (reply-to reply-to) (body body)) object (format stream "~@[subj: ~a ~] ~@[reply-to: ~a ~] ~@[attach: ~a ~] ~a" subject reply-to attachments body)))) (defclass confirm-sending-window (focus-marked-window simple-line-navigation-window) ((screen :initarg :screen :initform nil :accessor screen) (message-data :initarg :message-data :initform (make-instance 'message-ready-to-send) :accessor message-data :type message-ready-to-send) (style :initarg :style :initform nil :accessor style))) (defmethod refresh-config :after ((object confirm-sending-window)) (with-accessors ((screen screen) (croatoan-window croatoan-window) (bgcolor bgcolor) (fgcolor fgcolor) (top-row-padding top-row-padding) (style style)) object (let* ((theme-style (swconf:form-style swconf:+key-input-dialog+)) (fg (swconf:foreground theme-style)) (bg (swconf:background theme-style)) (width (truncate (/ (win-width screen) 2))) (height (truncate (/ (win-height screen) 2))) (y (truncate (- (/ (win-height screen) 2) (/ height 2)))) (x (truncate (- (/ (win-width screen) 2) (/ width 2)))) (attach-y-start +header-send-window-height+)) (setf (c:background croatoan-window) (tui:make-win-background bg)) (setf (c:bgcolor croatoan-window) bg) (setf (c:fgcolor croatoan-window) fg) (setf style theme-style) (win-resize object width height) (win-move object x y) (setf (top-row-padding object) attach-y-start) object))) (defmethod draw :after ((object confirm-sending-window)) (with-accessors ((message-data message-data) (style style)) object (with-accessors ((reply-to reply-to) (attachments attachments) (body body) (subject subject) (mentions mentions) (visibility visibility) (language language)) message-data (with-croatoan-window (croatoan-window object) (let* ((bgcolor (c:bgcolor croatoan-window)) (fgcolor (c:fgcolor croatoan-window)) (input-bg (swconf:input-background style)) (input-fg (swconf:input-foreground style)) (user (if reply-to (db:status-id->username reply-to) (_ "none"))) (label-reply-raw (_ "Reply to: ")) (label-mentions-raw (_ "Mentions: ")) (label-subject-raw (_ "Subject: ")) (label-visibility-raw (_ "Visibility: ")) (label-language-raw (_ "Language: ")) (label-reply-length-raw (length label-reply-raw)) (label-mentions-length-raw (length label-mentions-raw)) (label-subject-raw-length (length label-subject-raw)) (label-visibility-raw-length (length label-visibility-raw)) (label-language-raw-length (length label-language-raw)) (max-field-length (max label-reply-length-raw label-mentions-length-raw label-subject-raw-length label-visibility-raw-length label-language-raw-length)) (label-subject (text-utils:right-padding label-subject-raw max-field-length)) (label-reply (text-utils:right-padding label-reply-raw max-field-length)) (label-mentions (text-utils:right-padding label-mentions-raw max-field-length)) (label-visibility (text-utils:right-padding label-visibility-raw max-field-length)) (label-language (text-utils:right-padding label-language-raw max-field-length)) (value-max-length (- (win-width-no-border object) max-field-length)) (label-attachments (_ "Attachments"))) (flet ((print-field (text x y bg fg &key (inverse nil)) (print-text object text x y :bgcolor (if inverse fg bg) :fgcolor (if inverse bg fg)))) (print-field label-reply 1 1 bgcolor fgcolor) (print-field (right-padding user value-max-length) max-field-length 1 input-bg input-fg) (print-field label-mentions 1 2 bgcolor fgcolor) (print-field (right-padding mentions value-max-length) max-field-length 2 input-bg input-fg) (print-field label-subject 1 3 bgcolor fgcolor) (print-field (right-padding subject value-max-length) max-field-length 3 input-bg input-fg) (print-field label-visibility 1 4 bgcolor fgcolor) (print-field (right-padding visibility value-max-length) max-field-length 4 input-bg input-fg) (print-field label-language 1 5 bgcolor fgcolor) (print-field (right-padding language value-max-length) max-field-length 5 input-bg input-fg) (print-field (right-padding (text-ellipsis label-attachments (win-width-no-border object)) (win-width-no-border object)) 1 6 bgcolor fgcolor :inverse t))))))) (defun init (message-data screen) (flet ((make-rows (data bg fg) (mapcar #'(lambda (a) (make-instance 'line :normal-text a :selected-text a :normal-bg bg :normal-fg fg :selected-bg fg :selected-fg bg)) data))) (let* ((low-level-window (make-croatoan-window :enable-function-keys t))) (setf *send-message-window* (make-instance 'confirm-sending-window :uses-border-p t :screen screen :keybindings keybindings:*send-message-keymap* :croatoan-window low-level-window :message-data message-data)) (refresh-config *send-message-window*) (line-oriented-window:update-all-rows *send-message-window* (make-rows (attachments message-data) (c:bgcolor low-level-window) (c:fgcolor low-level-window))) (setf (row-selected-index *send-message-window*) 0) *send-message-window*)))