;;; -*- Mode: lisp; Package: termcap -*-

;;;  termcap.lisp --- interface to the termcap database

;;;  Copyright (C) 2003 by Walter C. Pelissero

;;;  Author: Walter C. Pelissero <walter@pelissero.de>
;;;  Project: ffm
;;;  $Id: F-60350968073F47868B0045D61E94CB9F.lisp,v 2.1 2003/07/20 22:55:46 wcp Exp $

;;;  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 2, 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; see the file COPYING.  If not, write to
;;;  the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;;  Boston, MA 02111-1307, USA.

;;;  Commentary:

(in-package :termcap)

(defvar *termcap-pathname* #P"/etc/termcap"
  "The pathname of the termcap database.  Normally \"/etc/termcap\".")
(defvar *debug* nil
  "If true the termcap paring routines will print some warnings about
misformed termcap entries.")
(deflazy *capabilities* (get-terminal-capabilities)
  "The terminal capabilities.  Whatever the current terminal is.")

(defun parse-db-capabilities (entry)
  "Parse a termcap entry and return an alist of its capabilities."
  (loop
     for str in (split-string entry #\: :escape #\\ :skip-empty t
				 :proc #'string-trim-whitespace)
     for cap = (interpret-capability str)
     when cap
     collect cap))

(defun ctrl (x)
  "Compute the character corresponding to the ^X (Ctrl-X) where X is a
character."
  (code-char (logand (char-code x) #x1f)))

(defun parse-string-capability (str)
  "Parse a termcap string capability STR.  Return either an expanded
string or a list os an expanded string and a padding value."
  (labels ((map-simple-escape (c)
	     (cadr (assoc c '((#\E #\escape) (#\r #\return) (#\n #\newline) (#\t #\tab)
			      (#\b #\backspace) (#\f #\formfeed)))))
	   (interpret (l)
	     (if (null l) nil
		 (let ((first (pop l)))
		   (if (null l)
		       (list first)
		       (case first
			 (#\\ (let* ((c (pop l))
				     (simple (map-simple-escape c)))
				(cond (simple
				       (cons simple (interpret l)))
				      ((char-digit-p c)
				       (multiple-value-bind (octal-value rest)
					   (parse-numeric-sequence (cons c l) :base 8 :maxlen 3)
					 (cons (code-char octal-value) (interpret rest))))
				      (t (cons c (interpret l))))))
			 (#\^ (cons (ctrl (car l)) (interpret (cdr l))))
			 (t (cons first (interpret l)))))))))
    (let ((list-of-chars (string->list str)))
      ;; sometimes the string capability is prefixed with a padding
      ;; value
      (multiple-value-bind (padding rest)
	  (parse-numeric-sequence list-of-chars)
	;; if the padding is followed by an asterisk then the padding
	;; is proportional to the number of affected lines (or
	;; whatever is passed to tputs)
	(if (zerop padding)
	    (list->string (interpret rest))
	    (let* ((propotional-padding
		    ;; for unknown reasons there are some string
		    ;; capabilities containing only a padding value,
		    ;; therefore we compare with eq and not with char=
		    (when (eq #\* (car rest)) (pop rest)))
		   (parsed-string (list->string (interpret rest))))
	      (list parsed-string padding propotional-padding)))))))

(defun interpret-capability (par)
  (flet ((tag ()
	   (subseq par 0 2)))
    (cond ((< (length par) 2)
	   (when *debug*
	     (warn "invalid termcap capability ~S" par)))
	  ((< (length par) 3)
	   ;; a boolean
	   (cons (tag) t))
	  (t (case (char par 2)
	       (#\# (cons (tag) (read-integer-from-string (subseq par 3))))
	       (#\= (cons (tag) (parse-string-capability (subseq par 3))))
	       (#\@ (cons (tag) nil))
	       (t (when *debug*
		    (warn "invalid termcap capability type ~S" par))))))))

(defun read-db-line (stream)
  (flet ((continued-p (str)
	   (and (not (string= "" str))
		(char= #\\ (char str (1- (length str)))))))
    (let ((line (read-line stream nil)))
      (cond ((not line)
	     nil)
	    ((continued-p line)
	     (concatenate 'string (subseq line 0 (1- (length line))) (read-db-line stream)))
	    (t line)))))

(defun split-db-line (line)
  "Given a complete termcap entry as string, split it in two and
return two values a list of the names this entry is known as, and a
string with the rest of the LINE containing the unparsed
capabilities."
  (let* ((col (position #\: line))
	 (names (split-string (subseq line 0 col) #\| :skip-empty t :proc #'string-trim-whitespace)))
    (values (remove-if #'(lambda (name)
			   (position-if #'whitespace-p name)) names)
	    (subseq line (1+ col)))))

(defun read-termcap (&optional (file *termcap-pathname*))
  (flet ((comment-p (str)
	     (char= #\# (char str 0))))
    (with-open-file (stream file)
      (let ((db '()))
	(loop
	   for line = (read-db-line stream)
	   while line
	   unless (or (string= "" line)
		      (comment-p line))
	   do (multiple-value-bind (names capabilities-string)
		  (split-db-line line)
		(let ((capabilities (parse-db-capabilities capabilities-string)))
		  (dolist (name names)
		    (push (cons name capabilities) db)))))
	db))))

(defun getcap (capability &optional termcap-entry)
  (gethash capability (or termcap-entry (*capabilities*))))

(defun get-terminal-capabilities (&optional (terminal (port:getenv "TERM")))
  "Return an hash table of the terminal capabilities of TERMINAL."
  (let ((termcap-db (read-termcap)))
    (labels ((find (name)
	       (let ((entry (cdr (assoc name termcap-db :test #'string-equal))))
		 (when entry
		   (let ((tc (cdr (assoc "tc" entry :test #'string=))))
		     (if tc
			 (append entry (find tc))
			 entry))))))
      ;; turn the alist into a hash table
      (let ((hash (make-hash-table :test 'equalp)))
	(dolist (cap (find terminal) hash)
	  (unless (gethash (car cap) hash)
	    (setf (gethash (car cap) hash) (cdr cap))))))))

(defun fill-control-string (string &rest parameters)
  (labels ((parse (list)
	     (if (null list)
		 '()
		 (let ((first (pop list)))
		   (if (eq first #\%)
		       (if (null list)
			   (list #\%)
			   (ecase (pop list)
			     (#\% (cons #\% (parse list)))
			     (#\d (append (string->list (write-to-string (pop parameters)))
					  (parse list)))
			     (#\2 (append (string->list (format nil "~2,'0D" (pop parameters)))
					  (parse list)))
			     (#\3 (append (string->list (format nil "~3,'0D" (pop parameters)))
					  (parse list)))
			     (#\. (append (code-char (pop parameters))
					  (parse list)))
			     (#\+ (append (code-char (+ (pop parameters) (char-code (car list))))
					  (parse (cdr list))))
			     (#\> (when (> (car parameters)
					   (char-code (car list)))
				    (setf (car parameters) (char-code (cadr list))))
				  (parse (cddr list)))
			     ;; swap two parameters (no output)
			     (#\r (let ((x (car parameters)))
				    (setf (car parameters) (cadr parameters))
				    (setf (cadr parameters) x))
				  (parse list))
			     ;; increment by one (no output)
			     (#\i (setf parameters (mapcar #'1+ parameters))
				  (parse list))
			     (#\n (setf parameters (mapcar #'(lambda (par)
							       (logxor par #o140))
							   parameters))
				  (parse list))
			     (#\B (setf parameters (mapcar #'(lambda (par)
							       (+ (* 16 (truncate par 10))
								  (rem par 10)))
							   parameters))
				  (parse list))
			     (#\D (setf parameters (mapcar #'(lambda (par)
							       (- par
								  (* 2 (rem par 16))))
							   parameters))
				  (parse list))))
		       (cons first (parse list)))))))
    (list->string (parse (string->list string)))))

;;;
;;;  Some of the most used procedures.  All the other capabilities
;;;  have to be accessed via the GETCAP function.
;;;

(deflazy pad-char
    (if (getcap "NP")
	nil
	(let ((pc (getcap "pc")))
	  (if pc
	      (char pc 0)
	      #\null))))

(defun put (string padding-times)
  (write-string string)
  (when (and padding-times (pad-char))
    (dotimes (x padding-times (values))
      (write-char (pad-char)))))

(defun move-to (col row)
  "Move terminal cursor to COL and ROW."
  (let ((cm (getcap "cm")))
    (multiple-value-bind (str padding proportional)
	(if (consp cm)
	    (apply #'values cm)
	    cm)
      (declare (ignore proportional))
      (put (fill-control-string str col row) padding))))