tcl/init/concmd.tcl

   1 set ::concmdlist [dict create]
   2 set ::concmdhelp [dict create]
   3
   4
   5 proc ::con::showhelp {cn} {
   6   global concmdhelp
   7   if {[dict exists $concmdhelp $cn]} {
   8     # show help
   9     cputs "\x02$cn: $concmdhelp($cn)"
  10   }
  11 }
  12
  13
  14 proc ::con::helpcomplete {args} {
  15   global concmdhelp
  16
  17   set cl [dict keys $concmdhelp]
  18   set lpx {}
  19
  20   if {[llength $args] < 1} {
  21     cputs "\x01help is available for:"
  22     foreach cmd [lsort [dict keys $concmdhelp]] { cputs "\x01$cmd" }
  23     set lpx [tcl::prefix longest $cl ""]
  24   } else {
  25     set cmd [lindex $args 0]
  26     if {[dict exists $concmdhelp $cmd]} {
  27       # show help
  28       set lpx $cmd
  29     } else {
  30       set lst [tcl::prefix all $cl $cmd]
  31       if {[llength $lst] == 1} {
  32         set lpx [lindex $lst 0]
  33       } elseif {[llength $lst] > 1} {
  34         foreach c [lsort $lst] { cputs "\x01$c" }
  35         set lpx [tcl::prefix longest $lst $cmd]
  36       } else {
  37         set lpx $cmd
  38       }
  39     }
  40   }
  41
  42   return "help $lpx"
  43 }
  44
  45
  46 dict set concmdlist help [lambda {args} {
  47   global concmdhelp
  48
  49   #cputs "help: <$args>"
  50   if {[llength $args] < 2} {
  51     cputs "help is available for:"
  52     foreach cn [dict keys $concmdhelp] {
  53       cputs "\x01$cn"
  54     }
  55   } else {
  56     set cn [lindex $args 1]
  57     if {[dict exists $concmdhelp $cn]} {
  58       # show help
  59       ::con::showhelp $cn
  60     } else {
  61       # show autocomplete or help
  62       set cl [dict keys $concmdhelp]
  63       set lst [tcl::prefix all $cl $cn]
  64       if {[llength $lst] == 1} { tailcall ::con::showhelp $cn }
  65       if {[llength $lst] > 1} {
  66         set lpx [tcl::prefix longest $lst $cn]
  67         consetstr "help $lpx"
  68       }
  69     }
  70   }
  71 }]
  72
  73
  74 proc concmd_simple_command {cmd args} {
  75   if {[llength $args] > 0} { $cmd {*}$args } else { cputs "$cmd: [$cmd]" }
  76 }
  77
  78 proc concmd_simple_command_noprint {cmd args} {
  79   $cmd {*}$args
  80 }
  81
  82
  83 proc concmd_info_command {cmd args} {
  84   cputs "$cmd: [$cmd {*}$args]"
  85 }
  86
  87
  88 proc concmdlist-register {handler lst} {
  89   set len [llength $lst]
  90   for {set idx 0} {$idx < $len} {} {
  91     set cn [lindex $lst $idx]
  92     incr idx
  93     dict set ::concmdlist $cn $handler
  94     if {$idx < $len && [lindex $lst $idx] eq "-help"} {
  95       incr idx
  96       if {$idx < $len} {
  97         dict set ::concmdhelp $cn [string trim [lindex $lst $idx]]
  98         incr idx
  99       }
 100     }
 101   }
 102 }
 103
 104
 105 # return result is not printed
 106 concmdlist-register concmd_simple_command_noprint {
 107   load -help { load Tcl source }
 108   quit -help { quit ZXEmut }
 109   reset -help { reset emulator
 110 reset [forced] [model] [issue] [memory] [trdos]
 111 48k: [issue2|issue3|2|3]
 112 pentagon: [128|512|1024]
 113 }
 114   snapshot -help { load or save snapshot
 115 snapshot <load|save> name
 116 }
 117   zxbind
 118   zxunbind
 119   bind
 120   unbind
 121   poke
 122   wpoke
 123   tape -help { tape command ?...?
 124 commands:
 125   insert filename
 126   save filename (not yet)
 127   eject
 128   clear
 129   start
 130   stop
 131   rewind
 132   list (not yet)
 133   option
 134     maxspeed      on/off/toggle
 135     detectloader  on/off/toggle
 136     autopause     on/off/toggle
 137 }
 138   disk -help { disk command ?...?
 139 commands:
 140   insert filename
 141   save filename
 142   eject
 143   format
 144   option autoadd_boot
 145   boot add [name] | remove | replace [name]
 146   protect
 147   unprotect
 148   info
 149   list
 150   extract
 151   add
 152 if filename starts with '[A-D]:'
 153 it means virtual drive number
 154 }
 155   nmi
 156   bp
 157   label
 158   reffile
 159   colormode -help { set color mode:
 160  normal
 161  monochrome (black-and-white)
 162  green
 163 }
 164   brightborder -help { control pentagon border brighness
 165 off: none used
 166 5|6|7: bit of ULA port used to control brightness
 167 }
 168   autofire
 169   rzx
 170   fldebug -help { FlashLoad loader detector debugging
 171 }
 172   tsmark
 173   tsdiff
 174   kbreset
 175   ayreset
 176 }
 177
 178 # return result is printed when the command is called without arguments
 179 concmdlist-register concmd_simple_command {
 180   console
 181   debugger
 182   memview
 183   sprview
 184   timings
 185   speed
 186   pause
 187   kbleds
 188   screenofs
 189   snow
 190   fullscreen
 191   noflic
 192   brightblack
 193   zxpalcolor
 194   filter
 195   keyhelp
 196   sound
 197   allowother128
 198   keymatrix
 199   issue
 200   grab
 201   maxspeedugly
 202   trdos
 203   fps
 204   swapbuttons
 205   kmouse
 206   kspanish
 207   kjoystick
 208   bad7ffd
 209   ay
 210   contention
 211   iocontention
 212   memcontention
 213   useplus3
 214   scrattrfill
 215   vid_scale
 216   vid_rescaler
 217   curblink
 218   opense
 219   gluck
 220   quickcommander
 221 }
 222
 223 # result is always printed
 224 concmdlist-register concmd_info_command {
 225   model
 226   peek
 227   wpeek
 228 }
 229
 230
 231
 232 # this is called from `conexec`
 233 # return "done" to stop processing
 234 # other return values means "go on"
 235 proc conexec_hook {args} {
 236   return "cont"
 237 }
 238
 239
 240 proc conexec {args} {
 241   global concmdlist
 242   if {[llength $args] > 0} {
 243     try {
 244       set ::con::executing 1
 245       if {[conexec_hook $args] != "done"} {
 246         #cputs [lindex $args 0]
 247         if {[dict exists $concmdlist [lindex $args 0]]} {
 248           set fn [dict get $concmdlist [lindex $args 0]]
 249           $fn [lindex $args 0] {*}[lrange $args 1 end]
 250         } else {
 251           cputs "unknown console command: [lindex $args 0]"
 252         }
 253       }
 254     } finally {
 255       set ::con::executing 0
 256     }
 257   }
 258 }
 259
 260
 261 # called when debugger breakpoint hit
 262 # [lindex args 0] is breakpoint type (number)
 263 proc breakpointhit {args} {
 264   # return "stop" or non-zero to activate debugger
 265   #cputs "BREAKPOINT HIT! [z80 getreg pc]"
 266   return "stop"
 267   #cputs "BREAKPOINT HIT!"
 268   #return "continue"
 269 }
 270
 271
 272 # called when a command received from unix socket
 273 # return:
 274 #   "close" to close connection
 275 #   "done" to indicate that no further processing required
 276 #   anything else to pass the command to console
 277 proc usock_received {args} {
 278   return ""
 279 }
 280
 281
 282 # called when we need to autocomplete a command
 283 proc conexec_ac {args} {
 284   #cputs "conexec_ac: [llength $args]"
 285   #foreach arg $args { cputs "  <$arg>" }
 286   #set cmd [lindex $args 0]
 287   try {
 288     set ::con::autocompletion 1
 289     #return [$cmd " ?ac" {*}[lrange $args 1 end]]
 290     #return [$cmd {*}[lrange $args 1 end]]
 291     #set res [{*}$args]
 292     #cputs "res: conexec_ac: [llength $res]"
 293     #foreach arg $args { cputs "  <$arg>" }
 294     #return $res
 295     return [{*}$args]
 296   } finally {
 297     set ::con::autocompletion 0
 298   }
 299 }
 300
 301
 302 # this is my first complex function in Tcl; enjoy!
 303 proc conautocomplete {args} {
 304   global concmdlist
 305
 306   set argl $args
 307   if {[llength $argl] == 0} { return "" }
 308
 309   set cmd [string map {* _ ? _ . _} [lindex $argl 0]]
 310   #set lst [dict keys $concmdlist "$cmd*"]
 311   set cl [dict keys $concmdlist]
 312   set lst [tcl::prefix all $cl $cmd]
 313   set res ""
 314   set pos 0
 315
 316   if {[llength $argl] > 1} {
 317     # command with args
 318     if {[llength $lst] == 1} {
 319       # call command autocompleter
 320       # FIXME: quote list items with spaces
 321       set cmd [lindex $lst 0]
 322       if {$cmd eq "help"} { tailcall ::con::helpcomplete {*}[lrange $argl 1 end] }
 323       return [conexec_ac $cmd {*}[lrange $argl 1 end]]
 324     }
 325     # shit! there is no such command!
 326     return ""
 327   }
 328
 329   if {[llength $lst] == 1} {
 330     # only one command
 331     set res [lindex $lst 0]
 332     if {[string equal $res $cmd]} {
 333       if {$cmd eq "help"} { tailcall ::con::helpcomplete {*}[lrange $argl 1 end] }
 334       return [conexec_ac $cmd {*}[lrange $argl 1 end]]
 335     } else {
 336       return "$res "
 337     }
 338   }
 339
 340   # many commands
 341   if {[llength $lst] > 1} {
 342     set res [tcl::prefix longest $lst $cmd]
 343     cputs "\x01===="
 344     foreach ccmd [lsort $lst] { cputs "\x01$ccmd" }
 345   }
 346
 347   return $res
 348 }