;;;; ioctl.scm -- ioctl (I/O control) interface
;;
;; Copyright (c) 2007-2009 Alex Shinn.  All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt

;; The ioctl(2) system call provides an interface to the operating
;; system terminal drivers (or more commonly these days to ptys
;; (pseudo-terminals)).  ioctl is very low-level - most aspects of the
;; terminal can be controlled with the higher-level termios(4),
;; available in Chicken as the even higher-level stty egg.

;; One thing you may want this library for is to access the terminal's
;; row and column dimensions, for which the ioctl-winsize procedure is
;; provided.

;; Procedure: ioctl-winsize [<port-or-fileno>]
;;
;;   Returns a list of the form (<num-rows> <num-columns>) for the
;;   given port or file descriptor, defaulting to current-output-port.

;; Procedure: ioctl <port-or-fileno> <request> <arg> ...
;;
;;   Makes the given ioctl request with any arguments provided.  The
;;   following requests are available:
;;
;; TIOCSETD int *ldisc
;;     change the line discipline:
;;                TTYDISC     termios interactive line discipline
;;                TABLDISC    tablet line discipline
;;                SLIPDISC    serial IP line discipline
;;                PPPDISC     PPP line discipline
;; TIOCGETD int *ldisc
;;     return the current line discipline
;; TIOCSBRK
;;     set the terminal into BREAK condition
;; TIOCCBRK
;;     clear the terminal BREAK condition
;; TIOCSDTR
;;     assert data terminal ready
;; TIOCCDTR
;;     clear data terminal ready
;; TIOCGPGRP int *tpgrp
;;     return the terminal's process group
;; TIOCSPGRP int *tpgrp
;;     associate the terminal's process group
;; TIOCGETA struct termios *term
;;     get the terminal's termios attributes
;; TIOCSETA struct termios *term
;;     set the terminal's termios attributes
;; TIOCSETAW struct termios *term
;;     set the termios attrs after any output completes
;; TIOCSETAF struct termios *term
;;     after any output completes, clear input and set termios attrs
;; TIOCOUTQ int *num
;;     current number of characters in the output queue
;; TIOCSTI char *cp
;;     manually send a character to the terminal
;; TIOCSTOP
;;     stop output (like typing ^S)
;; TIOCSTART
;;     start output (like typing ^Q)
;; TIOCSCTTY
;;     make this the controlling terminal for the process
;; TIOCDRAIN
;;     wait until all output is drained
;; TIOCEXCL
;;     set exclusive use on the terminal
;; TIOCNXCL
;;     clear exclusive use of the terminal
;; TIOCFLUSH int *what
;;     clear input/output if `what' has FREAD/FWRITE set
;; TIOCGWINSZ struct winsize *ws
;;     get the winsize information
;; TIOCSWINSZ struct winsize *ws
;;     set the winsize information
;; TIOCCONS int *on
;;     redirect kernel console messages
;; TIOCMSET int *state
;;     set the modem state bit flags according to the following:
;;                TIOCM_LE   Line Enable
;;                TIOCM_DTR  Data Terminal Ready
;;                TIOCM_RTS  Request To Send
;;                TIOCM_ST   Secondary Transmit
;;                TIOCM_SR   Secondary Receive
;;                TIOCM_CTS  Clear To Send
;;                TIOCM_CAR  Carrier Detect
;;                TIOCM_CD   Carrier Detect (synonym)
;;                TIOCM_RNG  Ring Indication
;;                TIOCM_RI   Ring Indication (synonym)
;;                TIOCM_DSR  Data Set Ready
;; TIOCMGET int *state
;;     get the modem state bit flags
;; TIOCMBIS int *state
;;     add modem state bit flags, OR-ing in the new states
;; TIOCMBIC int *state
;;     clear modem state bit flags
;;
;; The struct winsize *ws arguments use the winsize record:
;;
;;     make-winsize free-winsize
;;     winsize-row winsize-col
;;     winsize-row-set! winsize-col-set!
;;
;; The struct termios *term arguments use the term-attrs record from
;; the stty egg.
;;
;; The integer pointer arguments can be handled with pointers from the
;; lolevel extension.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(require-library posix foreigners)

(module ioctl
  (
   ;; interface
   ioctl ioctl-winsize
   ;; the winsize record
   make-winsize free-winsize
   winsize-row winsize-col winsize-xpixel winsize-ypixel
   winsize-row-set! winsize-col-set!
   winsize-xpixel-set! winsize-ypixel-set!
   ;; constants
   TIOCSETD TIOCGETD TIOCSBRK TIOCCBRK TIOCGPGRP TIOCSPGRP
   TIOCOUTQ TIOCSTI TIOCSCTTY TIOCEXCL TIOCNXCL
   TIOCGWINSZ TIOCSWINSZ TIOCCONS TIOCMSET TIOCM_LE
   TIOCM_DTR TIOCM_RTS TIOCM_ST TIOCM_SR TIOCM_CTS TIOCM_CAR
   TIOCM_CD TIOCM_RNG TIOCM_RI TIOCM_DSR TIOCMGET
   TIOCMBIS TIOCMBIC
   ;; removed: these are only available on BSD
   ;; TTYDISC TABLDISC SLIPDISC PPPDISC TIOCFLUSH TIOCDRAIN
   ;; TIOCSDTR TIOCCDTR TIOCGETA TIOCSETA TIOCSETAW TIOCSETAF
   ;; TIOCSTOP TIOCSTART
   )

(import scheme chicken posix foreign foreigners)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(declare (foreign-declare "#include <termios.h>\n"))
(declare (foreign-declare "#include <sys/ioctl.h>"))
(declare (foreign-declare "#include <errno.h>"))
(declare (foreign-declare "#include <string.h>"))
(declare (foreign-declare "typedef struct winsize struct_winsize;"))
(cond-expand
 ((not linux) (declare (foreign-declare "#include <sys/ttycom.h>")))
 (else))

(define-foreign-record-type (winsize "struct winsize")
  (constructor: %make-winsize)
  (destructor: free-winsize)
  (unsigned-short ws_row winsize-row winsize-row-set!)
  (unsigned-short ws_col winsize-col winsize-col-set!)
  (unsigned-short ws_xpixel winsize-xpixel winsize-xpixel-set!)
  (unsigned-short ws_ypixel winsize-ypixel winsize-ypixel-set!)
  )

(define (make-winsize . o)
  (let ((res (%make-winsize)))
    (cond
     ((pair? o)
      (winsize-row-set! res (car o))
      (if (pair? (cdr o))
          (winsize-col-set! res (cadr o)))))
    res))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; constants

(define-foreign-variable TIOCSETD_ unsigned-long "TIOCSETD")
(define TIOCSETD TIOCSETD_)
(define-foreign-variable TIOCGETD_ unsigned-long "TIOCGETD")
(define TIOCGETD TIOCGETD_)
(define-foreign-variable TIOCSBRK_ unsigned-long "TIOCSBRK")
(define TIOCSBRK TIOCSBRK_)
(define-foreign-variable TIOCCBRK_ unsigned-long "TIOCCBRK")
(define TIOCCBRK TIOCCBRK_)
(define-foreign-variable TIOCGPGRP_ unsigned-long "TIOCGPGRP")
(define TIOCGPGRP TIOCGPGRP_)
(define-foreign-variable TIOCSPGRP_ unsigned-long "TIOCSPGRP")
(define TIOCSPGRP TIOCSPGRP_)
(define-foreign-variable TIOCOUTQ_ unsigned-long "TIOCOUTQ")
(define TIOCOUTQ TIOCOUTQ_)
(define-foreign-variable TIOCSTI_ unsigned-long "TIOCSTI")
(define TIOCSTI TIOCSTI_)
(define-foreign-variable TIOCSCTTY_ unsigned-long "TIOCSCTTY")
(define TIOCSCTTY TIOCSCTTY_)
(define-foreign-variable TIOCEXCL_ unsigned-long "TIOCEXCL")
(define TIOCEXCL TIOCEXCL_)
(define-foreign-variable TIOCNXCL_ unsigned-long "TIOCNXCL")
(define TIOCNXCL TIOCNXCL_)
(define-foreign-variable TIOCGWINSZ_ unsigned-long "TIOCGWINSZ")
(define TIOCGWINSZ TIOCGWINSZ_)
(define-foreign-variable TIOCSWINSZ_ unsigned-long "TIOCSWINSZ")
(define TIOCSWINSZ TIOCSWINSZ_)
(define-foreign-variable TIOCCONS_ unsigned-long "TIOCCONS")
(define TIOCCONS TIOCCONS_)
(define-foreign-variable TIOCMSET_ unsigned-long "TIOCMSET")
(define TIOCMSET TIOCMSET_)
(define-foreign-variable TIOCM_LE_ unsigned-long "TIOCM_LE")
(define TIOCM_LE TIOCM_LE_)
(define-foreign-variable TIOCM_DTR_ unsigned-long "TIOCM_DTR")
(define TIOCM_DTR TIOCM_DTR_)
(define-foreign-variable TIOCM_RTS_ unsigned-long "TIOCM_RTS")
(define TIOCM_RTS TIOCM_RTS_)
(define-foreign-variable TIOCM_ST_ unsigned-long "TIOCM_ST")
(define TIOCM_ST TIOCM_ST_)
(define-foreign-variable TIOCM_SR_ unsigned-long "TIOCM_SR")
(define TIOCM_SR TIOCM_SR_)
(define-foreign-variable TIOCM_CTS_ unsigned-long "TIOCM_CTS")
(define TIOCM_CTS TIOCM_CTS_)
(define-foreign-variable TIOCM_CAR_ unsigned-long "TIOCM_CAR")
(define TIOCM_CAR TIOCM_CAR_)
(define-foreign-variable TIOCM_CD_ unsigned-long "TIOCM_CD")
(define TIOCM_CD TIOCM_CD_)
(define-foreign-variable TIOCM_RNG_ unsigned-long "TIOCM_RNG")
(define TIOCM_RNG TIOCM_RNG_)
(define-foreign-variable TIOCM_RI_ unsigned-long "TIOCM_RI")
(define TIOCM_RI TIOCM_RI_)
(define-foreign-variable TIOCM_DSR_ unsigned-long "TIOCM_DSR")
(define TIOCM_DSR TIOCM_DSR_)
(define-foreign-variable TIOCMGET_ unsigned-long "TIOCMGET")
(define TIOCMGET TIOCMGET_)
(define-foreign-variable TIOCMBIS_ unsigned-long "TIOCMBIS")
(define TIOCMBIS TIOCMBIS_)
(define-foreign-variable TIOCMBIC_ unsigned-long "TIOCMBIC")
(define TIOCMBIC TIOCMBIC_)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define ioctl0
  (foreign-lambda* int ((int fd) (unsigned-long req))
    "int res = ioctl(fd, req);"
    "return(res);"))

(define ioctl1
  (foreign-lambda* int ((int fd) (unsigned-long req) (c-pointer val1))
    "int res = ioctl(fd, req, val1);"
    "return(res);"))

(define (ioctl port request . o)
  (let ((fd (if (port? port) (port->fileno port) port)))
    (cond
     ((null? o) (ioctl0 fd request))
     (else (ioctl1 fd request (car o))))))

(define (ioctl-winsize . o)
  (let* ((port (if (pair? o) (car o) (current-output-port)))
         (fd (if (port? port) (port->fileno port) port))
         (ws (%make-winsize))
         (errcode (ioctl1 fd TIOCGWINSZ ws)))
    (let ((res (list (winsize-row ws) (winsize-col ws))))
      (free-winsize ws)
      (and (zero? errcode) res))))

)