An idea has long festered at the back of my mind that I might write a window manager in a scripting language. Since I am learning TCL I thought that I should finally get around to it and have a go in my new favourite language.

The code below is ''not ''(yet) that window manager. I decided that for v0.1, I should try (as a feasibility test) to implement the excellent http://incise.org/tinywm.html%|%tinywm%|% as a TCL program. Tinywm is an attempt to write a usable, if  basic, window manager in 50 lines of C.

There is more narrative needed but before boredom sets in I should probably show you some code. Keep reading further down...


======
# I got these from the wiki pages on combinatorial logic.
# I was almost completely lost, but the possibility of an elegant
# way of reading a file is appealing.
proc prog1 {value args} {set value;}
proc do2 {v f1 f2} {prog1 [$f1 $v] [$f2 $v];}
proc slurp {f} {do2 [open $f] read close;}

namespace eval X {
  variable s;
  variable screens;
  variable properties;
  variable ready 0;
  variable queue [list];
  variable request-count 0;
  variable log-file;
  variable errors;
  variable sym-list;

  # Hard-coding these values in the code would be easier
  # (and possibly faster), but having them declared as variables is 'cleaner'...
  array set errors {1 Request 2 Value 3 Window 4 Pixmap
              5 Atom 6 Cursor 7 Font 8 Match 9 Drawable
              10 Access 11 Alloc 12 Colourmap 13 GContext
              14 IDChoice 15 Name 16 Length 17 Implementation};

  array set keysyms [list F1 [expr 0xffbe]];

  variable synchronous 0;
  variable asynchronous 1;

  array set mods {shift 1 lock 2 control 4 mod1 8 mod2 16 mod3 32 mod4 64
        mod5 128 button1 256 button2 512 button3 1024 button4 2048 button5 4096}

  array set event-masks {key-press 1 key-release 2 button-press 4 button-release 8 pointer-motion 64}

  # ... and finally - some actual code...
  proc dump s {
    log "  $s : [uplevel "set $s"]";
  }

  proc log s {
    variable log-file;

    puts $s;
    puts ${log-file} $s;
  }

  # Pads s with enough null bytes to reach a length divisible by 4.
  proc pad4 s {
    upvar $s _s;

    set a [expr {4-([string length $_s]%4)}];
    if {$a!=4} {set _s $_s[binary format x$a];}
  }


  # Lazy but semi-valid way of authenticating.
  # An alternative solution would be to parse the authority file by hand
  # but this is fine.
  proc connect {{display ""}} {
    variable s;
    variable screens;
    variable properties;
    variable log-file;

    set log-file [open ~/.x11-log w+];
    chan configure ${log-file} -buffering none;

    if {$display==""} {set display $::env(DISPLAY);}

    # Parse display.
    lassign [split $display :] host temp;
    lassign [split $temp .] display-no screen;
    unset temp;

    set s [socket localhost [expr {6000+${display-no}}]];
    fconfigure $s -buffering none -blocking 0 -translation binary;

    set auth [slurp "| xauth list $display"];
    set connected 0;

    foreach {discard auth-proto auth-data} $auth {
      set auth-data [binary decode hex ${auth-data}]
      log "Trying ${auth-proto}->[lindex $auth 2]";

      set proto-len [string length ${auth-proto}];
      set data-len [string length ${auth-data}];

      pad4 auth-proto;
      pad4 auth-data;

      # 66 = B = MSB first. 108 = l = LSB first.
      # Realistically, protocol will always be 'MIT-MAGIC-COOKIE-1 which is always of
      # length 18 and the data length will always be 16, but we might as well do things properly...
      set out [binary format cxSSSSx2a*a* 66 11 0 ${proto-len} ${data-len} ${auth-proto} ${auth-data}];

      puts -nonewline $s $out;
      # flush $s;

      set start [clock milliseconds];
      set waiting 1;

      while {$waiting} {
        set in [read $s 16384];

        if {[string length $in]} {set waiting 0;}

        after 5 
        # If used over a real network I have no idea how long to wait for a suitable timeout.
        if {([clock milliseconds]-$start)>1000} {error "Connect timed out.";}
      }

      binary scan $in c code;

      switch $code {
        0 {log "X connect failed: [string range $in 8 end]";}
        2 {log "X needs more authentication (unsupported): [string range $in 8 end]"; return 0;}
        default {set connected 1; break;}
      }
    }
    if {!$connected} {return 0;}

    # Returned 1 - success...
    # Almost none of this information is useful at this point. But knowing the vendor length and number of formats
    # allows us to know the offset for the screen-list.
    binary scan $in cxSSSIIIISSccccccccx4 \
                          code major minor additional release res-base res-mask motion-size \
                          vendor-len max-request screen-count format-count image-order bmp-order bmp-unit bmp-pad min-key max-key;

    # This trick converts signed to unsigned.
    set min-key [expr {${min-key}&0xff}];
    set max-key [expr {${max-key}&0xff}];

    # Min/Max key values are useful later. I have no use for the max-request size but I might as well save it.
    set properties [list ${min-key} ${max-key} ${max-request}];

    if {${vendor-len}%4} {incr vendor-len [expr {4-(${vendor-len}%4)}];}

    set screen-start [expr {40+${vendor-len}+(8*${format-count})}];

    set _screens [split-buffer [string range $in ${screen-start} [expr {${screen-start}-1+(40*${screen-count})}]] 40];

    foreach scr $_screens {
      binary scan $scr IIIIISS root colourmap whitep blackp current-masks width height;
      lappend screens [list $root $width $height];
    }

    log "Connected to [string range $in 40 40+${vendor-len}] on root [lindex $screens 0 0]";

    fileevent $s readable X::socket-readable;

    return 1;
  }


  proc socket-readable "" {
    receive;
  }


  proc send-request buffer {
    variable request-count;
    variable s;

    incr request-count;
    set reqno ${request-count};
    if {${request-count}>65535} {set request-count 1; }

# log "SENDING [binary encode hex $buffer] ${request-count}";
    puts -nonewline $s $buffer;

    return $reqno;
  }

  # Just return the first item popped off of the queue.
  proc get-next-item "" {
    variable queue;

    set ret [lindex $queue 0];

    # TBD - might be a use for a K-trick here...?
    if {$ret!=""} {
      set queue [lreplace $queue 0 0];
    }

    return $ret;
  }

  # return (and remove from queue) the next item for the given sequence no.
  proc get-next-seq-item {seq {include-events 0}} {
    variable queue;

    set n 0;
    set found 0;

    foreach i $queue {
      if {([lindex $i 1]==$seq)} {
        switch [lindex $i 0] {
          ERROR -
          REPLY {set found 1;
                  break;}

          EVENT {if {${include-events} {set found 1; break;}}}
        }
      }
      incr n;
    }

    if {$found} {
      set queue [lreplace $queue $n $n];

      return $i;
    }

    return "";
  }


  # The next few procedures are simply so that I can pass the correct keycode to grab-key. Since in the
  # prototype there is only one key used (F1) it would be so much simpler to just use
  # e.g: 'xmodmap -pk|grep F1' and hard-code the keycode (67) - but this is a useful exercise...
  proc get-keymap "" {
    variable properties;
    variable sym-list;

    # properties 0 and 1 are the min/max keys reported by the server.
    lassign $properties min-key max-key;
    set seq [send-request [binary format cxSccx2 101 2 ${min-key} [expr {1+${max-key}-${min-key}}]]];

    receive;

    lassign [get-next-seq-item $seq] type seq buffer;

    if {$type!=""} {
      # We have a reply...
      switch $type {
        REPLY {
          binary scan $buffer xcSI syms-per-code seq2 sym-count;

          set _syms [lmap x [split-buffer [string range $buffer 32 end] 4] {binary scan $x I item; set item;}];

          # We now have a sequential list of (hundreds) of keysyms. Need to coalesce them into a list of lists.
          set _syms2 [chop-list $_syms ${syms-per-code}];

          # We now have the correct list, but it is offset by min-keycode positions.
          set sym-list [concat [lrepeat ${min-key} {} ] $_syms2];
        }
        ERROR {
          log "ERROR: {[parse-error $buffer]}";
          exit;
        }
      }
    }
  }

  # Did try to do this with lsearch but could not get that working...
  proc find-keysym s {
    variable sym-list;
    set i 0;
    foreach f ${sym-list} {
      if {$s in $f} {
        return $i;
      }

      incr i;
    }
  }

  # Break a list into a list of smaller lists each of size n.
  # e.g: chop-list {1 2 3 4 5 6} 3 -> {{1 2 3} {4 5 6}}
  proc chop-list {list n} {
    set ret [list];
    set start 0;
    set end [llength $list];
    set inc [expr {$n-1}];

    while {$start<$end} {
      lappend ret [lrange $list $start $start+$inc];

      incr start $n;
    }
    return $ret;
  }

  # Split an X11 'list' (e.g: contiguous buffer of repeated fixed-sized items) into a tcl list.
  proc split-buffer {buffer size} {
    set start 0;
    set end [string length $buffer];
    set list [list];
    set inc [expr {$size-1}];

    while {$start<$end} {
      lappend list [string range $buffer $start $start+$inc];

      incr start $size;
    }
    return $list;
  }

  proc grab-key {key mode {win ""}} {
    if {$win==""} {
      variable screens;
      set win [lindex $screens 0 0];
    }

    # TBD - more params here, mask, sync modes etc... 
    send-request [binary format ccSIScccx3 33 1 4 $win $mode $key 1 1];
  }

  
  # configure-window is so general that I've chosen to have several separate progs
  # to handle the various semantics: move,resize,move+resize,restack,set-border etc.
  proc move-window {window x y} {
    # 3 == set x and y
    send-request [binary format cxSISx2II 12 5 $window 3 $x $y];
  }

  proc resize-window {window width height} {
    # 12 == set height and width
    send-request [binary format cxSISx2II 12 5 $window 12 $width $height];
  }
  
  proc grab-button {button owner-events modifiers event-mask grab-win {cursor 0} {pointer-mode 1} {keyboard-mode 1}  {confine-win 0}} {
    send-request [binary format ccSISccIIcxS 28 ${owner-events} 6 ${grab-win} ${event-mask} ${pointer-mode} ${keyboard-mode} ${confine-win} $cursor $button $modifiers];
  }
  
  proc grab-pointer {owner-events event-mask grab-win {cursor 0} {pointer-mode 1} {keyboard-mode 1}  {confine-win 0} {time 0}} {
    set seq [send-request [binary format ccSISccIII 26 ${owner-events} 6 ${grab-win} ${event-mask} ${pointer-mode} ${keyboard-mode} ${confine-win} $cursor $time]];

    receive;

    lassign [get-next-seq-item $seq] type seq buffer;

    if {$type=="REPLY"} {
      # 'Processs' the reply...
      # binary scan $buffer xcS _status _seq ;
      # ... actually there is nothing to do with the reply - we are just glad not to have an error...
    } elseif {$type=="ERROR"} {
      log "ERROR: {[parse-error $buffer]}";
      exit;
    } 
  }

  proc ungrab-pointer "" {send-request [binary format cxSI 27 2 0];}

  proc parse-event buffer {
    # log "PARSE-EVENT [binary encode hex $buffer]";
    binary scan $buffer ccS code detail seq;

    switch $code {
      default {
        binary scan $buffer ccSIIIISSSSScx code detail seq f0 f1 f2 f3 f4 f5 f6 f7 f8 f9;
        list $code $detail $seq $f0 $f1 $f2 $f3 $f4 $f5 $f6 $f7 $f8 $f9;
      }
    }
  }

  proc parse-error buffer {
    variable errors;
    binary scan $buffer xcSISc code seq data minor major;

    list Code: $code ($errors($code)) Sequence: $seq Data: $data Minor: $minor Major: $major;
  }

  # Mode 0 = raiselowest, 1 = lowerhighest.
  proc circulate-win {mode window} {
    send-request [binary format ccSI 13 $mode 2 $window];}

  # Read the data pending.
  # Parse any errors and place on errors list.
  # Parse any events and place on events list.
  # Handle any reponse.
  # This bad, synchronous model should ensure only one response at a time.
  proc receive {{timeout 100}} {
    variable s;
    variable errors;
    variable queue;
    variable ready 0;

    set ret "";

    set start [clock milliseconds];
    set waiting 1;

    while {$waiting} {
      set in [read $s 16384];

      if {[string length $in]} {
        set waiting 0;
      } else {
        if {([clock milliseconds]-$start)>$timeout} {set $waiting 0;}
      }

      after 5;
    }

    while {[string length $in]} {
      binary scan $in c code;

      switch $code {
        0 { binary scan $in xcS code sequence;
            lappend queue [list ERROR $sequence [string range $in 0 31]];
            log "ERROR:[pretty-print-queue-item [lindex $queue end]]\n[parse-error [lindex $queue end 2]]";
            set in [string range $in 32 end]; }

        1 { binary scan $in x2SI sequence reply-len;
            log "REPLY: seq $sequence\nlength ${reply-len}(x4!)=[expr ${reply-len}*4](+32 :) )"

            lappend queue [list REPLY $sequence [string range $in 0 [expr {(${reply-len}*4)+31}]]];
            set in [string range $in [expr {${reply-len}*4}] end]; }

        default { binary scan $in x2S sequence;
            lappend queue [list EVENT $sequence [string range $in 0 31]];
            log "EVENT:[pretty-print-queue-item [lindex $queue end]]";
            set in [string range $in 32 end]; }
      }
      set in [read $s 16384];
    }
    set ready 1;
  }

  # Only for debug logging...
  proc pretty-print-queue-item s {
    return "<[lrange $s 0 1] [binary encode hex [lindex $s 2]]>";
  }

  proc get-geometry w {
    set seq [send-request [binary format cxSI 14 2 $w]];

    receive;

    lassign [get-next-seq-item $seq] type seq buffer;

    if {$type=="REPLY"} {
      binary scan $buffer xcSx4ISSSSS depth seq root x y width height border-width;
      return [list $depth $seq $root $x $y $width $height ${border-width}];
    } elseif {$type=="ERROR"} {
      log "ERROR: {[parse-error [lindex $reply 2]]}";
    }
  }
}
# End X


# All that was X11 handling. Now we can write the WM itself.
proc window-manager "" {
  if {![X::connect]} {exit 1;}

  initialise;
  
  set F1-sym [X::find-keysym $X::keysyms(F1)];

  while 1 {
    lassign [X::get-next-item] type seq buffer;

    while {$type==""} {
      set X::ready 0;
      vwait X::ready;
      lassign [X::get-next-item] type seq buffer;
    }

    set b [X::parse-event $buffer];


    # I tried using variables for the switch values, but to no avail...
    switch [lindex $b 0] {
      4 { # Button Press
          lassign $b discard detail seq time root event child root-x root-y event-x event-y state same-screen;
          X::grab-pointer 1 [expr {${X::event-masks(pointer-motion)}|${X::event-masks(button-release)}}] [lindex $X::screens 0 0];
          # set drag-info [list $detail $child {*}[lrange [X::get-geometry $child] 3 6] ${root-x} ${root-y}];
          set drag-info [concat $detail $child [lrange [X::get-geometry $child] 3 6] ${root-x} ${root-y}];

          # We will also need the offset of the click within the window. Rather
          # than calculate it for each MotionNotify, just calculate it once here.
          lappend drag-info [expr {${root-x}-[lindex ${drag-info} 2]}];
          lappend drag-info [expr {${root-y}-[lindex ${drag-info} 3]}];

          X::dump drag-info;
        }

      5 { # Cancel the pointer grab.
          # X::log "RELEASE!";
          X::ungrab-pointer;
        }

      6 { # Motion Notify
          lassign $b discard detail seq time root event child root-x root-y event-x event-y state same-screen;
          lassign ${drag-info} button window grab-x grab-y grab-width grab-height initial-x initial-y offset-x offset-y;
          # X::log "MOTION $detail $root $event $child ${root-x} ${root-y} ${event-x} ${event-y} ";
          if {$button==1} {
            # Button 1 - drag.
            X::move-window $window [expr {${root-x}-${offset-x}}] [expr {${root-y}-${offset-y}}];
          } elseif {$button==3} {
            # Button 3 - resize.
            X::resize-window $window [expr {(${root-x}-${initial-x})+${grab-width}}] [expr {${root-y}-${initial-y}+${grab-height}}];
          }
        }

      2 { # The only key that we grabbed was F1 with modifier 'alt' - but check anyway...
          if {([lindex $b 1]==${F1-sym})&&([lindex $b 11]==$X::mods(mod1))} {
            # Alt-F1
            # Strictly speaking; tinywm.c used XRaiseWindow, this is more in line with tinywm.py 
            # which circulates windows.
            X::circulate-win 0 [lindex $X::screens 0 0];
          }
        }
      default {
          X::log "WM:OTHER [X::pretty-print-queue-item [list $type $seq $buffer]]";
          if {$type=="ERROR"} {X::log "ERROR: [X::parse-error $buffer]";exit;}
      }
    }
  }
}

proc initialise "" {
  variable s;
  X::log "  Inintialising.";

  set root [lindex $X::screens 0 0];

  X::get-keymap;

  X::log "Grab key.";
  X::grab-key [X::find-keysym $X::keysyms(F1)] $X::mods(mod1);

  X::log "Grab button presses";
  X::grab-button 1 0 $X::mods(mod1) ${X::event-masks(button-press)} $root;
  X::grab-button 3 0 $X::mods(mod1) ${X::event-masks(button-press)} $root;
}

# Go!
window-manager;
======

Before any flames and derision pour in I should offer a few disclaimers:

   * This is my first TCL program of any sensible length and my first ever exposure to the X11 protocol, so I fear that I may have made hideous mistakes with either or both technologies. In particular I am aware that:
   ** A major reason for the move from xlib to xcb in the C world is to encourage asynchronous X11 processing rather than synchronous; however I can not see how to write this sensibly in an asynchronous manner. If I send a message which needs a reply it is because I want that reply '''now''' not in a few milliseconds time.
   ** Logging was done in the manner familiar to me from other languages. I hindsight I should have used trace.
   ** My mind is telling me that there really should be a co-routine in there somewhere.
   * There is at least one as yet unresolved bug (button release events sometimes get lost).
   * This is a rough-and-ready, hacked prototype. The finished version will (I hope) be a little cleaner...

The feasibility test was desirable for me to check two things:
   1. Is TCL equipped for writing a window manager? (I was pretty sure that it was and I am glad to see that it is).
   1. Can I write a window manager? (I was far less hopeful about that one - but it seems to be going well so far).

Now that the feasibility is complete, I will set about refactoring and adding the functionality that I actually want. I will post progress here if anyone in interested.

I hope this is of interest to someone.

<<categories>>Unix