Common Lisp で HTML のテンプレートエンジンを作るなら

リードテーブルをいじくりまわして、リーダで実装だよね。

そうすれば html を load したり、 compile-file で fasl にコンパイルできる。

全て S 式で書きたとろだけど、それはデザイナーさんに優しくないので、 ERB 形式で次のように書けるようにする。

<h2>パッケージリスト</h2>

<h3>loop で</h3>
<ul>
  <% (loop for i in (list-all-packages) do %>
  <li><%= (package-name i) %></li><% ) %>
</ul>

<h3>map で</h3>
<ol>
  <% (mapcar (lambda (x)
               %><li><%= (package-name x) %></li>
               <% )
             (list-all-packages)) %>
</ol>

S 式の途中で HTML に戻れるのがポイント。

最初は次のようにしていてメモリがいくらあっても足りない感じだった。

(loop for i from 0 below char-code-limit
      do (set-macro-character (code-char i) 'html-defun-readtable))

よく考えたら peek-char して最初の一文字だけ set-macro-character すればよかった。

(defun <%?-readtable (stream)
  (let ((*readtable* (basic-readtable))
        (char (peek-char nil stream t t t)))
    (case char
      (#\= (set-macro-character char '<%=-reader))
      (#\# (set-macro-character char '<%#-reader))
      (t   (set-macro-character #\% '%>-reader)))
    *readtable*))

(defun <%=-reader (stream char)
  (declare (ignore char))
  (setf *readtable* (copy-readtable nil))
  `(out
    (progn
      ,@(loop for c = (peek-char t stream t t t)
              if (char/= c #\%)
                collect (read stream t t t)
              else if (char= #\> (progn
                                   (read-char stream) ; %
                                   (peek-char nil stream t t t)))
                     do (read-char stream) ; >
                        (setf *readtable* (make-html-readtable stream))
                        (loop-finish)
              else
                collect (progn
                          (unread-char #\% stream)
                          (read stream t t t))))))

(defun <%#-reader (stream char)
  (declare (ignore char))
  (loop for % = (read-char stream) then c
        for c = (read-char stream)
        until (and (char= #\% %)
                   (char= #\> c)))
  (setf *readtable* (make-html-readtable stream))
  (read stream t t t))

(defun %>-reader (stream char)
  (declare (ignore char))
  (if (char= #\> (peek-char nil stream t t t))
      (progn
        (read-char stream)              ; >
        (setf *readtable* (make-html-readtable stream))
        (read stream nil stream t))
      (progn
        (unread-char #\% stream)
        (setf *readtable* (copy-readtable nil))
        (read stream t t t))))


(defun char-reader (stream char)
  (unread-char char stream)
  `(out ,(with-output-to-string (out)
           (loop for c = (read-char stream nil nil t)
                 while c
                 if (and (char= #\< c)
                         (char= #\% (peek-char nil stream nil nil t)))
                   do (read-char stream) ; %
                      (setf *readtable*  (<%?-readtable stream))
                      (loop-finish)
                 else
                   do (write-char c out)))))

(defgeneric make-html-readtable (x)
  (:method ((char character))
    (let ((*readtable* (copy-readtable nil)))
      (set-macro-character char 'char-reader)
      *readtable*))
  (:method ((stream stream))
    (make-html-readtable (peek-char nil stream nil nil t)))
  (:method ((x null))
    (copy-readtable nil)))

(defun out (x)
  (princ x))

(defun out-if (x)
  (when x (out x)))

(defun html-defun-readtable (fname pathspec)
  (let ((*readtable* (copy-readtable nil)))
    (set-macro-character
     (first-char pathspec)
     (lambda (stream char)
       (unread-char char stream)
       (print
        `(defun ,fname ()
           ,@(let ((*readtable* (make-html-readtable char)))
               (loop for x = (read stream nil stream t)
                     until (eq x stream)
                     collect x))))))
    *readtable*))

(defun first-char (pathspec)
  (with-open-file (in pathspec)
    (read-char in)))

(defun load-html (fname pathspec &rest args)
  (let ((*readtable* (html-defun-readtable fname pathspec)))
    (apply #'load pathspec args)
    fname))

(defun compile-html-file (fname input-file &rest args)
  (let ((*readtable* (html-defun-readtable fname input-file)))
    (apply #'compile-file input-file args)))

#|
(progn
  (load-html 'foo "/home/ancient/letter/lisp/try/html/test1.html")
  (foo))

(progn
  (load-html 'bar "/home/ancient/letter/lisp/try/html/test2.html")
  (bar))

(progn
  (load
   (compile-html-file 'foo "/home/ancient/letter/lisp/try/html/test1.html"))
  (foo))
|#

これで HTML ファイルが一つの defun としてコンパイルされる。

Common Lisp や Forth のようにリーダをいじれる言語は素晴しい。

窓使いの憂鬱 Linux 対応版

http://members.at.infoseek.co.jp/hattoushin_uma/

最高です。本当に素晴しい。 Dvorak 配列がいいとか、SandS 使いたいとか、括弧はシフト押さずに入力したいとかで、いろいろ苦労していたけど、これで幸せになれました。ありがとうございます。

Linux では uinput というカーネルモジュールを使っているので X もコンソールも一緒にカスタマイズできる。

インストール方法等は README ファイルに書かれているが、私の手順をここに書いておく。

コンパイルとインストール

./configure --prefix=/home/ancient/local/opt/mayu --datadir=/home/ancient/local/opt/mayu/share
make
make install

自動起動のために mayu_init_script を作成

#! /bin/sh
### BEGIN INIT INFO
# Provides:          mayu
# Required-Start:    $remote_fs $syslog
# Required-Stop:     $remote_fs $syslog
# Default-Start:     2 3 4 5
# Default-Stop:      0 1 6
# X-Interactive:     true
# Short-Description: mayu
### END INIT INFO

# PATH should only include /usr/* if it runs after the mountnfs.sh script
HOME=/home/ancient
PATH=$HOME/local/opt/mayu/bin:/sbin:/usr/sbin:/bin:/usr/bin
DESC="mayu"
NAME=mayu
DAEMON=$HOME/local/opt/mayu/bin/$NAME
DAEMON_ARGS="-v"
PIDFILE=/var/run/$NAME.pid
SCRIPTNAME=/etc/init.d/$NAME

# Exit if the package is not installed
[ -x "$DAEMON" ] || exit 0

# Read configuration variable file if it is present
[ -r /etc/default/$NAME ] && . /etc/default/$NAME

# Load the VERBOSE setting and other rcS variables
. /lib/init/vars.sh

# Define LSB log_* functions.
# Depend on lsb-base (>= 3.2-14) to ensure that this file is present
# and status_of_proc is working.
. /lib/lsb/init-functions

#
# Function that starts the daemon/service
#
do_start()
{
        # Return
        #   0 if daemon has been started
        #   1 if daemon was already running
        #   2 if daemon could not be started
        start-stop-daemon --start --quiet --background --pidfile $PIDFILE --exec $DAEMON --test > /dev/null \
                || return 1
        start-stop-daemon --start --quiet --background --pidfile $PIDFILE --exec $DAEMON -- \
                $DAEMON_ARGS \
                || return 2
        # Add code here, if necessary, that waits for the process to be ready
        # to handle requests from services started subsequently which depend
        # on this one.  As a last resort, sleep for some time.
}

#
# Function that stops the daemon/service
#
do_stop()
{
        # Return
        #   0 if daemon has been stopped
        #   1 if daemon was already stopped
        #   2 if daemon could not be stopped
        #   other if a failure occurred
        start-stop-daemon --stop --quiet --pidfile $PIDFILE --name $NAME
        RETVAL="$?"
        [ "$RETVAL" = 2 ] && return 2
        # Wait for children to finish too if this is a daemon that forks
        # and if the daemon is only ever run from this initscript.
        # If the above conditions are not satisfied then add some other code
        # that waits for the process to drop all resources that could be
        # needed by services started subsequently.  A last resort is to
        # sleep for some time.
        start-stop-daemon --stop --quiet --oknodo --exec $DAEMON

        [ "$?" = 2 ] && return 2
        # Many daemons don't delete their pidfiles when they exit.
        rm -f $PIDFILE
        return "$RETVAL"
}

#
# Function that sends a SIGHUP to the daemon/service
#
do_reload() {
        #
        # If the daemon can reload its configuration without
        # restarting (for example, when it is sent a SIGHUP),
        # then implement that here.
        #
        start-stop-daemon --stop --signal 1 --quiet --pidfile $PIDFILE --name $NAME
        return 0
}

case "$1" in
  start)
        [ "$VERBOSE" != no ] && log_daemon_msg "Starting $DESC" "$NAME"
        do_start
        case "$?" in
                0|1) [ "$VERBOSE" != no ] && log_end_msg 0 ;;
                2) [ "$VERBOSE" != no ] && log_end_msg 1 ;;
        esac
        ;;
  stop)
        [ "$VERBOSE" != no ] && log_daemon_msg "Stopping $DESC" "$NAME"
        do_stop
        case "$?" in
                0|1) [ "$VERBOSE" != no ] && log_end_msg 0 ;;
                2) [ "$VERBOSE" != no ] && log_end_msg 1 ;;
        esac
        ;;
  status)
       status_of_proc "$DAEMON" "$NAME" && exit 0 || exit $?
       ;;
  #reload|force-reload)
        #
        # If do_reload() is not implemented then leave this commented out
        # and leave 'force-reload' as an alias for 'restart'.
        #
        #log_daemon_msg "Reloading $DESC" "$NAME"
        #do_reload
        #log_end_msg $?
        #;;
  restart|force-reload)
        #
        # If the "reload" option is implemented then remove the
        # 'force-reload' alias
        #
        log_daemon_msg "Restarting $DESC" "$NAME"
        do_stop
        case "$?" in
          0|1)
                do_start
                case "$?" in
                        0) log_end_msg 0 ;;
                        1) log_end_msg 1 ;; # Old process is still running
                        *) log_end_msg 1 ;; # Failed to start
                esac
                ;;
          *)
                # Failed to stop
                log_end_msg 1
                ;;
        esac
        ;;
  *)
        #echo "Usage: $SCRIPTNAME {start|stop|restart|reload|force-reload}" >&2
        echo "Usage: $SCRIPTNAME {start|stop|status|restart|force-reload}" >&2
        exit 3
        ;;
esac

:

Debian なので update-rc.d する。

cd /etc/inid.d
sudo ln -s /home/ancient/letter/dot.file/mayu_init_script mayu
update-rc.d  mayu defaults

~/.mayu

def key Esc Escape                      =    0x01
def key _1                              =    0x02 # 1!
def key _2                              =    0x03 # 2@
def key _3                              =    0x04 # 3#
def key _4                              =    0x05 # 4$
def key _5                              =    0x06 # 5%
def key _6                              =    0x07 # 6^
def key _7                              =    0x08 # 7&
def key _8                              =    0x09 # 8*
def key _9                              =    0x0a # 9(
def key _0                              =    0x0b # 0)
def key HyphenMinus Hyphen Minus        =    0x0c # -_
def key EqualsSign Equal                =    0x0d # =+
def key BackSpace BS Back               =    0x0e
def key Tab                             =    0x0f
def key Q                               =    0x10
def key W                               =    0x11
def key E                               =    0x12
def key R                               =    0x13
def key T                               =    0x14
def key Y                               =    0x15
def key U                               =    0x16
def key I                               =    0x17
def key O                               =    0x18
def key P                               =    0x19
def key LeftSquareBracket OpenBracket   =    0x1a # [{
def key RightSquareBracket CloseBracket =    0x1b # ]}
def key Enter Return                    =    0x1c
def key LeftControl LControl LCtrl      =    0x1d
def key A                               =    0x1e
def key S                               =    0x1f
def key D                               =    0x20
def key F                               =    0x21
def key G                               =    0x22
def key H                               =    0x23
def key J                               =    0x24
def key K                               =    0x25
def key L                               =    0x26
def key Semicolon                       =    0x27 # ;:
def key Apostrophe Quote                =    0x28 # '"
def key GraveAccent BackQuote           =    0x29 # `~
def key LeftShift LShift                =    0x2a
def key ReverseSolidus BackSlash        =    0x2b # \|
def key Z                               =    0x2c
def key X                               =    0x2d
def key C                               =    0x2e
def key V                               =    0x2f
def key B                               =    0x30
def key N                               =    0x31
def key M                               =    0x32
def key Comma                           =    0x33 # ,<
def key FullStop Period                 =    0x34 # .>
def key Solidus Slash                   =    0x35 # /?
def key RightShift RShift               =    0x36
def key NumAsterisk NumMultiply         =    0x37 # Numpad *
def key LeftAlt LAlt LMenu              =    0x38
def key Space                           =    0x39
def key CapsLock Capital Caps           =    0x3a # CapsLock
def key F1                              =    0x3b
def key F2                              =    0x3c
def key F3                              =    0x3d
def key F4                              =    0x3e
def key F5                              =    0x3f
def key F6                              =    0x40
def key F7                              =    0x41
def key F8                              =    0x42
def key F9                              =    0x43
def key F10                             =    0x44
def key NumLock                         =    0x45
def key ScrollLock Scroll               =    0x46
def key Num7                            =    0x47 # Numpad 7
def key Num8                            =    0x48 # Numpad 8
def key Num9                            =    0x49 # Numpad 9
def key NumHyphenMinus NumMinus         =    0x4a # Numpad -
def key Num4                            =    0x4b # Numpad 4
def key Num5                            =    0x4c # Numpad 5
def key Num6                            =    0x4d # Numpad 6
def key NumPlusSign NumPlus             =    0x4e # Numpad +
def key Num1                            =    0x4f # Numpad 1
def key Num2                            =    0x50
def key Num3                            =    0x51
def key Num0                            =    0x52
def key NumFullStop NumPeriod           =    0x53 # Numpad .

def key F11                             =    0x57
def key F12                             =    0x58
def key F13                             =    0xb7
def key F14                             =    0xb8
def key F15                             =    0xb9
def key F16                             =    0xba
def key F17                             =    0xbb
def key F18                             =    0xbc
def key F19                             =    0xbd
def key F20                             =    0xbe
def key F21                             =    0xbf
def key F22                             =    0xc0
def key F23                             =    0xc1
def key F24                             =    0xc2

def key NumEnter NumReturn              =    0x60
def key RightControl RControl RCtrl     =    0x61
def key NumSolidus NumSlash             =    0x62 # テンキー /
def key PrintScreen Snapshot            =    0x63
def key RightAlt RAlt RMenu             =    0x64
def key Home                            =    0x66
def key Up                              =    0x67
def key PageUp Prior                    =    0x68
def key Left                            =    0x69
def key Right                           =    0x6a
def key End                             =    0x6b
def key Down                            =    0x6c
def key PageDown Next                   =    0x6d
def key Insert                          =    0x6e
def key Delete Del                      =    0x6f
def key Pause                           =    0x77 # Pause

def key Yen                             =    0x7c
def key LeftWindows LWindows LWin       =    0x7d
def key RightWindows RWindows RWin      =    0x7e
def key Applications Apps               =    0x7f

def key Henkan                          =    0x5c
def key Hiragana                        =    0x5d
def key Muhenkan                        =    0x5e
def key GraveAccent BackQuote           =    0x59


# def overflow                          =    0xff # overflow (ignore)

def mod Shift   = LShift RShift
def mod Alt     = LAlt RAlt
def mod Control = LControl RControl
def mod Windows = LWindows RWindows

# Key Sequence

keyseq $ToggleIME               = A-BackQuote
keyseq $CapsLock                = CapsLock

keyseq $SPACE                   = ~S-*Space                     # space
keyseq $EXCLAMATION_MARK        =  S-*_1                        # !
keyseq $QUOTATION_MARK          =  S-*Apostrophe                # "
keyseq $NUMBER_SIGN             =  S-*_3                        # #
keyseq $DOLLAR_SIGN             =  S-*_4                        # $
keyseq $PERCENT_SIGN            =  S-*_5                        # %
keyseq $AMPERSAND               =  S-*_7                        # &
keyseq $APOSTROPHE              = ~S-*Apostrophe                # '
keyseq $LEFT_PARENTHESIS        =  S-*_9                        # (
keyseq $RIGHT_PARENTHESIS       =  S-*_0                        # )
keyseq $ASTERISK                =  S-*_8                        # *
keyseq $PLUS_SIGN               =  S-*EqualsSign                # +
keyseq $COMMA                   = ~S-*Comma                     # ,
keyseq $HYPHEN-MINUS            = ~S-*HyphenMinus               # -
keyseq $FULL_STOP               = ~S-*FullStop                  # .
keyseq $SOLIDUS                 = ~S-*Solidus                   # /
keyseq $DIGIT_ZERO              = ~S-*_0                        # 0
keyseq $DIGIT_ONE               = ~S-*_1                        # 1
keyseq $DIGIT_TWO               = ~S-*_2                        # 2
keyseq $DIGIT_THREE             = ~S-*_3                        # 3
keyseq $DIGIT_FOUR              = ~S-*_4                        # 4
keyseq $DIGIT_FIVE              = ~S-*_5                        # 5
keyseq $DIGIT_SIX               = ~S-*_6                        # 6
keyseq $DIGIT_SEVEN             = ~S-*_7                        # 7
keyseq $DIGIT_EIGHT             = ~S-*_8                        # 8
keyseq $DIGIT_NINE              = ~S-*_9                        # 9
keyseq $COLON                   =  S-*Semicolon                 # :
keyseq $SEMICOLON               = ~S-*Semicolon                 # ;
keyseq $LESS-THAN_SIGN          =  S-*Comma                     # <
keyseq $EQUALS_SIGN             = ~S-*EqualsSign                # =
keyseq $GREATER-THAN_SIGN       =  S-*FullStop                  # >
keyseq $QUESTION_MARK           =  S-*Solidus                   # ?
keyseq $COMMERCIAL_AT           =  S-*_2                        # @
keyseq $LATIN_CAPITAL_LETTER_A  =  S-*A                         # A
keyseq $LATIN_CAPITAL_LETTER_B  =  S-*B                         # B
keyseq $LATIN_CAPITAL_LETTER_C  =  S-*C                         # C
keyseq $LATIN_CAPITAL_LETTER_D  =  S-*D                         # D
keyseq $LATIN_CAPITAL_LETTER_E  =  S-*E                         # E
keyseq $LATIN_CAPITAL_LETTER_F  =  S-*F                         # F
keyseq $LATIN_CAPITAL_LETTER_G  =  S-*G                         # G
keyseq $LATIN_CAPITAL_LETTER_H  =  S-*H                         # H
keyseq $LATIN_CAPITAL_LETTER_I  =  S-*I                         # I
keyseq $LATIN_CAPITAL_LETTER_J  =  S-*J                         # J
keyseq $LATIN_CAPITAL_LETTER_K  =  S-*K                         # K
keyseq $LATIN_CAPITAL_LETTER_L  =  S-*L                         # L
keyseq $LATIN_CAPITAL_LETTER_M  =  S-*M                         # M
keyseq $LATIN_CAPITAL_LETTER_N  =  S-*N                         # N
keyseq $LATIN_CAPITAL_LETTER_O  =  S-*O                         # O
keyseq $LATIN_CAPITAL_LETTER_P  =  S-*P                         # P
keyseq $LATIN_CAPITAL_LETTER_Q  =  S-*Q                         # Q
keyseq $LATIN_CAPITAL_LETTER_R  =  S-*R                         # R
keyseq $LATIN_CAPITAL_LETTER_S  =  S-*S                         # S
keyseq $LATIN_CAPITAL_LETTER_T  =  S-*T                         # T
keyseq $LATIN_CAPITAL_LETTER_U  =  S-*U                         # U
keyseq $LATIN_CAPITAL_LETTER_V  =  S-*V                         # V
keyseq $LATIN_CAPITAL_LETTER_W  =  S-*W                         # W
keyseq $LATIN_CAPITAL_LETTER_X  =  S-*X                         # X
keyseq $LATIN_CAPITAL_LETTER_Y  =  S-*Y                         # Y
keyseq $LATIN_CAPITAL_LETTER_Z  =  S-*Z                         # Z
keyseq $LEFT_SQUARE_BRACKET     = ~S-*LeftSquareBracket         # [
keyseq $REVERSE_SOLIDUS         = ~S-*ReverseSolidus            # \
keyseq $RIGHT_SQUARE_BRACKET    = ~S-*RightSquareBracket        # ]
keyseq $CIRCUMFLEX_ACCENT       =  S-*_6                        # ^
keyseq $LOW_LINE                =  S-*HyphenMinus               # _
keyseq $GRAVE_ACCENT            = ~S-*GraveAccent               # `
keyseq $LATIN_SMALL_LETTER_A    = ~S-*A                         # a
keyseq $LATIN_SMALL_LETTER_B    = ~S-*B                         # b
keyseq $LATIN_SMALL_LETTER_C    = ~S-*C                         # c
keyseq $LATIN_SMALL_LETTER_D    = ~S-*D                         # d
keyseq $LATIN_SMALL_LETTER_E    = ~S-*E                         # e
keyseq $LATIN_SMALL_LETTER_F    = ~S-*F                         # f
keyseq $LATIN_SMALL_LETTER_G    = ~S-*G                         # g
keyseq $LATIN_SMALL_LETTER_H    = ~S-*H                         # h
keyseq $LATIN_SMALL_LETTER_I    = ~S-*I                         # i
keyseq $LATIN_SMALL_LETTER_J    = ~S-*J                         # j
keyseq $LATIN_SMALL_LETTER_K    = ~S-*K                         # k
keyseq $LATIN_SMALL_LETTER_L    = ~S-*L                         # l
keyseq $LATIN_SMALL_LETTER_M    = ~S-*M                         # m
keyseq $LATIN_SMALL_LETTER_N    = ~S-*N                         # n
keyseq $LATIN_SMALL_LETTER_O    = ~S-*O                         # o
keyseq $LATIN_SMALL_LETTER_P    = ~S-*P                         # p
keyseq $LATIN_SMALL_LETTER_Q    = ~S-*Q                         # q
keyseq $LATIN_SMALL_LETTER_R    = ~S-*R                         # r
keyseq $LATIN_SMALL_LETTER_S    = ~S-*S                         # s
keyseq $LATIN_SMALL_LETTER_T    = ~S-*T                         # t
keyseq $LATIN_SMALL_LETTER_U    = ~S-*U                         # u
keyseq $LATIN_SMALL_LETTER_V    = ~S-*V                         # v
keyseq $LATIN_SMALL_LETTER_W    = ~S-*W                         # w
keyseq $LATIN_SMALL_LETTER_X    = ~S-*X                         # x
keyseq $LATIN_SMALL_LETTER_Y    = ~S-*Y                         # y
keyseq $LATIN_SMALL_LETTER_Z    = ~S-*Z                         # z
keyseq $LEFT_CURLY_BRACKET      =  S-*LeftSquareBracket         # {
keyseq $VERTICAL_LINE           =  S-*ReverseSolidus            # |
keyseq $RIGHT_CURLY_BRACKET     =  S-*RightSquareBracket        # }
keyseq $TILDE                   =  S-*GraveAccent               # ~


def subst *Minus                                = *LeftSquareBracket
def subst *Equal                                = *RightSquareBracket

def subst S-*_9                                 = $LESS-THAN_SIGN
def subst S-*_0                                 = $GREATER-THAN_SIGN

def subst *Q                                    = *Quote
def subst ~S-*W                                 = $LEFT_PARENTHESIS
def subst ~S-*E                                 = $RIGHT_PARENTHESIS
def subst S-*W                                  = $COMMA
def subst S-*E                                  = $FULL_STOP
def subst *R                                    = *P
def subst *T                                    = *Y
def subst *Y                                    = *F
def subst *U                                    = *G
def subst *I                                    = *C
def subst *O                                    = *R
def subst *P                                    = *Equal
def subst *LeftSquareBracket                    = *Slash
def subst *RightSquareBracket                   = *Semicolon

def subst *A                                    = *A
def subst *S                                    = *O
def subst *D                                    = *E
def subst *F                                    = *U
def subst *G                                    = *I
def subst *H                                    = *D
def subst *J                                    = *H
def subst *K                                    = *T
def subst *L                                    = *N
def subst *Semicolon                            = *S
def subst *Quote                                = *Minus

def subst *Z                                    = *L
def subst *X                                    = *Q
def subst *C                                    = *J
def subst *V                                    = *K
def subst *B                                    = *X
def subst *N                                    = *B
def subst *M                                    = *M
def subst *Comma                                = *W
def subst *Period                               = *V
def subst *Slash                                = *Z


keymap Global

mod control   +=   CapsLock
key *CapsLock  =  *LControl

# SandS
mod shift += !!Space
key R-*Space = &Ignore


mod alt       += Henkan
key *Henkan   =  *LeftAlt
#mod alt       += Hiragana
#key *Hiragana =  *LeftAlt

Common Lisp で SandS

いまとなってはどこからダウンロードしていか分からない C で実装された SandS が最近動かなくなって困っていた。

仕方ないので Common Lisp に移植しながら動くようにしてみた。もちろん CLX を使った。

問題は XTestFakeKeyEvent のあたりにあるもよう。いったんキーリリースしてやると動いた。

でも他にもスペース押しっぱなしにしているだけなのに、キープレス、キーリリース、キープレスと3つのイベントがきたりと、怪しげなところがある。

そんなことより、 Linux で動く窓使いの憂鬱 があるのにいままで気づかなかったことが一番の問題だと思う。

http://github.com/quek/cl-xsands

(defpackage cl-xsands
  (:use :cl))

(in-package :cl-xsands)

(defconstant +space-code+ 65)
(defconstant +shift-code+ 50)
(defconstant +tab-code+ 23)

(defvar *display*)
(defvar *window*)

(defun select-input ()
  (setf (xlib:window-event-mask *window*)
        (xlib:make-event-mask :focus-change)))

(defun off-space-auto-repeat ()
  (xlib:change-keyboard-control *display*
                                :key +space-code+
                                :auto-repeat-mode :off)
  (xlib:display-force-output *display*))

(defun default-space-auto-repeat ()
  (xlib:change-keyboard-control *display*
                                :key +space-code+
                                :auto-repeat-mode :default)
  (xlib:display-force-output *display*))

(defun grab-keyboard ()
  (xlib:grab-keyboard *window* :owner-p t
                      :sync-pointer-p nil :sync-keyboard-p nil)
  (xlib:display-force-output *display*))

(defun ungrab-keyboard ()
  (xlib:ungrab-keyboard *display*)
  (xlib:display-force-output *display*))

(defun grab-space ()
  (xlib:grab-key *window* +space-code+ :modifiers :any)
  (xlib:display-force-output *display*))

(defun ungrab-space ()
  (xlib:ungrab-key *window* +space-code+ :modifiers :any)
  (xlib:display-force-output *display*))

(defun emit (code)
  (xtest:fake-key-event *display* code t)
  (xtest:fake-key-event *display* code nil)
  (xlib:display-force-output *display*))

(defun init ()
  (setf *display* (xlib:open-default-display)
        *window* (xlib:input-focus *display*))
  (xlib:set-input-focus *display* *window* :parent)
  (select-input)
  (xlib:set-input-focus *display* :pointer-root :none)
  (xlib:set-input-focus *display* *window* :none)
  (off-space-auto-repeat)
  (xlib:display-force-output *display*))


(defmacro p (&rest args)
  (declare (ignorable args))
  #+nil
  `(progn
     (format t "~a~%" (get-internal-real-time))
     ,@(mapcar (lambda (x)
                 `(format t "~a => ~a~&" ',x ,x))
               args)
     (terpri)
     (force-output)))

(let (key-press-p)
  (defun proc ()
    (xlib:event-cond
     (*display*)
     (:focus-out () t
                 (p :focus-out)
                 (ungrab-space)
                 (setf *window* (loop thereis (ignore-errors
                                                (xlib:input-focus *display*))
                                      do (sleep 0.01)))
                 (unless (member *window* '(:none :pointer-root))
                   (select-input)
                   (grab-space)))
     (:key-release (code) (= code +space-code+)
                   (p :key-release-space)
                   (ungrab-keyboard)
                   (if key-press-p
                       (setf key-press-p nil)
                     (progn
                       (ungrab-space)
                       (emit +space-code+)
                       (grab-space))))
     (:key-press (code) t
                 (cond ((= code +space-code+)
                        (p :key-press-space)
                        (grab-keyboard))
                       (t
                        (p :key-press3 code)
                        (setf key-press-p t)
                        (ungrab-keyboard)
                        (xtest:fake-key-event *display* +shift-code+ t)
                        ;; いったんキーリリースが必要みたい。
                        (xtest:fake-key-event *display* code nil)
                        (xtest:fake-key-event *display* code t)
                        (xtest:fake-key-event *display* code nil)
                        (xtest:fake-key-event *display* +shift-code+ nil)
                        (grab-keyboard)))))
    (xlib:display-force-output *display*)))

(defun main ()
  (init)
  (loop (ignore-errors (funcall 'proc))))
;;(sb-thread:make-thread 'main)

#|
(xlib:process-event *display*
                    :timeout 0
                    :handler (lambda (&rest args) (print args)))

(xlib:event-listen *display*)

(let ((keycode 38))
  (xtest:fake-key-event *display* +shift-code+ t)
  (xtest:fake-key-event *display* keycode t)
  (xtest:fake-key-event *display* keycode nil)
  (xtest:fake-key-event *display* +shift-code+ nil)
  (xlib:display-force-output *display*))

(xlib:keysym->keycodes *display* xlib::left-shift-keysym)
|#

CLX が少し分かるようになったかも。