title index
To search the Tcler's Wiki, please use Search
fr: This is about retrieval or browsing the wiki pages, or at least some of them.
Out-dated online version
The server's data structure is based on package dcp , that creates definite completions on prefix lookup.
It goes without embedded links, instead the experimental client code below offers a text widget, to select short suffix strings step by step. The discriminating characters to type are displayed on yellow background.
Use Pos1 to return to startpage, backspace or arrow-left to step back.
Use the keyboard or click items, if no appropriate key is available.
Tab and space both select too.
To start, please type the initial letter of an arbitray word supposed in a wiki page title.
One exception: to find pages of category company|home|person, type a space first.
animation in Firefox, APNG Editor plugin 
Screenshot with demos in action 
package r Tk
package r http
#set ::url T://www.taipu.de/f
set ::url T://85.88.28.141/f
regsub T $::url http ::url
foreach k [winfo chi .] {
catch {destroy $k}
}
set ::tx [toplevel .index]
wm title $::tx nore..
frame $::tx.f
set ::reaped_code ""
label $::tx.f.l -text Select-Events:
pack $::tx.f.l -side left
set ::visit 1
checkbutton $::tx.f.visit -variable ::visit -text "open page in browser"
pack $::tx.f.visit -side left
set ::rp 0
checkbutton $::tx.f.reap -variable ::rp -text "reap & run Tk-code, possibly UNSECURE!" -fg red
pack $::tx.f.reap -side left
pack $::tx.f
set ::z $::tx.t
text $::z -ba lightgrey -wrap word -height 18
pack $::z
# fonts
set ::pfo device
set ::pfo_hot systemfixed
set ::pfo_title system
$::z tag con hot -for blue -ba yellow -fon $::pfo_hot
$::z tag con norm -for black -ba white -fon $::pfo
$::z tag con title -for black -ba \#9afb95 -fon $::pfo_title
bind . <F1> {console show}
wm title . taipudex
. configure -bg bisque
bind $::tx <Key-BackSpace> {ome}
bind $::tx <Key-Left> {ome}
bind $::tx <Key-Home> {woidle}
bind $::z <Motion> {mola @%x,%y}
bind $::z <1> {pu @%x,%y}
bind $::z <Leave> {mola ""}
bind $::tx <Key> {nore %A}
# regex-patterns of unsecure commands
set ::pAT_exec {\s*[\{\[]*\s*exe[c]{0,1}\s}
set ::pAT_eval {\s*[\{\[]*\s*eva[l]{0,1}\s}
set ::pAT_file {\s*[\{\[]*\s*fi(?:l|le){0,1}\s}
set ::pAT_open {\s*[\{\[]*\s*ope[n]{0,1}\s}
set ::pAT_load {\s*[\{\[]*\s*loa[d]{0,1}\s}
set ::pAT_package {\s*[\{\[]*\s*packa(?:g|ge){0,1}\s}
proc pu w {
set char [$::z get $w]
foreach tag [$::z tag names $w] {
if {[regexp ^tag $tag]} {
set char [string range $tag end end]
break
}
}
set todo ""
catch {set todo $::fmt($char)}
if {[string le $todo]} {
eval $todo
} else {
bell
}
}
array set ::kept {} ;# cached queries
array set ::fmt {} ;# actions for key event
set ::prev [list] ;# previous display
set ::act_h "" ;# active tag before
set ::amole "" ;# after id, property pink set
proc mola at {
if {![string le $at]} {
catch {after cancel $::amole}
if {[string le $::act_h]} {
$::z tag con $::act_h -ba {}
}
set ::amole ""
} else {
if {![string le $::amole]} {
set ::amole [after 150 [list amola $at]]
}
}
}
proc amola at {
catch {
foreach tag [$::z tag names $at] {
if {[regexp ^tag $tag]} {
$::z tag con $tag -ba pink
if {![string equal $::act_h $tag]} {
if {[string le $::act_h]} {
catch {$::z tag con $::act_h -ba {} }
set ::act_h $tag
break
}
set ::act_h $tag
}
}
}
}
set ::amole ""
}
proc ome {} {
set last [pop]
zag $last $::kept($last) 0
}
proc nore {uc} {
if {[string le $uc]} {
catch {
set afi $::fmt($uc)
if {[string le $afi]} {
eval $afi
}
} err
}
}
proc pop {} {
set ::prev [lreplace $::prev end end]
set res [lindex $::prev end]
set ::prev [lreplace $::prev end end]
return $res
}
proc push {x} {
lappend ::prev $x
}
proc woidle {{x {}}} {
# append minus to preserve trailing blank
set q $x-
set q [::http::mapReply $q]
wm title $::tx nore..
update idletasks
if {[catch {set vast $::kept($x)}]} {
if {[catch {set t [time {set n [::http::geturl $::url -query x=$q]}] } err]} {
#puts err=$err
tk_messageBox -icon error -message $err -title "error on $::url"
return
}
set t [expr {[lindex $t 0]/1000}]\ msec
wm title $::tx $t
zag $x [::http::data $n] 1
http::cleanup $n
} else {
wm title $::tx 0
zag $x $vast 0
}
}
proc zag {prefix x save} {
set x [encoding convertfrom utf-8 $x]
set ::title_l {}
push $prefix
if {$save} {
set ::kept($prefix) $x
}
$::z con -state normal
$::z delete 1.0 end
foreach tag [$::z tag names] {if {[regexp ^tag $tag]} {$::z tag delete $tag}}
set ::a $x
set nl2 [string first \n\n $x]
set tlen 2
if {[expr $nl2 > -1]} {
foreach pair [split [string range $x [expr {$nl2+2}] end] \n] {
foreach {k v} [split $pair \t] break
set ::titles($k) $v
set tmp [string le $v]
if {[expr {$tlen<$tmp}]} {set tlen $tmp}
}
incr nl2 -1
set x [string range $x 0 $nl2]
} else {
regsub {\n$} $x {} x
}
set itemlist [split $x \n]
set spaces ""
set nl \n
set h [lindex [$::z configure -height] end]
set sep [expr {([llength $itemlist]<=$h) ? $nl : $spaces }]
set longest 0
set first_t 1
array unset ::fmt
foreach t $itemlist {
set clen [string le $t]
if {[expr {$clen>$longest}]} {set longest $clen}
set tagstart [$::z ind insert]
set tagend $tagstart
$::z ins end \ $prefix norm
set hc ""
if {$first_t} {
set first_t 0
if {[regexp {^ [0-9]+$} $t]} {
set dis ""
} else {
set dis [string range $t 0 0]
}
} else {
set dis [string range $t 0 0]
}
set rest [string range $t 1 end]
append hc $dis
$::z ins end $hc hot
set uniq 2
if {![regexp {\$$} $t]} {
set all [split $rest \t]
set ff [lindex $all end]
foreach {fin ff} [split $t \t] break
set fin [string range $fin 1 end]
foreach pg [split $ff +] {
incr uniq -1
if {$uniq==1} {
if {![string eq $hc \t] } {
$::z ins end $fin\t norm
}
$::z ins end \ $::titles($pg)\t title
} else {
$::z ins end $sep
$::z ins end \t$::titles($pg)\t title
}
set tagend [$::z ind insert]
}
if {$uniq==1} {
set ::fmt($hc) [list sho $pg $::titles($pg)]
}
} else {
set fin $t
set fin [string range $t 1 end-1]
set ::fmt($hc) [list woidle $prefix$hc$fin]
append fin \u2026
$::z ins end $fin\t norm
$::z ins end \t title
set tagend [$::z ind insert]
}
$::z ins end $sep
$::z tag add tag$hc $tagstart $tagend
}
incr longest 1
incr tlen $tlen
$::z configure -tabs "[expr {$longest * [font measure $::pfo 0]}] left [expr {$tlen * [font measure $::pfo_title 0]}] right"
$::z configure -state disabled
}
proc sho {idx title} {
if {$::visit} {
if {[catch {lug https://wiki.tcl-lang.org/$idx} err]} {
tk_messageBox -icon error -message $err -title "error on starting browser"
}
}
if {$::rp} {
set ::reaped_code ""
reap $idx
if {[regexp {pack |grid } $::reaped_code]} {
# gui code found
set code $::reaped_code
set tk [regsub -all -line {^\s*package.*Tk\s*$} $code {} code]
regsub -all -line {^\s*console} $code {#console} code
# check unsecure commands
set crit [list]
foreach p [info vars ::pAT_*] {
if {[regv $p code]} {
lappend crit $p
}
}
# disregarded glob|socket|wm
# todo:
# maybe list package dependencies
# ask user, if to run anyway
if {[llength $crit]} {
set in [::safe::interpCreate]
::safe::loadTk $in
} else {
set in [interp create]
}
puts in=$in
append code \n[info body ::2top]\n
#puts code:<<$code>>
if {!$tk} {
$in eval "package require Tk\n$code"
} else {
$in eval "package require Tk\n$code"
}
}
}
}
proc 2top {} {
fore x [winfo chi .] {
if {[rege {Wish|Top} [winfo class $x]]} {
wm dei $x
}
}
}
proc regv {pname text} {
upvar $pname v
upvar $text t
return [regexp $v $t]
}
proc lug {url} {
if {[regexp windo $::tcl_platform(platform)]} {
set exe $::env(ProgramFiles)
append exe /Mozilla\ Firefox/firefox.exe
exec $exe $url &
} else {
exec iceweasel $url &
}
}
woidle ""
# from [https://wiki.tcl-lang.org/4718]
if {![catch { package require nstcl-html }] &&
![catch { package require nstcl-http }]} {
namespace import nstcl::*
} else {
package require http
proc ns_geturl {url} {
set conn [http::geturl $url]
set html [http::data $conn]
http::cleanup $conn
return $html
}
proc ns_striphtml {-tags_only html} {
regsub -all -- {<[^>]+>} $html "" html
return $html ;# corrected a typo here
}
proc ns_urlencode {string} {
set allowed_chars {[a-zA-Z0-9]}
set encoded_string ""
foreach char [split $string ""] {
if {[string match $allowed_chars $char]} {
append encoded_string $char
} else {
scan $char %c ascii
append encoded_string %[format %02x $ascii]
}
}
return $encoded_string
}
}
proc output {data} {
# we don't want to throw an error if stdout has been closed
catch { puts $data }
}
proc reap {page} {
package require htmlparse
set url https://wiki.tcl-lang.org/[ns_urlencode $page]
set now [clock format [clock seconds] -format "%e %b %Y, %H:%M" -gmt 1]
set html [ns_geturl $url]
# can't imagine why these characters would be in here, but just to be safe
set html [string map [list \x00 "" \x0d ""] $html]
set html [string map [list "<pre class=sh_tcl>" \x00 </pre> \x0d] $html]
if {![regexp -nocase {<title>([^<]*)</title>} $html => title]} {
set title "(no title!?)"
}
if {![regexp -nocase {<i>Updated on ([^G]+ GMT)} $html => updated]} {
set updated "???"
}
output "#####"
output "#"
output "# \"$title\""
output "#"
output "# Tcl code harvested on: $now GMT"
output "# Wiki page last updated: $updated"
output "#"
output "#####"
output \n
set html [ns_striphtml -tags_only $html]
foreach chunk [regexp -inline -all {\x00[^\x0d]+\x0d} $html] {
set chunk [string range $chunk 1 end-1]
set chunk [::htmlparse::mapEscapes $chunk]
foreach line [split $chunk \n] {
if {[string index $line 0] == " "} {
set line [string range $line 1 end]
}
output $line
}
}
output \n
output "# EOF"
output \n
}
proc output s {
append ::reaped_code $s\n
}
set ::reaped_code ""