Tcl Source Code

Check-in [c9c95d03d6]
Login
☰Core Home Timeline Branches Tags Tickets Download Wiki

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:* Added new ::nacl ensemble to init.natcl, moved most support commands there * created an execll method on Tcl object to accept command as list * All args to <embed> now passed in as ::argv * added a ::nacl::verbose var which toggles verbose debug narrative * reorganised .html and .natcl files into demo/ subdir * minor mods to canv and balls to cope with above * added loader.js to cope with above and give a cleaner js interface * rewrote balls.html to demonstrate cleaner interfaces.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | ferrieux-nacl
Files: files | file ages | folders
SHA1: c9c95d03d62e44b33358e7b95b97f7fcd5225171
User & Date: colin 2011-05-04 02:47:02
Context
2011-05-04
03:22
* left out updateCoords, added it back into balls.html pending final disposition check-in: 43996dcdef user: colin tags: ferrieux-nacl
02:47
* Added new ::nacl ensemble to init.natcl, moved most support commands there * created an execll met... check-in: c9c95d03d6 user: colin tags: ferrieux-nacl
2011-04-18
21:53
More concise serialization of coord-updates check-in: 7755a6cc4c user: ferrieux tags: ferrieux-nacl
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Name change from nacl/a.natcl to nacl/demo/a.natcl.

Name change from nacl/b.natcl to nacl/demo/b.natcl.

Name change from nacl/balls.html to nacl/demo/balls.html. 

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85

86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169

<!DOCTYPE html>
<html>
  <!--
  Copyright (c) 2010 The Native Client Authors. All rights reserved.
  Use of this source code is governed by a BSD-style license that can be
  found in the LICENSE file.
  -->
<head>

    <title>NaTcl : Tcl in Nacl</title>

  <script type="text/javascript">

// NaTcl -- JS glue
     
var tclModule = null;  // our singleton Tcl interp

var canvas = null;
var context = null;
var canvcoords = [];

function updateCoords(ar)
{
    var i,n;

    n=ar.length;
    for(i=0;i<n;i+=2)
	canvcoords[ar[i]]=ar[i+1];
}

// give it global scope. will be regen'd by canv code.
function repaint() {}

// debugging stuff

function printf(s)
{
    // I like debugging to stderr instead of console.log,
    // because when things go wrong, the JS console is not
    // alays reachable.
    
    tclModule.eval('printf {'+s+'}');
}

function ljoin()
{
    // yeah. 'arguments' is 'similar to an array but not quite'
    // that's why I think JS has no soul.
    
    return Array.prototype.slice.call(arguments).join("\n");
}

// --- tclDo is the main JS-Tcl trampoline.
//
//  Its job is to pass a Tcl string to [eval] (through naclwrap, see
//  init.nacl), and then take back the result as JS and eval() it.
//  It also detects errors in the latter eval() and pipes them back
//  to [bgerror].

tclReportError = "";

function tclDo(s) {
    //printf("do:"+s);
    try {
	t = tclModule.eval("naclwrap {"+s+"}");
	//printf("ret:"+t);
	eval(t);
    } catch(err) {
	//printf("JS-err:"+err);
	tclReportError="bgerror {"+err+" -- while doing: "+t+"}";
	setTimeout('tclDo(tclReportError)',0);
    }
}

// --- tclsource starts an XHR, and calls the given 'tcb' (Tcl
// --- Callback) on completion. A catchable Tcl-level error is raised
// --- in case of not-200. Used by [source].

function tclsource(url,tcb) {
    //printf('tclsource');
    xs = new XMLHttpRequest();
    xs.open("GET",url,true);
    xs.send(null);
    xs.onreadystatechange = function() {
	//printf("XHR-source:"+xs.readyState);

	if (xs.readyState==4)
	    {
		if (xs.status==200) {
		    tclDo(tcb+"  {"+xs.responseText+"}");
		} else {
		    tclDo(tcb+"  {error \"Can't source -- "+xs.statusText+"\"}");
		}
	    }
    };
}


// ---------- GUI and standard NaCl-loading machinery --------

var statusField = null;

function updateStatus(s) {
    if (statusField) {
        statusField.innerHTML = s;
    }
}

function moduleDidLoad() {
    
    tclModule = document.getElementById('tcl');
    updateStatus('NaTcl Loaded ; Fetching and running !');
    tclDo('coroutine main_coro source balls.natcl');
    
}

// If the page loads before the Native Client module loads, then set the
// status message indicating that the module is still loading.  Otherwise,
// do not change the status message.

function pageDidLoad() {
    statusField = document.getElementById('modstatus');
    canvas=document.getElementById('canvas');
    context=canvas.getContext("2d");
    if (tclModule == null) {
        updateStatus('Loading NaTcl...');
    }
}

</script>
</head>

<body onload="pageDidLoad()">

<h1>NaTcl -- Native Client Tcl Module</h1>
<p>

  <canvas id="canvas" width="578" height="200"></canvas>

  <!-- Load the published .nexe.  This includes the 'nacl' attribute which
  shows how to load multi-architecture modules.  Each entry in the "nexes"
  object in the  .nmf manifest file is a key-value pair: the key is the runtime
  ('x86-32', 'x86-64', etc.); the value is a URL for the desired NaCl module.
  To load the debug versions of your .nexes, set the 'nacl' attribute to the
  _dbg.nmf version of the manifest file.
  -->
  <embed name="nacl_module"
         id="tcl"
         width=0 height=0
         nacl="tcl.nmf"
         type="application/x-nacl"
         onload="moduleDidLoad();" />
</p>

<p>This is a NaTcl emulation of the "Google Balls" Javascript demo at <a href="http://www.html5canvastutorials.com/labs/html5-canvas-google-bouncing-balls/">http://www.html5canvastutorials.com/labs/html5-canvas-google-bouncing-balls/</a></p>

Status: <b><span id="modstatus">Loading...</span></b>
<hr>
<p style="font-size : smaller;">
To run this demo, you need
<ul style="font-size : smaller;">
<li> An x86-family processor
<li> Chrome 10 or higher
<li> Enabled "Native Client" item in about:flags
<li> (if on Linux) the --no-sandbox command-line flag to Chrome
<li> if everything else fails, try the Nacl demos at <a href="http://code.google.com/chrome/nativeclient/docs/examples.html">http://code.google.com/chrome/nativeclient/docs/examples.html</a>
</ul>
</p>
</body>
</html>



<
<
<
<
<
|
<
<
<
|
|
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<

<
<
<
<
|
<
<
|
|
<
<
<
<
<
|
<
|
|
<
<
|
<
|
|
<
<
<
<
<
|
<
<
<
|
<
<
<
<
<
|
<
>
<
|
<
<
|
<
<
<
<
<
|
|
<
|
<
|
<
<
<
<
<
|
<
|
<
<
<
|
<
|
<
<
<
|
<
<
<
<
<
<
<
|
|
|
<
|
<
|
<
<
|
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
|

<
<
<
<
<
<
<
<
<
<
<
<
<
<
|


1
2





3



4
5

6




























7




8


9
10





11

12
13


14

15
16





17



18





19

20

21


22





23
24

25

26





27

28



29

30



31







32
33
34

35

36


37

38













39
40














41
42

<!DOCTYPE html>
<html>





  <head>



    <script type="text/javascript" src="loader.js"></script>
  </head>

  <body>

































   <embed


      name='nacl_module'
      id='tcl'





      width=0 height=0

      nacl='tcl.nmf'
      type='application/x-nacl'


      onload='moduleDidLoad();'

      verbose=0
      source='balls.natcl'>





         <canvas id="canvas" width="578" height="200"></canvas>



         <h2>Status</h2>





         <div id="modstatus">NO-STATUS</div>

   </embed>




   <p style="font-size : smaller;">





      To run this demo, you need
      <ul style="font-size : smaller;">

        <li> An x86-family processor</li>

        <li> Chrome 10 or higher</li>





        <li> Enabled "Native Client" item in about:flags</li>

        <li> (if on Linux) the --no-sandbox command-line flag to Chrome</li>



       <li> if everything else fails, try the Nacl demos at <a href="http://code.google.com/chrome/nativeclient/docs/examples.html">http://code.google.com/chrome/nativeclient/docs/examples.html</a></li>

      </ul>



   </p>








    <script type="text/javascript">
      var statusField = document.getElementById('modstatus');

      var canvas = document.getElementById('canvas');

      var context=canvas.getContext("2d");


      var repaint = function () {};

      var canvcoords = [];













    </script>















  </body>
</html>

Name change from nacl/balls.natcl to nacl/demo/balls.natcl.

︙︙
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31

set collisionDamper 0.3
set floorFriction [expr {0.0005*$frameInterval}]
set mouseForceMultiplier [expr {1.0*$frameInterval}]
set restoreForce  [expr {0.002*$frameInterval}]

set mouseX 99999
set mouseY 99999
 
set balls {}

set blue   "#3A5BCD"
set red    "#EF2B36"
set yellow "#FFC636"
set green  "#02A817"









|








17
18
19
20
21
22
23
24
25
26
27
28
29
30
31

set collisionDamper 0.3
set floorFriction [expr {0.0005*$frameInterval}]
set mouseForceMultiplier [expr {1.0*$frameInterval}]
set restoreForce  [expr {0.002*$frameInterval}]

set mouseX 99999
set mouseY 99999

set balls {}

set blue   "#3A5BCD"
set red    "#EF2B36"
set yellow "#FFC636"
set green  "#02A817"
︙︙
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122

newball 139 136 0 0 $blue
newball 152 136 0 0 $blue
newball 166 136 0 0 $blue
newball 174 127 0 0 $blue
newball 179 110 0 0 $blue
newball 166 109 0 0 $blue
newball 156 110 0 0 $blue
 
# O
newball 210 81 0 0 $red
newball 197 91 0 0 $red
newball 196 103 0 0 $red
newball 200 116 0 0 $red
newball 209 127 0 0 $red
newball 223 130 0 0 $red
newball 237 127 0 0 $red
newball 244 114 0 0 $red
newball 242 98 0 0 $red
newball 237 86 0 0 $red
newball 225 81 0 0 $red
 
# O
set oOffset 67
newball [expr {$oOffset + 210}] 81 0 0 $yellow
newball [expr {$oOffset + 197}] 91 0 0 $yellow
newball [expr {$oOffset + 196}] 103 0 0 $yellow
newball [expr {$oOffset + 200}] 116 0 0 $yellow
newball [expr {$oOffset + 209}] 127 0 0 $yellow
newball [expr {$oOffset + 223}] 130 0 0 $yellow
newball [expr {$oOffset + 237}] 127 0 0 $yellow
newball [expr {$oOffset + 244}] 114 0 0 $yellow
newball [expr {$oOffset + 242}] 98 0 0 $yellow
newball [expr {$oOffset + 237}] 86 0 0 $yellow
newball [expr {$oOffset + 225}] 81 0 0 $yellow
 
# G
newball 370 80 0 0 $blue
newball 358 79 0 0 $blue
newball 346 79 0 0 $blue
newball 335 84 0 0 $blue
newball 330 98 0 0 $blue
newball 334 111 0 0 $blue
newball 348 116 0 0 $blue
newball 362 109 0 0 $blue
newball 362 94 0 0 $blue
newball 355 128 0 0 $blue
newball 340 135 0 0 $blue
newball 327 142 0 0 $blue
newball 325 155 0 0 $blue
newball 339 165 0 0 $blue
newball 352 166 0 0 $blue
newball 367 161 0 0 $blue
newball 371 149 0 0 $blue
newball 366 137 0 0 $blue
 
# L
newball 394 49 0 0 $green
newball 381 50 0 0 $green
newball 391 61 0 0 $green
newball 390 73 0 0 $green
newball 392 89 0 0 $green
newball 390 105 0 0 $green
newball 390 118 0 0 $green
newball 388 128 0 0 $green
newball 400 128 0 0 $green
 
# E
newball 426 101 0 0 $red
newball 436 98 0 0 $red
newball 451 95 0 0 $red
newball 449 83 0 0 $red
newball 443 78 0 0 $red
newball 430 77 0 0 $red








|












|













|



















|










|








50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122

newball 139 136 0 0 $blue
newball 152 136 0 0 $blue
newball 166 136 0 0 $blue
newball 174 127 0 0 $blue
newball 179 110 0 0 $blue
newball 166 109 0 0 $blue
newball 156 110 0 0 $blue

# O
newball 210 81 0 0 $red
newball 197 91 0 0 $red
newball 196 103 0 0 $red
newball 200 116 0 0 $red
newball 209 127 0 0 $red
newball 223 130 0 0 $red
newball 237 127 0 0 $red
newball 244 114 0 0 $red
newball 242 98 0 0 $red
newball 237 86 0 0 $red
newball 225 81 0 0 $red

# O
set oOffset 67
newball [expr {$oOffset + 210}] 81 0 0 $yellow
newball [expr {$oOffset + 197}] 91 0 0 $yellow
newball [expr {$oOffset + 196}] 103 0 0 $yellow
newball [expr {$oOffset + 200}] 116 0 0 $yellow
newball [expr {$oOffset + 209}] 127 0 0 $yellow
newball [expr {$oOffset + 223}] 130 0 0 $yellow
newball [expr {$oOffset + 237}] 127 0 0 $yellow
newball [expr {$oOffset + 244}] 114 0 0 $yellow
newball [expr {$oOffset + 242}] 98 0 0 $yellow
newball [expr {$oOffset + 237}] 86 0 0 $yellow
newball [expr {$oOffset + 225}] 81 0 0 $yellow

# G
newball 370 80 0 0 $blue
newball 358 79 0 0 $blue
newball 346 79 0 0 $blue
newball 335 84 0 0 $blue
newball 330 98 0 0 $blue
newball 334 111 0 0 $blue
newball 348 116 0 0 $blue
newball 362 109 0 0 $blue
newball 362 94 0 0 $blue
newball 355 128 0 0 $blue
newball 340 135 0 0 $blue
newball 327 142 0 0 $blue
newball 325 155 0 0 $blue
newball 339 165 0 0 $blue
newball 352 166 0 0 $blue
newball 367 161 0 0 $blue
newball 371 149 0 0 $blue
newball 366 137 0 0 $blue

# L
newball 394 49 0 0 $green
newball 381 50 0 0 $green
newball 391 61 0 0 $green
newball 390 73 0 0 $green
newball 392 89 0 0 $green
newball 390 105 0 0 $green
newball 390 118 0 0 $green
newball 388 128 0 0 $green
newball 400 128 0 0 $green

# E
newball 426 101 0 0 $red
newball 436 98 0 0 $red
newball 451 95 0 0 $red
newball 449 83 0 0 $red
newball 443 78 0 0 $red
newball 430 77 0 0 $red
︙︙
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216

	    set x [expr {$::ballRadius+2}]
	    set vx [expr {-$vx*(1.0-$::collisionDamper)}]
	}
	set ::b($id) [list $x $y $vx $vy $rx $ry]
	canv_moveto $id [expr {int($x+0.5)}] [expr {int($y+0.5)}]
    }
}
    

proc motioncb {x y} {
    set ::mouseX $x
    set ::mouseY $y
}
proc entercb {} {
    printf "Enter Canvas !!!"








<








202
203
204
205
206
207
208

209
210
211
212
213
214
215

	    set x [expr {$::ballRadius+2}]
	    set vx [expr {-$vx*(1.0-$::collisionDamper)}]
	}
	set ::b($id) [list $x $y $vx $vy $rx $ry]
	canv_moveto $id [expr {int($x+0.5)}] [expr {int($y+0.5)}]
    }
}


proc motioncb {x y} {
    set ::mouseX $x
    set ::mouseY $y
}
proc entercb {} {
    printf "Enter Canvas !!!"
︙︙

Name change from nacl/c.natcl to nacl/demo/c.natcl.

Name change from nacl/canv.natcl to nacl/demo/canv.natcl.

︙︙
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26


# canv_status_coords : 1: some old items moved
# canv_status_func: 0:unchanged 1:new-items-on-top 2:changed

proc canv_addhook {} {
    if {$::canv_hooked} return
    set ::canv_hooked 1
    lappend ::naclhooks canv_hook
}

proc canv_new_items {} {
    return [lrange $::canv_tlist $::canv_jcnt end]
}

proc canv_compile_repaint l {








|








12
13
14
15
16
17
18
19
20
21
22
23
24
25
26


# canv_status_coords : 1: some old items moved
# canv_status_func: 0:unchanged 1:new-items-on-top 2:changed

proc canv_addhook {} {
    if {$::canv_hooked} return
    set ::canv_hooked 1
    ::nacl hook canv_hook
}

proc canv_new_items {} {
    return [lrange $::canv_tlist $::canv_jcnt end]
}

proc canv_compile_repaint l {
︙︙
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98

    set ::canv_status_coords 0
    array unset ::canv_moved

    if {[info exists js]} {
	if {$::canv_verbose} {
	    printf "CANV_HOOK emits:\n$js\n"
	}
	append ::JS $js
    }
}

proc lremove {l e} {
     set out {}
    foreach x $l {
	if {$x==$e} continue








|








84
85
86
87
88
89
90
91
92
93
94
95
96
97
98

    set ::canv_status_coords 0
    array unset ::canv_moved

    if {[info exists js]} {
	if {$::canv_verbose} {
	    printf "CANV_HOOK emits:\n$js\n"
	}
	nacl js $js
    }
}

proc lremove {l e} {
     set out {}
    foreach x $l {
	if {$x==$e} continue
︙︙
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208

	set ::canv_status_coords 1
    }
}

proc canv_bind {evt cb} {
    switch -exact -- $evt {
	<Motion> {
	    append ::JS "canvas.onmousemove = function (evt) {
			tclDo([jsquote "$cb "]+(evt.clientX-canvas.offsetLeft)+' '+(evt.clientY-canvas.offsetTop));
		};\n"
	}
	<Leave> {
	    append ::JS "canvas.onmouseout = function (evt) {
			tclDo([jsquote "$cb "]);
		};\n"
	}
	<Enter> {
	    append ::JS "canvas.onmouseover = function (evt) {
			tclDo([jsquote "$cb "]);
		};\n"
	}
	default {error "Unsupported event '$evt'"}
    }
}








|
|
|


|
|
|


|
|
|





185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208

	set ::canv_status_coords 1
    }
}

proc canv_bind {evt cb} {
    switch -exact -- $evt {
	<Motion> {
	    nacl js "canvas.onmousemove = function (evt) {
			tclDo([::nacl jsquote "$cb "]+(evt.clientX-canvas.offsetLeft)+' '+(evt.clientY-canvas.offsetTop));
		}"
	}
	<Leave> {
	    nacl js "canvas.onmouseout = function (evt) {
			tclDo([::nacl jsquote "$cb "]);
		}"
	}
	<Enter> {
	    nacl js "canvas.onmouseover = function (evt) {
			tclDo([::nacl jsquote "$cb "]);
		}"
	}
	default {error "Unsupported event '$evt'"}
    }
}

Name change from nacl/index.html to nacl/demo/index.html.

︙︙

Added nacl/demo/loader.js. 



















































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88

// NaTcl -- JS glue
var tclModule = null;  // our singleton Tcl interp

function printf()
{
    // I like debugging to stderr instead of console.log,
    // because when things go wrong, the JS console is not
    // alays reachable.
    tclModule.evall('printf', arguments.join(' '));
}

function ljoin()
{
    // yeah. 'arguments' is 'similar to an array but not quite'
    // that's why I think JS has no soul.

    return Array.prototype.slice.call(arguments).join("\n");
}

// --- tclDo is the main JS-Tcl trampoline.
//
//  Its job is to pass a Tcl string to [eval] (through naclwrap, see
//  init.nacl), and then take back the result as JS and eval() it.
//  It also detects errors in the latter eval() and pipes them back
//  to [bgerror].

function tclEsc(text) {
  return text.replace(/[][\\$""]/g,'\\$0');
}

function tclDo(s) {
    try {
        //printf("do:"+s);
	t = tclModule.eval("::nacl::wrap {" + s + "}");
	//printf("ret:"+t);
	eval(t);
    } catch(err) {
	//printf("JS-err:"+err);
	setTimeout('tcl("::nacl::bgerror,"'+ err + ',' + t + ')',0);
    }
}

function tcl() {
    try {
        //printf.apply(this, arguments);
	t = tclModule.evall.apply(tclModule, arguments);
        //printf("ret:", t);
    } catch (err) {
	//printf("JS-err:", err);
	setTimeout('tcl("::nacl::bgerror,"'+ err + ',' + t + ')',0);
    }

    try {
	eval(t);
    } catch(err) {
	//printf("JS-err:", err);
	setTimeout('tcl("::nacl::bgerror,"'+ err + ',' + t + ')',0);
    }
}

// --- tclsource starts an XHR, and calls the given 'tcb' (Tcl
// --- Callback) on completion. A catchable Tcl-level error is raised
// --- in case of not-200. Used by [source].
function tclsource(url,tcb) {
    //printf('tclsource');
    xs = new XMLHttpRequest();
    xs.open("GET",url,true);
    xs.send(null);
    xs.onreadystatechange = function() {
	//printf("XHR-source:"+xs.readyState);
	if (xs.readyState==4)
	    {
		if (xs.status==200) {
		    tclDo(tcb+" {"+xs.responseText+"}");
		} else {
		    tclDo(tcb+" {error \"Can't source -- "+xs.statusText+"\"}");
		}
	    }
    };
}

// ---------- GUI and standard NaCl-loading machinery --------

function moduleDidLoad() {
    tclModule = document.getElementById('tcl');
    // tcl('lappend', '::JS', "alert('ARGV:[join $::argv]')");
    tcl('eval', 'coroutine', '::main_coro', 'source', '[dict get $::argv source]');
}

Added nacl/demo/tcl.nmf. 















>
>
>
>
>
>

1
2
3
4
5
6

{
  "nexes": {
    "x86-32": "tcl32.nexe",
    "x86-64": "tcl64.nexe",
  }
}

Changes to nacl/init.natcl. 

1
2


3
4
5
6
7
8
9
10






11







12






13




14



15


16










17
18

19

20
21
22
23
24
25
26
27



























28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51

#------ Standard NaTcl preamble




# core JS/Tcl interaction
proc jsquote s {
    regsub -all {[''\\]} $s {\\&} s
    regsub -all \n $s {'+"\\n"+'} s
    return '${s}'
}







proc bgerror s {







    printf "### BGERROR: $s\n# [info errorstack]"






    set ::JS "alert([jsquote "BGERROR: $s"]);"




}






set ::naclhooks {}











proc naclwrap s {

    set ::JS ""

    if {[catch {
	uplevel 1 $s
	foreach x $::naclhooks {uplevel #0 $x}
    } err]} {
	printf "Wrapper error: $err"
	bgerror $err
    }
    return $::JS



























}

# Coro-based [source] necessary for bootstrapping
proc source url {
    set j "tclsource([jsquote $url],[jsquote [info coroutine]]);\n"
    append ::JS $j
    set x [yield]
    uplevel 1 $x
}

# Async [after] using JS's setTimeout()
proc after {ms script} {
    append ::JS "setTimeout(function(){tclDo([jsquote $script]);},$ms);\n"
}

# Async [every] using JS's setInterval()
proc every {ms script} {
    append ::JS "setInterval(function(){tclDo([jsquote $script]);},$ms);\n"
}

# Delayed DOM-setting through the tclDo() trampoline
proc domset {element inner} {
    append ::JS "$element.innerHTML=[jsquote $inner];\n"
}



>
>

|
|
|
|
|
|

>
>
>
>
>
>
|
>
>
>
>
>
>
>
|
>
>
>
>
>
>
|
>
>
>
>
|
>
>
>
|
>
>
|
>
>
>
>
>
>
>
>
>
>
|
|
>
|
>
|
|
|
|
|
|
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>



|
|
<

|



|
|



|
|



|
|


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101

102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119

#------ Standard NaTcl preamble

namespace eval ::nacl {
    variable verbose 0

    # core JS/Tcl interaction
    proc jsquote s {
        regsub -all {[''\\]} $s {\\&} s
        regsub -all \n $s {'+"\\n"+'} s
        return '${s}'
    }

    # hook - append Tcl hooks to be evaluated per ???
    variable hooks {}
    proc hook {args} {
        variable hooks
        lappend hooks {*}$args
    }

    # js - append javascript to be evaluated in nacl
    # as a result of currently evaluating Tcl script
    variable JS {}	;# accumulation of javascript to evaluate
    proc js {args} {
        variable JS
        append JS [join $args \;\n] \n
    }

    variable defaults {}
    proc opts {args} {
	set type ""
	if {[llength $args]%2} {
	    set args [lassign $args type]
	}

	set opts {}
	variable defaults
	if {$type ne "" && [dict exists $defaults $type]} {
	    set args [list {*}[dict get $defaults $type] {*}$args]
	}
	dict for {n v} $args {
	    if {$v eq ""} {
		set v "''"	;# ensure we don't send naked names
	    }
	    lappend opts "$n:$v"
	}

	if {$opts eq ""} {
	    return ""
	} else {
	    return "\{[join $opts ,]\}"
	}
    }

    proc bgerror {args} {
        printf "### BGERROR: [join $args]\n# [info errorstack]"
        js "alert([jsquote "BGERROR: [join $args]"])"
    }

    proc wrap {s} {
        variable JS ""
        variable hooks
        if {[catch {
            uplevel #0 $s
            foreach x $hooks {uplevel #0 $x}
        } err eo]} {
            printf "Wrapper error: $err ($eo)"
            bgerror "$err ($eo)"
        }
        return $JS
    }

    # evall - evaluate a list as a command
    # returns javascript to evaluate in nacl
    proc evall {args} {
        variable JS ""
        variable hooks
        if {[catch {
            uplevel #0 {*}$args
            foreach x $hooks {uplevel #0 $x}
        } err eo]} {
            printf "evall error: $err ($eo)"
            bgerror "$err ($eo)"
        }
        return $JS
    }

    # start - natcl module has been loaded with the following args
    proc start {args} {
        set ::argv $args
        if {[dict exists $args verbose]} {
            variable verbose [dict get $args verbose]
        }
    }

    namespace export -clear *
    namespace ensemble create -subcommands {}
}

# Coro-based [source] necessary for bootstrapping
proc ::source {url} {
    nacl js "tclsource([::nacl::jsquote $url],[::nacl::jsquote [info coroutine]])"

    set x [yield]
    uplevel #0 $x
}

# Async [after] using JS's setTimeout()
proc ::after {ms script} {
    nacl js "setTimeout(function(){tclDo([::nacl::jsquote $script]);},$ms)"
}

# Async [every] using JS's setInterval()
proc ::every {ms script} {
    nacl js "setInterval(function(){tclDo([::nacl::jsquote $script]);},$ms)"
}

# Delayed DOM-setting through the tclDo() trampoline
proc ::domset {element inner} {
    nacl js "$element.innerHTML=[::nacl::jsquote $inner]"
}

Changes to nacl/naclMain.c.

︙︙
13
14
15
16
17
18
19

20
21
22
23
24
25
26


#include <errno.h>
#include "tcl.h"
#include "tclInt.h"

static Tcl_Interp *interp = NULL;
static int pid = 0;


const char *init_tcl_contents =
"set ::tcl_library {/}\n"
# include "init.tcl.c"
  ;

static int PrintfObjCmd(








>








13
14
15
16
17
18
19
20
21
22
23
24
25
26
27


#include <errno.h>
#include "tcl.h"
#include "tclInt.h"

static Tcl_Interp *interp = NULL;
static int pid = 0;
static int verbose = 0;

const char *init_tcl_contents =
"set ::tcl_library {/}\n"
# include "init.tcl.c"
  ;

static int PrintfObjCmd(
︙︙
62
63
64
65
66
67
68

69
70

71
72
73
74
75
76
77

  }
  //printf("DBUG:Tcl_Init2\n");
  if (Tcl_Eval(ii,init_tcl_contents)!=TCL_OK) {
    printf("NaTcl(%d): Tcl Init Failed: %s !!!\n",pid,Tcl_GetStringResult(ii));
    return NULL;
  }
  Tcl_CreateObjCommand(ii,"printf",PrintfObjCmd,NULL,NULL);

  return ii;
}

static const char *EvalTcl(char *s)
{
  if (!interp) return "No Tcl Interp!!!";
  Tcl_Eval(interp,s);
  return Tcl_GetStringResult(interp);
}









>


>








63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80

  }
  //printf("DBUG:Tcl_Init2\n");
  if (Tcl_Eval(ii,init_tcl_contents)!=TCL_OK) {
    printf("NaTcl(%d): Tcl Init Failed: %s !!!\n",pid,Tcl_GetStringResult(ii));
    return NULL;
  }
  Tcl_CreateObjCommand(ii,"printf",PrintfObjCmd,NULL,NULL);
  Tcl_LinkVar(ii, "::nacl::verbose", (char *)&verbose, TCL_LINK_INT);
  return ii;
}

static const char *EvalTcl(char *s)
{
  if (!interp) return "No Tcl Interp!!!";
  Tcl_Eval(interp,s);
  return Tcl_GetStringResult(interp);
}
︙︙
160
161
162
163
164
165
166























167
168
169
170
171
172
173

 *     these values match the indices of the corresponding names in @a argn.
 * @return @a PP_TRUE on success.
 */
static PP_Bool Instance_DidCreate(PP_Instance instance,
                                  uint32_t argc,
                                  const char* argn[],
                                  const char* argv[]) {























  return PP_TRUE;
}

/**
 * Called when the NaCl module is destroyed. This will always be called,
 * even if DidCreate returned failure. This routine should deallocate any data
 * associated with the instance.








>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>








163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199

 *     these values match the indices of the corresponding names in @a argn.
 * @return @a PP_TRUE on success.
 */
static PP_Bool Instance_DidCreate(PP_Instance instance,
                                  uint32_t argc,
                                  const char* argn[],
                                  const char* argv[]) {
    printf("NaTcl(%d): DBUG: Instance_DidCreate %x\n", getpid(), (unsigned int)instance);
  int i;
  Tcl_Obj *args[1+argc+argc];

  args[0] = Tcl_NewStringObj("::nacl::start",-1);
  Tcl_IncrRefCount(args[0]);

  for (i = 0; i < argc; i++) {
      printf("NaTcl(%d): DBUG: Instance_DidCreate arg %s=%s\n", getpid(), argn[i], argv[i]);

      args[(2*i)+1] = Tcl_NewStringObj(argn[i], -1);
      Tcl_IncrRefCount(args[(2*i)+1]);

      args[(2*i)+2] = Tcl_NewStringObj(argv[i], -1);
      Tcl_IncrRefCount(args[(2*i)+2]);
  }

  Tcl_EvalObjv(interp, argc*2+1, args, 0);
  for (i = 0; i < (2*argc)+1; i++) {
      Tcl_DecrRefCount(args[i]);
  }
  printf("NaTcl(%d): Instance_DidCreate result: %s\n", pid, Tcl_GetStringResult(interp));

  return PP_TRUE;
}

/**
 * Called when the NaCl module is destroyed. This will always be called,
 * even if DidCreate returned failure. This routine should deallocate any data
 * associated with the instance.
︙︙
243
244
245
246
247
248
249

250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270


271
272
273
274
275
276
277


/**
 * Create scriptable object for the given instance.
 * @param[in] instance The instance ID.
 * @return A scriptable object.
 */
static struct PP_Var Instance_GetInstanceObject(PP_Instance instance) {

  if (var_interface) {
    return var_interface->CreateObject(instance, &ppp_class, NULL);
  }
  return PP_MakeUndefined();
}

/**
 * Check existence of the function associated with @a name.
 * @param[in] object unused
 * @param[in] name method name
 * @param[out] exception pointer to the exception object, unused
 * @return If the method does exist, return true.
 * If the method does not exist, return false and don't set the exception.
 */
static bool Tcl_HasMethod(void* object,
                                 struct PP_Var name,
                                 struct PP_Var* exception) {
  const char* method_name = VarToCStr(name);
  if (NULL != method_name) {
    if (strcmp(method_name, "eval") == 0)
      return true;


  }
  return false;
}

/**
 * Invoke the function associated with @a name.
 * @param[in] object unused








>



















|
|
>
>








269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306


/**
 * Create scriptable object for the given instance.
 * @param[in] instance The instance ID.
 * @return A scriptable object.
 */
static struct PP_Var Instance_GetInstanceObject(PP_Instance instance) {
    printf("NaTcl(%d): DBUG: NaTcl GetInstanceObject %x\n",getpid(), (unsigned int)instance);
  if (var_interface) {
    return var_interface->CreateObject(instance, &ppp_class, NULL);
  }
  return PP_MakeUndefined();
}

/**
 * Check existence of the function associated with @a name.
 * @param[in] object unused
 * @param[in] name method name
 * @param[out] exception pointer to the exception object, unused
 * @return If the method does exist, return true.
 * If the method does not exist, return false and don't set the exception.
 */
static bool Tcl_HasMethod(void* object,
                                 struct PP_Var name,
                                 struct PP_Var* exception) {
  const char* method_name = VarToCStr(name);
  if (NULL != method_name) {
      if (strcmp(method_name, "eval") == 0)
          return true;
      else if (strcmp(method_name, "evall") == 0)
          return true;
  }
  return false;
}

/**
 * Invoke the function associated with @a name.
 * @param[in] object unused
︙︙
291
292
293
294
295
296
297



298



299
300
301
302
303
304











305


















306
307
308

309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342

343
344
345
346
347
348
349
350
351
352
353

  if (NULL != method_name) {
    if (strcmp(method_name, "eval") == 0) {
      if (argc == 1) {
        if (argv[0].type != PP_VARTYPE_STRING) {
          v = StrToVar("Arg from Javascript is not a string!");
        } else {
          char* str = strdup(VarToCStr(argv[0]));



	  const char* res = EvalTcl(str);



          v = StrToVar(res);
          free(str);
        }
      } else {
        v = StrToVar("Unexpected number of args");
      }











    } else {


















      v = StrToVar("Unknown method");
    }
  }

  return v;
}

/**
 * Entrypoints for the module.
 * Initialize instance interface and scriptable object class.
 * @param[in] a_module_id module ID
 * @param[in] get_browser pointer to PPB_GetInterface
 * @return PP_OK on success, any other value on failure.
 */
PP_EXPORT int32_t PPP_InitializeModule(PP_Module a_module_id,
                                       PPB_GetInterface get_browser) {
  pid = getpid();
  module_id = a_module_id;
  var_interface =
      (struct PPB_Var_Deprecated*)(get_browser(PPB_VAR_DEPRECATED_INTERFACE));

  printf("NaTcl(%d): DBUG: NaTcl starting\n",pid);
  interp = NewTcl();
  if (!interp) return PP_ERROR_FAILED;

  memset(&ppp_class, 0, sizeof(ppp_class));
  ppp_class.Call = Tcl_Call;
  ppp_class.HasMethod = Tcl_HasMethod;
  return PP_OK;
}

/**
 * Returns an interface pointer for the interface of the given name, or NULL
 * if the interface is not supported.
 * @param[in] interface_name name of the interface
 * @return pointer to the interface
 */
PP_EXPORT const void* PPP_GetInterface(const char* interface_name) {

  if (strcmp(interface_name, PPP_INSTANCE_INTERFACE) == 0)
    return &instance_interface;
  return NULL;
}

/**
 * Called before the plugin module is unloaded.
 */
PP_EXPORT void PPP_ShutdownModule() {
  //  if (interp) EndTcl(interp);
}








>
>
>

>
>
>






>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|


>

















|
















>












320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419

  if (NULL != method_name) {
    if (strcmp(method_name, "eval") == 0) {
      if (argc == 1) {
        if (argv[0].type != PP_VARTYPE_STRING) {
          v = StrToVar("Arg from Javascript is not a string!");
        } else {
          char* str = strdup(VarToCStr(argv[0]));
          if (verbose) {
              printf("NaTcl(%d): EVAL of: %s\n",pid, str);
          }
	  const char* res = EvalTcl(str);
          if (verbose) {
              printf("NaTcl(%d): EVAL result: %s\n",pid, Tcl_GetStringResult(interp));
          }
          v = StrToVar(res);
          free(str);
        }
      } else {
        v = StrToVar("Unexpected number of args");
      }
    } else if (strcmp(method_name, "evall") == 0) {
        Tcl_Obj *args[argc+1];
        uint32_t len = 0;
        int i;

        args[0] = Tcl_NewStringObj("::nacl::evall",-1);
        Tcl_IncrRefCount(args[0]);

        for (i = 0; i < argc; i++) {
            if (argv[i].type != PP_VARTYPE_STRING) {
                v = StrToVar("Arg from Javascript is not a string!");
            } else {
                const char *bytes = var_interface->VarToUtf8(argv[i], &len);
                args[i+1] = Tcl_NewStringObj(bytes, len);
                Tcl_IncrRefCount(args[i+1]);
                if (verbose) {
                    printf("NaTcl(%d): EVALL arg: '%s'\n",pid, bytes);
                }
            }
        }
        Tcl_EvalObjv(interp, argc+1, args, 0);
        if (verbose) {
            printf("NaTcl(%d): EVALL result: '%s'\n",pid, Tcl_GetStringResult(interp));
        }

        for (i = 0; i < argc+1; i++) {
            Tcl_DecrRefCount(args[i]);
        }
        v = StrToVar(Tcl_GetStringResult(interp));
    } else {
        v = StrToVar("Unknown method");
    }
  }

  return v;
}

/**
 * Entrypoints for the module.
 * Initialize instance interface and scriptable object class.
 * @param[in] a_module_id module ID
 * @param[in] get_browser pointer to PPB_GetInterface
 * @return PP_OK on success, any other value on failure.
 */
PP_EXPORT int32_t PPP_InitializeModule(PP_Module a_module_id,
                                       PPB_GetInterface get_browser) {
  pid = getpid();
  module_id = a_module_id;
  var_interface =
      (struct PPB_Var_Deprecated*)(get_browser(PPB_VAR_DEPRECATED_INTERFACE));

  printf("NaTcl(%d): DBUG: PPP_InitializeModule\n",pid);
  interp = NewTcl();
  if (!interp) return PP_ERROR_FAILED;

  memset(&ppp_class, 0, sizeof(ppp_class));
  ppp_class.Call = Tcl_Call;
  ppp_class.HasMethod = Tcl_HasMethod;
  return PP_OK;
}

/**
 * Returns an interface pointer for the interface of the given name, or NULL
 * if the interface is not supported.
 * @param[in] interface_name name of the interface
 * @return pointer to the interface
 */
PP_EXPORT const void* PPP_GetInterface(const char* interface_name) {
    printf("NaTcl(%d): DBUG: PPP_GetInterface '%s'\n", getpid(), (char *)interface_name);
  if (strcmp(interface_name, PPP_INSTANCE_INTERFACE) == 0)
    return &instance_interface;
  return NULL;
}

/**
 * Called before the plugin module is unloaded.
 */
PP_EXPORT void PPP_ShutdownModule() {
  //  if (interp) EndTcl(interp);
}

This page was generated in about 0.017s by Fossil 2.24 [f4ffefe708] 2024-04-17 14:02:19