Ticol Tcl - Code Examples

Code on this page has been statically highlighted by Ticol

Print "Hello world"
puts "Hello world"
More advanced Hello world by storing the command in q and expanding using the {*} operator
set q "puts {Hello world}"
{*}$q
Hello world as a CGI web application
puts "Content-type: text/html\r\n\r\n"
puts "Hello world"
die
Loop iterate variable i from 0 to 9 and print out
option expression off
for {set i 0} {< $i 10} {incr i} {
	puts "i is $i"
	++ i
}
The [foreach] command may often be more useful than [for]
set lst {a b c d e f}
foreach {x y} $lst {
    puts  "Multiple variables may be processed $x $y"
}
Multiple commands on one line
set a 22;set b 7.0;set p [expr $a/$b];puts "Pi is $p"
Example of multi-level dereferencing using $ compared to using [set]

In Tcl, [set] is used either to assign or to echo a variable's contents

Each level of dereference called for [puts] is the same. $var is equivalent to [set var]

The variable chain runs:  d -> c -> b -> a -> 23

set a 23
set b a
set c b
set d c
puts $$$$d                          # 4 levels of dereference
puts [set $$$d]                     # 4 levels of dereference
puts [set [set $$d]]                # 4 levels of dereference
puts [set [set [set $d]]]           # 4 levels of dereference
puts [set [set [set [set d]]]]      # 4 levels of dereference
Dynamically include data from another file using [return]

The data file returns a list of pairs which can be used by [array set]

# Data file. include_data.tcl
return {
	1 {foo}
	2 {bar}
	3 {baz}
	4 {quux}
}

# Main file which will include the data file
puts "Including include_data.tcl"
array set data [eval include_data.tcl]
for {set i 1} {<= $i [array size data]} {++ i} {
	puts "$data($i)"
}
Read up to 100 bytes from a  file referred to in the first script argument - argv(1)

The commands are similar to those available in C/C++

[readfile] is also available, which can read via a single command

set fp [file open [unescape $argv(1)]]
set r [file gets $fp s 100]
puts "s is '$s"
file close $fp
Call nested levels of [expr]
puts [expr [<< [expr 20+3] [expr 2^4] 32] - 472]
puts [expr 1*[<< 1 1]*3/4.0*5]
Call math functions directly

Note that these are exported [expr] functions, not commands. They are exported via [funct]

puts [funct log10 2]
puts [funct round $pi 2]
puts [funct rnd 1 10]
puts [* [funct atan 1] 4]
Loop until the user presses the ESC key

[inkey] checks if a keystroke is available, if so, the key code is returned

puts "Press ESC to halt"
while {1} {
	puts "Looping"
	sleep 1000
	if {== [inkey] 27} { 	# ESC is 27
		stop 
	}
}
Define a procedure which uses recursion and call it
proc factorial {val} {
	puts "Current level: [info level] - val: $val"
	set lvl [info level]
	if {$lvl == $val} {
		return $val
	}
	return [expr {($val-$lvl) * [factorial $val]}]
}
puts [factorial 3]
The Ticol [loop] command is simpler and more efficient than [for] or [while]
option expression off
loop i 0 10 1 {
	if {== $i 5} {
		# Skip 5 and increment past 6
		++ i
		continue
	}
}
puts "i is $i"
Show RPN representation of an expression in the CLI using [calc] instead of [expr]

Will display: [- [+ [+ [* 4 4] [* 4 4]] 4] [* 4 4]]

Which is the same as [- [+ [+ 16 16] 4] 16]
Which is the same as: [- [+ 32 4] 16]
Which is the same as  [- 36 16]
Which results in: 20

It is recursively evaluated in the order
[- [+ [+ 16 16] 4] [* 4 4]]
[- [+ 32 4] [* 4 4]]
[- 36 [* 4 4]]
[- 36 16]]
20

option preprocessor off
puts [calc 4*4+4*4+4-4*4 -explain]
Define an 'at exit' command

The defined procedure will print "* Bye *" when a script exits

if { ! [defined at_exit] } {
	proc at_exit {} {
		newline
		textcolor yellow
		puts "* Bye *"
		textcolor
	}
}
Run obfuscated Tcl code within a Tcl script using the TCX plugin

ticol.exe filename.tcl /c is used to generate the code

base64.exe is used to convert the resulting binary code to base 64 ASCII

# Uses default encryption
# Encode using ticol.exe filename.tcl /c and base64.exe filename.tcx
set code "ibuhXiuUJYyD6Uubn7G4L/wRkK/BtOkaHi5IFuULSaPU/3YskM139se
IuesC7KEhQjprZY83PyZAqzgwFmlfnIkpMMmSMvs="
# Load the plugin
lib ticol_tcx
# Execute the code (call [eval] internally)
tcx $code -run
Unwrap a multi-level list

Will return:

catlog
cd
title   Empire Burlesque
artist  Bob Dylan
Company Columbia
Price   10.90
year    1985
set l "{catlog {cd {{title {Empire Burlesque}} {artist {Bob Dylan}} \
	  {Company Columbia} {Price 10.90} {year 1985} }}}"

proc unwrap_as_text {l} {
	global foo::s            # Avoid clashes with root a namespace var
	foreach x $l {
		if {> [ldepth $l] 2} {
			unwrap_as_text $x
		} else {
			append ::foo::s "$x\t"
		}
	}
	if {<= [ldepth $l] 2} {
		set ::foo::s [string trim $::foo::s "\t "]
		append ::foo::s "\r\n"
	}
}
unwrap_as_text $l
textcolor cyan
puts $foo::s
textcolor
You can use the dreaded goto if confined within a special [goto_block]

There is nothing wrong with using a goto in the right place

option expression off
set s 0
goto_block {
   start {				# Loop start
      ++ s				# Increment
      if {> $s 9} {			# Test
         goto end			# Exit
      }
      goto start			# Loop end
   }
   end {
      textcolor magenta
      puts "Puts exited OK at label: end"
      textcolor
   }
}
Read in a web page and split off the HTML tags
Prints out.. e.g.

<html>
<head>
<title>
</title>
</head>
<body bgcolor="#000000" text="#C0C0C0" link="#00FFFF">
...
option expression off
lib ticol_html

set s [http http://localhost:8800]
do {
	set t [html chomp_tag s]
	puts $t
} while {ne $t ""}
Read the registry to get a file association

For me, this returns:

Filetype ".tcl" opens with "C:\Program Files (x86)\Notepad++\notepad++.exe" "%1"

lib ticol_reg
set ext .tcl
# Read the type name
set type [registry get HKEY_CLASSES_ROOT\\$ext {}]
# Work out where to look for the command
set path HKEY_CLASSES_ROOT\\$type\\Shell\\Open\\command
# Read the command
set command [registry get $path {}]
puts "Filetype \"$ext\" opens with $command"
Use the [md5] command  to generate random numbers
set seed $pi					# Could instead use [clock]
set counter 0					# Global/static counter 
option expression on				# Use [expr] for flow-control

proc hashrnd {lo hi} {				# Hash-generated random number
        upvar seed				# Not recursive. No level given
        upvar counter
        incr counter
        set r [md5 [+ $counter $seed]]		# Get an MD5 value
        set q "0x"				# Literal 0x prefix
        append q [mids r [% $counter 24] 8] 	# Slice a section of the MD5
        return [expr "$q % (($hi-$lo)+1)+$lo"]	# Evaluate as hexadecimal
}
option expression on
for {set i 0} { $i < 10000} {incr i} {
	puts "hashrnd 10..10000:\t[hashrnd 10 10000]"
}
Windows service control query using ticol_calldll plugin

This shows struct, const and enum declaration as well as the use of a base struct as a typdef using [new]

 

Returns

* "Distributed Link Tracking Client" Running? true 
* "No Such Service FooBar" Running? false
* "Themes" Running? true

 

option escape on

lib ticol_calldll -nocomplain
newline

struct type_service_status {			# Can  be used as a typedef with [new]
	{dwServiceType 4}
	{dwCurrentState 4}
	{dwControlsAccepted 4}
	{dwWin32ExitCode 4}
	{dwServiceSpecificExitCode 4}
	{dwCheckPoint 4}
	{dwWaitHint 4}
}

enum {
	SERVICE_STATUS_UNKNOWN			# 0
	SERVICE_STOPPED				# 1
	SERVICE_START_PENDING			# 2
	SERVICE_STOP_PENDING			# 3
	SERVICE_RUNNING				# 4
	SERVICE_CONTINUE_PENDING		# 5
	SERVICE_PAUSE_PENDING			# 6
	SERVICE_PAUSED				# 7
}

const SC_MANAGER_ENUMERATE_SERVICE	0x0004

struct service_status {
	{dwServiceType 4}
	{dwCurrentState 4}
	{dwControlsAccepted 4}
	{dwWin32ExitCode 4}
	{dwServiceSpecificExitCode 4}
	{dwCheckPoint 4}
	{dwWaitHint 4}
}

if {! [defined is_service_running]} {
	proc is_service_running {service_name} {
		#############################################################
		# Query a service by name
		#############################################################
		# [in]		Registered service name 
		#		Note: Not the descriptive name
		# [return]	Boolean status value
		#############################################################
		option expression push on
		upvar true
		upvar false
		set r $false
		new ::type_service_status ss
		
		set scm_handle [calldll Advapi32 OpenSCManagerA [info hostname] 0 $::SC_MANAGER_ENUMERATE_SERVICE]
		if {$scm_handle > 0} {
			set sc_handle [calldll Advapi32 OpenServiceA $scm_handle $service_name $::SC_MANAGER_ENUMERATE_SERVICE]
			if {$sc_handle > 0} {
				set r [calldll Advapi32 QueryServiceStatus $sc_handle ss]
				calldll Advapi32 CloseServiceHandle $sc_handle
				if {[ofaddressb ss.dwCurrentState] == $::SERVICE_RUNNING} {
					set r $true
				}
			}
			calldll Advapi32 CloseServiceHandle $scm_handle
		}
		option expression pop
		return $r
	}
}

textcolor white darkmagenta
puts " * "Distributed Link Tracking Client" Running? [bool [is_service_running {trkwks}]]"
puts " * "No Such Service FooBar" Running? [bool [is_service_running {FooBar}]]"
puts " * "Themes" Running? [bool [is_service_running {Themes}]]" -nonewline
textcolor
newline
Towers of Hanoi in Tcl

A more extensive example. Being highly-iterative, this is vastly slower than the identical, compiled C++ hanoi.exe example available here for comparison

This runs in about 4 seconds for 17 rings on an old-generation i5 with several other items multi-tasking

The compiled C+ exe version of the same code takes 68ms for 17 rings. Any iterative intensive code which runs outside of a Ticol native command will run a couple of orders of magnitude slower than compiled code. Since DLL plugins are quite easy to produce with the quickest time to create a plugin being about 20 minutes, I would move any frequently used or computationally-intensive code into a separate plugin command

option expression off
cls
set n 0
set yloc 1
if {! [defined draw_status]} {
	proc draw_status {} {
		upvar yloc
		gotoxy 1 $yloc 
		upvar a 
		upvar b
		upvar c
		upvar n 
		upvar moves
		upvar x
		textcolor white
		puts "Towers of Hanoi ($n) - Pole Status ([comma $x] moves)\n"
		textcolor red
		printf "Pole A(%2i) %-67s\r\n" [stack count a] [stack list a]
		textcolor yellow
		printf "Pole B(%2i) %-67s\r\n" [stack count b] [stack list b]
		textcolor green
		printf "Pole C(%2i) %-67s\r\n" [stack count c] [stack list c]
		textcolor
	}
}

textcolor white blue
puts "  Towers of Hanoi  "
textcolor
newline

if {[< $argc 2]} {
	puts "How many rings (2..25)? " -nonewline
	gets stdin n
	if {|| [== $n ""] [== $n 0]} {stop}
} else {
	set n $argv(1)
}
set n [min $n 25]

stack create a $n			# Init 3 stacks to given size
stack create b $n
stack create c $n

for {set x 0} {[< $x $n ]} {++ x} {	# Create initial stack of hoops
	stack push a [+ $x 1]		# 0..n-1
}

set x 1
set shln [<< 1 $n]			# Precalc (1 << $n), << for n

draw_status

set start_secs [clock seconds]
set start [timer]
while {< $x $shln} {
	set xminus1 [- $x 1]
	stack push [chr [calc ((($x|$xminus1) + 1) % 3 )] 97] \
		[stack pop [chr [calc ($x & $xminus1) % 3] 97]]
	is_mod $x 50000 draw_status
	++ x
}
set end [timer]
set end_secs [clock seconds]

draw_status
newline
puts "Took [- $end $start] millisecond(s) and [comma $x] move(s)"
puts "Took [- $end_secs $start_secs] second(s) and [comma $x] move(s)"
newline
puts "Done."

stack unset a
stack unset b
stack unset c

Back | Top