# Load webview and other stuff.
package require twv
package require Markdown
# On MacOSX we need Tk early, otherwise crashes occur.
if {$tcl_platform(os) eq "Darwin"} {
package require Tk
}
# If nothing is in top toplevel, withdraw it assuming
# we don't need it for now.
if {([info command winfo] eq "winfo") &&
[winfo exists .] && ([winfo children .] eq "")} {
wm withdraw .
}
namespace eval ::tsb {
variable inload 0
variable ready 0
}
# The history array of input fields.
array set H {1 ""}
# This is invoked from the JS window.external.invoke function.
# The first non-blank characters are assumed to be the integer id
# of the (input) field.
proc ::tsb::call_from_js {str} {
set n [string first " " $str]
if {$n < 0} {
return
}
set id [string trim [string range $str 0 $n]]
incr n
set str [string trim [string range $str $n end]]
if {$id == 0} {
# Should be the ping, Vasily.
# But can be the reload, too.
catch {uplevel \#0 $str}
return
}
set ::H($id) $str
if {$str eq ""} {
$::W call Wclear $id
return
}
set newfield 0
set ::ID $id
if {[string first "#HTML" $str] == 0} {
set n [string first "\n" $str]
if {$n > 4} {
incr n
set str [string range $str $n end]
}
$::W call Wraw $id $str 1
$::W call Inhide $id 1
set newfield 1
} elseif {[string first "#MARKDOWN" $str] == 0} {
set n [string first "\n" $str]
if {$n > 8} {
incr n
set str [string range $str $n end]
}
set str [Markdown::convert $str]
$::W call Wraw $id $str 1
$::W call Inhide $id 1
set newfield 1
} elseif {[catch {uplevel \#0 $str} ret opts]} {
if {[dict get $opts -code] == 4} {
# continue
$::W call Wclear $id
} else {
$::W call Werror $id $::errorInfo
}
} else {
if {$ret ne ""} {
$::W call Wresult $id $ret
} else {
$::W call Wclear $id
}
set newfield 1
}
if {$newfield} {
incr id
if {![info exists ::H($id)]} {
set ::H($id) ""
$::W call Field $id
}
}
unset -nocomplain ::ID
}
# Change current (input) field if it consisted only of
# single command "cmd". Useful for "img" and load/save
# when a file dialog is used to select the file name.
proc ::tsb::change_field {cmd str} {
if {[info exists ::ID]} {
set id $::ID
if {[string trim $::H($id)] eq $cmd} {
$::W call Winput $id $str
set ::H($id) $str
}
}
}
# Write raw HTML to current output field.
proc htmlraw {str {hidden 0}} {
if {[info exists ::ID]} {
$::W call Wraw $::ID $str
if {$hidden} {
$::W call Inhide $::ID 1
}
}
return
}
# Quote angle brackets et.al. for HTML output.
proc ::tsb::htmlquote {str} {
return [string map {& \& < \< > \> "\"" \"} $str]
}
# Simple HTML table formatter. If "ncols" is negative,
# make a header, otherwise omit headers. If "ncols" is
# not an integer it's taken as header list.
proc table {ncols data} {
if {![string is integer $ncols]} {
set tdata $data
set data $ncols
set ncols [expr {0 - [llength $data]}]
}
if {$ncols == 0} {
return
}
set ret "<table style='border: 1px solid;"
append ret " margin-left: 1em; border-collapse: collapse; width: 90%'>"
if {$ncols < 0} {
set ncols [expr {0 - $ncols}]
append ret "<tr>"
for {set i 0} {$i < $ncols} {incr i} {
append ret "<th style='border: 1px solid;'>" \
"<pre style='margin: 0.25em;'>" \
[::tsb::htmlquote [lindex $data $i]] "</pre></th>"
}
append ret "</tr>"
set data [lrange $data $ncols end]
}
if {[info exists tdata]} {
set data $tdata
}
while {[llength $data]} {
append ret "<tr>"
for {set i 0} {$i < $ncols} {incr i} {
append ret "<td style='border: 1px solid;'>" \
"<pre style='margin: 0.25em;'>" \
[::tsb::htmlquote [lindex $data $i]] "</pre></td>"
}
append ret "</tr>"
set data [lrange $data $ncols end]
}
append ret "</table><br>"
htmlraw $ret
}
# Insert various headers (<h1>, <h2> ...) and rulers.
proc h1 {str} {
htmlraw "<h1>[::tsb::htmlquote $str]</h1>" 1
}
proc h2 {str} {
htmlraw "<h2>[::tsb::htmlquote $str]</h2>" 1
}
proc h3 {str} {
htmlraw "<h3>[::tsb::htmlquote $str]</h3>" 1
}
proc h4 {str} {
htmlraw "<h4>[::tsb::htmlquote $str]</h4>" 1
}
proc h5 {str} {
htmlraw "<h5>[::tsb::htmlquote $str]</h5>" 1
}
proc hr {} {
set hr "<hr style='margin-left: 1em; margin-right: 1em;"
append hr " margin-top: 1em; margin-bottom: 1em;"
append hr " background-color: #000; height: 2px;'>"
htmlraw $hr 1
}
# Insert image from local file.
proc img {{name {}} {import 0} {mime {}}} {
set selname 0
if {$name eq ""} {
set selname 1
set name [$::W dialog open "Select Image"]
}
if {$name eq ""} {
return
}
# This needs work.
if {$mime ne ""} {
set mime [::tsb::htmlquote $mime]
} else {
set mime image/[string tolower [file extension $name]]
}
if {![catch {open $name rb} f]} {
set ret "<img style='margin: 1em;' src='data:$mime;base64,\n"
append ret [binary encode base64 -maxlen 78 [read $f]]
append ret "'>\n"
close $f
if {$selname || $import} {
set cmd [dict get [info frame -1] cmd]
if {$import} {
set newcmd "#HTML\n$ret"
} else {
set newcmd $cmd
lappend newcmd $name
}
::tsb::change_field $cmd $newcmd
}
htmlraw $ret 1
}
return
}
# Insert image from byte array.
proc img_from_binary {data mime {hidden 1}} {
set mime [::tsb::htmlquote $mime]
set ret "<img style='margin: 1em;' src='data:$mime;base64,\n"
append ret [binary encode base64 -maxlen 78 $data]
append ret "'>\n"
htmlraw $ret $hidden
return
}
# Load and save functions.
proc ::tsb::load {{name {}}} {
variable inload
if {$inload} {
return
}
if {$name eq ""} {
set name [$::W dialog open "Load From File"]
}
if {$name eq ""} {
return
}
set f [open $name r]
set data [read $f]
close $f
array set h $data
after idle [list ::tsb::loadh $data]
set ::tsb::file $name
$::W title "$::tsb::title - [file tail $name]"
return -code 4 ;# continue
}
proc ::tsb::loadh {data} {
variable inload
set inload 1
unset -nocomplain ::H
$::W call ClearFields
foreach {key value} $data {
if {[string is integer $key]} {
set h($key) $value
}
}
foreach key [lsort -integer [array names h]] {
$::W call InitField $key $h($key)
}
foreach key [lsort -integer [array names h]] {
set ::H($key) ""
set next $key
incr next
set ::H($next) ""
::tsb::call_from_js "$key $h($key)"
}
if {[info exists next]} {
unset ::H($next)
}
set inload 0
}
proc ::tsb::save {{name {}}} {
variable inload
if {$inload} {
return
}
set selname 0
if {$name eq ""} {
set selname 1
set name [$::W dialog open "Save To File"]
}
if {$name eq ""} {
return
}
set f [open $name w]
puts $f [array get ::H]
close $f
if {$selname} {
set cmd [dict get [info frame -1] cmd]
set newcmd $cmd
lappend newcmd $name
::tsb::change_field $cmd $newcmd
}
set ::tsb::file $name
$::W title "$::tsb::title - [file tail $name]"
return -code 4 ;# continue
}
# The sin: the ping function, to keep events alive and kicking.
proc ::tsb::ping {args} {
# Nothing to see here ...
}
# Reload document related functions; used for initial load, too.
proc ::tsb::reload0 {} {
variable ready
if {![info exists ::W]} {
# Can happen during init of webview.
return
}
set ready 1
$::W call document.write $::tsb::D
set title $::tsb::title
if {$::tsb::file ne ""} {
append title " - [file tail $::tsb::file]"
}
$::W title $title
::tsb::loadh [array get ::H]
}
proc ::tsb::reload {args} {
after cancel ::tsb::reload0
after idle ::tsb::reload0
}
# Clear page.
proc ::tsb::clear {} {
variable inload
if {$inload} {
return
}
after idle ::tsb::clearh
set ::tsb::file ""
$::W title $::tsb::title
return -code 4 ;# continue
}
proc ::tsb::clearh {} {
unset -nocomplain ::H
$::W call ClearFields
set ::H(1) ""
$::W call InitField 1 $::H(1)
}
# Evaluate field.
proc ::tsb::eval {id} {
tailcall $::W call Feval $id
}
# Print page; on Windows seems not to work, but pressing
# <Control-p> opens the printer dialog at least.
proc ::tsb::print {} {
tailcall $::W call window.print()
}
# A minimal canvas emulation for plotchart. The svg method
# produces SVG into the current (output) field.
#
# set C [::tsb::canvas ...]
# $C create line 10 10 20 20 -fill black ...
# ...
# $C svg
# $C destroy
namespace eval ::tsb {
variable C
array set C {cid 0}
proc tagfind {c tags} {
variable C
set all $C($c,dlist)
foreach tt $tags {
if {$tt eq "&&"} {
continue
}
set sub {}
if {[string is integer $tt] && [info exists C($c,$tt)]} {
set sub $tt
} else {
foreach item $all {
set t [dict get $C($c,$item) -tags]
if {$tt in $t} {
lappend sub $item
}
}
}
set all $sub
}
return $all
}
proc canvascmd {c cmd args} {
variable C
set ret ""
switch -glob -- $cmd {
cr* {
# create
set args [lassign $args type]
set id [incr C($c,id)]
set coords {}
set count 0
foreach arg $args {
if {[string is double $arg]} {
lappend coords $arg
} else {
break
}
incr count
}
dict set C($c,$id) -type $type
dict set C($c,$id) -coords $coords
dict set C($c,$id) -tags {}
foreach {opt val} [lrange $args $count end] {
if {[string match -ta* $opt]} {
set opt -tags
}
dict set C($c,$id) $opt $val
}
lappend C($c,dlist) $id
set ret $id
}
bb* {
# bbox, assumes measuring text item with "M"
set ret {0 0 12 16}
}
cg* {
# cget
switch -glob -- [lindex $args 0] {
-bd - -bo* {
set ret 0
}
-wi* {
set ret $C($c,width)
}
-he* {
set ret $C($c,height)
}
}
}
ra* {
# raise
lassign $args tags
set all $C($c,dlist)
foreach t [tagfind $c $tags] {
set n [lsearch -exact $all $t]
if {$n >= 0} {
set all [lreplace $all $n $n]
lappend all $t
}
}
set C($c,dlist) $all
}
lo* {
# lower
lassign $args tags
set all $C($c,dlist)
foreach t [tagfind $c $tags] {
set n [lsearch -exact $all $t]
if {$n >= 0} {
set all [lreplace $all $n $n]
set all [linsert $all 0 $t]
}
}
set C($c,dlist) $all
}
des* {
# destroy
set cmd $C($c,cmd)
foreach name [array names C $c,*] {
unset C($name)
}
rename "::$cmd" {}
}
de* {
# delete
lassign $args tags
set all $C($c,dlist)
foreach t [tagfind $c $tags] {
set n [lsearch -exact $all $t]
if {$n >= 0} {
set all [lreplace $all $n $n]
unset C($c,$t)
}
}
set C($c,dlist) $all
}
coo* {
# coords
set coords [lassign $args id]
if {![info exists C($c,$id)]} {
foreach item $C($c,dlist) {
set t [dict get $C($c,$item) -tags]
if {$id in $t} {
if {[llength $coords]} {
dict set C($c,$item) -coords $coords
} else {
set ret [dict get $C($c,$item) -coords]
}
}
}
} elseif {[llength $coords]} {
dict set C($c,$id) -coords $coords
} else {
set ret [dict get $C($c,$id) -coords]
}
}
sv* {
# svg
package require can2svg
set xml "<?xml version='1.0'?>\n"
append xml "<svg width='$C($c,width)' height='$C($c,height)'"
append xml " version='1.1'"
append xml " xmlns='http://www.w3.org/2000/svg'"
append xml " xmlns:xlink='http://www.w3.org/1999/xlink'>\n"
foreach item $C($c,dlist) {
set type [dict get $C($c,$item) -type]
switch -- $type {
image - window {
continue
}
}
set cmd [list create $type \
{*}[dict get $C($c,$item) -coords]]
foreach key [dict keys $C($c,$item)] {
switch -- $key {
-tags - -type - -coords {
# already done or ignored
}
default {
lappend cmd $key [dict get $C($c,$item) $key]
}
}
}
append xml " " [can2svg::can2svg $cmd {*}$args] "\n"
}
append xml "</svg>\n"
htmlraw $xml 0
}
}
return $ret
}
proc canvas {args} {
variable C
set cid $C(cid)
set cmd tsb_canv_obj$cid
proc ::$cmd {cmd args} [subst {
tailcall [namespace current]::canvascmd $cid \$cmd {*}\$args
}]
set C($cid,cmd) $cmd
set C($cid,dlist) {}
set C($cid,width) 640
set C($cid,height) 480
set C($cid,id) 0
incr C(cid)
foreach {key value} $args {
switch -glob -- $key {
-wi* {
if {[scan $value %d value]} {
set C($cid,width) $value
}
}
-he* {
if {[scan $value %d value]} {
set C($cid,height) $value
}
}
}
}
return $cmd
}
}
# Replacements for puts, get, read: move originals to tsb namespace.
rename puts ::tsb::puts
rename gets ::tsb::gets
rename read ::tsb::read
proc puts {args} {
set len [llength $args]
lassign $args arg1 arg2 arg3
if {[info exists ::ID]} {
switch $len {
1 {
$::W call Wresult $::ID "${arg1}\n"
return
}
2 {
switch -- $arg1 {
-nonewline {
$::W call Wresult $::ID $arg2
return
}
stdout {
$::W call Wresult $::ID "${arg2}\n"
return
}
stderr {
$::W call Werror $::ID "${arg2}\n"
return
}
}
}
3 {
if {($arg1 eq "-nonewline") && ($arg2 eq "stdout")} {
$::W call Wresult $::ID $arg3
return
} elseif {($arg1 eq "-nonewline") && ($arg2 eq "stderr")} {
$::W call Werror $::ID $arg3
return
}
}
}
}
if {[catch [linsert $args 0 ::tsb::puts] msg]} {
return -code error $msg
}
return $msg
}
proc gets {args} {
set len [llength $args]
lassign $args arg1 arg2
if {[info exists ::ID]} {
switch $len {
1 {
if {$arg1 eq "stdin"} {
return ""
}
}
2 {
if {$arg1 eq "stdin"} {
upvar 1 $arg2 var
set var ""
return ""
}
}
}
}
if {[catch [linsert $args 0 ::tsb::gets] msg]} {
return -code error $msg
}
return $msg
}
proc read {args} {
set len [llength $args]
lassign $args arg1 arg2
if {[info exists ::ID]} {
switch $len {
1 {
if {$arg1 eq "stdin"} {
return ""
}
}
2 {
if {($arg1 eq "stdin") && [string is integer $arg2]} {
return ""
}
if {($arg1 eq "-nonewline") && ($arg2 eq "stdin")} {
return ""
}
}
}
}
if {[catch [linsert $args 0 ::tsb::read] msg]} {
return -code error $msg
}
return $msg
}
namespace eval ::tsb {
# JS core functions assembled from various pieces into a big string.
variable D
# HEAD
set D {<!DOCTYPE html><html lang="en"><head>}
append D {<meta charset="utf-8">}
append D {<meta http-equiv="X-UA-Compatible" content="IE=edge">}
# STYLE, CSS
append D {<style>}
if {$::tcl_platform(platform) eq "windows"} {
append D {
body {
font-family: Arial, Tahoma, Helvetica, sans-serif; font-size: 90%;
}
pre, code {
font-family: Consolas, monospace; font-size: 90%;
}
textarea {
font-size: 100%;
}
}
} else {
append D {
body {
font-family: sans-serif, Helvetica; font-size: 90%;
}
}
}
append D {
textarea {
border: 1px solid #AAAAAA;
margin: 4px;
outline: none;
padding: 4px;
}
textarea:focus {
border: 3px solid rgba(81, 203, 238, 1);
margin: 2px;
padding: 4px;
}
}
append D {</style>}
# SCRIPT
append D {
<script type="text/javascript">
var msLike = /MSIE|Trident|Edge/i.test(navigator.userAgent);
if (!msLike && !window.external) {
/* See also webview.h */
window.external = {
invoke: function(str) {
window.webkit.messageHandlers.external.postMessage(str);
}
};
}
var needsClear = new Array();
var RunTcl = function(str) { window.external.invoke(str); };
/* The 2nd sin: this drives the Tcl event loop. */
var Gtimer = window.setInterval(function() {
window.external.invoke("0 ::tsb::ping\n");
}, 20);
var Wclear = function(id) {
if (!needsClear[id]) {
return;
}
var output =
document.getElementById('out' + id + '-pre').firstChild;
if (output.innerHTML.length > 0) {
output.style.color = 'inherit';
output.innerHTML = '';
}
output = document.getElementById('out' + id + '-raw');
if (output.innerHTML.length > 0) {
output.innerHTML = '';
}
};
var Wresult = function(id, str) {
var output =
document.getElementById('out' + id + '-pre').firstChild;
str = str.replace(/&/g, '&');
str = str.replace(/</g, '<');
str = str.replace(/>/g, '>');
str = str.replace(/\"/g, '"');
output.style.color = 'inherit';
if (needsClear[id]) {
output.innerHTML = str;
output = document.getElementById('out' + id + '-raw');
output.innerHTML = '';
} else {
output.innerHTML += str;
}
needsClear[id] = null;
};
var Werror = function(id, str) {
var output =
document.getElementById('out' + id + '-pre').firstChild;
str = str.replace(/&/g, '&');
str = str.replace(/</g, '<');
str = str.replace(/>/g, '>');
str = str.replace(/\"/g, '"');
output.style.color = 'red';
if (needsClear[id]) {
output.innerHTML = str;
output = document.getElementById('out' + id + '-raw');
output.innerHTML = '';
} else {
output.innerHTML += str;
}
needsClear[id] = null;
};
var Wraw = function(id, str) {
var output = document.getElementById('out' + id + '-raw');
if (needsClear[id]) {
output.innerHTML = str;
} else {
output.innerHTML += str;
}
if (needsClear[id]) {
output =
document.getElementById('out' + id + '-pre').firstChild;
if (output.innerHTML.length > 0) {
output.style.color = 'inherit';
output.innerHTML = '';
}
}
needsClear[id] = null;
};
var Inhide = function(id, hide) {
var input = document.getElementById('in' + id);
var output = document.getElementById('out' + id + '-raw');
if (hide) {
input.style.display = 'none';
output.addEventListener('dblclick', function(event) {
Inhide(id, 0);
});
} else {
output.removeEventListener('dblclick', null);
input.style.display = 'inline';
}
};
var Winput = function(id, str) {
var input = document.getElementById('code' + id);
input.value = str;
var lines = str.split(/\r?\n|\r/);
var nlines = (lines.length < 43) ? lines.length : 43;
input.rows = nlines;
};
var Feval = function(id) {
var input = document.getElementById('code' + id);
needsClear[id] = true;
RunTcl("" + id + " " + input.value);
};
var Field = function(id) {
var div = document.createElement('div');
div.classname = 'field';
var html = '<div class="field" id="in' + id + '">';
html += '<label for="code' + id + '"';
if (msLike) {
html += ' style="font-family: Consolas, sans-serif;"';
} else {
html += ' style="vertical-align: 10px; font-family: monospace;"';
}
html += '> in(' + id + ') </label>';
html += '<textarea id="code' + id + '" rows="1"';
if (msLike) {
html += ' style="width: 90%; resize: none;';
html += ' font-family: Consolas, monospace;';
html += ' overflow: hidden"';
} else {
html += ' style="width: 90%; resize: none;';
html += ' font-family: monospace; overflow: hidden"';
}
html += '></textarea></div><div class="field"';
html += ' id="out' + id + '-pre"';
if (msLike) {
html += ' style="word-wrap: break-word;"';
} else {
html += ' style="overflow-wrap: break-word;"';
}
html += '><pre></pre></div>';
html += '<div class="field" id="out' + id + '-raw"></div>';
div.innerHTML = html;
document.body.appendChild(div);
needsClear[id] = null;
var input = document.getElementById('code' + id);
input.addEventListener('keydown', function(event) {
var code;
var shift = false;
if (window.event) {
code = window.event.keyCode;
if (window.event.shiftKey) {
shift = true;
}
} else {
code = event.keyCode;
if (event.shiftKey) {
shift = true;
}
if (shift && code == 13) {
event.stopPropagation();
}
}
if (shift && code == 13) {
needsClear[id] = true;
RunTcl("" + id + " " + input.value);
event.preventDefault();
return false;
}
});
input.addEventListener('input', function(event) {
var lines = input.value.split(/\r?\n|\r/);
var nlines = (lines.length < 43) ? lines.length : 43;
input.rows = nlines;
});
input.focus();
return input;
};
var InitField = function(id, str) {
var input = Field(id);
input.value = str;
var lines = str.split(/\r?\n|\r/);
var nlines = (lines.length < 43) ? lines.length : 43;
input.rows = nlines;
};
var ClearFields = function() {
while (1) {
var fields = document.getElementsByClassName('field');
if (fields.length > 0) {
fields[0].parentNode.removeChild(fields[0]);
continue;
}
break;
}
};
/* Is this really needed? */
window.addEventListener('unload', function(event) {
window.clearInterval(Gtimer);
Gtimer = null;
});
</script>
}
# BODY (empty), END
append D {</head><body></body></html>}
# The URL to be displayed.
# Windows: data:text/html,<html><head><script>window.external.invoke("0 ::tsb::reload");</script></head></html>
# MacOS: data:text/html,<html><head><script>window.external.invoke("0 ::tsb::reload");</script></head></html>
# WebkitGtk: data:text/html,<html><head><script>window.webkit.messageHandlers.extern.postMessage("0 ::tsb::reload");</script></head></html>
variable U
set U "data:text/html,%3Chtml%3E%3Chead%3E%3Cscript%3E"
if {($tcl_platform(platform) eq "windows") ||
($tcl_platform(os) eq "Darwin")} {
append U "window.external.invoke(%220%20::tsb::reload%22)%3B"
} else {
append U "window.webkit.messageHandlers.external.postMessage(%220%20::tsb::reload%22)%3B"
}
append U "%3C%2Fscript%3E%3C%2Fhead%3E%3C%2Fhtml%3E"
# The base title
variable title "Taygete Scrap Book"
# The current file
variable file ""
}
# If file name given, load history array from it now.
set title $::tsb::title
if {[llength $argv] && [file readable [lindex $argv 0]]} {
catch {
apply {name {
set f [open $name r]
set data [read $f]
close $f
array set ::H $data
set ::tsb::file $name
}} [lindex $argv 0]
}
}
# Initialize webview; document is loaded indirectly via the URL
# which triggers ::tsb::reload which does the rest, but see
# the ::tsb::ready block below.
set W [::twv::new -width 800 -height 600 -title $::tsb::title \
-url $::tsb::U -resizable 1 -debug 0 \
-callback ::tsb::call_from_js]
# On Windows this seems the way to load, maybe timing?
if {!$::tsb::ready} {
::tsb::reload0
}
# Enter the webview event loop.
$W run
# Done.
exit 0